tricu

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

Manifest.hs (4942B)

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