{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UnboxedTuples              #-}

module System.FS.BlockIO.API (
    -- * HasBlockIO
    HasBlockIO (..)
  , IOCtxParams (..)
  , defaultIOCtxParams
  , mkClosedError
  , IOOp (..)
  , ioopHandle
  , ioopFileOffset
  , ioopBuffer
  , ioopBufferOffset
  , ioopByteCount
  , IOResult (..)
    -- ** Advice
  , Advice (..)
  , hAdviseAll
  , hDropCacheAll
    -- ** File locks
  , GHC.LockMode (..)
  , GHC.FileLockingNotSupported (..)
  , LockFileHandle (..)
    -- ** Storage synchronisation
  , synchroniseFile
  , synchroniseDirectoryRecursive
    -- * Defaults for the real file system
  , tryLockFileIO
  , createHardLinkIO
    -- * Re-exports
  , ByteCount
  , FileOffset
  ) where

import           Control.DeepSeq
import           Control.Monad (forM_)
import           Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
                     MonadThrow (..), bracketOnError, try)
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           GHC.IO.Exception (IOErrorType (ResourceVanished))
import qualified GHC.IO.Handle.Lock as GHC
import           GHC.Stack (HasCallStack)
import qualified System.FS.API as FS
import           System.FS.API (BufferOffset, FsError (..), FsPath, Handle (..),
                     HasFS, SomeHasFS (..))
import           System.FS.IO (HandleIO)
import qualified System.IO as GHC
import           System.IO.Error (ioeSetErrorString, mkIOError)
import           System.Posix.Types (ByteCount, FileOffset)
import           Text.Printf

-- | Abstract interface for submitting large batches of I\/O operations.
data HasBlockIO m h = HasBlockIO {
    -- | (Idempotent) close the interface.
    --
    -- Using 'submitIO' after 'close' should thrown an 'FsError' exception. See
    -- 'mkClosedError'.
    forall (m :: * -> *) h. HasBlockIO m h -> HasCallStack => m ()
close    :: HasCallStack => m ()
    -- | Submit a batch of I\/O operations and wait for the result.
    --
    -- Results correspond to input 'IOOp's in a pair-wise manner, i.e., one can
    -- match 'IOOp's with 'IOResult's by indexing into both vectors at the same
    -- position.
    --
    -- If any of the I\/O operations fails, an 'FsError' exception will be thrown.
  , 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)
    -- | Set the file data caching mode for a file handle.
    --
    -- This has different effects on different distributions.
    -- * [Linux]: set the @O_DIRECT@ flag.
    -- * [MacOS]: set the @F_NOCACHE@ flag.
    -- * [Windows]: no-op.
    --
    -- TODO: subsequent reads/writes with misaligned byte arrays should fail
    -- both in simulation and real implementation.
  , forall (m :: * -> *) h. HasBlockIO m h -> Handle h -> Bool -> m ()
hSetNoCache :: Handle h -> Bool -> m ()
    -- | Predeclare an access pattern for file data.
    --
    -- This has different effects on different distributions.
    -- * [Linux]: perform @posix_fadvise(2).
    -- * [MacOS]: no-op.
    -- * [Windows]: no-op.
  , forall (m :: * -> *) h.
HasBlockIO m h
-> Handle h -> FileOffset -> FileOffset -> Advice -> m ()
hAdvise :: Handle h -> FileOffset -> FileOffset -> Advice -> m ()
    -- | Allocate file space.
    --
    -- This has different effects on different distributions.
    -- * [Linux]: perform @posix_fallocate(2).
    -- * [MacOS]: no-op.
    -- * [Windows]: no-op.
  , forall (m :: * -> *) h.
HasBlockIO m h -> Handle h -> FileOffset -> FileOffset -> m ()
hAllocate :: Handle h -> FileOffset -> FileOffset -> m ()
    -- | Try to acquire a file lock without blocking.
    --
    -- This uses different locking methods on different distributions.
    -- * [Linux]: Open file descriptor (OFD)
    -- * [MacOS]: @flock@
    -- * [Windows]: @LockFileEx@
    --
    -- This function can throw 'GHC.FileLockingNotSupported' when file locking
    -- is not supported.
    --
    -- NOTE: though it would have been nicer to allow locking /file handles/
    -- instead of /file paths/, it would make the implementation of this
    -- function in 'IO' much more complex. In particular, if we want to reuse
    -- "GHC.IO.Handle.Lock" functionality, then we have to either ...
    --
    -- 1. Convert there and back between OS-specific file desciptors and
    --   'GHC.Handle's, which is not possible on Windows without creating new
    --   file descriptors, or ...
    -- 2. Vendor all of the "GHC.IO.Handle.Lock" code and its dependencies
    --    (i.e., modules), which is a prohibitively large body of code for GHC
    --    versions before @9.0@.
    --
    -- The current interface is therefore limited, but should be sufficient for
    -- use cases where a lock file is used to guard against concurrent access by
    -- different processes. e.g., a database lock file.
    --
    -- TODO: it is /probably/ possible to provide a 'onLockFileHandle' function
    -- that allows you to use 'LockFileHandle' as a 'Handle', but only within a
    -- limited scope. That is, it has to fit the style of @withHandleToHANDLE ::
    -- Handle -> (HANDLE -> IO a) -> IO a@ from the @Win32@ package.
  , forall (m :: * -> *) h.
