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

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

import           Foreign.C.Error (eXDEV)
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 = HasFS m h
-> HasFS m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h h'.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> HasFS m h' -> ActionRegistry m -> FsPath -> FsPath -> m ()
copyFile' HasFS m h
hfs HasFS m h
hfs

{-# SPECIALISE
  copyFile' ::
       HasFS IO h
    -> HasFS IO h'
    -> ActionRegistry IO
    -> FS.FsPath
    -> FS.FsPath
    -> IO ()
  #-}
-- | @'copyFile' sourceFS destinationFS reg sourcePath destinationPath@ copies the file
--   contents of @sourcePath@ on @sourceFS@ to the @destinationPath@ on @destinationFS@.
copyFile' ::
     (MonadMask m, PrimMonad m)
  => HasFS m h  -- ^ The 'HasFS' instance for the source filesystem
  -> HasFS m h' -- ^ The 'HasFS' instance for the target filesystem
  -> ActionRegistry m
  -> FS.FsPath
  -> FS.FsPath
  -> m ()
copyFile' :: forall (m :: * -> *) h h'.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> HasFS m h' -> ActionRegistry m -> FsPath -> FsPath -> m ()
copyFile' HasFS m h
sourceFS HasFS m h'
destinationFS 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'
destinationFS 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
sourceFS 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'
destinationFS 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'
destinationHandle -> 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
sourceFS 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'
destinationFS Handle h'
destinationHandle ByteString
bs

{-------------------------------------------------------------------------------
  Hard link with fallback
-------------------------------------------------------------------------------}

{- |
The file transfer mode to be used by a snapshot import or export.
-}
data Mode m h
  = HardLink
    -- | Whether or not to allow fallback to copying.
    !Bool
    -- | The 'HasBlockIO' instance that enables hard linking.
    !(HasBlockIO m h)
  | forall h'.
    Copy
    -- | The 'HasFS' instance that enables copying.
    !(HasFS m h')

{-# SPECIALISE
  hardLinkOrCopy ::
       HasFS IO h
    -> Mode IO h
    -> ActionRegistry IO
    -> FS.FsPath
    -> FS.FsPath
    -> IO ()
  #-}
-- | @'hardLinkOrCopy' sourceFS mode hbio reg sourcePath destinationPath@
--   attempts to create a hard link or create a copy from @sourcePath@ to
--   @destinationPath@ depending on the @mode@
--
-- If @mode = HardLink b hbio@, then this functions attemtps to create a hard
-- link from @sourcePath@ to @destinationPath@ if both are on the same file
-- system and copies the file otherwise (if @b == True@).
--
-- If @mode = Copy destinationFS@, then this function copies from @sourcePath@
-- to @destinationPath@, where the latter is interpreted with respect to
-- @destinationFS@
hardLinkOrCopy ::
  (MonadMask m, PrimMonad m)
  => -- | The 'HasFS' instance for the source filesystem
     HasFS m h
  -> -- | Either a 'HasBlockIO' instance for the source filesystem,
     --   or a 'HasFS' instance for the destination filesystem
     Mode m h
  -> ActionRegistry m
  -> FS.FsPath         -- ^ The source path
  -> FS.FsPath         -- ^ The destination path
  -> m ()
hardLinkOrCopy :: forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> Mode m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLinkOrCopy HasFS m h
sourceFS (HardLink Bool
fallback HasBlockIO m h
sourceBIO) ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath = do
  let -- NOTE: On Windows, the error code is ERROR_NOT_SAME_DEVICE (17),
      --       but the Win32 primitive for creating hard links maps this
      --       to the POSIX error code EXDEV using the maperrno builtin.
      isEXDEV :: FsError -> Bool
      isEXDEV :: FsError -> Bool
isEXDEV FsError
e = FsError -> Maybe Errno
fsErrorNo FsError
e Maybe Errno -> Maybe Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno -> Maybe Errno
forall a. a -> Maybe a
Just Errno
eXDEV
      ifEXDEV :: FsError -> Maybe FsError
ifEXDEV FsError
e = if FsError -> Bool
isEXDEV FsError
e then FsError -> Maybe FsError
forall a. a -> Maybe a
Just FsError
e else Maybe FsError
forall a. Maybe a
Nothing

      doHardLink :: m ()
doHardLink = 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
sourceFS HasBlockIO m h
sourceBIO ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath
      doFallBack :: m ()
doFallBack = HasFS m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
copyFile HasFS m h
sourceFS ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath
      doHardLinkThenFallBack :: m ()
doHardLinkThenFallBack = (FsError -> Maybe FsError) -> m () -> (FsError -> m ()) -> m ()
forall e b a.
Exception e =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust FsError -> Maybe FsError
ifEXDEV m ()
doHardLink (m () -> FsError -> m ()
forall a b. a -> b -> a
const m ()
doFallBack)

  if Bool
fallback then m ()
doHardLinkThenFallBack else m ()
doHardLink

hardLinkOrCopy HasFS m h
sourceFS (Copy HasFS m h'
destinationFS) ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath =
  HasFS m h
-> HasFS m h' -> ActionRegistry m -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h h'.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> HasFS m h' -> ActionRegistry m -> FsPath -> FsPath -> m ()
copyFile' HasFS m h
sourceFS HasFS m h'
destinationFS ActionRegistry m
reg FsPath
sourcePath FsPath
destinationPath

{-# SPECIALISE
  hardLinkOrCopyDirectoryRecursive ::
       HasFS IO h
    -> Mode IO h
    -> ActionRegistry IO
    -> FS.FsPath
    -> FS.FsPath
    -> IO ()
  #-}
hardLinkOrCopyDirectoryRecursive ::
     (MonadMask m, PrimMonad m)
  => -- | The 'HasFS' instance for the source filesystem
     HasFS m h
  -> -- | Either a 'HasBlockIO' instance for the source filesystem,
     --   or a 'HasFS' instance for the destination filesystem
     Mode m h
  -> ActionRegistry m
     -- | Source path
  -> FS.FsPath
     -- | Destination path
  -> FS.FsPath
  -> m ()
hardLinkOrCopyDirectoryRecursive :: forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> Mode m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLinkOrCopyDirectoryRecursive HasFS m h
sourceFS Mode m h
mode 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
sourceFS 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
sourceFS FsPath
sourcePath'
    if Bool
isFile then
      HasFS m h
-> Mode m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> Mode m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLinkOrCopy HasFS m h
sourceFS Mode m h
mode 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
sourceFS FsPath
sourcePath'
      if Bool
isDirectory then do
        HasFS m h
-> Mode m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
forall (m :: * -> *) h.
(MonadMask m, PrimMonad m) =>
HasFS m h
-> Mode m h -> ActionRegistry m -> FsPath -> FsPath -> m ()
hardLinkOrCopyDirectoryRecursive HasFS m h
sourceFS Mode m h
mode 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
"hardLinkOrCopyDirectoryRecursive: %s is not a file or directory"
          (FsPath -> String
forall a. Show a => a -> String
show FsPath
sourcePath')