{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module BDCS.Export.Directory(directorySink)
where
import Control.Conditional(unlessM)
import Control.Monad.Except(MonadError, throwError)
import Control.Monad.IO.Class(MonadIO, liftIO)
import qualified Data.ByteString as BS
import Data.Conduit(Consumer, awaitForever)
import qualified Data.Text as T
import Data.Time.Clock.POSIX(posixSecondsToUTCTime)
import System.Directory(createDirectoryIfMissing, setModificationTime)
import System.FilePath((</>), dropDrive, takeDirectory)
import System.Posix.Files(createNamedPipe, createSymbolicLink, directoryMode, fileTypeModes, intersectFileModes, namedPipeMode, setFileMode, symbolicLinkMode)
import System.Posix.Types(CMode(..))
import qualified BDCS.CS as CS
import BDCS.DB
import BDCS.Utils.Filesystem(doesPathExist)
directorySink :: (MonadError String m, MonadIO m) => FilePath -> Consumer (Files, CS.Object) m ()
directorySink outPath = awaitForever $ \case
(f, CS.SpecialObject) -> checkoutSpecial f
(f, CS.FileObject bs) -> checkoutFile f bs
where
checkoutSpecial :: (MonadError String m, MonadIO m) => Files -> m ()
checkoutSpecial f@Files{..} =
let fullPath = outPath </> dropDrive (T.unpack filesPath)
fileType = fromIntegral filesMode `intersectFileModes` fileTypeModes
in
if | fileType == symbolicLinkMode -> checkoutSymlink fullPath f
| fileType == directoryMode -> liftIO $ createDirectoryIfMissing True fullPath >> setMetadata f fullPath
| fileType == namedPipeMode -> liftIO $ createNamedPipe fullPath $ fromIntegral filesMode
| otherwise -> throwError "Invalid file type"
checkoutSymlink :: (MonadError String m, MonadIO m) => FilePath -> Files -> m ()
checkoutSymlink _ Files{filesTarget=Nothing, ..} = throwError "Missing symlink target"
checkoutSymlink fullPath Files{filesTarget=Just target, ..} =
liftIO $ unlessM (doesPathExist fullPath) (createSymbolicLink (T.unpack target) fullPath)
checkoutFile :: MonadIO m => Files -> BS.ByteString -> m ()
checkoutFile f@Files{..} contents = liftIO $ do
let fullPath = outPath </> dropDrive (T.unpack filesPath)
createDirectoryIfMissing True $ takeDirectory fullPath
BS.writeFile fullPath contents
setMetadata f fullPath
setMetadata :: Files -> FilePath -> IO ()
setMetadata Files{..} fullPath = do
setFileMode fullPath (CMode $ fromIntegral filesMode)
setModificationTime fullPath (posixSecondsToUTCTime $ realToFrac filesMtime)