-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE ScopedTypeVariables #-}
-- | Do things with files.
module Util.File (
    -- * read/write
    writeLines
    , writeAtomic
    , symlink
    -- * query
    , writable
    -- * directory
    , list, listRecursive
    , walk
    -- * compression
    , readGz, writeGz
) where
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Zlib.Internal as Zlib.Internal
import qualified Control.Exception as Exception
import           Control.Monad (forM_, unless, when)
import           Control.Monad.Extra (filterM, ifM, orM, partitionM, whenM)
import           Control.Monad.Trans (liftIO)

import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as Lazy
import           Data.Text (Text)
import qualified Data.Text.IO as Text.IO

import qualified Streaming as S
import qualified Streaming.Prelude as S
import qualified System.Directory as Directory
import           System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.IO.Error as Error
import qualified System.Posix.Files as Posix.Files

import qualified Util.Exceptions as Exceptions


-- * read/write

writeLines :: FilePath -> [Text] -> IO ()
writeLines :: [Char] -> [Text] -> IO ()
writeLines [Char]
fname [Text]
lines = forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile [Char]
fname IOMode
IO.WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
hdl ->
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
hdl) [Text]
lines

writeAtomic :: FilePath -> ByteString.ByteString -> IO ()
writeAtomic :: [Char] -> ByteString -> IO ()
writeAtomic [Char]
fn ByteString
bytes = do
    [Char] -> ByteString -> IO ()
ByteString.writeFile [Char]
tmp ByteString
bytes
    [Char] -> [Char] -> IO ()
Directory.renameFile [Char]
tmp [Char]
fn
    where
    tmp :: [Char]
tmp = [Char]
fn forall a. [a] -> [a] -> [a]
++ [Char]
".write.tmp"

-- | Make a symlink atomically.
symlink :: String -> FilePath -> IO ()
symlink :: [Char] -> [Char] -> IO ()
symlink [Char]
dest [Char]
fname = do
    Maybe [Char]
oldDest <- forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
Directory.getSymbolicLinkTarget [Char]
fname
    -- Don't remake if it's already right.  Probably unnecessary, but it
    -- happens a lot and we can avoid touching the filesystem.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [Char]
oldDest forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just [Char]
dest) forall a b. (a -> b) -> a -> b
$ do
        -- If a previous process got killed, there might be stale .tmp files.
        forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
Directory.removeFile ([Char]
fname forall a. Semigroup a => a -> a -> a
<> [Char]
".tmp")
        -- Atomically replace the old link, if any.
        [Char] -> [Char] -> IO ()
Directory.createFileLink [Char]
dest ([Char]
fname forall a. Semigroup a => a -> a -> a
<> [Char]
".tmp")
        [Char] -> [Char] -> IO ()
Directory.renameFile ([Char]
fname forall a. Semigroup a => a -> a -> a
<> [Char]
".tmp") [Char]
fname

-- * query

sameContents :: FilePath -> FilePath -> IO Bool
sameContents :: [Char] -> [Char] -> IO Bool
sameContents [Char]
fn1 [Char]
fn2 = do
    Maybe ByteString
c1 <- forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
Lazy.readFile [Char]
fn1
    Maybe ByteString
c2 <- forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
Lazy.readFile [Char]
fn2
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ByteString
c1 forall a. Eq a => a -> a -> Bool
== Maybe ByteString
c2

-- | Throw if this file exists but isn't writable.
requireWritable :: FilePath -> IO ()
requireWritable :: [Char] -> IO ()
requireWritable [Char]
fn = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Bool
writable [Char]
fn) forall a b. (a -> b) -> a -> b
$
    forall e a. Exception e => e -> IO a
Exception.throwIO forall a b. (a -> b) -> a -> b
$ IOErrorType -> [Char] -> Maybe Handle -> Maybe [Char] -> IOError
Error.mkIOError IOErrorType
Error.permissionErrorType
        [Char]
"refusing to overwrite a read-only file" forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [Char]
fn)

-- | True if the file doesn't exist, or if it does but is writable.
writable :: FilePath -> IO Bool
writable :: [Char] -> IO Bool
writable [Char]
fn = forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM
    [ Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM [[Char] -> IO Bool
Directory.doesFileExist [Char]
fn, [Char] -> IO Bool
Directory.doesDirectoryExist [Char]
fn]
    , Permissions -> Bool
Directory.writable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Permissions
Directory.getPermissions [Char]
fn
    ]

-- * directory

-- | Like 'Directory.listDirectory' except prepend the directory.
list :: FilePath -> IO [FilePath]
list :: [Char] -> IO [[Char]]
list [Char]
dir = do
    [[Char]]
fns <- [Char] -> IO [[Char]]
Directory.listDirectory [Char]
dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
dir </>)) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=[Char]
".") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1) [[Char]]
fns
    where
    strip :: [Char] -> [Char]
strip (Char
'.' : Char
'/' : [Char]
path) = [Char]
path
    strip [Char]
path = [Char]
path

listRecursive :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
listRecursive :: ([Char] -> Bool) -> [Char] -> IO [[Char]]
listRecursive [Char] -> Bool
descend [Char]
dir = do
    Bool
is_file <- [Char] -> IO Bool
Directory.doesFileExist [Char]
dir
    if Bool
is_file then forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]
dir]
        else Bool -> ([Char] -> Bool) -> [Char] -> IO [[Char]]
maybeDescend ([Char]
dir forall a. Eq a => a -> a -> Bool
== [Char]
"." Bool -> Bool -> Bool
|| [Char] -> Bool
descend [Char]
dir) [Char] -> Bool
descend [Char]
dir
    where
    maybeDescend :: Bool -> ([Char] -> Bool) -> [Char] -> IO [[Char]]
