{-# LANGUAGE ScopedTypeVariables, CPP #-}
{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}

-- | More IO functions. The functions include ones for reading files with specific encodings,
--   strictly reading files, and writing files with encodings. There are also some simple
--   temporary file functions, more advanced alternatives can be found in
--   the <https://hackage.haskell.org/package/exceptions exceptions> package.
module System.IO.Extra(
    module System.IO,
    captureOutput,
    withBuffering,
    -- * Read encoding
    readFileEncoding, readFileUTF8, readFileBinary,
    -- * Strict reading
    readFile', readFileEncoding', readFileUTF8', readFileBinary',
    -- * Write with encoding
    writeFileEncoding, writeFileUTF8, writeFileBinary,
    -- * Temporary files
    withTempFile, withTempDir, newTempFile, newTempDir,
    newTempFileWithin, newTempDirWithin,
    -- * File comparison
    fileEq,
    ) where

import System.IO
import Control.Concurrent.Extra
import Control.Monad.Extra
import Control.Exception.Extra as E
import GHC.IO.Handle(hDuplicate,hDuplicateTo)
import System.Directory.Extra
import System.IO.Error
import System.IO.Unsafe
import System.FilePath
import Data.Char
import Data.Time.Clock
import Data.Tuple.Extra
import Data.IORef
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.C.Types
import Data.Functor
import Prelude

-- File reading

-- | Like 'readFile', but setting an encoding.
readFileEncoding :: TextEncoding -> FilePath -> IO String
readFileEncoding :: TextEncoding -> FilePath -> IO FilePath
readFileEncoding TextEncoding
enc FilePath
file = do
    Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
file IOMode
ReadMode
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
enc
    Handle -> IO FilePath
hGetContents Handle
h

-- | Like 'readFile', but with the encoding 'utf8'.
readFileUTF8 :: FilePath -> IO String
readFileUTF8 :: FilePath -> IO FilePath
readFileUTF8 = TextEncoding -> FilePath -> IO FilePath
readFileEncoding TextEncoding
utf8

-- | Like 'readFile', but for binary files.
readFileBinary :: FilePath -> IO String
readFileBinary :: FilePath -> IO FilePath
readFileBinary FilePath
file = do
    Handle
h <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
file IOMode
ReadMode
    Handle -> IO FilePath
hGetContents Handle
h

-- Strict file reading

#if __GLASGOW_HASKELL__ < 811
-- readFile' and hGetContents' were added in GHC 9.0

-- | A strict version of 'hGetContents'.
hGetContents' :: Handle -> IO String
hGetContents' h = do
    s <- hGetContents h
    void $ evaluate $ length s
    pure s

-- | A strict version of 'readFile'. When the string is produced, the entire
--   file will have been read into memory and the file handle will have been closed.
--   Closing the file handle does not rely on the garbage collector.
--
-- > \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file
readFile' :: FilePath -> IO String
readFile' file = withFile file ReadMode hGetContents'

#endif

-- | A strict version of 'readFileEncoding', see 'readFile'' for details.
readFileEncoding' :: TextEncoding -> FilePath -> IO String
readFileEncoding' :: TextEncoding -> FilePath -> IO FilePath
readFileEncoding' TextEncoding
e FilePath
file = forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
file IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO FilePath
hGetContents' Handle
h

-- | A strict version of 'readFileUTF8', see 'readFile'' for details.
readFileUTF8' :: FilePath -> IO String
readFileUTF8' :: FilePath -> IO FilePath
readFileUTF8' = TextEncoding -> FilePath -> IO FilePath
readFileEncoding' TextEncoding
utf8

-- | A strict version of 'readFileBinary', see 'readFile'' for details.
readFileBinary' :: FilePath -> IO String
readFileBinary' :: FilePath -> IO FilePath
readFileBinary' FilePath
file = forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
file IOMode
ReadMode Handle -> IO FilePath
hGetContents'

-- File writing

-- | Write a file with a particular encoding.
writeFileEncoding :: TextEncoding -> FilePath -> String -> IO ()
writeFileEncoding :: TextEncoding -> FilePath -> FilePath -> IO ()
writeFileEncoding TextEncoding
enc FilePath
file FilePath
x = forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
file IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
enc
    Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
x

-- | Write a file with the 'utf8' encoding.
--
-- > \s -> withTempFile $ \file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file
writeFileUTF8 :: FilePath -> String -> IO ()
writeFileUTF8 :: FilePath -> FilePath -> IO ()
writeFileUTF8 = TextEncoding -> FilePath -> FilePath -> IO ()
writeFileEncoding TextEncoding
utf8

-- | Write a binary file.
--
-- > \(ASCIIString s) -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file
writeFileBinary :: FilePath -> String -> IO ()
writeFileBinary :: FilePath -> FilePath -> IO ()
writeFileBinary FilePath
file FilePath
x = forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
file IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
x

-- Console

-- | Capture the 'stdout' and 'stderr' of a computation.
--
-- > captureOutput (print 1) == pure ("1\n",())
captureOutput :: IO a -> IO (String, a)
captureOutput :: forall a. IO a -> IO (FilePath, a)
captureOutput IO a
act = forall a. (FilePath -> IO a) -> IO a
withTempFile forall a b. (a -> b) -> a -> b
$ \FilePath
file ->
    forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
file IOMode
ReadWriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        a
res <- forall {b}. Handle -> Handle -> IO b -> IO b
clone Handle
stdout Handle
h forall a b. (a -> b) -> a -> b
$ forall {b}. Handle -> Handle -> IO b -> IO b
clone Handle
stderr Handle
h forall a b. (a -> b) -> a -> b
$ do
            Handle -> IO ()
hClose Handle
h
            IO a
act
        FilePath
out <- FilePath -> IO FilePath
readFile' FilePath
file
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
out, a
res)
    where
        clone :: Handle -> Handle -> IO b -> IO b
