tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

Filesystem.hs (2107B)

      1 module ContentStore.Filesystem
      2   ( putObject
      3   , getObject
      4   , objectPath
      5   , ensureStore
      6   ) where
      7 
      8 import ContentStore.Object
      9 
     10 import Control.Monad    (unless, when)
     11 import Data.Text        (unpack)
     12 import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
     13 import System.FilePath  ((</>))
     14 import System.IO        (hClose, openBinaryTempFile)
     15 
     16 import qualified Data.ByteString as BS
     17 
     18 ensureStore :: StorePath -> IO ()
     19 ensureStore (StorePath root) = do
     20   createDirectoryIfMissing True (root </> "objects")
     21   createDirectoryIfMissing True (root </> "aliases" </> "names")
     22   createDirectoryIfMissing True (root </> "aliases" </> "modules")
     23   createDirectoryIfMissing True (root </> "aliases" </> "packages")
     24   createDirectoryIfMissing True (root </> "manifests")
     25   createDirectoryIfMissing True (root </> "tmp")
     26 
     27 objectPath :: StorePath -> ObjectHash -> FilePath
     28 objectPath (StorePath root) h = root </> "objects" </> shardForHash h </> unpack h
     29 
     30 putObject :: StorePath -> Domain -> BS.ByteString -> IO ObjectHash
     31 putObject store@(StorePath root) domain payload = do
     32   ensureStore store
     33   let h = hashObject domain payload
     34       shardDir = root </> "objects" </> shardForHash h
     35       finalPath = objectPath store h
     36   createDirectoryIfMissing True shardDir
     37   exists <- doesFileExist finalPath
     38   if exists
     39     then verifyExisting finalPath
     40     else do
     41       let tmpDir = root </> "tmp"
     42       (tmpPath, handle) <- openBinaryTempFile tmpDir (unpack h ++ ".tmp")
     43       BS.hPut handle payload
     44       hClose handle
     45       raced <- doesFileExist finalPath
     46       if raced
     47         then removeFile tmpPath >> verifyExisting finalPath
     48         else renameFile tmpPath finalPath
     49   return h
     50   where
     51     verifyExisting path = do
     52       existing <- BS.readFile path
     53       when (existing /= payload) $
     54         fail $ "content-addressed object exists with mismatched bytes: " ++ path
     55 
     56 getObject :: StorePath -> ObjectHash -> IO (Maybe BS.ByteString)
     57 getObject store h = do
     58   let path = objectPath store h
     59   exists <- doesFileExist path
     60   if exists then Just <$> BS.readFile path else return Nothing