{-# 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
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
file IOMode
ReadMode
hSetEncoding h enc
hGetContents 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
h <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
file IOMode
ReadMode
hGetContents 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
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
out <- readFile' file
pure (out, res)
where
clone :: Handle -> Handle -> IO b -> IO b
clone Handle
out Handle
h IO b
act = do
buf <- Handle -> IO BufferMode
hGetBuffering Handle
out
out2 <- hDuplicate out
hDuplicateTo h out
act `finally` do
hDuplicateTo out2 out
hClose out2
hSetBuffering out 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
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
newIORef $ fromIntegral 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
file <- IO FilePath
create
del <- once $ ignore $ removeFile file
pure (file, del)
where
create :: IO FilePath
create = do
val <- IO Int
tempUnique
(file, h) <- retryBool (\(IOError
_ :: IOError) -> Bool
True) 5 $ openTempFile tmpdir $ "extra-file-" ++ show val ++ "-"
hClose h
pure file
withTempFile :: (FilePath -> IO a) -> IO a
withTempFile :: forall a. (FilePath -> IO a) -> IO a
withTempFile FilePath -> IO a
act = do
(file, del) <- IO (FilePath, IO ())
newTempFile
act file `finally` 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
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
del <- once $ ignore $ removeDirectoryRecursive dir
pure (dir, del)
where
create :: FilePath -> IO FilePath
create FilePath
tmpdir = do
v <- IO Int
tempUnique
let 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
catchBool isAlreadyExistsError
(createDirectoryPrivate dir >> pure dir) $
\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
(dir,del) <- IO (FilePath, IO ())
newTempDir
act dir `finally` 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
r1 <- Handle -> Ptr CUChar -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h1 Ptr CUChar
b1 Int
bufsz
r2 <- hGetBuf h2 b2 bufsz
if r1 == 0
then pure $ r2 == 0
else pure (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 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