tricu

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

Filesystem.hs (2972B)

      1 module ContentStore.Filesystem
      2   ( putObject
      3   , getVerifiedObject
      4   , getObject
      5   , objectPath
      6   , resolveStorePath
      7   , ensureStore
      8   ) where
      9 
     10 import ContentStore.Object
     11 
     12 import Control.Monad    (unless, when)
     13 import Data.Text        (unpack)
     14 import System.Directory (getHomeDirectory, createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
     15 import System.FilePath  ((</>))
     16 import System.IO        (hClose, openBinaryTempFile)
     17 
     18 import qualified Data.ByteString as BS
     19 
     20 ensureStore :: StorePath -> IO ()
     21 ensureStore (StorePath root) = do
     22   createDirectoryIfMissing True (root </> "objects")
     23   createDirectoryIfMissing True (root </> "aliases" </> "names")
     24   createDirectoryIfMissing True (root </> "aliases" </> "modules")
     25   createDirectoryIfMissing True (root </> "aliases" </> "packages")
     26   createDirectoryIfMissing True (root </> "manifests")
     27   createDirectoryIfMissing True (root </> "tmp")
     28 
     29 objectPath :: StorePath -> ObjectHash -> FilePath
     30 objectPath (StorePath root) h = case validateObjectHash h of
     31   Left err -> errorWithoutStackTrace err
     32   Right () -> root </> "objects" </> shardForHash h </> unpack h
     33 
     34 putObject :: StorePath -> Domain -> BS.ByteString -> IO ObjectHash
     35 putObject store@(StorePath root) domain payload = do
     36   ensureStore store
     37   let h = hashObject domain payload
     38       shardDir = root </> "objects" </> shardForHash h
     39       finalPath = objectPath store h
     40   createDirectoryIfMissing True shardDir
     41   exists <- doesFileExist finalPath
     42   if exists
     43     then verifyExisting finalPath
     44     else do
     45       let tmpDir = root </> "tmp"
     46       (tmpPath, handle) <- openBinaryTempFile tmpDir (unpack h ++ ".tmp")
     47       BS.hPut handle payload
     48       hClose handle
     49       raced <- doesFileExist finalPath
     50       if raced
     51         then removeFile tmpPath >> verifyExisting finalPath
     52         else renameFile tmpPath finalPath
     53   return h
     54   where
     55     verifyExisting path = do
     56       existing <- BS.readFile path
     57       when (existing /= payload) $
     58         fail $ "content-addressed object exists with mismatched bytes: " ++ path
     59 
     60 getObject :: StorePath -> ObjectHash -> IO (Maybe BS.ByteString)
     61 -- Raw storage read: checks the filename, not a content domain. Typed consumers
     62 -- must use getVerifiedObject (or authenticate the returned bytes themselves).
     63 getObject store h = do
     64   either fail pure (validateObjectHash h)
     65   let path = objectPath store h
     66   exists <- doesFileExist path
     67   if exists then Just <$> BS.readFile path else return Nothing
     68 
     69 getVerifiedObject :: StorePath -> Domain -> ObjectHash -> IO (Maybe BS.ByteString)
     70 getVerifiedObject store domain h = do
     71   payload <- getObject store h
     72   case payload of
     73     Nothing -> pure Nothing
     74     Just bytes -> do
     75       either fail pure (verifyObjectBytes domain h bytes)
     76       pure (Just bytes)
     77 
     78 resolveStorePath :: Maybe FilePath -> IO StorePath
     79 resolveStorePath (Just path) = return (StorePath path)
     80 resolveStorePath Nothing = do
     81   home <- getHomeDirectory
     82   return (StorePath (home </> ".tricu" </> "store"))