61 lines
2.1 KiB
Haskell
61 lines
2.1 KiB
Haskell
module ContentStore.Filesystem
|
|
( putObject
|
|
, getObject
|
|
, objectPath
|
|
, ensureStore
|
|
) where
|
|
|
|
import ContentStore.Object
|
|
|
|
import Control.Monad (unless, when)
|
|
import Data.Text (unpack)
|
|
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
|
|
import System.FilePath ((</>))
|
|
import System.IO (hClose, openBinaryTempFile)
|
|
|
|
import qualified Data.ByteString as BS
|
|
|
|
ensureStore :: StorePath -> IO ()
|
|
ensureStore (StorePath root) = do
|
|
createDirectoryIfMissing True (root </> "objects")
|
|
createDirectoryIfMissing True (root </> "aliases" </> "names")
|
|
createDirectoryIfMissing True (root </> "aliases" </> "modules")
|
|
createDirectoryIfMissing True (root </> "aliases" </> "packages")
|
|
createDirectoryIfMissing True (root </> "manifests")
|
|
createDirectoryIfMissing True (root </> "tmp")
|
|
|
|
objectPath :: StorePath -> ObjectHash -> FilePath
|
|
objectPath (StorePath root) h = root </> "objects" </> shardForHash h </> unpack h
|
|
|
|
putObject :: StorePath -> Domain -> BS.ByteString -> IO ObjectHash
|
|
putObject store@(StorePath root) domain payload = do
|
|
ensureStore store
|
|
let h = hashObject domain payload
|
|
shardDir = root </> "objects" </> shardForHash h
|
|
finalPath = objectPath store h
|
|
createDirectoryIfMissing True shardDir
|
|
exists <- doesFileExist finalPath
|
|
if exists
|
|
then verifyExisting finalPath
|
|
else do
|
|
let tmpDir = root </> "tmp"
|
|
(tmpPath, handle) <- openBinaryTempFile tmpDir (unpack h ++ ".tmp")
|
|
BS.hPut handle payload
|
|
hClose handle
|
|
raced <- doesFileExist finalPath
|
|
if raced
|
|
then removeFile tmpPath >> verifyExisting finalPath
|
|
else renameFile tmpPath finalPath
|
|
return h
|
|
where
|
|
verifyExisting path = do
|
|
existing <- BS.readFile path
|
|
when (existing /= payload) $
|
|
fail $ "content-addressed object exists with mismatched bytes: " ++ path
|
|
|
|
getObject :: StorePath -> ObjectHash -> IO (Maybe BS.ByteString)
|
|
getObject store h = do
|
|
let path = objectPath store h
|
|
exists <- doesFileExist path
|
|
if exists then Just <$> BS.readFile path else return Nothing
|