111 lines
4.0 KiB
Haskell
111 lines
4.0 KiB
Haskell
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
|