tricu

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

Resolver.hs (4081B)

      1 module ContentStore.Resolver
      2   ( ObjectResolver(..)
      3   , filesystemResolver
      4   , cachedFilesystemResolver
      5   , resolveObjectByHash
      6   , resolveManifest
      7   , resolveTree
      8   ) where
      9 
     10 import ContentStore.Alias
     11 import ContentStore.Arboricx
     12 import ContentStore.Filesystem
     13 import ContentStore.Object
     14 import Module.Manifest
     15 import Research (Node(..), T, deserializeNode)
     16 import qualified Research
     17 
     18 import Data.ByteString (ByteString)
     19 import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')
     20 import qualified Data.Map as Map
     21 import qualified Data.Text as T
     22 
     23 -- | Object and alias resolution capability. Module/import code should depend on
     24 -- this boundary rather than on a concrete filesystem store. Future resolvers can
     25 -- add trusted remotes, registries, or caches while preserving the same verified
     26 -- content-addressed interface.
     27 data ObjectResolver = ObjectResolver
     28   { resolverAlias    :: AliasKind -> T.Text -> IO (Maybe ObjectRef)
     29   , resolverObject   :: ObjectRef -> IO (Maybe ByteString)
     30   , resolverManifest :: ObjectHash -> IO (Maybe ModuleManifest)
     31   , resolverTree     :: ObjectHash -> IO (Maybe T)
     32   }
     33 
     34 filesystemResolver :: StorePath -> ObjectResolver
     35 filesystemResolver store = resolver
     36   where
     37     resolver = ObjectResolver
     38       { resolverAlias = readAlias store
     39       , resolverObject = \ref -> getObject store (objectRefHash ref)
     40       , resolverManifest = resolveManifestFromObjects resolver
     41       , resolverTree = resolveTreeFromObjects resolver
     42       }
     43 
     44 cachedFilesystemResolver :: StorePath -> IO ObjectResolver
     45 cachedFilesystemResolver store = do
     46   objectCache <- newIORef Map.empty
     47   manifestCache <- newIORef Map.empty
     48   treeCache <- newIORef Map.empty
     49   let resolver = ObjectResolver
     50         { resolverAlias = readAlias store
     51         , resolverObject = cachedLookup objectCache (\ref -> getObject store (objectRefHash ref))
     52         , resolverManifest = cachedLookup manifestCache (resolveManifestFromObjects resolver)
     53         , resolverTree = cachedLookup treeCache (resolveTreeFromObjects resolver)
     54         }
     55   return resolver
     56   where
     57     cachedLookup :: Ord k => IORef (Map.Map k v) -> (k -> IO v) -> k -> IO v
     58     cachedLookup ref load key = do
     59       cache <- readIORef ref
     60       case Map.lookup key cache of
     61         Just value -> return value
     62         Nothing -> do
     63           value <- load key
     64           atomicModifyIORef' ref (\m -> (Map.insert key value m, ()))
     65           return value
     66 
     67 resolveObjectByHash :: ObjectResolver -> T.Text -> ObjectHash -> IO (Maybe ByteString)
     68 resolveObjectByHash resolver kind h =
     69   resolverObject resolver (ObjectRef kind h)
     70 
     71 resolveManifest :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
     72 resolveManifest = resolverManifest
     73 
     74 resolveManifestFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
     75 resolveManifestFromObjects resolver h = do
     76   mBytes <- resolveObjectByHash resolver (unDomain manifestDomain) h
     77   case mBytes of
     78     Nothing -> return Nothing
     79     Just bytes -> case decodeManifest bytes of
     80       Left err -> fail $ "invalid module manifest " ++ T.unpack h ++ ": " ++ err
     81       Right manifest -> return (Just manifest)
     82 
     83 resolveTree :: ObjectResolver -> ObjectHash -> IO (Maybe T)
     84 resolveTree = resolverTree
     85 
     86 resolveTreeFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe T)
     87 resolveTreeFromObjects resolver h = do
     88   mNode <- resolveNode resolver h
     89   case mNode of
     90     Nothing -> return Nothing
     91     Just node -> hydrate node
     92   where
     93     resolveNode r nodeHash = do
     94       mBytes <- resolveObjectByHash r (unDomain merkleNodeDomain) nodeHash
     95       case mBytes of
     96         Nothing -> return Nothing
     97         Just bytes -> return (Just (deserializeNode bytes))
     98 
     99     hydrate NLeaf = return (Just Research.Leaf)
    100     hydrate (NStem child) = fmap Research.Stem <$> hydrateHash child
    101     hydrate (NFork left right) = do
    102       l <- hydrateHash left
    103       r <- hydrateHash right
    104       return $ Research.Fork <$> l <*> r
    105 
    106     hydrateHash nodeHash = do
    107       mChild <- resolveNode resolver nodeHash
    108       case mChild of
    109         Nothing -> return Nothing
    110         Just child -> hydrate child