tricu

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

Resolver.hs (4574B)

      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 Runtime (Node(..), T, deserializeNode)
     16 import qualified Runtime
     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. Implementations must authenticate
     26 -- their typed manifest/tree callbacks; callers cannot recover the original bytes
     27 -- from a decoded result. Filesystem callbacks verify before decode/cache insertion.
     28 -- Cached verified bytes are immutable snapshots, not live filesystem views.
     29 data ObjectResolver = ObjectResolver
     30   { resolverAlias    :: AliasKind -> T.Text -> IO (Maybe ObjectRef)
     31   , resolverObject   :: ObjectRef -> IO (Maybe ByteString)
     32   , resolverManifest :: ObjectHash -> IO (Maybe ModuleManifest)
     33   , resolverTree     :: ObjectHash -> IO (Maybe T)
     34   }
     35 
     36 filesystemResolver :: StorePath -> ObjectResolver
     37 filesystemResolver store = resolver
     38   where
     39     resolver = ObjectResolver
     40       { resolverAlias = readAlias store
     41       , resolverObject = \ref -> getVerifiedObject store (Domain (objectRefKind ref)) (objectRefHash ref)
     42       , resolverManifest = resolveManifestFromObjects resolver
     43       , resolverTree = resolveTreeFromObjects resolver
     44       }
     45 
     46 cachedFilesystemResolver :: StorePath -> IO ObjectResolver
     47 cachedFilesystemResolver store = do
     48   objectCache <- newIORef Map.empty
     49   manifestCache <- newIORef Map.empty
     50   treeCache <- newIORef Map.empty
     51   let resolver = ObjectResolver
     52         { resolverAlias = readAlias store
     53         , resolverObject = cachedLookup objectCache (\ref -> getVerifiedObject store (Domain (objectRefKind ref)) (objectRefHash ref))
     54         , resolverManifest = cachedLookup manifestCache (resolveManifestFromObjects resolver)
     55         , resolverTree = cachedLookup treeCache (resolveTreeFromObjects resolver)
     56         }
     57   return resolver
     58   where
     59     cachedLookup :: Ord k => IORef (Map.Map k v) -> (k -> IO v) -> k -> IO v
     60     cachedLookup ref load key = do
     61       cache <- readIORef ref
     62       case Map.lookup key cache of
     63         Just value -> return value
     64         Nothing -> do
     65           value <- load key
     66           atomicModifyIORef' ref (\m -> (Map.insert key value m, ()))
     67           return value
     68 
     69 resolveObjectByHash :: ObjectResolver -> T.Text -> ObjectHash -> IO (Maybe ByteString)
     70 resolveObjectByHash resolver kind h = do
     71   either fail pure (validateObjectHash h)
     72   payload <- resolverObject resolver (ObjectRef kind h)
     73   case payload of
     74     Nothing -> pure Nothing
     75     Just bytes -> do
     76       either fail pure (verifyObjectBytes (Domain kind) h bytes)
     77       pure (Just bytes)
     78 
     79 resolveManifest :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
     80 resolveManifest = resolverManifest
     81 
     82 resolveManifestFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
     83 resolveManifestFromObjects resolver h = do
     84   mBytes <- resolveObjectByHash resolver (unDomain manifestDomain) h
     85   case mBytes of
     86     Nothing -> return Nothing
     87     Just bytes -> case decodeManifest bytes of
     88       Left err -> fail $ "invalid module manifest " ++ T.unpack h ++ ": " ++ err
     89       Right manifest -> return (Just manifest)
     90 
     91 resolveTree :: ObjectResolver -> ObjectHash -> IO (Maybe T)
     92 resolveTree = resolverTree
     93 
     94 resolveTreeFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe T)
     95 resolveTreeFromObjects resolver h = do
     96   mNode <- resolveNode resolver h
     97   case mNode of
     98     Nothing -> return Nothing
     99     Just node -> hydrate node
    100   where
    101     resolveNode r nodeHash = do
    102       mBytes <- resolveObjectByHash r (unDomain merkleNodeDomain) nodeHash
    103       case mBytes of
    104         Nothing -> return Nothing
    105         Just bytes -> return (Just (deserializeNode bytes))
    106 
    107     hydrate NLeaf = return (Just Runtime.Leaf)
    108     hydrate (NStem child) = fmap Runtime.Stem <$> hydrateHash child
    109     hydrate (NFork left right) = do
    110       l <- hydrateHash left
    111       r <- hydrateHash right
    112       return $ Runtime.Fork <$> l <*> r
    113 
    114     hydrateHash nodeHash = do
    115       mChild <- resolveNode resolver nodeHash
    116       case mChild of
    117         Nothing -> return Nothing
    118         Just child -> hydrate child