module Database.LSMTree.Internal.FS (
    -- * Hard links
    hardLink
  , hardLinkDirectoryRecursive
    -- * Copy file
  , copyFile
  ) where

import           Control.ActionRegistry
import           Control.Monad (forM_, void)
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Primitive (PrimMonad)

import qualified System.FS.API as FS
import           System.FS.API
import qualified System.FS.API.Lazy as FSL
import qualified System.FS.BlockIO.API as FS
import           System.FS.BlockIO.API (HasBlockIO)
import           Text.Printf (printf)

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

{-# SPECIALISE
  hardLink ::
       HasFS IO h
    -> HasBlockIO IO h
    -> ActionRegistry IO
    -> FS.FsPath
    -> FS.FsPath
    -> IO ()
  #-}
-- | @'hardLink' hfs hbio reg sourcePath destinationPath@ creates a hard link from
-- @sourcePath@ to @destinationPath@.
--
-- Both the source path and destination path should be on the same disk volume.
hardLink ::
     (MonadMask m, PrimMonad m)
  => HasFS m h
  -> HasBlockIO m h
  -> ActionRegistry m
  -> FS.FsPath
  -> FS.FsPath
  -> m ()
hardLink :: forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> HasBlockIO m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLink HasFS m h
hfs HasBlockIO m h
hbio ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath = do
    ActionRegistry m -> m () -> m () -> m ()
forall (m :: * -> *) a.
(PrimMonad m, MonadMask m, HasCallStack) =>
ActionRegistry m -> m a -> m () -> m a
withRollback_ ActionRegistry m
reg
      (HasBlockIO m h -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h. HasBlockIO m h -> FsPath -> FsPath -> m ()
FS.createHardLink HasBlockIO m h
hbio FsPath
sourcePath FsPath
destinationPath)
      (HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
FS.removeFile HasFS m h
hfs FsPath
destinationPath)

{-# SPECIALISE
  hardLinkDirectoryRecursive ::
       HasFS IO h
    -> HasBlockIO IO h
    -> ActionRegistry IO
    -> FS.FsPath
    -> FS.FsPath
    -> IO ()
  #-}
-- | Recursively create hard links for all the directory contents of the source
-- path at the destination path.
--
-- Both the source path and destination path should be on the same disk volume.
hardLinkDirectoryRecursive ::
     (MonadMask m, PrimMonad m)
  => HasFS m h
  -> HasBlockIO m h
  -> ActionRegistry m
     -- | Source path
  -> FS.FsPath
     -- | Destination path
  -> FS.FsPath
  -> m ()
hardLinkDirectoryRecursive :: forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> HasBlockIO m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLinkDirectoryRecursive HasFS m h
hfs HasBlockIO m h
hbio ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath = 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
sourcePath
    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 sourcePath' :: FsPath
sourcePath' = FsPath
sourcePath FsPath -> FsPath -> FsPath
FS.</> [String] -> FsPath
FS.mkFsPath [String
entry]
          destinationPath' :: FsPath
destinationPath' = FsPath
destinationPath 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
sourcePath'
      if Bool
isFile then
        HasFS m h
-> HasBlockIO m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> HasBlockIO m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLink HasFS m h
hfs HasBlockIO m h
hbio ActionRegistry m
reg FsPath
sourcePath' FsPath
destinationPath'
      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
sourcePath'
        if Bool
isDirectory then do
          HasFS m h
-> HasBlockIO m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> HasBlockIO m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLinkDirectoryRecursive HasFS m h
hfs HasBlockIO m h
hbio ActionRegistry m
reg FsPath
sourcePath' FsPath
destinationPath'
        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
"hardLinkDirectoryRecursive: %s is not a file or directory"
            (FsPath -> String
forall a. Show a => a -> String
show FsPath
sourcePath')

{-------------------------------------------------------------------------------
  Copy file
-------------------------------------------------------------------------------}

{-# SPECIALISE
  copyFile ::
       HasFS IO h
    -> ActionRegistry IO
    -> FS.FsPath
    -> FS.FsPath
    -> IO ()
  #-}
-- | @'copyFile' hfs reg sourcePath destinationPath@ copies the file contents of
-- @sourcePath@ to the @destinationPath@.
copyFile ::
     (MonadMask m, PrimMonad m)
  => HasFS m h
  -> ActionRegistry m
  -> FS.FsPath
  -> FS.FsPath
  -> m ()
copyFile :: forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
copyFile HasFS m h
hfs ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath =
    (m () -> m () -> m ()) -> m () -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ActionRegistry m -> m () -> m () -> m ()
forall (m :: * -> *) a.
(PrimMonad m, MonadMask m, HasCallStack) =>
ActionRegistry m -> m a -> m () -> m a
withRollback_ ActionRegistry m
reg) (HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
FS.removeFile HasFS m h
hfs FsPath
destinationPath) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      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
sourcePath OpenMode
FS.ReadMode ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
sourceHandle ->
        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
destinationPath (AllowExisting -> OpenMode
FS.WriteMode AllowExisting
FS.MustBeNew) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
targetHandle -> do
          ByteString
bs <- HasFS m h -> Handle h -> m ByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> m ByteString
FSL.hGetAll HasFS m h
hfs Handle h
sourceHandle
          m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
FSL.hPutAll HasFS m h
hfs Handle h
targetHandle ByteString
bs