tricu

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

Manifest.hs (4640B)

      1 module Module.Manifest
      2   ( ModuleManifest(..)
      3   , ModuleReference(..)
      4   , ModuleExport(..)
      5   , manifestDomain
      6   , encodeManifest
      7   , decodeManifest
      8   , putManifest
      9   , getManifest
     10   ) where
     11 
     12 import ContentStore.Filesystem (getObject, putObject)
     13 import ContentStore.Object
     14 import ContentStore.Alias (ObjectRef(..))
     15 
     16 import Data.ByteString (ByteString)
     17 import Data.Text (Text)
     18 import Data.Text.Encoding (decodeUtf8', encodeUtf8)
     19 
     20 import qualified Data.Text as Text
     21 
     22 -- | Immutable module artifact. Names are export labels inside this manifest;
     23 -- content identity is carried by object references and the manifest CAS hash.
     24 data ModuleManifest = ModuleManifest
     25   { moduleManifestReferences :: [ModuleReference]
     26   , moduleManifestExports    :: [ModuleExport]
     27   } deriving (Eq, Ord, Show)
     28 
     29 -- | Direct content-addressed reference needed to understand, fetch, or audit
     30 -- this manifest. The alias is human-facing metadata for diagnostics/workspace
     31 -- presentation; the referenced object is the portable identity. These are not
     32 -- source-language imports.
     33 data ModuleReference = ModuleReference
     34   { moduleReferenceAlias :: Text
     35   , moduleReferenceRef   :: ObjectRef
     36   } deriving (Eq, Ord, Show)
     37 
     38 -- | Exported executable artifact. Optional contract terms are ordinary tree
     39 -- terms referenced from elsewhere in the store, not a special artifact kind.
     40 data ModuleExport = ModuleExport
     41   { moduleExportName   :: Text
     42   , moduleExportObject :: ObjectRef
     43   , moduleExportAbi    :: Text
     44   } deriving (Eq, Ord, Show)
     45 
     46 manifestDomain :: Domain
     47 manifestDomain = Domain "arboricx.module-manifest.v1"
     48 
     49 encodeManifest :: ModuleManifest -> ByteString
     50 encodeManifest manifest = encodeUtf8 $ Text.unlines $
     51   ["arboricx.module-manifest.v1"]
     52   ++ map encodeReference (moduleManifestReferences manifest)
     53   ++ map encodeExport (moduleManifestExports manifest)
     54   where
     55     encodeReference ref = Text.intercalate "\t"
     56       [ "reference"
     57       , esc (moduleReferenceAlias ref)
     58       , esc (objectRefKind $ moduleReferenceRef ref)
     59       , esc (objectRefHash $ moduleReferenceRef ref)
     60       ]
     61     encodeExport ex = Text.intercalate "\t"
     62       [ "export"
     63       , esc (moduleExportName ex)
     64       , esc (objectRefKind $ moduleExportObject ex)
     65       , esc (objectRefHash $ moduleExportObject ex)
     66       , esc (moduleExportAbi ex)
     67       ]
     68 
     69 -- | Parse the canonical manifest encoding.
     70 decodeManifest :: ByteString -> Either String ModuleManifest
     71 decodeManifest bs = do
     72   txt <- either (Left . show) Right (decodeUtf8' bs)
     73   case Text.lines txt of
     74     [] -> Left "empty module manifest"
     75     header : rows
     76       | header /= "arboricx.module-manifest.v1" -> Left "unsupported module manifest version"
     77       | otherwise -> foldl step (Right (ModuleManifest [] [])) rows
     78   where
     79     step acc line = do
     80       manifest <- acc
     81       case Text.splitOn "\t" line of
     82         ["reference", alias, kind, hash] -> do
     83           ref <- ModuleReference <$> unesc alias <*> (ObjectRef <$> unesc kind <*> unesc hash)
     84           Right manifest { moduleManifestReferences = moduleManifestReferences manifest ++ [ref] }
     85         ["export", name, kind, hash, abi] -> do
     86           ex <- ModuleExport
     87             <$> unesc name
     88             <*> (ObjectRef <$> unesc kind <*> unesc hash)
     89             <*> unesc abi
     90           Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] }
     91         _ -> Left $ "invalid module manifest row: " ++ Text.unpack line
     92 
     93 putManifest :: StorePath -> ModuleManifest -> IO ObjectHash
     94 putManifest store = putObject store manifestDomain . encodeManifest
     95 
     96 getManifest :: StorePath -> ObjectHash -> IO (Maybe ModuleManifest)
     97 getManifest store h = do
     98   mBytes <- getObject store h
     99   case mBytes of
    100     Nothing -> return Nothing
    101     Just bytes -> case decodeManifest bytes of
    102       Left err -> fail $ "invalid module manifest " ++ Text.unpack h ++ ": " ++ err
    103       Right manifest -> return (Just manifest)
    104 
    105 esc :: Text -> Text
    106 esc = Text.concatMap $ \c -> case c of
    107   '%'  -> "%25"
    108   '\t' -> "%09"
    109   '\n' -> "%0A"
    110   '\r' -> "%0D"
    111   _    -> Text.singleton c
    112 
    113 unesc :: Text -> Either String Text
    114 unesc txt = go txt ""
    115   where
    116     go rest acc = case Text.uncons rest of
    117       Nothing -> Right acc
    118       Just ('%', xs) ->
    119         let (code, tail') = Text.splitAt 2 xs
    120             decoded = case code of
    121               "25" -> Just "%"
    122               "09" -> Just "\t"
    123               "0A" -> Just "\n"
    124               "0D" -> Just "\r"
    125               _    -> Nothing
    126         in case decoded of
    127           Nothing -> Left $ "invalid percent escape: %" ++ Text.unpack code
    128           Just c  -> go tail' (acc <> c)
    129       Just (c, xs) -> go xs (acc <> Text.singleton c)