tricu

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

Codec.hs (6726B)

      1 {-# LANGUAGE ScopedTypeVariables #-}
      2 -- Format-specific authenticated transport, independent of store paths/publication.
      3 module IOV2.Codec (hashIndexed, writeIndexed, verifyIndexed, readIndexed, readIndexedWith, sectionLimit, manifestLimit) where
      4 
      5 import qualified IOV2.Resources as R
      6 import ContentStore.Snapshot
      7 import ContentStore.Indexed (indexedTreeDomain, decodeIndexedSnapshot)
      8 import ContentStore.Object (Domain(..), hashToText, validateObjectHash)
      9 import Wire (Bundle, buildBundleShared, bundleEncodedLength, emitBundle)
     10 import Crypto.Hash (Context, SHA256, hashInit, hashUpdate, hashFinalize)
     11 import qualified Data.ByteString as BS
     12 import Data.Text.Encoding (encodeUtf8)
     13 import Control.Monad (unless)
     14 import Runtime (T)
     15 import Control.Exception
     16 import Data.IORef
     17 import qualified Data.Text as Text
     18 import System.IO (Handle, hClose)
     19 
     20 sectionLimit, manifestLimit :: Int
     21 sectionLimit = 64
     22 manifestLimit = 65536
     23 
     24 readIndexed :: R.Runtime -> R.Scope -> R.Token -> FilePath -> Integer -> Integer -> String
     25   -> IO (Either R.Problem T)
     26 readIndexed = readIndexedWith hClose
     27 
     28 -- Injectable release for lifecycle/fault controls, not a production fault flag.
     29 readIndexedWith :: (Handle -> IO ()) -> R.Runtime -> R.Scope -> R.Token -> FilePath
     30   -> Integer -> Integer -> String -> IO (Either R.Problem T)
     31 readIndexedWith release runtime scope reader directory limit size digest
     32   | limit < 0 || size < 0 || size > limit || limit > R.positionLimit =
     33       pure (Left (R.Problem "invalid-bound" "read" "invalid snapshot size limit" "none"))
     34   | Left _ <- validateObjectHash expected =
     35       pure (Left (R.Problem "invalid-argument" "read" "expected 64 lowercase hexadecimal digits" "none"))
     36   | null directory = pure (Left (R.Problem "invalid-argument" "read" "empty snapshot directory" "none"))
     37   | otherwise = R.withReaderLease runtime scope reader $ \receive ->
     38       withAuthenticatedSnapshotUsing lifetime directory limit size indexedTreeDomain expected receive $ \snapshot -> do
     39         decoded <- decodeIndexedSnapshot sectionLimit manifestLimit snapshot
     40         either (R.resourceFault . malformed) pure decoded
     41   where
     42     expected = Text.pack digest
     43     malformed message = R.Problem "invalid-data" "read" (take 512 message) "unknown"
     44     -- Register the anonymous spool before consuming input. A terminal exception
     45     -- leaves its entry for structured scope settlement, preserving the primary
     46     -- fault/cancellation and collecting any cleanup diagnostics there.
     47     lifetime allocate consume = R.withTemporary runtime scope "read"
     48       (do handle <- allocate; pure (handle, release handle))
     49       (\handle -> consume handle `catch` (R.resourceFault . snapshotProblem))
     50       >>= either R.resourceFault pure
     51     snapshotProblem e = case e of
     52       SnapshotDigestMismatch -> R.Problem "integrity-failed" "read" "CAS digest mismatch" "unknown"
     53       InvalidSnapshotBound -> R.Problem "invalid-bound" "read" "invalid snapshot size limit" "none"
     54       InvalidSnapshotDigest -> R.Problem "invalid-argument" "read" "invalid digest" "none"
     55       SnapshotTruncated -> malformed "incomplete indexed frame"
     56       SnapshotReaderExceededBound -> malformed "reader exceeded frame bound"
     57       InvalidSnapshotRange -> malformed "invalid snapshot range"
     58 
     59 -- Prepare/hash a resident DAG, not an encoded byte list. Encoding is regenerated
     60 -- during writing: sharing a lazy byte-chunk list across passes would retain the
     61 -- entire encoding. Application policy still selects sharding and publication.
     62 prepareIndexed :: Integer -> T -> IO (Either R.Problem (Bundle, Integer, String))
     63 prepareIndexed limit tree
     64   | limit < 0 || limit > R.positionLimit = pure (Left (R.Problem "invalid-bound" "hash" "invalid encoded size limit" "none"))
     65   | otherwise = do
     66       bundle <- buildBundleShared [("root", tree)]
     67       let size = bundleEncodedLength bundle
     68       if size > limit then pure (Left (R.Problem "invalid-bound" "hash" "encoded tree exceeds limit" "none"))
     69       else do
     70         let Domain domain = indexedTreeDomain
     71         context <- newIORef (hashUpdate (hashInit :: Context SHA256) (encodeUtf8 domain <> BS.singleton 0))
     72         emitBundle R.chunkLimit bundle $ \bytes -> do
     73           previous <- readIORef context
     74           next <- evaluate (hashUpdate previous bytes)
     75           writeIORef context next
     76         finished <- readIORef context
     77         digest <- evaluate (hashToText (hashFinalize finished))
     78         pure (Right (bundle, size, Text.unpack digest))
     79 
     80 hashIndexed :: Integer -> T -> IO (Either R.Problem (Integer, String))
     81 hashIndexed limit tree = fmap (fmap (\(_,size,digest) -> (size,digest))) (prepareIndexed limit tree)
     82 
     83 writeIndexed :: R.Runtime -> R.Scope -> R.Token -> Integer -> String -> T
     84   -> IO (Either R.Problem (Integer, String))
     85 writeIndexed runtime scope writer limit expected tree
     86   | limit < 0 || limit > R.positionLimit = pure (Left (R.Problem "invalid-bound" "write" "invalid encoded size limit" "none"))
     87   | Left _ <- validateObjectHash (Text.pack expected) = pure (Left (R.Problem "invalid-argument" "write" "expected 64 lowercase hexadecimal digits" "none"))
     88   | otherwise = R.withWriterLease runtime scope writer $ \send -> do
     89       (bundle,size,digest) <- prepareIndexed limit tree >>= either R.resourceFault pure
     90       unless (digest == expected) (R.resourceFault (R.Problem "integrity-failed" "write" "CAS digest mismatch" "none"))
     91       let allBytes bytes = unless (BS.null bytes) $ do
     92             count <- send bytes
     93             allBytes (BS.drop count bytes)
     94       emitBundle R.chunkLimit bundle allBytes
     95       pure (size,digest)
     96 
     97 -- Compare the exact canonical bytes, not merely their digest. This consumes one
     98 -- known-size frame without an EOF probe; source policy must check whole-file EOF
     99 -- when verifying an immutable store winner. No untrusted bytes are decoded.
    100 verifyIndexed :: R.Runtime -> R.Scope -> R.Token -> Integer -> T
    101   -> IO (Either R.Problem (Integer, String))
    102 verifyIndexed runtime scope reader limit tree
    103   | limit < 0 || limit > R.positionLimit = pure (Left (R.Problem "invalid-bound" "verify" "invalid encoded size limit" "none"))
    104   | otherwise = R.withReaderLease runtime scope reader $ \receive -> do
    105       (bundle,size,digest) <- prepareIndexed limit tree >>= either R.resourceFault pure
    106       let compareBytes expected = unless (BS.null expected) $ do
    107             actual <- receive (BS.length expected)
    108             unless (not (BS.null actual) && actual == BS.take (BS.length actual) expected)
    109               (R.resourceFault (R.Problem "integrity-failed" "verify" "indexed frame differs from canonical tree" "unknown"))
    110             compareBytes (BS.drop (BS.length actual) expected)
    111       emitBundle R.chunkLimit bundle compareBytes
    112       pure (size,digest)