Tricu 2.0.0

Sorry for squashing all of this but 🤷

src/ContentStore/Resolver.hs

@@ -0,0 +1,110 @@
+module ContentStore.Resolver
+  ( ObjectResolver(..)
+  , filesystemResolver
+  , cachedFilesystemResolver
+  , resolveObjectByHash
+  , resolveManifest
+  , resolveTree
+  ) where
+
+import ContentStore.Alias
+import ContentStore.Arboricx
+import ContentStore.Filesystem
+import ContentStore.Object
+import Module.Manifest
+import Research (Node(..), T, deserializeNode)
+import qualified Research
+
+import Data.ByteString (ByteString)
+import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')
+import qualified Data.Map as Map
+import qualified Data.Text as T
+
+-- | Object and alias resolution capability. Module/import code should depend on
+-- this boundary rather than on a concrete filesystem store. Future resolvers can
+-- add trusted remotes, registries, or caches while preserving the same verified
+-- content-addressed interface.
+data ObjectResolver = ObjectResolver
+  { resolverAlias    :: AliasKind -> T.Text -> IO (Maybe ObjectRef)
+  , resolverObject   :: ObjectRef -> IO (Maybe ByteString)
+  , resolverManifest :: ObjectHash -> IO (Maybe ModuleManifest)
+  , resolverTree     :: ObjectHash -> IO (Maybe T)
+  }
+
+filesystemResolver :: StorePath -> ObjectResolver
+filesystemResolver store = resolver
+  where
+    resolver = ObjectResolver
+      { resolverAlias = readAlias store
+      , resolverObject = \ref -> getObject store (objectRefHash ref)
+      , resolverManifest = resolveManifestFromObjects resolver
+      , resolverTree = resolveTreeFromObjects resolver
+      }
+
+cachedFilesystemResolver :: StorePath -> IO ObjectResolver
+cachedFilesystemResolver store = do
+  objectCache <- newIORef Map.empty
+  manifestCache <- newIORef Map.empty
+  treeCache <- newIORef Map.empty
+  let resolver = ObjectResolver
+        { resolverAlias = readAlias store
+        , resolverObject = cachedLookup objectCache (\ref -> getObject store (objectRefHash ref))
+        , resolverManifest = cachedLookup manifestCache (resolveManifestFromObjects resolver)
+        , resolverTree = cachedLookup treeCache (resolveTreeFromObjects resolver)
+        }
+  return resolver
+  where
+    cachedLookup :: Ord k => IORef (Map.Map k v) -> (k -> IO v) -> k -> IO v
+    cachedLookup ref load key = do
+      cache <- readIORef ref
+      case Map.lookup key cache of
+        Just value -> return value
+        Nothing -> do
+          value <- load key
+          atomicModifyIORef' ref (\m -> (Map.insert key value m, ()))
+          return value
+
+resolveObjectByHash :: ObjectResolver -> T.Text -> ObjectHash -> IO (Maybe ByteString)
+resolveObjectByHash resolver kind h =
+  resolverObject resolver (ObjectRef kind h)
+
+resolveManifest :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
+resolveManifest = resolverManifest
+
+resolveManifestFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
+resolveManifestFromObjects resolver h = do
+  mBytes <- resolveObjectByHash resolver (unDomain manifestDomain) h
+  case mBytes of
+    Nothing -> return Nothing
+    Just bytes -> case decodeManifest bytes of
+      Left err -> fail $ "invalid module manifest " ++ T.unpack h ++ ": " ++ err
+      Right manifest -> return (Just manifest)
+
+resolveTree :: ObjectResolver -> ObjectHash -> IO (Maybe T)
+resolveTree = resolverTree
+
+resolveTreeFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe T)
+resolveTreeFromObjects resolver h = do
+  mNode <- resolveNode resolver h
+  case mNode of
+    Nothing -> return Nothing
+    Just node -> hydrate node
+  where
+    resolveNode r nodeHash = do
+      mBytes <- resolveObjectByHash r (unDomain merkleNodeDomain) nodeHash
+      case mBytes of
+        Nothing -> return Nothing
+        Just bytes -> return (Just (deserializeNode bytes))
+
+    hydrate NLeaf = return (Just Research.Leaf)
+    hydrate (NStem child) = fmap Research.Stem <$> hydrateHash child
+    hydrate (NFork left right) = do
+      l <- hydrateHash left
+      r <- hydrateHash right
+      return $ Research.Fork <$> l <*> r
+
+    hydrateHash nodeHash = do
+      mChild <- resolveNode resolver nodeHash
+      case mChild of
+        Nothing -> return Nothing
+        Just child -> hydrate child