clone Handle
out Handle
h IO b
act = do
            BufferMode
buf <- Handle -> IO BufferMode
hGetBuffering Handle
out
            Handle
out2 <- Handle -> IO Handle
hDuplicate Handle
out
            Handle -> Handle -> IO ()
hDuplicateTo Handle
h Handle
out
            IO b
act forall a b. IO a -> IO b -> IO a
`finally` do
                Handle -> Handle -> IO ()
hDuplicateTo Handle
out2 Handle
out
                Handle -> IO ()
hClose Handle
out2
                Handle -> BufferMode -> IO ()
hSetBuffering Handle
out BufferMode
buf


-- | Execute an action with a custom 'BufferMode', a wrapper around
--   'hSetBuffering'.
withBuffering :: Handle -> BufferMode -> IO a -> IO a
withBuffering :: forall a. Handle -> BufferMode -> IO a -> IO a
withBuffering Handle
h BufferMode
m IO a
act = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> IO BufferMode
hGetBuffering Handle
h) (Handle -> BufferMode -> IO ()
hSetBuffering Handle
h) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
m
    IO a
act


---------------------------------------------------------------------
-- TEMPORARY FILE
-- We don't use GHC's temp file code, because its buggy, see:
-- https://ghc.haskell.org/trac/ghc/ticket/10731

{-# NOINLINE tempRef #-}
tempRef :: IORef Int
tempRef :: IORef Int
tempRef = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Integer
rand :: Integer <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Read a => FilePath -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> DiffTime
utctDayTime) IO UTCTime
getCurrentTime
    forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rand

tempUnique :: IO Int
tempUnique :: IO Int
tempUnique = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Int
tempRef forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& forall a. Enum a => a -> a
succ


-- | Provide a function to create a temporary file, and a way to delete a
--   temporary file. Most users should use 'withTempFile' which
--   combines these operations.
newTempFile :: IO (FilePath, IO ())
newTempFile :: IO (FilePath, IO ())
newTempFile = FilePath -> IO (FilePath, IO ())
newTempFileWithin forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
getTemporaryDirectory

