module BDCS.Export.Customize(CSOverlay,
Customization(..),
addToOverlay,
filesToObjectsC,
runCustomizations)
where
import qualified Control.Exception.Lifted as CEL
import Control.Monad(foldM)
import Control.Monad.Except(MonadError, throwError)
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Logger(MonadLogger, MonadLoggerIO, logDebugN)
import Control.Monad.Trans.Control(MonadBaseControl)
import Crypto.Hash(Digest, hash)
import Crypto.Hash.Algorithms(Blake2b_256)
import Data.ByteArray(convert)
import qualified Data.ByteString as BS
import Data.Conduit(Conduit, awaitForever, yield)
import Data.ContentStore(ContentStore)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import BDCS.CS(Object(..), fileToObjectC)
import BDCS.DB(Files(..))
import BDCS.Export.FSTree(FSTree, addFileToTree)
type CSOverlay = Map.Map BS.ByteString Object
data Customization = WriteFile Files (Maybe BS.ByteString)
deriving (Eq, Show)
filesToObjectsC :: (MonadError String m, MonadIO m) => CSOverlay -> ContentStore -> Conduit Files m (Files, Object)
filesToObjectsC overlay repo = awaitForever $ \f@Files{..} ->
case maybe Nothing (flip Map.lookup overlay) filesCs_object of
Nothing -> fileToObjectC repo f
Just obj -> yield (f, obj)
addToOverlay :: (MonadError String m, MonadLogger m) => CSOverlay -> FSTree -> Files -> Maybe BS.ByteString -> m (CSOverlay, FSTree)
addToOverlay overlay tree file content = do
logDebugN $ T.pack "Adding to overlay: " `T.append` filesPath file
let (newFile, newOverlay) = case content of
Nothing-> (file{filesCs_object = Nothing}, overlay)
Just c -> let digest = makeDigest c
in (file{filesCs_object = Just digest}, Map.insert digest (FileObject c) overlay)
newTree <- addFileToTree True tree newFile
return (newOverlay, newTree)
where
makeDigest :: BS.ByteString -> BS.ByteString
makeDigest input =
let digest = hash input :: Digest Blake2b_256
in convert digest
runCustomizations :: (MonadBaseControl IO m, MonadError String m, MonadLoggerIO m) =>
CSOverlay
-> ContentStore
-> FSTree
-> [Customization]
-> m (CSOverlay, FSTree)
runCustomizations overlay _repo tree customizations = do
logDebugN $ T.pack "Running customizations"
foldM runCustomization (overlay, tree) customizations `CEL.catch` \e -> throwError $ show (e :: CEL.IOException)
where
runCustomization :: (MonadError String m, MonadLoggerIO m) => (CSOverlay, FSTree) -> Customization -> m (CSOverlay, FSTree)
runCustomization (o, t) (WriteFile file content) = addToOverlay o t file content