Codec.hs (6722B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 -- Format-specific authenticated transport, independent of store paths/publication. 3 module IO.Codec (hashIndexed, writeIndexed, verifyIndexed, readIndexed, readIndexedWith, sectionLimit, manifestLimit) where 4 5 import qualified IO.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)