HasBlockIO m h
-> FsPath -> LockMode -> m (Maybe (LockFileHandle m))
tryLockFile :: FsPath -> GHC.LockMode -> m (Maybe (LockFileHandle m))

    -- | Synchronise file contents with the storage device.
    --
    -- Ensure that all change to the file handle's contents which exist only in
    -- memory (as buffered system cache pages) are transfered/flushed to disk.
    -- This will also update the file handle's associated metadata.
    --
    -- This uses different system calls on different distributions.
    -- * [Linux]: @fsync(2)@
    -- * [MacOS]: @fsync(2)@
    -- * [Windows]: @flushFileBuffers@
  , forall (m :: * -> *) h. HasBlockIO m h -> Handle h -> m ()
hSynchronise :: Handle h -> m ()

    -- | Synchronise a directory with the storage device.
    --
    -- This uses different system calls on different distributions.
    -- * [Linux]: @fsync(2)@
    -- * [MacOS]: @fsync(2)@
    -- * [Windows]: no-op
  , forall (m :: * -> *) h. HasBlockIO m h -> FsPath -> m ()
synchroniseDirectory :: FsPath -> m ()

    -- | Create a hard link for an existing file at the source path and a new
    -- file at the target path.
    --
    -- This uses different system calls on different distributions.
    -- * [Linux]: @link@
    -- * [MacOS]: @link@
    -- * [Windows]: @CreateHardLinkW@
  , 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

-- | Concurrency parameters for initialising a 'HasBlockIO. Can be ignored by
-- serial implementations.
data IOCtxParams = IOCtxParams {
                     IOCtxParams -> Int
ioctxBatchSizeLimit   :: !Int,
                     IOCtxParams -> Int
ioctxConcurrencyLimit :: !Int
                   }

instance NFData IOCtxParams where
  rnf :: IOCtxParams -> ()
rnf (IOCtxParams Int
x Int
y) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
x () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
y

defaultIOCtxParams :: IOCtxParams
defaultIOCtxParams :: IOCtxParams
defaultIOCtxParams = IOCtxParams {
      ioctxBatchSizeLimit :: Int
ioctxBatchSizeLimit   = Int
64,
      ioctxConcurrencyLimit :: Int
ioctxConcurrencyLimit = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
    }

mkClosedError :: HasCallStack => SomeHasFS m -> String -> FsError
mkClosedError :: forall (m :: * -> *).
HasCallStack =>
SomeHasFS m -> String -> FsError
mkClosedError (SomeHasFS HasFS m h
hasFS) String
loc = HasCallStack => FsErrorPath -> IOError -> FsError
FsErrorPath -> IOError -> FsError
FS.ioToFsError (HasFS m h -> FsPath -> FsErrorPath
forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
FS.mkFsErrorPath HasFS m h
hasFS ([String] -> FsPath
FS.mkFsPath [])) IOError
ioerr
  where ioerr :: IOError
ioerr =
          IOError -> String -> IOError
