tricu

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

Executable.hs (4764B)

      1 -- Authenticated executable loading. Object references establish kind and content;
      2 -- only a module export supplies an ABI. Failures are IO errors, not process exits.
      3 module ContentStore.Executable
      4   ( loadVerifiedManifest, loadVerifiedExport, loadVerifiedExportWith
      5   , loadVerifiedExports, loadVerifiedExportSelection, loadExecutableObject ) where
      6 
      7 import ContentStore.Object
      8 import ContentStore.Filesystem (getObject)
      9 import ContentStore.Arboricx (treeTermDomain, decodeTreeTermShared)
     10 import ContentStore.Indexed
     11 import ContentStore.Alias (ObjectRef(..))
     12 import Module.Manifest
     13 import qualified Runtime as Tree
     14 import qualified Data.Text as T
     15 import Control.Exception (evaluate)
     16 import Control.Monad (forM, unless)
     17 
     18 loadVerifiedManifest :: StorePath -> T.Text -> IO ModuleManifest
     19 loadVerifiedManifest store manifestHash = do
     20   either (fail . ("Invalid module manifest hash: " ++)) pure
     21     (textToHashBytes manifestHash)
     22   manifestPayload <- getObject store manifestHash >>= maybe
     23     (fail $ "Module manifest not found in store: " ++ T.unpack manifestHash) pure
     24   unless (hashObject manifestDomain manifestPayload == manifestHash) $
     25     fail "Module manifest digest mismatch"
     26   manifest <- either (fail . ("Invalid module manifest: " ++)) pure
     27     (decodeManifest manifestPayload)
     28   pure manifest
     29 
     30 loadVerifiedExport :: StorePath -> T.Text -> T.Text -> IO (ObjectHash, Tree.T)
     31 loadVerifiedExport = loadVerifiedExportWith (const $ pure ())
     32 
     33 loadVerifiedExportWith :: (String -> IO ()) -> StorePath -> T.Text -> T.Text -> IO (ObjectHash, Tree.T)
     34 loadVerifiedExportWith sample store manifestHash name = do
     35   manifest <- loadVerifiedManifest store manifestHash
     36   sample "manifest-verified"
     37   loadManifestExport sample store manifest name
     38 
     39 loadVerifiedExports :: StorePath -> T.Text -> IO [(String, Tree.T)]
     40 loadVerifiedExports store pin = do
     41   exports <- loadVerifiedExportSelection store pin Nothing
     42   pure [(T.unpack name, term) | (name, term) <- exports]
     43 
     44 -- Nothing selects the complete interface in manifest order. An explicit list
     45 -- loads only those names, in caller order; unrelated export objects stay unread.
     46 loadVerifiedExportSelection :: StorePath -> T.Text -> Maybe [T.Text] -> IO [(T.Text, Tree.T)]
     47 loadVerifiedExportSelection store pin selection = do
     48   manifest <- loadVerifiedManifest store pin
     49   let sample = const $ pure ()
     50   case selection of
     51     Nothing -> forM (moduleManifestExports manifest) $ \ex -> do
     52       (_, term) <- loadModuleExport sample store ex
     53       pure (moduleExportName ex, term)
     54     Just names -> forM names $ \name -> do
     55       (_, term) <- loadManifestExport sample store manifest name
     56       pure (name, term)
     57 
     58 -- Internal: the manifest must have passed authentication and decoding above.
     59 loadManifestExport :: (String -> IO ()) -> StorePath -> ModuleManifest -> T.Text -> IO (ObjectHash, Tree.T)
     60 loadManifestExport sample store manifest name = do
     61   let matches = filter ((== name) . moduleExportName)
     62         (moduleManifestExports manifest)
     63   ex <- case matches of
     64     [single] -> pure single
     65     [] -> fail $ "Module export not found: " ++ T.unpack name
     66     _ -> fail $ "Duplicate module export: " ++ T.unpack name
     67   loadModuleExport sample store ex
     68 
     69 loadModuleExport :: (String -> IO ()) -> StorePath -> ModuleExport -> IO (ObjectHash, Tree.T)
     70 loadModuleExport sample store ex = do
     71   let ref = moduleExportObject ex
     72   unless (moduleExportAbi ex == "arboricx.abi.tree.v1") $
     73     fail $ "Unsupported module export ABI: " ++ T.unpack (moduleExportAbi ex)
     74   term <- loadExecutableObjectWith sample store ref
     75   pure (objectRefHash ref, term)
     76 
     77 loadExecutableObject :: StorePath -> ObjectRef -> IO Tree.T
     78 loadExecutableObject = loadExecutableObjectWith (const $ pure ())
     79 
     80 loadExecutableObjectWith :: (String -> IO ()) -> StorePath -> ObjectRef -> IO Tree.T
     81 loadExecutableObjectWith sample store ref = do
     82   domain <- if objectRefKind ref == unDomain treeTermDomain
     83     then pure treeTermDomain
     84     else if objectRefKind ref == unDomain indexedTreeDomain
     85       then pure indexedTreeDomain
     86       else fail $ "Unsupported module export object kind: " ++ T.unpack (objectRefKind ref)
     87   either (fail . ("Invalid executable tree hash: " ++)) pure
     88     (textToHashBytes $ objectRefHash ref)
     89   treePayload <- getObject store (objectRefHash ref) >>= maybe
     90     (fail $ "Executable tree not found: " ++ T.unpack (objectRefHash ref)) pure
     91   sample "executable-read"
     92   unless (hashObject domain treePayload == objectRefHash ref) $
     93     fail "Executable tree digest mismatch"
     94   sample "executable-digest-verified"
     95   term <- either (fail . ("Invalid executable tree: " ++)) pure
     96     ((if domain == indexedTreeDomain then decodeIndexedTree else decodeTreeTermShared) treePayload)
     97   _ <- evaluate term
     98   sample "executable-decoded"
     99   pure term
    100