{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
module System.FS.BlockIO.API (
HasBlockIO (..)
, IOOp (..)
, ioopHandle
, ioopFileOffset
, ioopBuffer
, ioopBufferOffset
, ioopByteCount
, IOResult (..)
, Advice (..)
, hAdviseAll
, hDropCacheAll
, GHC.LockMode (..)
, GHC.FileLockingNotSupported (..)
, LockFileHandle (..)
, synchroniseFile
, synchroniseDirectoryRecursive
, ByteCount
, FileOffset
) where
import Control.DeepSeq
import Control.Monad (forM_)
import Control.Monad.Class.MonadThrow (MonadThrow (..))
import Control.Monad.Primitive (PrimMonad (PrimState))
import Data.Primitive.ByteArray (MutableByteArray)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
import qualified GHC.IO.Handle.Lock as GHC
import GHC.Stack (HasCallStack)
import qualified System.FS.API as FS
import System.FS.API (BufferOffset, FsPath, Handle (..), HasFS)
import System.Posix.Types (ByteCount, FileOffset)
import Text.Printf
data HasBlockIO m h = HasBlockIO {
forall (m :: * -> *) h. HasBlockIO m h -> HasCallStack => m ()
close :: HasCallStack => m ()
, forall (m :: * -> *) h.
HasBlockIO m h
-> HasCallStack =>
Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
submitIO :: HasCallStack => V.Vector (IOOp (PrimState m) h) -> m (VU.Vector IOResult)
, forall (m :: * -> *) h. HasBlockIO m h -> Handle h -> Bool -> m ()
hSetNoCache :: Handle h -> Bool -> m ()
, forall (m :: * -> *) h.
HasBlockIO m h
-> Handle h -> FileOffset -> FileOffset -> Advice -> m ()
hAdvise :: Handle h -> FileOffset -> FileOffset -> Advice -> m ()
, forall (m :: * -> *) h.
HasBlockIO m h -> Handle h -> FileOffset -> FileOffset -> m ()
hAllocate :: Handle h -> FileOffset -> FileOffset -> m ()
, forall (m :: * -> *) h.
HasBlockIO m h
-> FsPath -> LockMode -> m (Maybe (LockFileHandle m))
tryLockFile :: FsPath -> GHC.LockMode -> m (Maybe (LockFileHandle m))
, forall (m :: * -> *) h. HasBlockIO m h -> Handle h -> m ()
hSynchronise :: Handle h -> m ()
, forall (m :: * -> *) h. HasBlockIO m h -> FsPath -> m ()
synchroniseDirectory :: FsPath -> m ()
, forall (m :: * -> *) h. HasBlockIO m h -> FsPath -> FsPath -> m ()
createHardLink :: FsPath -> FsPath -> m ()
}
instance NFData (HasBlockIO m h) where
rnf :: HasBlockIO m h -> ()
rnf (HasBlockIO HasCallStack => m ()
a HasCallStack =>
Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
b Handle h -> Bool -> m ()
c Handle h -> FileOffset -> FileOffset -> Advice -> m ()
d Handle h -> FileOffset -> FileOffset -> m ()
e FsPath -> LockMode -> m (Maybe (LockFileHandle m))
f Handle h -> m ()
g FsPath -> m ()
h FsPath -> FsPath -> m ()
i) =
m () -> ()
forall a. a -> ()
rwhnf m ()
HasCallStack => m ()
a () -> () -> ()
forall a b. a -> b -> b
`seq` (Vector (IOOp (PrimState m) h) -> m (Vector IOResult)) -> ()
forall a. a -> ()
rwhnf HasCallStack =>
Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
b () -> () -> ()
forall a b. a -> b -> b
`seq` (Handle h -> Bool -> m ()) -> ()
forall a. NFData a => a -> ()
rnf Handle h -> Bool -> m ()
c () -> () -> ()
forall a b. a -> b -> b
`seq`
(Handle h -> FileOffset -> FileOffset -> Advice -> m ()) -> ()
forall a. a -> ()
rwhnf Handle h -> FileOffset -> FileOffset -> Advice -> m ()
d () -> () -> ()
forall a b. a -> b -> b
`seq` (Handle h -> FileOffset -> FileOffset -> m ()) -> ()
forall a. a -> ()
rwhnf Handle h -> FileOffset -> FileOffset -> m ()
e () -> () -> ()
forall a b. a -> b -> b
`seq` (FsPath -> LockMode -> m (Maybe (LockFileHandle m))) -> ()
forall a. a -> ()
rwhnf FsPath -> LockMode -> m (Maybe (LockFileHandle m))
f () -> () -> ()
forall a b. a -> b -> b
`seq`
(Handle h -> m ()) -> ()
forall a. a -> ()
rwhnf Handle h -> m ()
g () -> () -> ()
forall a b. a -> b -> b
`seq` (FsPath -> m ()) -> ()
forall a. a -> ()
rwhnf FsPath -> m ()
h () -> () -> ()
forall a b. a -> b -> b
`seq` (FsPath -> FsPath -> m ()) -> ()
forall a. a -> ()
rwhnf FsPath -> FsPath -> m ()
i
data IOOp s h =
IOOpRead !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount
| IOOpWrite !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount
instance NFData (IOOp s h) where
rnf :: IOOp s h -> ()
rnf = IOOp s h -> ()
forall a. a -> ()
rwhnf
ioopHandle :: IOOp s h -> Handle h
ioopHandle :: forall s h. IOOp s h -> Handle h
ioopHandle (IOOpRead Handle h
h FileOffset
_ MutableByteArray s
_ BufferOffset
_ ByteCount
_) = Handle h
h
ioopHandle (IOOpWrite Handle h
h FileOffset
_ MutableByteArray s
_ BufferOffset
_ ByteCount
_) = Handle h
h
ioopFileOffset :: IOOp s h -> FileOffset
ioopFileOffset :: forall s h. IOOp s h -> FileOffset
ioopFileOffset (IOOpRead Handle h
_ FileOffset
off MutableByteArray s
_ BufferOffset
_ ByteCount
_) = FileOffset
off
ioopFileOffset (IOOpWrite Handle h
_ FileOffset
off MutableByteArray s
_ BufferOffset
_ ByteCount
_) = FileOffset
off
ioopBuffer :: IOOp s h -> MutableByteArray s
ioopBuffer :: forall s h. IOOp s h -> MutableByteArray s
ioopBuffer (IOOpRead Handle h
_ FileOffset
_ MutableByteArray s
buf BufferOffset
_ ByteCount
_) = MutableByteArray s
buf
ioopBuffer (IOOpWrite Handle h
_ FileOffset
_ MutableByteArray s
buf BufferOffset
_ ByteCount
_) = MutableByteArray s
buf
ioopBufferOffset :: IOOp s h -> BufferOffset
ioopBufferOffset :: forall s h. IOOp s h -> BufferOffset
ioopBufferOffset (IOOpRead Handle h
_ FileOffset
_ MutableByteArray s
_ BufferOffset
bufOff ByteCount
_) = BufferOffset
bufOff
ioopBufferOffset (IOOpWrite Handle h
_ FileOffset
_ MutableByteArray s
_ BufferOffset
bufOff ByteCount
_) = BufferOffset
bufOff
ioopByteCount :: IOOp s h -> ByteCount
ioopByteCount :: forall s h. IOOp s h -> ByteCount
ioopByteCount (IOOpRead Handle h
_ FileOffset
_ MutableByteArray s
_ BufferOffset
_ ByteCount
c) = ByteCount
c
ioopByteCount (IOOpWrite Handle h
_ FileOffset
_ MutableByteArray s
_ BufferOffset
_ ByteCount
c) = ByteCount
c
newtype IOResult = IOResult ByteCount
deriving stock (Int -> IOResult -> ShowS
[IOResult] -> ShowS
IOResult -> String
(Int -> IOResult -> ShowS)
-> (IOResult -> String) -> ([IOResult] -> ShowS) -> Show IOResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IOResult -> ShowS
showsPrec :: Int -> IOResult -> ShowS
$cshow :: IOResult -> String
show :: IOResult -> String
$cshowList :: [IOResult] -> ShowS
showList :: [IOResult] -> ShowS
Show, IOResult -> IOResult -> Bool
(IOResult -> IOResult -> Bool)
-> (IOResult -> IOResult -> Bool) -> Eq IOResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IOResult -> IOResult -> Bool
== :: IOResult -> IOResult -> Bool
$c/= :: IOResult -> IOResult -> Bool
/= :: IOResult -> IOResult -> Bool
Eq)
deriving newtype Addr# -> Int# -> IOResult
ByteArray# -> Int# -> IOResult
Proxy IOResult -> Int#
IOResult -> Int#
(Proxy IOResult -> Int#)
-> (IOResult -> Int#)
-> (Proxy IOResult -> Int#)
-> (IOResult -> Int#)
-> (ByteArray# -> Int# -> IOResult)
-> (forall s.
MutableByteArray# s
-> Int# -> State# s -> (# State# s, IOResult #))
-> (forall s.
MutableByteArray# s -> Int# -> IOResult -> State# s -> State# s)
-> (forall s.
MutableByteArray# s
-> Int# -> Int# -> IOResult -> State# s -> State# s)
-> (Addr# -> Int# -> IOResult)
-> (forall s.
Addr# -> Int# -> State# s -> (# State# s, IOResult #))
-> (forall s. Addr# -> Int# -> IOResult -> State# s -> State# s)
-> (forall s.
Addr# -> Int# -> Int# -> IOResult -> State# s -> State# s)
-> Prim IOResult
forall s. Addr# -> Int# -> Int# -> IOResult -> State# s -> State# s
forall s. Addr# -> Int# -> State# s -> (# State# s, IOResult #)
forall s. Addr# -> Int# -> IOResult -> State# s -> State# s
forall s.
MutableByteArray# s
-> Int# -> Int# -> IOResult -> State# s -> State# s
forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, IOResult #)
forall s.
MutableByteArray# s -> Int# -> IOResult -> State# s -> State# s
forall a.
(Proxy a -> Int#)
-> (a -> Int#)
-> (Proxy a -> Int#)
-> (a -> Int#)
-> (ByteArray# -> Int# -> a)
-> (forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, a #))
-> (forall s.
MutableByteArray# s -> Int# -> a -> State# s -> State# s)
-> (forall s.
MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s)
-> (Addr# -> Int# -> a)
-> (forall s. Addr# -> Int# -> State# s -> (# State# s, a #))
-> (forall s. Addr# -> Int# -> a -> State# s -> State# s)
-> (forall s. Addr# -> Int# -> Int# -> a -> State# s -> State# s)
-> Prim a
$csizeOfType# :: Proxy IOResult -> Int#
sizeOfType# :: Proxy IOResult -> Int#
$csizeOf# :: IOResult -> Int#
sizeOf# :: IOResult -> Int#
$calignmentOfType# :: Proxy IOResult -> Int#
alignmentOfType# :: Proxy IOResult -> Int#
$calignment# :: IOResult -> Int#
alignment# :: IOResult -> Int#
$cindexByteArray# :: ByteArray# -> Int# -> IOResult
indexByteArray# :: ByteArray# -> Int# -> IOResult
$creadByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, IOResult #)
readByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, IOResult #)
$cwriteByteArray# :: forall s.
MutableByteArray# s -> Int# -> IOResult -> State# s -> State# s
writeByteArray# :: forall s.
MutableByteArray# s -> Int# -> IOResult -> State# s -> State# s
$csetByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> IOResult -> State# s -> State# s
setByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> IOResult -> State# s -> State# s
$cindexOffAddr# :: Addr# -> Int# -> IOResult
indexOffAddr# :: Addr# -> Int# -> IOResult
$creadOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, IOResult #)
readOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, IOResult #)
$cwriteOffAddr# :: forall s. Addr# -> Int# -> IOResult -> State# s -> State# s
writeOffAddr# :: forall s. Addr# -> Int# -> IOResult -> State# s -> State# s
$csetOffAddr# :: forall s. Addr# -> Int# -> Int# -> IOResult -> State# s -> State# s
setOffAddr# :: forall s. Addr# -> Int# -> Int# -> IOResult -> State# s -> State# s
VP.Prim
newtype instance VUM.MVector s IOResult = MV_IOResult (VP.MVector s IOResult)
newtype instance VU.Vector IOResult = V_IOResult (VP.Vector IOResult)
deriving via (VU.UnboxViaPrim IOResult) instance VGM.MVector VU.MVector IOResult
deriving via (VU.UnboxViaPrim IOResult) instance VG.Vector VU.Vector IOResult
instance VUM.Unbox IOResult
data Advice =
AdviceNormal
| AdviceRandom
| AdviceSequential
| AdviceWillNeed
| AdviceDontNeed
| AdviceNoReuse
deriving stock (Int -> Advice -> ShowS
[Advice] -> ShowS
Advice -> String
(Int -> Advice -> ShowS)
-> (Advice -> String) -> ([Advice] -> ShowS) -> Show Advice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Advice -> ShowS
showsPrec :: Int -> Advice -> ShowS
$cshow :: Advice -> String
show :: Advice -> String
$cshowList :: [Advice] -> ShowS
showList :: [Advice] -> ShowS
Show, Advice -> Advice -> Bool
(Advice -> Advice -> Bool)
-> (Advice -> Advice -> Bool) -> Eq Advice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Advice -> Advice -> Bool
== :: Advice -> Advice -> Bool
$c/= :: Advice -> Advice -> Bool
/= :: Advice -> Advice -> Bool
Eq)
hAdviseAll :: HasBlockIO m h -> Handle h -> Advice -> m ()
hAdviseAll :: forall (m :: * -> *) h.
HasBlockIO m h -> Handle h -> Advice -> m ()
hAdviseAll HasBlockIO m h
hbio Handle h
h Advice
advice = HasBlockIO m h
-> Handle h -> FileOffset -> FileOffset -> Advice -> m ()
forall (m :: * -> *) h.
HasBlockIO m h
-> Handle h -> FileOffset -> FileOffset -> Advice -> m ()
hAdvise HasBlockIO m h
hbio Handle h
h FileOffset
0 FileOffset
0 Advice
advice
hDropCacheAll :: HasBlockIO m h -> Handle h -> m ()
hDropCacheAll :: forall (m :: * -> *) h. HasBlockIO m h -> Handle h -> m ()
hDropCacheAll HasBlockIO m h
hbio Handle h
h = HasBlockIO m h -> Handle h -> Advice -> m ()
forall (m :: * -> *) h.
HasBlockIO m h -> Handle h -> Advice -> m ()
hAdviseAll HasBlockIO m h
hbio Handle h
h Advice
AdviceDontNeed
{-# SPECIALISE synchroniseFile :: HasFS IO h -> HasBlockIO IO h -> FsPath -> IO () #-}
synchroniseFile :: MonadThrow m => HasFS m h -> HasBlockIO m h -> FsPath -> m ()
synchroniseFile :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> HasBlockIO m h -> FsPath -> m ()
synchroniseFile HasFS m h
hfs HasBlockIO m h
hbio FsPath
path =
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
FS.withFile HasFS m h
hfs FsPath
path (AllowExisting -> OpenMode
FS.ReadWriteMode AllowExisting
FS.MustExist) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ HasBlockIO m h -> Handle h -> m ()
forall (m :: * -> *) h. HasBlockIO m h -> Handle h -> m ()
hSynchronise HasBlockIO m h
hbio
{-# SPECIALISE synchroniseDirectoryRecursive ::
HasFS IO h
-> HasBlockIO IO h
-> FsPath
-> IO ()
#-}
synchroniseDirectoryRecursive ::
MonadThrow m
=> HasFS m h
-> HasBlockIO m h
-> FsPath
-> m ()
synchroniseDirectoryRecursive :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> HasBlockIO m h -> FsPath -> m ()
synchroniseDirectoryRecursive HasFS m h
hfs HasBlockIO m h
hbio FsPath
path = do
Set String
entries <- HasFS m h -> HasCallStack => FsPath -> m (Set String)
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
FS.listDirectory HasFS m h
hfs FsPath
path
Set String -> (String -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set String
entries ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
entry -> do
let path' :: FsPath
path' = FsPath
path FsPath -> FsPath -> FsPath
FS.</> [String] -> FsPath
FS.mkFsPath [String
entry]
Bool
isFile <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
FS.doesFileExist HasFS m h
hfs FsPath
path'
if Bool
isFile then
HasFS m h -> HasBlockIO m h -> FsPath -> m ()
forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> HasBlockIO m h -> FsPath -> m ()
synchroniseFile HasFS m h
hfs HasBlockIO m h
hbio FsPath
path'
else do
Bool
isDirectory <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
FS.doesDirectoryExist HasFS m h
hfs FsPath
path'
if Bool
isDirectory then do
HasFS m h -> HasBlockIO m h -> FsPath -> m ()
forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> HasBlockIO m h -> FsPath -> m ()
synchroniseDirectoryRecursive HasFS m h
hfs HasBlockIO m h
hbio FsPath
path'
HasBlockIO m h -> FsPath -> m ()
forall (m :: * -> *) h. HasBlockIO m h -> FsPath -> m ()
synchroniseDirectory HasBlockIO m h
hbio FsPath
path'
else
String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf
String
"listDirectoryRecursive: %s is not a file or directory"
(FsPath -> String
forall a. Show a => a -> String
show FsPath
path')
newtype LockFileHandle m = LockFileHandle {
forall (m :: * -> *). LockFileHandle m -> m ()
hUnlock :: m ()
}