module Data.ContentStore(ContentStore,
CsError(..),
CsMonad,
runCsMonad,
contentStoreDigest,
contentStoreValid,
fetchByteString,
fetchByteStringC,
fetchFile,
fetchLazyByteString,
fetchLazyByteStringC,
mkContentStore,
openContentStore,
storeByteString,
storeByteStringC,
storeByteStringSink,
storeDirectory,
storeFile,
storeLazyByteString,
storeLazyByteStringC,
storeLazyByteStringSink)
where
import Conduit
import Control.Conditional(ifM, unlessM, whenM)
import Control.Monad((>=>), forM, forM_, join, void)
import Control.Monad.Base(MonadBase(..))
import Control.Monad.Except(ExceptT, MonadError, catchError, runExceptT, throwError)
import Control.Monad.IO.Class(MonadIO, liftIO)
import Control.Monad.Trans.Control(MonadBaseControl(..))
import Control.Monad.Trans.Resource(MonadResource, MonadThrow, ResourceT, runResourceT)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Maybe(isNothing)
import System.Directory(canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeFile, renameFile)
import System.FilePath((</>))
import System.IO(Handle, SeekMode(..))
import System.IO.Temp(openTempFile)
import System.Posix.IO(FileLock, LockRequest(..), OpenMode(..), closeFd, defaultFileFlags, fdToHandle, getLock, handleToFd, openFd, setLock, waitToSetLock)
import Data.ContentStore.Config(Config(..), defaultConfig, readConfig, writeConfig)
import Data.ContentStore.Digest
data ContentStore = ContentStore {
csConfig :: Config,
csRoot :: FilePath,
csHash :: DigestAlgorithm
}
data CsError =
CsError String
| CsErrorCollision String
| CsErrorConfig String
| CsErrorInvalid String
| CsErrorMissing
| CsErrorNoSuchObject String
| CsErrorUnsupportedHash String
deriving (Eq, Show)
newtype CsMonad a = CsMonad { getCsMonad :: ResourceT (ExceptT CsError IO) a }
deriving (Applicative, Functor, Monad, MonadBase IO, MonadError CsError, MonadIO, MonadResource, MonadThrow)
instance MonadBaseControl IO CsMonad where
type StM CsMonad a = StM (ResourceT (ExceptT CsError IO)) a
liftBaseWith f = CsMonad $ liftBaseWith $ \r -> f (r . getCsMonad)
restoreM = CsMonad . restoreM
runCsMonad :: CsMonad a -> IO (Either CsError a)
runCsMonad x = runExceptT $ runResourceT $ getCsMonad x
csSubdirs :: [String]
csSubdirs = ["objects", "tmp", "lock"]
ensureObjectSubdirectory :: ContentStore -> String -> IO ()
ensureObjectSubdirectory cs subdir =
createDirectoryIfMissing True (objectSubdirectoryPath cs subdir)
objectSubdirectoryPath :: ContentStore -> String -> FilePath
objectSubdirectoryPath ContentStore{..} subdir =
csRoot </> "objects" </> subdir
storedObjectDestination :: ObjectDigest -> (String, String)
storedObjectDestination = storedObjectLocation . toHex
storedObjectLocation :: String -> (String, String)
storedObjectLocation = splitAt 2
findObject :: (MonadError CsError m, MonadIO m) => ContentStore -> ObjectDigest -> m FilePath
findObject cs digest = do
let (subdir, filename) = storedObjectDestination digest
path = objectSubdirectoryPath cs subdir </> filename
ifM (liftIO $ doesFileExist path)
(return path)
(throwError $ CsErrorNoSuchObject $ toHex digest)
startStore :: ContentStore -> IO (FilePath, Handle)
startStore ContentStore{..} = do
(path, fd) <- withGlobalLock csRoot $ do
(path, handle) <- openTempFile (csRoot </> "tmp") "import"
fd <- handleToFd handle
setLock fd fullLock
return (path, fd)
handle' <- fdToHandle fd
return (path, handle')
finishStore :: ContentStore -> (FilePath, Handle) -> ObjectDigest -> IO ()
finishStore cs (tmpPath, handle) digest = do
let (subdir, filename) = storedObjectDestination digest
let path = objectSubdirectoryPath cs subdir </> filename
ensureObjectSubdirectory cs subdir
renameFile tmpPath path
fd <- handleToFd handle
setLock fd fullUnlock
closeFd fd
doStore :: MonadIO m => ContentStore -> (a -> ObjectDigest) -> (Handle -> Consumer a IO ()) -> Conduit a m ObjectDigest
doStore cs hasher writer = awaitForever $ \object -> do
let digest = hasher object
let (subdir, filename) = storedObjectDestination digest
path = objectSubdirectoryPath cs subdir </> filename
liftIO $ ensureObjectSubdirectory cs subdir
liftIO $ unlessM (doesFileExist path) $ do
(tmpPath, handle) <- startStore cs
void $ runConduit $ yield object .| writer handle
finishStore cs (tmpPath, handle) digest
yield digest
doStoreSink :: MonadIO m => ContentStore -> (DigestContext -> a -> DigestContext) -> (Handle -> Sink a m ()) -> Sink a m ObjectDigest
doStoreSink cs hasher writer = do
(tmpPath, handle) <- liftIO $ startStore cs
let initctx = digestInit $ csHash cs
(_, digest) <- getZipConduit ((,) <$> ZipConduit (writer handle)
<*> ZipConduit (digestSink initctx))
let (subdir, _) = storedObjectDestination digest
liftIO $ ensureObjectSubdirectory cs subdir
liftIO $ finishStore cs (tmpPath, handle) digest
return digest
where
digestSink ctx = await >>= \case
Nothing -> return $ digestFinalize ctx
Just chunk -> digestSink $ hasher ctx chunk
fullLock :: FileLock
fullLock = (WriteLock, AbsoluteSeek, 0, 0)
fullUnlock :: FileLock
fullUnlock = (Unlock, AbsoluteSeek, 0, 0)
withGlobalLock :: MonadIO m => FilePath -> m a -> m a
withGlobalLock csRoot action = do
let lockFile = csRoot </> "lock" </> "lockfile"
fd <- liftIO $ openFd lockFile WriteOnly (Just 0o644) defaultFileFlags
liftIO $ waitToSetLock fd fullLock
ret <- action
liftIO $ setLock fd fullUnlock >> closeFd fd
return ret
cleanupTmp :: FilePath -> IO ()
cleanupTmp csRoot = withGlobalLock csRoot $ listDirectory (csRoot </> "tmp") >>= mapM_ cleanupOne
where
cleanupOne :: FilePath -> IO ()
cleanupOne tmpFile = do
let fullPath = csRoot </> tmpFile
fd <- openFd fullPath ReadOnly Nothing defaultFileFlags
whenM (isNothing <$> getLock fd fullLock) $ removeFile fullPath
contentStoreValid :: (MonadError CsError m, MonadIO m) => FilePath -> m Bool
contentStoreValid fp = do
unlessM (liftIO $ doesDirectoryExist fp) $
throwError CsErrorMissing
unlessM (liftIO $ doesFileExist $ fp </> "config") $
throwError $ CsErrorInvalid "config"
forM_ csSubdirs $ \subdir ->
unlessM (liftIO $ doesDirectoryExist $ fp </> subdir) $
throwError $ CsErrorInvalid subdir
return True
contentStoreDigest :: ContentStore -> DigestAlgorithm
contentStoreDigest ContentStore{..} = csHash
mkContentStore :: (MonadError CsError m, MonadIO m) => FilePath -> m ContentStore
mkContentStore fp = do
path <- liftIO $ canonicalizePath fp
csExists <- contentStoreValid path `catchError` \_ -> return False
if csExists then openContentStore path
else do
mapM_ (\d -> liftIO $ createDirectoryIfMissing True (path </> d))
csSubdirs
liftIO $ writeConfig (path </> "config") defaultConfig
openContentStore path
openContentStore :: (MonadError CsError m, MonadIO m) => FilePath -> m ContentStore
openContentStore fp = do
path <- liftIO $ canonicalizePath fp
void $ contentStoreValid path
liftIO $ cleanupTmp path
conf <- liftIO (readConfig $ path </> "config") >>= \case
Left e -> throwError $ CsErrorConfig (show e)
Right c -> return c
let algo = confHash conf
case getDigestAlgorithm algo of
Nothing -> throwError $ CsErrorUnsupportedHash (show algo)
Just da -> return ContentStore { csRoot=path, csConfig=conf, csHash=da }
headCError :: MonadError CsError m => String -> Consumer a m a
headCError s =
join $ maybe (throwError $ CsError s) return <$> headC
headCMissing :: MonadError CsError m => ObjectDigest -> Consumer a m a
headCMissing digest =
join $ maybe (throwError $ CsErrorNoSuchObject (show digest)) return <$> headC
fetchByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadThrow m) =>
ContentStore
-> ObjectDigest
-> m BS.ByteString
fetchByteString cs digest =
runConduitRes (yield digest .| fetchByteStringC cs .| headCMissing digest)
fetchByteStringC :: (MonadError CsError m, MonadIO m, MonadResource m) => ContentStore -> Conduit ObjectDigest m BS.ByteString
fetchByteStringC cs = awaitForever $
findObject cs >=> sourceFile
storeByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m) =>
ContentStore
-> BS.ByteString
-> m ObjectDigest
storeByteString cs bs =
runConduitRes (yield bs .| storeByteStringC cs .| headCError "Failed to store object")
storeByteStringC :: (MonadError CsError m, MonadIO m) => ContentStore -> Conduit BS.ByteString m ObjectDigest
storeByteStringC cs = doStore cs (digestByteString $ csHash cs) sinkHandle
storeByteStringSink :: MonadIO m => ContentStore -> Sink BS.ByteString m ObjectDigest
storeByteStringSink cs = doStoreSink cs digestUpdate sinkHandle
fetchLazyByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadThrow m) =>
ContentStore
-> ObjectDigest
-> m LBS.ByteString
fetchLazyByteString cs digest =
runConduitRes (yield digest .| fetchLazyByteStringC cs .| headCMissing digest)
fetchLazyByteStringC :: (MonadError CsError m, MonadIO m, MonadResource m) => ContentStore -> Conduit ObjectDigest m LBS.ByteString
fetchLazyByteStringC cs = awaitForever $
findObject cs >=> \path -> sourceFile path .| sinkLazy
storeLazyByteString :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m) =>
ContentStore
-> LBS.ByteString
-> m ObjectDigest
storeLazyByteString cs bs =
runConduitRes (yield bs .| storeLazyByteStringC cs .| headCError "Failed to store object")
storeLazyByteStringC :: (MonadError CsError m, MonadIO m) => ContentStore -> Conduit LBS.ByteString m ObjectDigest
storeLazyByteStringC cs = doStore cs (digestLazyByteString $ csHash cs) (\h -> mapC LBS.toStrict .| sinkHandle h)
storeLazyByteStringSink :: MonadIO m => ContentStore -> Sink LBS.ByteString m ObjectDigest
storeLazyByteStringSink cs = doStoreSink cs (LBS.foldlChunks digestUpdate) (\h -> mapC LBS.toStrict .| sinkHandle h)
storeDirectory :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadResource m) =>
ContentStore
-> FilePath
-> m [(FilePath, ObjectDigest)]
storeDirectory cs fp = do
entries <- runConduit $ sourceDirectoryDeep False fp .| sinkList
forM entries $ \entry -> do
digest <- storeFile cs entry
return (entry, digest)
fetchFile :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadResource m) =>
ContentStore
-> ObjectDigest
-> FilePath
-> m ()
fetchFile cs digest dest =
runConduitRes $ yield digest .| fetchByteStringC cs .| sinkFile dest
storeFile :: (MonadBaseControl IO m, MonadError CsError m, MonadIO m, MonadResource m) =>
ContentStore
-> FilePath
-> m ObjectDigest
storeFile cs fp = do
lbs <- liftIO $ LBS.readFile fp
storeLazyByteString cs lbs