tricu

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

Inspection.hs (6574B)

      1 {-# LANGUAGE BangPatterns #-}
      2 -- Read-only evidence, independent of evaluators and registry transport.
      3 module Module.Inspection
      4   ( Inspection(..), inspectModule, inspectModuleWithBudget, inspectionStatus, compareGraphs, safeText
      5   ) where
      6 
      7 import ContentStore.Object
      8 import ContentStore.Alias (ObjectRef(..))
      9 import ContentStore.Filesystem (objectPath)
     10 import ContentStore.Bundle (indexedTreeDomain)
     11 import Module.Manifest
     12 import qualified Wire as W
     13 import Control.Exception (IOException, catch, bracket)
     14 import Control.Monad (foldM)
     15 import qualified Data.ByteString as BS
     16 import Data.Text (Text)
     17 import qualified Data.Text as T
     18 import Data.Text.Encoding (encodeUtf8)
     19 import qualified Data.Map.Strict as M
     20 import qualified Data.IntMap.Strict as IM
     21 import qualified Data.Foldable as F
     22 import Data.List (foldl')
     23 import Numeric (showHex)
     24 import System.IO (openBinaryFile, IOMode(ReadMode), hClose)
     25 import System.Posix.Files (getSymbolicLinkStatus, isRegularFile)
     26 import System.IO.Error (isDoesNotExistError)
     27 
     28 data Inspection = Inspection
     29   { inspectedManifest :: Either Text ModuleManifest
     30   , inspectedExports :: M.Map Text (Either Text W.Bundle)
     31   }
     32 
     33 -- Escape all non-ASCII/control bytes and '%' in display fields, including errors.
     34 safeText :: Text -> Text
     35 safeText = T.pack . concatMap escape . BS.unpack . encodeUtf8
     36   where
     37     escape b | b >= 32 && b <= 126 && b /= 37 = [toEnum (fromIntegral b)]
     38              | otherwise = '%' : (if b < 16 then "0" else "") ++ showHex b ""
     39 
     40 readEvidence :: StorePath -> Domain -> Int -> Text -> IO (Either Text BS.ByteString)
     41 readEvidence store domain limit pin = case validateObjectHash pin of
     42   Left err -> pure (Left ("invalid: " <> T.pack err))
     43   Right () -> (do
     44     status <- getSymbolicLinkStatus (objectPath store pin)
     45     if not (isRegularFile status) then pure (Left "unavailable: expected regular CAS file") else
     46       bracket (openBinaryFile (objectPath store pin) ReadMode) hClose $ \h -> do
     47         bytes <- BS.hGet h (limit + 1)
     48         pure $ if BS.length bytes > limit then Left "unavailable: object exceeds remaining module inspection byte budget"
     49           else case verifyObjectBytes domain pin bytes of
     50             Left err -> Left ("invalid: " <> T.pack err)
     51             Right () -> Right bytes)
     52     `catch` (\(e :: IOException) -> pure (Left (if isDoesNotExistError e then "missing" else "unavailable: " <> T.pack (show e))))
     53 
     54 inspectModule :: StorePath -> Text -> IO Inspection
     55 inspectModule = inspectModuleWithBudget (64 * 1024 * 1024)
     56 
     57 -- Explicit budget is also used by focused tests; the CLI uses the default.
     58 inspectModuleWithBudget :: Int -> StorePath -> Text -> IO Inspection
     59 inspectModuleWithBudget budget store pin
     60   | budget < 0 || budget == maxBound = pure (Inspection (Left "unavailable: invalid inspection budget") M.empty)
     61   | otherwise = inspectWithBudget budget store pin
     62 
     63 inspectWithBudget :: Int -> StorePath -> Text -> IO Inspection
     64 inspectWithBudget budget store pin = do
     65   bytes <- readEvidence store manifestDomain 65536 pin
     66   let manifest = bytes >>= \payload -> case decodeManifest payload of
     67         Left err -> Left ("invalid: " <> T.pack err)
     68         Right m | not (null (moduleManifestReferences m)) || null (moduleManifestExports m) -> Left "unsupported: expected a closed nonempty package module"
     69                 | otherwise -> Right m
     70   exports <- case manifest of
     71     Left _ -> pure M.empty
     72     Right m -> do
     73       (_,_,found) <- foldM inspect (budget, M.empty, M.empty) (moduleManifestExports m)
     74       pure found
     75   pure (Inspection manifest exports)
     76   where
     77     inspect (!remaining,!cache,!found) ex = do
     78       let ref = moduleExportObject ex
     79           cached evidence remainingBytes nextCache = pure (remainingBytes,nextCache,M.insert (moduleExportName ex) evidence found)
     80       if objectRefKind ref /= unDomain indexedTreeDomain || moduleExportAbi ex /= "arboricx.abi.tree.v1"
     81         then cached (Left "unsupported: expected indexed tree with tree ABI") remaining cache
     82         else case M.lookup ref cache of
     83           Just evidence -> cached evidence remaining cache
     84           Nothing -> do
     85             bytes <- readEvidence store indexedTreeDomain remaining (objectRefHash ref)
     86             let evidence = bytes >>= \payload -> case decodeGraph payload of
     87                   Left err -> Left ("invalid: " <> T.pack err)
     88                   Right graph -> Right graph
     89                 -- Only retained authenticated bytes count toward graph memory.
     90                 remainingBytes = either (const remaining) (\payload -> remaining - BS.length payload) bytes
     91             evidence `seq` cached evidence remainingBytes (M.insert ref evidence cache)
     92     decodeGraph payload = do
     93       graph <- W.decodeBundle payload
     94       W.verifyBundle graph
     95       case (W.bundleRoots graph, W.manifestExports (W.bundleManifest graph)) of
     96         ([root],[ex]) | W.exportName ex == "root" && W.exportRoot ex == root
     97           && W.exportKind ex == "term" && W.exportAbi ex == "arboricx.abi.tree.v1" -> Right graph
     98         _ -> Left "indexed tree requires one root named root with the tree ABI"
     99 
    100 inspectionStatus :: Inspection -> Text
    101 inspectionStatus i = case inspectedManifest i of
    102   Left err -> err
    103   Right _ -> if all good (M.elems (inspectedExports i)) then "verified" else "incomplete (see exports)"
    104   where good (Right _) = True; good _ = False
    105 
    106 -- Collision-free hash-consing, not probabilistic subtree hashes or recursive T
    107 -- equality. Intern child-ID tuples in ONE table shared by both graphs. Memory is
    108 -- proportional to stored records; no logical unfolding, evaluation or CAS writes.
    109 compareGraphs :: W.Bundle -> W.Bundle -> Either String Bool
    110 compareGraphs left right = do
    111   W.verifyBundle left
    112   W.verifyBundle right
    113   a <- single left; b <- single right
    114   let (!table,!l) = intern M.empty left
    115       (_,!r) = intern table right
    116   pure (l IM.! a == r IM.! b)
    117   where
    118     single graph = case W.bundleRoots graph of
    119       [root] -> Right (fromIntegral root)
    120       _ -> Left "structural comparison requires one root"
    121     intern initial graph = foldl' step (initial,IM.empty) (zip [0..] (F.toList (W.bundleNodes graph)))
    122     step (!table,!indices) (index,node) =
    123       let child n = indices IM.! fromIntegral n
    124           key = case node of
    125             W.BNLeaf -> (0 :: Int,0,0)
    126             W.BNStem c -> (1,child c,0)
    127             W.BNFork l r -> (2,child l,child r)
    128       in case M.lookup key table of
    129         Just ident -> (table,IM.insert index ident indices)
    130         Nothing -> let ident = M.size table
    131                    in (M.insert key ident table,IM.insert index ident indices)