{-# LANGUAGE DeriveGeneric #-} module Wire ( Bundle (..) , BundleManifest (..) , TreeSpec (..) , NodeHashSpec (..) , RuntimeSpec (..) , BundleRoot (..) , BundleExport (..) , BundleMetadata (..) , ClosureMode (..) , encodeBundle , decodeBundle , verifyBundle , collectReachableNodes , exportBundle , exportNamedBundle , importBundle ) where import ContentStore (getNodeMerkle, loadTree, putMerkleNode, storeTerm) import Research import Control.Exception (SomeException, evaluate, try) import Control.Monad (foldM, unless, when) import Crypto.Hash (Digest, SHA256, hash) import Data.Aeson ( FromJSON (..) , ToJSON (..) , Value (String) , eitherDecodeStrict' , encode , object , withObject , (.:) , (.:?) , (.!=) , (.=) ) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.ByteArray (convert) import Data.ByteString (ByteString) import Data.Foldable (traverse_) import Data.Map (Map) import Data.Text (Text, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word16, Word32, Word64, Word8) import Database.SQLite.Simple (Connection) import GHC.Generics (Generic) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T -- | Portable bundle major/minor version supported by this module. bundleMajorVersion :: Word16 bundleMajorVersion = 1 bundleMinorVersion :: Word16 bundleMinorVersion = 0 -- | Header magic for the portable executable-object container. bundleMagic :: ByteString bundleMagic = BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00] -- "ARBORIX\0" headerLength :: Int headerLength = 32 sectionEntryLength :: Int sectionEntryLength = 60 sectionManifest, sectionNodes :: Word32 sectionManifest = 1 sectionNodes = 2 flagCritical :: Word16 flagCritical = 0x0001 compressionNone, digestSha256 :: Word16 compressionNone = 0 digestSha256 = 1 -- | Closure declaration. V1 only accepts complete bundles for import. data ClosureMode = ClosureComplete | ClosurePartial deriving (Show, Eq, Ord, Generic) instance ToJSON ClosureMode where toJSON ClosureComplete = String "complete" toJSON ClosurePartial = String "partial" instance FromJSON ClosureMode where parseJSON (String "complete") = pure ClosureComplete parseJSON (String "partial") = pure ClosurePartial parseJSON _ = fail "closure must be \"complete\" or \"partial\"" data NodeHashSpec = NodeHashSpec { nodeHashAlgorithm :: Text , nodeHashDomain :: Text } deriving (Show, Eq, Ord, Generic) instance ToJSON NodeHashSpec where toJSON s = object [ "algorithm" .= nodeHashAlgorithm s , "domain" .= nodeHashDomain s ] instance FromJSON NodeHashSpec where parseJSON = withObject "NodeHashSpec" $ \o -> NodeHashSpec <$> o .: "algorithm" <*> o .: "domain" data TreeSpec = TreeSpec { treeCalculus :: Text , treeNodeHash :: NodeHashSpec , treeNodePayload :: Text } deriving (Show, Eq, Ord, Generic) instance ToJSON TreeSpec where toJSON s = object [ "calculus" .= treeCalculus s , "nodeHash" .= treeNodeHash s , "nodePayload" .= treeNodePayload s ] instance FromJSON TreeSpec where parseJSON = withObject "TreeSpec" $ \o -> TreeSpec <$> o .: "calculus" <*> o .: "nodeHash" <*> o .: "nodePayload" data RuntimeSpec = RuntimeSpec { runtimeSemantics :: Text , runtimeEvaluation :: Text , runtimeAbi :: Text , runtimeCapabilities :: [Text] } deriving (Show, Eq, Ord, Generic) instance ToJSON RuntimeSpec where toJSON s = object [ "semantics" .= runtimeSemantics s , "evaluation" .= runtimeEvaluation s , "abi" .= runtimeAbi s , "capabilities" .= runtimeCapabilities s ] instance FromJSON RuntimeSpec where parseJSON = withObject "RuntimeSpec" $ \o -> RuntimeSpec <$> o .: "semantics" <*> o .: "evaluation" <*> o .: "abi" <*> o .:? "capabilities" .!= [] data BundleRoot = BundleRoot { rootHash :: MerkleHash , rootRole :: Text } deriving (Show, Eq, Ord, Generic) instance ToJSON BundleRoot where toJSON r = object [ "hash" .= rootHash r , "role" .= rootRole r ] instance FromJSON BundleRoot where parseJSON = withObject "BundleRoot" $ \o -> BundleRoot <$> o .: "hash" <*> o .:? "role" .!= "root" data BundleExport = BundleExport { exportName :: Text , exportRoot :: MerkleHash , exportKind :: Text , exportAbi :: Text , exportInput :: Maybe Text , exportOutput :: Maybe Text } deriving (Show, Eq, Ord, Generic) instance ToJSON BundleExport where toJSON e = object [ "name" .= exportName e , "root" .= exportRoot e , "kind" .= exportKind e , "abi" .= exportAbi e , "input" .= exportInput e , "output" .= exportOutput e ] instance FromJSON BundleExport where parseJSON = withObject "BundleExport" $ \o -> BundleExport <$> o .: "name" <*> o .: "root" <*> o .:? "kind" .!= "term" <*> o .:? "abi" .!= "arborix.abi.tree.v1" <*> o .:? "input" <*> o .:? "output" data BundleMetadata = BundleMetadata { metadataPackage :: Maybe Text , metadataVersion :: Maybe Text , metadataDescription :: Maybe Text , metadataLicense :: Maybe Text , metadataCreatedBy :: Maybe Text } deriving (Show, Eq, Ord, Generic) instance ToJSON BundleMetadata where toJSON m = object [ "package" .= metadataPackage m , "version" .= metadataVersion m , "description" .= metadataDescription m , "license" .= metadataLicense m , "createdBy" .= metadataCreatedBy m ] instance FromJSON BundleMetadata where parseJSON = withObject "BundleMetadata" $ \o -> BundleMetadata <$> o .:? "package" <*> o .:? "version" <*> o .:? "description" <*> o .:? "license" <*> o .:? "createdBy" data BundleManifest = BundleManifest { manifestSchema :: Text , manifestBundleType :: Text , manifestTree :: TreeSpec , manifestRuntime :: RuntimeSpec , manifestClosure :: ClosureMode , manifestRoots :: [BundleRoot] , manifestExports :: [BundleExport] , manifestImports :: [Value] , manifestSections :: Value , manifestMetadata :: BundleMetadata } deriving (Show, Eq, Generic) instance ToJSON BundleManifest where toJSON m = object [ "schema" .= manifestSchema m , "bundleType" .= manifestBundleType m , "tree" .= manifestTree m , "runtime" .= manifestRuntime m , "closure" .= manifestClosure m , "roots" .= manifestRoots m , "exports" .= manifestExports m , "imports" .= manifestImports m , "sections" .= manifestSections m , "metadata" .= manifestMetadata m ] instance FromJSON BundleManifest where parseJSON = withObject "BundleManifest" $ \o -> BundleManifest <$> o .: "schema" <*> o .: "bundleType" <*> o .: "tree" <*> o .: "runtime" <*> o .: "closure" <*> o .: "roots" <*> o .: "exports" <*> o .:? "imports" .!= [] <*> o .:? "sections" .!= object [] <*> o .:? "metadata" .!= BundleMetadata Nothing Nothing Nothing Nothing Nothing -- | Portable executable-object bundle. -- -- Merkle node payloads remain the language-neutral executable core: -- Leaf = 0x00; Stem = 0x01 || child_hash; Fork = 0x02 || left_hash || right_hash. -- Names, exports, runtime metadata, and package metadata live in the manifest layer. data Bundle = Bundle { bundleVersion :: Word16 , bundleRoots :: [MerkleHash] , bundleNodes :: Map MerkleHash ByteString , bundleManifest :: BundleManifest , bundleManifestBytes :: ByteString } deriving (Show, Eq) -- | Encode a Bundle to portable Bundle v1 bytes. encodeBundle :: Bundle -> ByteString encodeBundle bundle = let nodeSection = encodeNodeSection (bundleNodes bundle) manifestBytes = if BS.null (bundleManifestBytes bundle) then BL.toStrict (encode (bundleManifest bundle)) else bundleManifestBytes bundle sectionCount = 2 dirOffset = fromIntegral headerLength sectionDirLength = sectionCount * sectionEntryLength manifestOffset = fromIntegral (headerLength + sectionDirLength) nodesOffset = manifestOffset + fromIntegral (BS.length manifestBytes) manifestEntry = encodeSectionEntry sectionManifest 1 flagCritical compressionNone manifestOffset (fromIntegral $ BS.length manifestBytes) manifestBytes nodesEntry = encodeSectionEntry sectionNodes 1 flagCritical compressionNone nodesOffset (fromIntegral $ BS.length nodeSection) nodeSection header = encodeHeader bundleMajorVersion bundleMinorVersion (fromIntegral sectionCount) 0 dirOffset in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection -- | Decode portable Bundle v1 bytes. decodeBundle :: ByteString -> Either String Bundle decodeBundle bs | BS.take (BS.length bundleMagic) bs == bundleMagic = decodePortableBundle bs | otherwise = Left "invalid magic" -- --------------------------------------------------------------------------- -- Portable container encoding / decoding -- --------------------------------------------------------------------------- data SectionEntry = SectionEntry { seType :: Word32 , seVersion :: Word16 , seFlags :: Word16 , seCompression :: Word16 , seDigestAlgorithm :: Word16 , seOffset :: Word64 , seLength :: Word64 , seDigest :: ByteString } deriving (Show, Eq) encodeHeader :: Word16 -> Word16 -> Word32 -> Word64 -> Word64 -> ByteString encodeHeader major minor sectionCount flags dirOffset = bundleMagic <> encode16 major <> encode16 minor <> encode32 sectionCount <> encode64 flags <> encode64 dirOffset encodeSectionEntry :: Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> Word64 -> ByteString -> ByteString encodeSectionEntry sectionType sectionVersion sectionFlags compression offset lengthBytes sectionBytes = encode32 sectionType <> encode16 sectionVersion <> encode16 sectionFlags <> encode16 compression <> encode16 digestSha256 <> encode64 offset <> encode64 lengthBytes <> sha256 sectionBytes decodePortableBundle :: ByteString -> Either String Bundle decodePortableBundle bs = do (major, minor, sectionCount, _flags, dirOffset) <- decodePortableHeader bs when (major /= bundleMajorVersion) $ Left $ "unsupported bundle major version: " ++ show major let dirStart = fromIntegral dirOffset dirBytes = fromIntegral sectionCount * sectionEntryLength when (BS.length bs < dirStart + dirBytes) $ Left "bundle truncated in section directory" entries <- decodeSectionEntries sectionCount (BS.take dirBytes $ BS.drop dirStart bs) traverse_ rejectUnknownCritical entries manifestEntry <- requireSection sectionManifest entries nodesEntry <- requireSection sectionNodes entries manifestBytes <- readAndVerifySection bs manifestEntry nodesBytes <- readAndVerifySection bs nodesEntry manifest <- case eitherDecodeStrict' manifestBytes of Left err -> Left $ "invalid manifest JSON: " ++ err Right m -> Right m nodes <- decodeNodeSection nodesBytes let roots = map rootHash (manifestRoots manifest) return Bundle { bundleVersion = major * 1000 + minor , bundleRoots = roots , bundleNodes = nodes , bundleManifest = manifest , bundleManifestBytes = manifestBytes } rejectUnknownCritical :: SectionEntry -> Either String () rejectUnknownCritical entry = let known = seType entry `elem` [sectionManifest, sectionNodes] critical = seFlags entry .&. flagCritical /= 0 in when (critical && not known) $ Left $ "unknown critical section type: " ++ show (seType entry) requireSection :: Word32 -> [SectionEntry] -> Either String SectionEntry requireSection sectionType entries = case filter ((== sectionType) . seType) entries of [entry] -> Right entry [] -> Left $ "missing required section type: " ++ show sectionType _ -> Left $ "duplicate section type: " ++ show sectionType readAndVerifySection :: ByteString -> SectionEntry -> Either String ByteString readAndVerifySection bs entry = do when (seCompression entry /= compressionNone) $ Left $ "unsupported compression codec in section " ++ show (seType entry) when (seDigestAlgorithm entry /= digestSha256) $ Left $ "unsupported digest algorithm in section " ++ show (seType entry) let offset = fromIntegral (seOffset entry) len = fromIntegral (seLength entry) when (offset < 0 || len < 0 || BS.length bs < offset + len) $ Left $ "section extends beyond bundle end: " ++ show (seType entry) let sectionBytes = BS.take len $ BS.drop offset bs when (sha256 sectionBytes /= seDigest entry) $ Left $ "section digest mismatch: " ++ show (seType entry) Right sectionBytes decodePortableHeader :: ByteString -> Either String (Word16, Word16, Word32, Word64, Word64) decodePortableHeader bs | BS.length bs < headerLength = Left "bundle too short for header" | BS.take 8 bs /= bundleMagic = Left "invalid portable bundle magic" | otherwise = do (major, r1) <- decode16be "major_version" (BS.drop 8 bs) (minor, r2) <- decode16be "minor_version" r1 (sectionCount, r3) <- decode32be "section_count" r2 (flags, r4) <- decode64be "flags" r3 (dirOffset, _) <- decode64be "directory_offset" r4 Right (major, minor, sectionCount, flags, dirOffset) decodeSectionEntries :: Word32 -> ByteString -> Either String [SectionEntry] decodeSectionEntries count bytes = reverse <$> go count bytes [] where go 0 _ acc = Right acc go n bs acc = do when (BS.length bs < sectionEntryLength) $ Left "section directory truncated" (sectionType, r1) <- decode32be "section_type" bs (sectionVersion, r2) <- decode16be "section_version" r1 (sectionFlags, r3) <- decode16be "section_flags" r2 (compression, r4) <- decode16be "compression_codec" r3 (digAlg, r5) <- decode16be "digest_algorithm" r4 (offset, r6) <- decode64be "section_offset" r5 (len, r7) <- decode64be "section_length" r6 let (dig, rest) = BS.splitAt 32 r7 when (BS.length dig /= 32) $ Left "section digest truncated" let entry = SectionEntry sectionType sectionVersion sectionFlags compression digAlg offset len dig go (n - 1) rest (entry : acc) -- --------------------------------------------------------------------------- -- Manifest construction -- --------------------------------------------------------------------------- defaultManifest :: [(Text, MerkleHash)] -> Int -> BundleManifest defaultManifest namedRoots nodeCount = BundleManifest { manifestSchema = "arborix.bundle.manifest.v1" , manifestBundleType = "tree-calculus-executable-object" , manifestTree = TreeSpec { treeCalculus = "tree-calculus.v1" , treeNodeHash = NodeHashSpec { nodeHashAlgorithm = "sha256" , nodeHashDomain = "arborix.merkle.node.v1" } , treeNodePayload = "arborix.merkle.payload.v1" } , manifestRuntime = RuntimeSpec { runtimeSemantics = "tree-calculus.v1" , runtimeEvaluation = "normal-order" , runtimeAbi = "arborix.abi.tree.v1" , runtimeCapabilities = [] } , manifestClosure = ClosureComplete , manifestRoots = zipWith mkRoot [0 :: Int ..] (map snd namedRoots) , manifestExports = map mkExport namedRoots , manifestImports = [] , manifestSections = object [ "nodes" .= object [ "count" .= nodeCount , "payload" .= ("arborix.merkle.payload.v1" :: Text) ] ] , manifestMetadata = BundleMetadata { metadataPackage = Nothing , metadataVersion = Nothing , metadataDescription = Nothing , metadataLicense = Nothing , metadataCreatedBy = Just "arborix" } } where mkRoot 0 h = BundleRoot h "default" mkRoot _ h = BundleRoot h "root" mkExport (name, h) = BundleExport { exportName = name , exportRoot = h , exportKind = "term" , exportAbi = "arborix.abi.tree.v1" , exportInput = Nothing , exportOutput = Nothing } -- --------------------------------------------------------------------------- -- Node section encoding / decoding -- --------------------------------------------------------------------------- encodeNodeSection :: Map MerkleHash ByteString -> ByteString encodeNodeSection nodes = encode64 (fromIntegral $ Map.size nodes) <> mconcat (map nodeEntryToBinary $ Map.toAscList nodes) -- | Encode a single (hash, canonical-payload) node entry. nodeEntryToBinary :: (MerkleHash, ByteString) -> ByteString nodeEntryToBinary (h, payload) = merkleHashToRaw h <> encode32 (fromIntegral $ BS.length payload) <> payload decodeNodeSection :: ByteString -> Either String (Map MerkleHash ByteString) decodeNodeSection bs = do (nodeCount, rest) <- decode64be "node_count" bs decodeNodeEntries nodeCount rest -- | Decode a sequence of node entries. decodeNodeEntries :: Word64 -> ByteString -> Either String (Map MerkleHash ByteString) decodeNodeEntries count bs = go count bs Map.empty where go 0 rest acc | BS.null rest = Right acc | otherwise = Left "trailing bytes after node section" go n bytes acc | BS.length bytes < 36 = Left "not enough bytes for node entry header (hash + length)" | otherwise = do let (hashBytes, rest) = BS.splitAt 32 bytes (plen, rest') <- decode32be "payload_len" rest let payloadLen = fromIntegral plen if BS.length rest' < payloadLen then Left "payload extends beyond node section end" else do let (payload, after) = BS.splitAt payloadLen rest' h = rawToMerkleHash hashBytes when (Map.member h acc) $ Left $ "duplicate node entry: " ++ unpack h go (n - 1) after (Map.insert h payload acc) -- --------------------------------------------------------------------------- -- Bundle verification -- --------------------------------------------------------------------------- verifyBundle :: Bundle -> Either String () verifyBundle bundle | bundleVersion bundle < 1 = Left $ "unsupported bundle version: " ++ show (bundleVersion bundle) | Map.null (bundleNodes bundle) = Left "bundle has no nodes" verifyBundle bundle = do verifyManifest (bundleManifest bundle) let nodeMap = bundleNodes bundle rootSet = Set.fromList (bundleRoots bundle) manifestRootSet = Set.fromList (map rootHash $ manifestRoots $ bundleManifest bundle) exportRoots = map exportRoot $ manifestExports $ bundleManifest bundle unless (rootSet == manifestRootSet) $ Left "bundle root list does not match manifest roots" traverse_ (requirePresent "root hash missing from bundle") (bundleRoots bundle) traverse_ (requirePresent "export root hash missing from bundle") exportRoots decoded <- traverse verifyNodePayload (Map.toList nodeMap) traverse_ (verifyChildrenPresent nodeMap) decoded verifyCompleteClosure nodeMap (bundleRoots bundle) where requirePresent label h = unless (Map.member h (bundleNodes bundle)) $ Left $ label ++ ": " ++ unpack h verifyManifest :: BundleManifest -> Either String () verifyManifest manifest = do when (manifestSchema manifest /= "arborix.bundle.manifest.v1") $ Left $ "unsupported manifest schema: " ++ unpack (manifestSchema manifest) when (manifestBundleType manifest /= "tree-calculus-executable-object") $ Left $ "unsupported bundle type: " ++ unpack (manifestBundleType manifest) let treeSpec = manifestTree manifest hashSpec = treeNodeHash treeSpec runtimeSpec = manifestRuntime manifest when (treeCalculus treeSpec /= "tree-calculus.v1") $ Left $ "unsupported calculus: " ++ unpack (treeCalculus treeSpec) when (nodeHashAlgorithm hashSpec /= "sha256") $ Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec) when (nodeHashDomain hashSpec /= "arborix.merkle.node.v1") $ Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec) when (treeNodePayload treeSpec /= "arborix.merkle.payload.v1") $ Left $ "unsupported node payload: " ++ unpack (treeNodePayload treeSpec) when (runtimeSemantics runtimeSpec /= "tree-calculus.v1") $ Left $ "unsupported runtime semantics: " ++ unpack (runtimeSemantics runtimeSpec) when (runtimeAbi runtimeSpec /= "arborix.abi.tree.v1") $ Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec) unless (null $ runtimeCapabilities runtimeSpec) $ Left "host/runtime capabilities are not supported by bundle v1" when (manifestClosure manifest /= ClosureComplete) $ Left "bundle v1 imports require closure = complete" unless (null $ manifestImports manifest) $ Left "bundle v1 imports require an empty imports list" when (null $ manifestRoots manifest) $ Left "manifest has no roots" when (null $ manifestExports manifest) $ Left "manifest has no exports" traverse_ verifyExport (manifestExports manifest) where verifyExport exported = do when (T.null $ exportName exported) $ Left "manifest export has empty name" when (T.null $ exportRoot exported) $ Left "manifest export has empty root" verifyNodePayload :: (MerkleHash, ByteString) -> Either String (MerkleHash, Node) verifyNodePayload (h, payload) = do node <- safeDeserializeNode payload let actual = nodeHash node unless (actual == h) $ Left $ "node hash mismatch for " ++ unpack h ++ "; payload hashes to " ++ unpack actual Right (h, node) verifyChildrenPresent :: Map MerkleHash ByteString -> (MerkleHash, Node) -> Either String () verifyChildrenPresent nodeMap (h, node) = case node of NLeaf -> Right () NStem child -> requireChild h child NFork left right -> requireChild h left >> requireChild h right where requireChild parent child = unless (Map.member child nodeMap) $ Left $ "missing child node referenced by " ++ unpack parent ++ ": " ++ unpack child verifyCompleteClosure :: Map MerkleHash ByteString -> [MerkleHash] -> Either String () verifyCompleteClosure nodeMap roots = do _ <- foldM visit Set.empty roots Right () where visit seen h | Set.member h seen = Right seen | otherwise = do payload <- case Map.lookup h nodeMap of Nothing -> Left $ "closure missing node: " ++ unpack h Just p -> Right p node <- safeDeserializeNode payload let seen' = Set.insert h seen case node of NLeaf -> Right seen' NStem child -> visit seen' child NFork left right -> visit seen' left >>= \seenL -> visit seenL right safeDeserializeNode :: ByteString -> Either String Node safeDeserializeNode payload = case BS.uncons payload of Just (0x00, rest) | BS.null rest -> Right NLeaf | otherwise -> Left "invalid leaf payload length" Just (0x01, rest) | BS.length rest == 32 -> Right $ NStem (rawToMerkleHash rest) | otherwise -> Left "invalid stem payload length" Just (0x02, rest) | BS.length rest == 64 -> let (left, right) = BS.splitAt 32 rest in Right $ NFork (rawToMerkleHash left) (rawToMerkleHash right) | otherwise -> Left "invalid fork payload length" _ -> Left "invalid merkle node payload" -- --------------------------------------------------------------------------- -- Reachability traversal -- --------------------------------------------------------------------------- collectReachableNodes :: Connection -> MerkleHash -> IO [(MerkleHash, ByteString)] collectReachableNodes conn root = do let go seen current = do case Map.lookup current seen of Just _ -> return seen Nothing -> do maybeNode <- getNodeMerkle conn current case maybeNode of Nothing -> error $ "exportBundle: missing Merkle node: " ++ unpack current Just node -> do let payload = serializeNode node seen' = Map.insert current payload seen case node of NLeaf -> return seen' NStem childHash -> go seen' childHash NFork lHash rHash -> go seen' lHash >>= \seenL -> go seenL rHash seen <- go Map.empty root return $ Map.toAscList seen -- --------------------------------------------------------------------------- -- High-level export / import -- --------------------------------------------------------------------------- exportBundle :: Connection -> [MerkleHash] -> IO ByteString exportBundle conn hashes = exportNamedBundle conn (zip (defaultExportNames $ length hashes) hashes) exportNamedBundle :: Connection -> [(Text, MerkleHash)] -> IO ByteString exportNamedBundle conn namedHashes = do let hashes = map snd namedHashes entries <- concat <$> mapM (collectReachableNodes conn) hashes let nodeMap = Map.fromList entries manifest = defaultManifest namedHashes (Map.size nodeMap) manifestBytes = BL.toStrict (encode manifest) bundle = Bundle { bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion , bundleRoots = hashes , bundleNodes = nodeMap , bundleManifest = manifest , bundleManifestBytes = manifestBytes } return $ encodeBundle bundle importBundle :: Connection -> ByteString -> IO [MerkleHash] importBundle conn bs = case decodeBundle bs of Left err -> error $ "Wire.importBundle: " ++ err Right bundle -> case verifyBundle bundle of Left err -> error $ "Wire.importBundle verify: " ++ err Right () -> do traverse_ (\payload -> do node <- deserializeForImport payload putMerkleNode conn node ) (Map.elems $ bundleNodes bundle) registerBundleExports conn bundle return $ bundleRoots bundle registerBundleExports :: Connection -> Bundle -> IO () registerBundleExports conn bundle = traverse_ registerExport (manifestExports $ bundleManifest bundle) where registerExport exported = do maybeTree <- loadTree conn (exportRoot exported) case maybeTree of Nothing -> error $ "Wire.importBundle: export root missing after node import: " ++ unpack (exportRoot exported) Just tree -> do _ <- storeTerm conn [unpack $ exportName exported] tree return () -- --------------------------------------------------------------------------- -- Primitive binary helpers -- --------------------------------------------------------------------------- encode16 :: Word16 -> ByteString encode16 w = BS.pack [ fromIntegral (shiftR w 8) , fromIntegral w ] encode32 :: Word32 -> ByteString encode32 w = BS.pack [ fromIntegral (shiftR w 24) , fromIntegral (shiftR w 16) , fromIntegral (shiftR w 8) , fromIntegral w ] encode64 :: Word64 -> ByteString encode64 w = BS.pack [ fromIntegral (shiftR w 56) , fromIntegral (shiftR w 48) , fromIntegral (shiftR w 40) , fromIntegral (shiftR w 32) , fromIntegral (shiftR w 24) , fromIntegral (shiftR w 16) , fromIntegral (shiftR w 8) , fromIntegral w ] decode16be :: String -> ByteString -> Either String (Word16, ByteString) decode16be label bs | BS.length bs < 2 = Left (label ++ ": not enough bytes for u16") | otherwise = let b0 = fromIntegral (BS.index bs 0) :: Word16 b1 = fromIntegral (BS.index bs 1) :: Word16 in Right ((b0 `shiftL` 8) .|. b1, BS.drop 2 bs) -- | Decode a big-endian u32 from the head of a ByteString. decode32be :: String -> ByteString -> Either String (Word32, ByteString) decode32be label bs | BS.length bs < 4 = Left (label ++ ": not enough bytes for u32") | otherwise = let b0 = fromIntegral (BS.index bs 0) :: Word32 b1 = fromIntegral (BS.index bs 1) :: Word32 b2 = fromIntegral (BS.index bs 2) :: Word32 b3 = fromIntegral (BS.index bs 3) :: Word32 val = (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3 in Right (val, BS.drop 4 bs) decode64be :: String -> ByteString -> Either String (Word64, ByteString) decode64be label bs | BS.length bs < 8 = Left (label ++ ": not enough bytes for u64") | otherwise = let byte i = fromIntegral (BS.index bs i) :: Word64 val = (byte 0 `shiftL` 56) .|. (byte 1 `shiftL` 48) .|. (byte 2 `shiftL` 40) .|. (byte 3 `shiftL` 32) .|. (byte 4 `shiftL` 24) .|. (byte 5 `shiftL` 16) .|. (byte 6 `shiftL` 8) .|. byte 7 in Right (val, BS.drop 8 bs) -- --------------------------------------------------------------------------- -- Hash conversion -- --------------------------------------------------------------------------- -- | Convert a hex MerkleHash to its raw 32-byte representation. merkleHashToRaw :: MerkleHash -> ByteString merkleHashToRaw h = case Base16.decode (encodeUtf8 h) of Left _ -> error $ "Wire.merkleHashToRaw: invalid hex: " ++ show h Right bs | BS.length bs == 32 -> bs | otherwise -> error $ "Wire.merkleHashToRaw: expected 32 bytes: " ++ show h -- | Convert raw 32 bytes back to a hex MerkleHash. rawToMerkleHash :: ByteString -> MerkleHash rawToMerkleHash bs = decodeUtf8 (Base16.encode bs) sha256 :: ByteString -> ByteString sha256 bytes = convert ((hash bytes) :: Digest SHA256) defaultExportNames :: Int -> [Text] defaultExportNames n = case n of 0 -> [] 1 -> ["root"] _ -> ["root" <> T.pack (show i) | i <- [0 :: Int .. n - 1]] deserializeForImport :: ByteString -> IO Node deserializeForImport payload = do result <- try (evaluate $ deserializeNode payload) :: IO (Either SomeException Node) case result of Left err -> error $ "Wire.importBundle: invalid merkle node payload: " ++ show err Right node -> return node