-- | Like 'newTempFile' but using a custom temporary directory.
newTempFileWithin :: FilePath -> IO (FilePath, IO ())
newTempFileWithin :: FilePath -> IO (FilePath, IO ())
newTempFileWithin FilePath
tmpdir = do
        FilePath
file <- IO FilePath
create
        IO ()
del <- forall a. IO a -> IO (IO a)
once forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignore forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
file
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
file, IO ()
del)
    where
        create :: IO FilePath
create = do
            Int
val <- IO Int
tempUnique
            (FilePath
file, Handle
h) <- forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
retryBool (\(IOError
_ :: IOError) -> Bool
True) Int
5 forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmpdir forall a b. (a -> b) -> a -> b
$ FilePath
"extra-file-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
val forall a. [a] -> [a] -> [a]
++ FilePath
"-"
            Handle -> IO ()
hClose Handle
h
            forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
file


-- | Create a temporary file in the temporary directory. The file will be deleted
--   after the action completes (provided the file is not still open).
--   The 'FilePath' will not have any file extension, will exist, and will be zero bytes long.
--   If you require a file with a specific name, use 'withTempDir'.
--
-- > withTempFile doesFileExist == pure True
-- > (doesFileExist =<< withTempFile pure) == pure False
-- > withTempFile readFile' == pure ""
withTempFile :: (FilePath -> IO a) -> IO a
withTempFile :: forall a. (FilePath -> IO a) -> IO a
withTempFile FilePath -> IO a
act = do
    (FilePath
file, IO ()
del) <- IO (FilePath, IO ())
newTempFile
    FilePath -> IO a
act FilePath
file forall a b. IO a -> IO b -> IO a
`finally` IO ()
del


-- | Provide a function to create a temporary directory, and a way to delete a
--   temporary directory. Most users should use 'withTempDir' which
--   combines these operations.
newTempDir :: IO (FilePath, IO ())
newTempDir :: IO (FilePath, IO ())
newTempDir = FilePath -> IO (FilePath, IO ())
newTempDirWithin forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
getTemporaryDirectory

-- | Like 'newTempDir' but using a custom temporary directory.
newTempDirWithin :: FilePath -> IO (FilePath, IO ())
newTempDirWithin :: FilePath -> IO (FilePath, IO ())
newTempDirWithin FilePath
tmpdir = do
        FilePath
dir <- forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
retryBool (\(IOError
_ :: IOError) -> Bool
True) Int
5 forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
create FilePath
tmpdir
        IO ()
del <- forall a. IO a -> IO (IO a)
once forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignore forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
dir
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
dir, IO ()
del)
    where
        create :: FilePath -> IO FilePath
create FilePath
tmpdir = do
            Int
v <- IO Int
tempUnique
            let dir :: FilePath
dir = FilePath
tmpdir FilePath -> FilePath -> FilePath
</> FilePath
"extra-dir-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
v
            forall e a.
Exception e =>
(e -> Bool) -> IO a -> (e -> IO a) -> IO a
catchBool IOError -> Bool
isAlreadyExistsError
                (FilePath -> IO ()
createDirectoryPrivate FilePath
dir forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
dir) forall a b. (a -> b) -> a -> b
$
                \IOError
_ -> FilePath -> IO FilePath
create FilePath
tmpdir


-- | Create a temporary directory inside the system temporary directory.
--   The directory will be deleted after the action completes.
--
-- > withTempDir doesDirectoryExist == pure True
-- > (doesDirectoryExist =<< withTempDir pure) == pure False
-- > withTempDir listFiles == pure []
withTempDir :: (FilePath -> IO a) -> IO a
withTempDir :: forall a. (FilePath -> IO a) -> IO a
withTempDir FilePath -> IO a
act = do
    (FilePath
dir,IO ()
del) <- IO (FilePath, IO ())
newTempDir
    FilePath -> IO a
act FilePath
dir forall a b. IO a -> IO b -> IO a
`finally` IO ()
del

