tricu

Snapshot.hs (4919B)

---

 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 -- Internal authenticated transport for indexed codecs, not a store service.
 -- No paths, source trees or application publication policy are interpreted here.
 module ContentStore.Snapshot
   ( Snapshot, snapshotLength, readSnapshot
   , SnapshotError(..), withAuthenticatedSnapshot, withAuthenticatedSnapshotUsing
   ) where
 
 import ContentStore.Object (Domain(..), ObjectHash, hashToText, validateObjectHash)
 import Control.Concurrent.MVar
 import Control.Exception
 import Control.Monad (unless, when)
 import Crypto.Hash (Context, SHA256, hashInit, hashUpdate, hashFinalize)
 import qualified Data.ByteString as BS
 import Data.Text.Encoding (encodeUtf8)
 import System.Directory (removeFile)
 import System.IO
 
 -- The constructor and writable handle never escape this module. A Snapshot is
 -- valid only during the callback; its read operation serializes seek/read pairs.
 -- This is not confinement against other code with the process's OS authority.
 data Snapshot = Snapshot !Integer !(MVar Handle)
 
 snapshotLength :: Snapshot -> Integer
 snapshotLength (Snapshot size _) = size
 
 data SnapshotError = InvalidSnapshotBound | InvalidSnapshotDigest
   | SnapshotTruncated | SnapshotReaderExceededBound | SnapshotDigestMismatch
   | InvalidSnapshotRange
   deriving (Eq, Show)
 instance Exception SnapshotError
 
 chunkSize :: Int
 chunkSize = 4096
 
 -- Both limits are checked before allocating a file or consuming input. The
 -- caller supplies an EXACT frame length and a policy limit: neither an EOF probe
 -- nor any byte of the following frame is requested. A reader must return between
 -- zero and the requested number of bytes; zero before the boundary is truncation.
 --
 -- Disk: one unlinked file, at most size payload bytes (+ filesystem bookkeeping).
 -- Transfer memory: one bounded chunk and hash context, independent of size.
 -- Authentication finishes before invoking the decoder callback, against the same
 -- private bytes it will read, never a second pass over the original source.
 -- No fsync is necessary: this is a temporary snapshot, not durable publication.
 withAuthenticatedSnapshot :: FilePath -> Integer -> Integer -> Domain -> ObjectHash
   -> (Int -> IO BS.ByteString) -> (Snapshot -> IO a) -> IO a
 withAuthenticatedSnapshot = withAuthenticatedSnapshotUsing (\allocate use -> bracket allocate hClose use)
 
 -- Native structured IO supplies registry-backed lifetime management here, so a
 -- terminal fault/cancellation leaves cleanup to lexical settlement (including its
 -- diagnostic precedence), rather than allowing bracket cleanup to mask a fault.
 withAuthenticatedSnapshotUsing :: (forall a. IO Handle -> (Handle -> IO a) -> IO a)
   -> FilePath -> Integer -> Integer -> Domain -> ObjectHash
   -> (Int -> IO BS.ByteString) -> (Snapshot -> IO b) -> IO b
 withAuthenticatedSnapshotUsing lifetime directory limit size (Domain domain) expected receive consume = do
   when (limit < 0 || size < 0 || size > limit || limit > 2^(63 :: Int)-1) $
     throwIO InvalidSnapshotBound
   case validateObjectHash expected of
     Left _ -> throwIO InvalidSnapshotDigest
     Right () -> pure ()
   lifetime acquire $ \handle -> do
     let initial = hashUpdate (hashInit :: Context SHA256) (encodeUtf8 domain <> BS.singleton 0)
         copy !remaining !context
           | remaining == 0 = pure context
           | otherwise = do
               let wanted = fromInteger (min remaining (toInteger chunkSize))
               bytes <- receive wanted
               let count = BS.length bytes
               when (count > wanted) (throwIO SnapshotReaderExceededBound)
               when (count == 0) (throwIO SnapshotTruncated)
               BS.hPut handle bytes
               next <- evaluate (hashUpdate context bytes)
               copy (remaining - toInteger count) next
     context <- copy size initial
     unless (hashToText (hashFinalize context) == expected) (throwIO SnapshotDigestMismatch)
     hFlush handle
     mutex <- newMVar handle
     consume (Snapshot size mutex)
   where
     acquire = mask_ $ do
       (path, handle) <- openBinaryTempFile directory ".tricu-snapshot-"
       -- Unlink before reading any untrusted input. No named scratch artifact is
       -- retained after successful acquisition, including on process termination.
       (removeFile path >> hSetBuffering handle NoBuffering >> pure handle)
         `onException` hClose handle
 
 -- Bounded positional reads from the authenticated snapshot. The supplied offset
 -- is absolute; EOF is sticky by length, not inferred from the public input.
 readSnapshot :: Snapshot -> Integer -> Int -> IO BS.ByteString
 readSnapshot (Snapshot size mutex) offset count = do
   when (offset < 0 || offset > size || count < 0 || count > chunkSize) $
     throwIO InvalidSnapshotRange
   withMVar mutex $ \handle -> do
     hSeek handle AbsoluteSeek offset
     BS.hGet handle (fromInteger (min (toInteger count) (size - offset)))