maybeDescend Bool
True [Char] -> Bool
descend [Char]
dir = do
        [[Char]]
fns <- [Char] -> IO [[Char]]
list [Char]
dir
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Char] -> Bool) -> [Char] -> IO [[Char]]
listRecursive [Char] -> Bool
descend) [[Char]]
fns
    maybeDescend Bool
False [Char] -> Bool
_ [Char]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Walk the filesystem and stream (dir, fname).
walk :: (FilePath -> Bool) -> FilePath
    -> S.Stream (S.Of (FilePath, [FilePath])) IO ()
walk :: ([Char] -> Bool) -> [Char] -> Stream (Of ([Char], [[Char]])) IO ()
walk [Char] -> Bool
wantDir = forall {m :: * -> *}.
MonadIO m =>
[Char] -> Stream (Of ([Char], [[Char]])) m ()
go
    where
    go :: [Char] -> Stream (Of ([Char], [[Char]])) m ()
go [Char]
dir = do
        ([[Char]]
dirs, [[Char]]
fnames) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM ([Char] -> IO Bool
Directory.doesDirectoryExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
dir</>))
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [[Char]]
Directory.listDirectory [Char]
dir
        forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield ([Char]
dir, [[Char]]
fnames)
        [[Char]]
dirs <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char]
dir</>) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
wantDir [[Char]]
dirs
        [[Char]]
dirs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ if Bool
followLinks then forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]]
dirs
            else forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO Bool
Directory.pathIsSymbolicLink) [[Char]]
dirs
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> Stream (Of ([Char], [[Char]])) m ()
go [[Char]]
dirs
    followLinks :: Bool
followLinks = Bool
False

-- * compression

-- | Read and decompress a gzipped file.
readGz :: FilePath -> IO (Either String ByteString.ByteString)
readGz :: [Char] -> IO (Either [Char] ByteString)
readGz [Char]
fn = ByteString -> IO (Either [Char] ByteString)
decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO ByteString
Lazy.readFile [Char]
fn

decompress :: Lazy.ByteString -> IO (Either String ByteString.ByteString)
decompress :: ByteString -> IO (Either [Char] ByteString)
decompress ByteString
bytes =
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. DecompressError -> Either [Char] b
handle) forall a b. (a -> b) -> a -> b
$
        forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO a
Exception.evaluate (ByteString -> ByteString
Lazy.toStrict (ByteString -> ByteString
GZip.decompress ByteString
bytes))
    where handle :: DecompressError -> Either [Char] b
handle (DecompressError
exc :: Zlib.Internal.DecompressError) = forall a b. a -> Either a b
Left (forall a. Show a => a -> [Char]
show DecompressError
exc)

-- | Write a gzipped file.  Try to do so atomically by writing to a tmp file
-- first and renaming it.
--
-- Like @mv@, this will refuse to overwrite a file if it isn't writable.  If
-- the file wouldn't have changed, abort the write and delete the tmp file.
-- The mtime won't change, and the caller gets a False, which can be used to
-- avoid rebuilds.
writeGz :: Int -- ^ save this many previous versions of the file
    -> FilePath -> ByteString.ByteString -> IO Bool
    -- ^ False if the file wasn't written because it wouldn't have changed.
writeGz :: Int -> [Char] -> ByteString -> IO Bool
writeGz Int
rotations [Char]
fn ByteString
bytes = do
    [Char] -> IO ()
requireWritable [Char]
fn
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
rotationsforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
requireWritable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
rotation
    let tmp :: [Char]
tmp = [Char]
fn forall a. [a] -> [a] -> [a]
++ [Char]
".write.tmp"
    [Char] -> ByteString -> IO ()
Lazy.writeFile [Char]
tmp forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
GZip.compress forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Lazy.fromStrict ByteString
bytes
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ([Char] -> [Char] -> IO Bool
sameContents [Char]
fn [Char]
tmp)
        ([Char] -> IO ()
Directory.removeFile [Char]
tmp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) forall a b. (a -> b) -> a -> b
$
        do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
rotationsforall a. Num a => a -> a -> a
-Int
1, Int
rotationsforall a. Num a => a -> a -> a
-Int
2 .. Int
1] forall a b. (a -> b) -> a -> b
$ \Int
n ->
                forall a. IO a -> IO ()
Exceptions.ignoreEnoent_ forall a b. (a -> b) -> a -> b
$
                    [Char] -> [Char] -> IO ()
Directory.renameFile (forall a. Show a => a -> [Char]
rotation (Int
nforall a. Num a => a -> a -> a
-Int
1)) (forall a. Show a => a -> [Char]
rotation Int
n)
            -- Go to some hassle to ensure files are replaced atomically.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rotations forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO ()
Exceptions.ignoreEnoent_ forall a b. (a -> b) -> a -> b
$ do
                [Char] -> [Char] -> IO ()
Posix.Files.createLink [Char]
fn (forall a. Show a => a -> [Char]
rotation Integer
0 forall a. Semigroup a => a -> a -> a
<> [Char]
".tmp")
                [Char] -> [Char] -> IO ()
Directory.renameFile (forall a. Show a => a -> [Char]
rotation Integer
0 forall a. Semigroup a => a -> a -> a
<> [Char]
".tmp") (forall a. Show a => a -> [Char]
rotation Integer
0)
            [Char] -> [Char] -> IO ()
Directory.renameFile [Char]
tmp [Char]
fn
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    where
    rotation :: a -> [Char]
rotation a
n = [Char]
fn forall a. Semigroup a => a -> a -> a
<> [Char]
"." forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
n