lsm-tree-1.1.0.0: src-core/Database/LSMTree/Internal/FS.hs

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 hfs hbio reg sourcePath destinationPath = do
    withRollback_ reg
      (FS.createHardLink hbio sourcePath destinationPath)
      (FS.removeFile hfs 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 hfs hbio reg sourcePath destinationPath = do
    entries <- FS.listDirectory hfs sourcePath
    forM_ entries $ \entry -> do
      let sourcePath' = sourcePath FS.</> FS.mkFsPath [entry]
          destinationPath' = destinationPath FS.</> FS.mkFsPath [entry]
      isFile <- FS.doesFileExist hfs sourcePath'
      if isFile then
        hardLink hfs hbio reg sourcePath' destinationPath'
      else do
        isDirectory <- FS.doesDirectoryExist hfs sourcePath'
        if isDirectory then do
          hardLinkDirectoryRecursive hfs hbio reg sourcePath' destinationPath'
        else
          error $ printf
            "hardLinkDirectoryRecursive: %s is not a file or directory"
            (show 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 hfs reg sourcePath destinationPath =
    flip (withRollback_ reg) (FS.removeFile hfs destinationPath) $
      FS.withFile hfs sourcePath FS.ReadMode $ \sourceHandle ->
        FS.withFile hfs destinationPath (FS.WriteMode FS.MustBeNew) $ \targetHandle -> do
          bs <- FSL.hGetAll hfs sourceHandle
          void $ FSL.hPutAll hfs targetHandle bs