-- | Returns 'True' when both files have the same size.
sameSize :: Handle -> Handle -> IO Bool
sameSize :: Handle -> Handle -> IO Bool
sameSize Handle
h1 Handle
h2 = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Eq a => a -> a -> Bool
(==) (Handle -> IO Integer
hFileSize Handle
h1) (Handle -> IO Integer
hFileSize Handle
h2)

foreign import ccall unsafe "string.h memcmp" memcmp
    :: Ptr CUChar -> Ptr CUChar -> CSize -> IO CInt

-- | Returns 'True' when the contents of both files is the same.
sameContent :: Handle -> Handle -> IO Bool
sameContent :: Handle -> Handle -> IO Bool
sameContent Handle
h1 Handle
h2 = Handle -> Handle -> IO Bool
sameSize Handle
h1 Handle
h2 forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ forall {a} {b}. (Ptr a -> IO b) -> IO b
withb (\Ptr CUChar
b1 -> forall {a} {b}. (Ptr a -> IO b) -> IO b
withb forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
b2 -> Ptr CUChar -> Ptr CUChar -> IO Bool
eq Ptr CUChar
b1 Ptr CUChar
b2)
    where eq :: Ptr CUChar -> Ptr CUChar -> IO Bool
eq Ptr CUChar
b1 Ptr CUChar
b2 = do
            Int
r1 <- forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h1 Ptr CUChar
b1 Int
bufsz
            Int
r2 <- forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h2 Ptr CUChar
b2 Int
bufsz
            if Int
r1 forall a. Eq a => a -> a -> Bool
== Int
0
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int
r2 forall a. Eq a => a -> a -> Bool
== Int
0
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
r1 forall a. Eq a => a -> a -> Bool
== Int
r2) forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ forall {a}. Integral a => Ptr CUChar -> Ptr CUChar -> a -> IO Bool
bufeq Ptr CUChar
b1 Ptr CUChar
b2 Int
r1 forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Ptr CUChar -> Ptr CUChar -> IO Bool
eq Ptr CUChar
b1 Ptr CUChar
b2
          bufeq :: Ptr CUChar -> Ptr CUChar -> a -> IO Bool
bufeq Ptr CUChar
b1 Ptr CUChar
b2 a
s = (forall a. Eq a => a -> a -> Bool
==CInt
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CUChar -> Ptr CUChar -> CSize -> IO CInt
memcmp Ptr CUChar
b1 Ptr CUChar
b2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
s)
          withb :: (Ptr a -> IO b) -> IO b
withb = forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned Int
bufsz Int
4096
          bufsz :: Int
bufsz = Int
64forall a. Num a => a -> a -> a
*Int
1024

-- | Returns 'True' if both files have the same content.
--   Raises an error if either file is missing.
--
-- > fileEq "does_not_exist1" "does_not_exist2" == undefined
-- > fileEq "does_not_exist" "does_not_exist" == undefined
-- > withTempFile $ \f1 -> fileEq "does_not_exist" f1 == undefined
-- > withTempFile $ \f1 -> withTempFile $ \f2 -> fileEq f1 f2
-- > withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "a" >> fileEq f1 f2
-- > withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "b" >> notM (fileEq f1 f2)
fileEq :: FilePath -> FilePath -> IO Bool
fileEq :: FilePath -> FilePath -> IO Bool
fileEq FilePath
p1 FilePath
p2 = forall {r}. FilePath -> (Handle -> IO r) -> IO r
withH FilePath
p1 forall a b. (a -> b) -> a -> b
$ \Handle
h1 -> forall {r}. FilePath -> (Handle -> IO r) -> IO r
withH FilePath
p2 forall a b. (a -> b) -> a -> b
$ \Handle
h2 -> Handle -> Handle -> IO Bool
sameContent Handle
h1 Handle
h2
    where withH :: FilePath -> (Handle -> IO r) -> IO r
withH FilePath
p = forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
p IOMode
ReadMode