{-# LANGUAGE ScopedTypeVariables, CPP #-}
{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
module System.IO.Extra(
module System.IO,
captureOutput,
withBuffering,
readFileEncoding, readFileUTF8, readFileBinary,
readFile', readFileEncoding', readFileUTF8', readFileBinary',
writeFileEncoding, writeFileUTF8, writeFileBinary,
withTempFile, withTempDir, newTempFile, newTempDir,
newTempFileWithin, newTempDirWithin,
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
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
readFileUTF8 :: FilePath -> IO String
readFileUTF8 :: FilePath -> IO FilePath
readFileUTF8 = TextEncoding -> FilePath -> IO FilePath
readFileEncoding TextEncoding
utf8
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
#if __GLASGOW_HASKELL__ < 811
hGetContents' :: Handle -> IO String
hGetContents' h = do
s <- hGetContents h
void $ evaluate $ length s
pure s
readFile' :: FilePath -> IO String
readFile' file = withFile file ReadMode hGetContents'
#endif
readFileEncoding' :: TextEncoding -> FilePath -> IO String
readFileEncoding' :: TextEncoding -> FilePath -> IO FilePath
readFileEncoding' TextEncoding
e FilePath
file = FilePath -> IOMode -> (Handle -> IO FilePath) -> IO FilePath
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
file IOMode
ReadMode ((Handle -> IO FilePath) -> IO FilePath)
-> (Handle -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
e IO () -> IO FilePath -> IO FilePath
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO FilePath
hGetContents' Handle
h
readFileUTF8' :: FilePath -> IO String
readFileUTF8' :: FilePath -> IO FilePath
readFileUTF8' = TextEncoding -> FilePath -> IO FilePath
readFileEncoding' TextEncoding
utf8
readFileBinary' :: FilePath -> IO String
readFileBinary' :: FilePath -> IO FilePath
readFileBinary' FilePath
file = FilePath -> IOMode -> (Handle -> IO FilePath) -> IO FilePath
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
file IOMode
ReadMode Handle -> IO FilePath
hGetContents'
writeFileEncoding :: TextEncoding -> FilePath -> String -> IO ()
writeFileEncoding :: TextEncoding -> FilePath -> FilePath -> IO ()
writeFileEncoding TextEncoding
enc FilePath
file FilePath
x = FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
file IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
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
writeFileUTF8 :: FilePath -> String -> IO ()
writeFileUTF8 :: FilePath -> FilePath -> IO ()
writeFileUTF8 = TextEncoding -> FilePath -> FilePath -> IO ()
writeFileEncoding TextEncoding
utf8
writeFileBinary :: FilePath -> String -> IO ()
writeFileBinary :: FilePath -> FilePath -> IO ()
writeFileBinary FilePath
file FilePath
x = FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
file IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
x
captureOutput :: IO a -> IO (String, a)
captureOutput :: forall a. IO a -> IO (FilePath, a)
captureOutput IO a
act = (FilePath -> IO (FilePath, a)) -> IO (FilePath, a)
forall a. (FilePath -> IO a) -> IO a
withTempFile ((FilePath -> IO (FilePath, a)) -> IO (FilePath, a))
-> (FilePath -> IO (FilePath, a)) -> IO (FilePath, a)
forall a b. (a -> b) -> a -> b
$ \FilePath
file ->
FilePath
-> IOMode -> (Handle -> IO (FilePath, a)) -> IO (FilePath, a)
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
file IOMode
ReadWriteMode ((Handle -> IO (FilePath, a)) -> IO (FilePath, a))
-> (Handle -> IO (FilePath, a)) -> IO (FilePath, a)
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
a
res <- Handle -> Handle -> IO a -> IO a
forall {b}. Handle -> Handle -> IO b -> IO b
clone Handle
stdout Handle
h (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> IO a -> IO a
forall {b}. Handle -> Handle -> IO b -> IO b
clone Handle
stderr Handle
h (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose Handle
h
IO a
act
FilePath
out <- FilePath -> IO FilePath
readFile' FilePath
file
(FilePath, a) -> IO (FilePath, a)
forall a. a -> IO a
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 IO b -> IO () -> IO b
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
withBuffering :: Handle -> BufferMode -> IO a -> IO a
withBuffering :: forall a. Handle -> BufferMode -> IO a -> IO a
withBuffering Handle
h BufferMode
m IO a
act = IO BufferMode
-> (BufferMode -> IO ()) -> (BufferMode -> IO a) -> IO a
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) ((BufferMode -> IO a) -> IO a) -> (BufferMode -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> BufferMode -> IO a
forall a b. a -> b -> a
const (IO a -> BufferMode -> IO a) -> IO a -> BufferMode -> IO a
forall a b. (a -> b) -> a -> b
$ do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
m
IO a
act
{-# NOINLINE tempRef #-}
tempRef :: IORef Int
tempRef :: IORef Int
tempRef = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ do
Integer
rand :: Integer <- (UTCTime -> Integer) -> IO UTCTime -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> Integer
forall a. Read a => FilePath -> a
read (FilePath -> Integer)
-> (UTCTime -> FilePath) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (UTCTime -> FilePath) -> UTCTime -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit (FilePath -> FilePath)
-> (UTCTime -> FilePath) -> UTCTime -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> FilePath
forall a. Show a => a -> FilePath
show (DiffTime -> FilePath)
-> (UTCTime -> DiffTime) -> UTCTime -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> DiffTime
utctDayTime) IO UTCTime
getCurrentTime
Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int -> IO (IORef Int)) -> Int -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rand
tempUnique :: IO Int
tempUnique :: IO Int
tempUnique = IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Int
tempRef ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> (Int -> Int) -> Int -> (Int, Int)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& Int -> Int
forall a. Enum a => a -> a
succ
newTempFile :: IO (FilePath, IO ())
newTempFile :: IO (FilePath, IO ())
newTempFile = FilePath -> IO (FilePath, IO ())
newTempFileWithin (FilePath -> IO (FilePath, IO ()))
-> IO FilePath -> IO (FilePath, IO ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
getTemporaryDirectory
newTempFileWithin :: FilePath -> IO (FilePath, IO ())
newTempFileWithin :: FilePath -> IO (FilePath, IO ())
newTempFileWithin FilePath
tmpdir = do
FilePath
file <- IO FilePath
create
IO ()
del <- IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
once (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
file
(FilePath, IO ()) -> IO (FilePath, IO ())
forall a. a -> IO a
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) <- (IOError -> Bool)
-> Int -> IO (FilePath, Handle) -> IO (FilePath, Handle)
forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
retryBool (\(IOError
_ :: IOError) -> Bool
True) Int
5 (IO (FilePath, Handle) -> IO (FilePath, Handle))
-> IO (FilePath, Handle) -> IO (FilePath, Handle)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmpdir (FilePath -> IO (FilePath, Handle))
-> FilePath -> IO (FilePath, Handle)
forall a b. (a -> b) -> a -> b
$ FilePath
"extra-file-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
val FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-"
Handle -> IO ()
hClose Handle
h
FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
file
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 IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` IO ()
del
newTempDir :: IO (FilePath, IO ())
newTempDir :: IO (FilePath, IO ())
newTempDir = FilePath -> IO (FilePath, IO ())
newTempDirWithin (FilePath -> IO (FilePath, IO ()))
-> IO FilePath -> IO (FilePath, IO ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
getTemporaryDirectory
newTempDirWithin :: FilePath -> IO (FilePath, IO ())
newTempDirWithin :: FilePath -> IO (FilePath, IO ())
newTempDirWithin FilePath
tmpdir = do
FilePath
dir <- (IOError -> Bool) -> Int -> IO FilePath -> IO FilePath
forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
retryBool (\(IOError
_ :: IOError) -> Bool
True) Int
5 (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
create FilePath
tmpdir
IO ()
del <- IO () -> IO (IO ())
forall a. IO a -> IO (IO a)
once (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
dir
(FilePath, IO ()) -> IO (FilePath, IO ())
forall a. a -> IO a
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-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
v
(IOError -> Bool)
-> IO FilePath -> (IOError -> IO FilePath) -> IO FilePath
forall e a.
Exception e =>
(e -> Bool) -> IO a -> (e -> IO a) -> IO a
catchBool IOError -> Bool
isAlreadyExistsError
(FilePath -> IO ()
createDirectoryPrivate FilePath
dir IO () -> IO FilePath -> IO FilePath
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
dir) ((IOError -> IO FilePath) -> IO FilePath)
-> (IOError -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$
\IOError
_ -> FilePath -> IO FilePath
create FilePath
tmpdir
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 IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` IO ()
del
sameSize :: Handle -> Handle -> IO Bool
sameSize :: Handle -> Handle -> IO Bool
sameSize Handle
h1 Handle
h2 = (Integer -> Integer -> Bool) -> IO Integer -> IO Integer -> IO Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Integer -> Integer -> Bool
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
sameContent :: Handle -> Handle -> IO Bool
sameContent :: Handle -> Handle -> IO Bool
sameContent Handle
h1 Handle
h2 = Handle -> Handle -> IO Bool
sameSize Handle
h1 Handle
h2 IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ (Ptr CUChar -> IO Bool) -> IO Bool
forall {a} {b}. (Ptr a -> IO b) -> IO b
withb (\Ptr CUChar
b1 -> (Ptr CUChar -> IO Bool) -> IO Bool
forall {a} {b}. (Ptr a -> IO b) -> IO b
withb ((Ptr CUChar -> IO Bool) -> IO Bool)
-> (Ptr CUChar -> IO Bool) -> IO Bool
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 <- Handle -> Ptr CUChar -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h1 Ptr CUChar
b1 Int
bufsz
Int
r2 <- Handle -> Ptr CUChar -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h2 Ptr CUChar
b2 Int
bufsz
if Int
r1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int
r2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
r1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r2) IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Ptr CUChar -> Ptr CUChar -> Int -> IO Bool
forall {a}. Integral a => Ptr CUChar -> Ptr CUChar -> a -> IO Bool
bufeq Ptr CUChar
b1 Ptr CUChar
b2 Int
r1 IO Bool -> IO Bool -> IO Bool
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 = (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==CInt
0) (CInt -> Bool) -> IO CInt -> IO Bool
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 (a -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
s)
withb :: (Ptr a -> IO b) -> IO b
withb = Int -> Int -> (Ptr a -> IO b) -> IO b
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned Int
bufsz Int
4096
bufsz :: Int
bufsz = Int
64Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024
fileEq :: FilePath -> FilePath -> IO Bool
fileEq :: FilePath -> FilePath -> IO Bool
fileEq FilePath
p1 FilePath
p2 = FilePath -> (Handle -> IO Bool) -> IO Bool
forall {r}. FilePath -> (Handle -> IO r) -> IO r
withH FilePath
p1 ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h1 -> FilePath -> (Handle -> IO Bool) -> IO Bool
forall {r}. FilePath -> (Handle -> IO r) -> IO r
withH FilePath
p2 ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
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 = FilePath -> IOMode -> (Handle -> IO r) -> IO r
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
p IOMode
ReadMode