ioeSetErrorString
            (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
ResourceVanished String
loc Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
            (String
"HasBlockIO closed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
loc)


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

-- | Number of read/written bytes.
newtype IOResult = IOResult ByteCount
  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

{-------------------------------------------------------------------------------
  Advice
-------------------------------------------------------------------------------}

-- | Basically "System.Posix.Fcntl.Advice" from the @unix@ package
data Advice =
    AdviceNormal
  | AdviceRandom
  | AdviceSequential
  | AdviceWillNeed
  | AdviceDontNeed
  | AdviceNoReuse
  deriving stock (Int -> Advice -> String -> String
[Advice] -> String -> String
Advice -> String
(Int -> Advice -> String -> String)
-> (Advice -> String)
-> ([Advice] -> String -> String)
-> Show Advice
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Advice -> String -> String
showsPrec :: Int -> Advice -> String -> String
$cshow :: Advice -> String
show :: Advice -> String
$cshowList :: [Advice] -> String -> String
showList :: [Advice] -> String -> String
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)

-- | Apply 'Advice' to all bytes of a file, which is referenced by a 'Handle'.
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 -- len=0 implies until the end of file

-- | Drop the full file referenced by a 'Handle' from the OS page cache, if
-- present.
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

{-------------------------------------------------------------------------------
  Storage synchronisation
-------------------------------------------------------------------------------}

{-# SPECIALISE synchroniseFile :: HasFS IO h -> HasBlockIO IO h -> FsPath -> IO () #-}
-- | Synchronise a file and its contents with the storage device.
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 ()
  #-}
-- | Synchronise a directory and recursively its contents with the storage
-- device.
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 -> String -> String
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')

{-------------------------------------------------------------------------------
  File locks
-------------------------------------------------------------------------------}

-- | A handle to a file locked using 'tryLockFile'.
newtype LockFileHandle m = LockFileHandle {
    -- | Release a file lock acquired using 'tryLockFile'.
    forall (m :: * -> *). LockFileHandle m -> m ()
hUnlock :: m ()
  }

tryLockFileIO :: HasFS IO HandleIO -> FsPath -> GHC.LockMode -> IO (Maybe (LockFileHandle IO))
tryLockFileIO :: HasFS IO HandleIO
-> FsPath -> LockMode -> IO (Maybe (LockFileHandle IO))
tryLockFileIO HasFS IO HandleIO
hfs FsPath
fsp LockMode
mode = do
    String
fp <- HasFS IO HandleIO -> FsPath -> IO String
forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
FS.unsafeToFilePath HasFS IO HandleIO
hfs FsPath
fsp -- shouldn't fail because we are in IO
    HasFS IO HandleIO
-> FsPath
-> IO (Maybe (LockFileHandle IO))
-> IO (Maybe (LockFileHandle IO))
forall a.
HasCallStack =>
HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO HasFS IO HandleIO
hfs FsPath
fsp (IO (Maybe (LockFileHandle IO)) -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO)) -> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$
      IO Handle
-> (Handle -> IO ())
-> (Handle -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError (String -> IOMode -> IO Handle
GHC.openFile String
fp IOMode
GHC.WriteMode) Handle -> IO ()
GHC.hClose ((Handle -> IO (Maybe (LockFileHandle IO)))
 -> IO (Maybe (LockFileHandle IO)))
-> (Handle -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        IO Bool
-> (Bool -> IO ())
-> (Bool -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError (Handle -> LockMode -> IO Bool
GHC.hTryLock Handle
h LockMode
mode) (\Bool
_ -> Handle -> IO ()
GHC.hUnlock Handle
h) ((Bool -> IO (Maybe (LockFileHandle IO)))
 -> IO (Maybe (LockFileHandle IO)))
-> (Bool -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ \Bool
b -> do
          if Bool
b then
            Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO)))
-> Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ LockFileHandle IO -> Maybe (LockFileHandle IO)
forall a. a -> Maybe a
Just LockFileHandle { hUnlock :: IO ()
hUnlock = HasFS IO HandleIO -> FsPath -> IO () -> IO ()
forall a.
HasCallStack =>
HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO HasFS IO HandleIO
hfs FsPath
fsp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  Handle -> IO ()
GHC.hUnlock Handle
h
                    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Handle -> IO ()
GHC.hClose Handle
h
                }
          else
            Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO)))
-> Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ Maybe (LockFileHandle IO)
forall a. Maybe a
Nothing

-- This is copied/adapted from System.FS.IO
rethrowFsErrorIO :: HasCallStack => HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO :: forall a.
HasCallStack =>
HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO HasFS IO HandleIO
hfs FsPath
fp IO a
action = do
    Either IOError a
res <- IO a -> IO (Either IOError a)
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try IO a
action
    case Either IOError a
res of
      Left IOError
err -> IOError -> IO a
forall a. HasCallStack => IOError -> IO a
handleError IOError
err
      Right a
a  -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  where
    handleError :: HasCallStack => IOError -> IO a
    handleError :: forall a. HasCallStack => IOError -> IO a
handleError IOError
ioErr =
      FsError -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FsError -> IO a) -> FsError -> IO a
forall a b. (a -> b) -> a -> b
$ HasCallStack => FsErrorPath -> IOError -> FsError
FsErrorPath -> IOError -> FsError
FS.ioToFsError (HasFS IO HandleIO -> FsPath -> FsErrorPath
forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
FS.mkFsErrorPath HasFS IO HandleIO
hfs FsPath
fp) IOError
ioErr

{-------------------------------------------------------------------------------
  Hard links
-------------------------------------------------------------------------------}

createHardLinkIO ::
     HasFS IO HandleIO
  -> (FilePath -> FilePath -> IO ())
  -> (FsPath -> FsPath -> IO ())
createHardLinkIO :: HasFS IO HandleIO
-> (String -> String -> IO ()) -> FsPath -> FsPath -> IO ()
createHardLinkIO HasFS IO HandleIO
hfs String -> String -> IO ()
f = \FsPath
source FsPath
target -> do
    String
source' <- HasFS IO HandleIO -> FsPath -> IO String
forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
FS.unsafeToFilePath HasFS IO HandleIO
hfs FsPath
source -- shouldn't fail because we are in IO
    String
target' <- HasFS IO HandleIO -> FsPath -> IO String
forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
FS.unsafeToFilePath HasFS IO HandleIO
hfs FsPath
target -- shouldn't fail because we are in IO
    String -> String -> IO ()
f String
source' String
target'