commit 55bc8eea789e2df778f21c2490e4e36bf0f20dd9
parent 29477c3dbe623df004ebdab31140086010723a51
Author: James Eversole <james@eversole.co>
Date: Wed, 6 May 2026 15:30:56 -0500
Support multiple named exports globally
Diffstat:
5 files changed, 125 insertions(+), 44 deletions(-)
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -11,11 +11,11 @@ import Lexer
import Parser
import Research
import ContentStore (initContentStore, storeTerm, hashTerm)
-import Wire (exportNamedBundle)
+import Wire (exportNamedBundle, defaultExportNames)
-import Control.Monad ()
+import Control.Monad (forM_)
import Data.List (partition)
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (mapMaybe)
import System.Environment (setEnv)
import System.FilePath (takeDirectory, normalise, (</>))
import System.Exit (die)
@@ -164,23 +164,37 @@ nsVariable moduleName name = moduleName ++ "." ++ name
-- | Compile a tricu source file to a standalone Arborix bundle.
-- Uses a temp content store so it does not collide with the global one.
-compileFile :: FilePath -> FilePath -> Maybe T.Text -> IO ()
-compileFile inputPath outputPath maybeExportName = do
+-- Supports multiple named exports; each is stored separately in the
+-- temp store so that resolveExportTarget can look them up by name.
+compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
+compileFile inputPath outputPath maybeNames = do
-- Evaluate the file to get the full environment
env <- evaluateFile inputPath
- -- Look up the export name: prefer explicit, then fall back to "main"
- let name = fromMaybe "main" (T.unpack <$> maybeExportName)
- case Map.lookup name env of
- Nothing -> die $ "No definition '" ++ name ++ "' found in " ++ inputPath
- Just term -> do
- -- Create a temp content store
- setEnv "TRICU_DB_PATH" "/tmp/tricu-compile.db"
- conn <- initContentStore
- -- Store the term in the temp store
- _ <- storeTerm conn [name] term
- -- Export the bundle (exportNamedBundle returns already-encoded bytes)
- bundleData <- exportNamedBundle conn [(T.pack name, hashTerm term)]
- BL.writeFile outputPath (BL.fromStrict bundleData)
- close conn
- putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
- putStrLn $ " export: " ++ name
+ -- Look up each requested definition name
+ let defaultNames = ["main"]
+ wantedNames = if null maybeNames then defaultNames else maybeNames
+ wantedNamesUnpacked = map T.unpack wantedNames
+ compiledTerms <- mapM (\n -> case Map.lookup n env of
+ Nothing -> die $ "No definition '" ++ n ++ "' found in " ++ inputPath
+ Just t -> return (n, t)) wantedNamesUnpacked
+ let compiledMap :: Map.Map T.Text T = Map.fromList
+ $ map (\(n,t) -> (T.pack n, t)) compiledTerms
+ compiledNames :: [T.Text] = Map.keys compiledMap
+ compiledTermsList :: [T] = Map.elems compiledMap
+ -- Create a temp content store
+ setEnv "TRICU_DB_PATH" "/tmp/tricu-compile.db"
+ conn <- initContentStore
+ -- Store each term in the temp store under its requested name
+ forM_ (zip compiledNames compiledTermsList) $ \(n, t) ->
+ storeTerm conn [T.unpack n] t
+ -- Generate default export names when none were supplied
+ let expNames = if null maybeNames
+ then defaultExportNames (length compiledNames)
+ else compiledNames
+ exports :: [(T.Text, MerkleHash)] = zip expNames (map hashTerm compiledTermsList)
+ -- Export the bundle (exportNamedBundle returns already-encoded bytes)
+ bundleData <- exportNamedBundle conn exports
+ BL.writeFile outputPath (BL.fromStrict bundleData)
+ close conn
+ putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
+ putStrLn $ " exports: " ++ T.unpack (T.intercalate ", " expNames)
diff --git a/src/Main.hs b/src/Main.hs
@@ -28,8 +28,8 @@ data TricuArgs
= Repl
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
| TDecode { file :: [FilePath] }
- | Compile { inputFile :: FilePath, outFile :: FilePath, exportNameOpt :: String }
- | Export { hash :: String, exportNameOpt :: String, outFile :: FilePath }
+ | Compile { inputFile :: FilePath, outFile :: FilePath, names :: [String] }
+ | Export { hash :: String, exportNameOpt :: String, outFile :: FilePath, names :: [String] }
| Import { inFile :: FilePath }
| Serve { host :: String, port :: Int }
deriving (Show, Data, Typeable)
@@ -67,11 +67,13 @@ decodeMode = TDecode
exportMode :: TricuArgs
exportMode = Export
- { hash = def &= help "Full/prefix hash or stored term name to export."
+ { hash = def &= help "Hash or stored term name(s) to export (comma-separated)."
&= name "h" &= typ "HASH_OR_NAME"
- , exportNameOpt = def &= help "Export name to place in the bundle manifest. Defaults to the stored term name when exporting by name; otherwise defaults to root."
+ , exportNameOpt = def &= help "Export name (legacy; use -n NAME for full control)."
&= name "n" &= typ "NAME"
, outFile = def &= help "Output file path for the bundle." &= name "o" &= typ "FILE"
+ , names = def &= help "Export name(s) for the bundle manifest (comma-separated or repeated -n)."
+ &= typ "NAME"
}
&= help "Export a Merkle bundle from the content store."
&= explicit
@@ -92,8 +94,8 @@ compileMode = Compile
&= name "f" &= typ "FILE"
, outFile = def &= help "Output bundle file path (.tri.bundle)."
&= name "o" &= typ "FILE"
- , exportNameOpt = def &= help "Definition name to use as the bundle root. Defaults to 'main'."
- &= name "x" &= typ "NAME"
+ , names = def &= help "Definition name(s) to export as bundle roots (comma-separated or repeated -x). Defaults to 'main'."
+ &= name "x" &= typ "NAME"
}
&= help "Compile a tricu source file into a standalone Arborix portable bundle."
&= explicit
@@ -151,13 +153,23 @@ main = do
[] -> getContents
(filePath:_) -> readFile filePath
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
- Export { hash = hashStr, exportNameOpt = exportNameArg, outFile = outFilePath } -> do
+ Export { hash = hashStr, exportNameOpt = legacyName, names = namesArg, outFile = outFilePath } -> do
conn <- initContentStore
- (resolvedHash, storedNames) <- resolveExportTarget conn hashStr
- expName <- chooseExportName exportNameArg hashStr storedNames
- bundleData <- exportNamedBundle conn [(expName, resolvedHash)]
+ let hashList = T.split (== ',') (T.pack hashStr)
+ hashes <- mapM (\h -> do
+ (resolvedHash, _) <- resolveExportTarget conn (T.unpack h)
+ return resolvedHash) hashList
+ -- Merge legacy -n and new -n (names); names wins when non-empty
+ let allNames = if null namesArg
+ then if null legacyName then [] else [legacyName]
+ else namesArg
+ let expNames = if null allNames
+ then defaultExportNames (length hashes)
+ else map T.pack allNames
+ let exports = zip expNames hashes
+ bundleData <- exportNamedBundle conn exports
BL.writeFile outFilePath (BL.fromStrict bundleData)
- putStrLn $ "Exported bundle export " ++ unpack expName ++ " -> " ++ unpack resolvedHash ++ " to " ++ outFilePath
+ putStrLn $ "Exported bundle with " ++ show (length exports) ++ " export(s) to " ++ outFilePath
close conn
Import { inFile = importFile } -> do
conn <- initContentStore
@@ -166,9 +178,9 @@ main = do
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\r -> putStrLn $ " " ++ unpack r) roots
close conn
- Compile { inputFile = compileInputFile, outFile = compileOutFile, exportNameOpt = exportNameArg } ->
- let bundleExportName = if null exportNameArg then Nothing else Just (T.pack exportNameArg)
- in compileFile compileInputFile compileOutFile bundleExportName
+ Compile { inputFile = compileInputFile, outFile = compileOutFile, names = namesArg } ->
+ let exportNames = if null namesArg then [] else map T.pack namesArg
+ in compileFile compileInputFile compileOutFile exportNames
Serve { host = hostStr, port = portNum } -> do
putStrLn $ "Starting Arborix bundle server on " ++ hostStr ++ ":" ++ show portNum
putStrLn $ " GET /bundle/hash/:hash -- primary endpoint"
diff --git a/src/Server.hs b/src/Server.hs
@@ -7,16 +7,20 @@ import ContentStore (initContentStore, nameToTerm, hashToTerm, listStoredTerms,
import Database.SQLite.Simple (close)
import Wire (exportNamedBundle)
+import Control.Monad (when)
+import Data.Maybe (catMaybes)
+import Control.Monad (void)
+
import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType)
import Network.Wai
import Network.Wai.Handler.Warp (defaultSettings, runSettings, setHost, setPort)
import Data.String (fromString)
import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8)
-import Data.Char (isHexDigit)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Char (isHexDigit, toLower)
+import Data.ByteString.Char8 (unpack)
import Data.ByteString.Lazy (fromStrict)
-
import qualified Data.Text as T
-- | Start an HTTP server that serves Arborix bundles from the
@@ -30,10 +34,11 @@ import qualified Data.Text as T
--
-- Endpoints
-- ---------
--- GET /health - 200 "ok"
--- GET /bundle/name/:name - export by stored term name
--- GET /bundle/hash/:hash - export by full Merkle hash
--- GET /terms - plain-text listing (debug)
+-- GET /health - 200 "ok"
+-- GET /bundle/name/:name - export single term by name
+-- GET /bundle/hash/:hash - export single term by hash
+-- GET /bundle/roots?n=...&h=... - export multiple roots (n=name, h=hash)
+-- GET /terms - plain-text listing (debug)
--
runServer :: String -> Int -> IO ()
runServer hostStr port =
@@ -49,6 +54,9 @@ app request respond = case (requestMethod request, pathInfo request) of
("GET", ["health"]) ->
respond $ healthResponse
+ ("GET", ["bundle", "roots"]) ->
+ rootsHandler request respond
+
("GET", ["bundle", "name", nameText]) -> do
body <- nameHandler nameText
respond body
@@ -76,6 +84,54 @@ app request respond = case (requestMethod request, pathInfo request) of
healthResponse :: Response
healthResponse = responseLBS status200 [] "ok"
+-- | GET /bundle/roots?n=root&n=helper&h=abc123...
+-- Resolve multiple named roots (by stored term name or raw hash)
+-- and return a single bundle containing all of them.
+--
+-- Query parameters:
+-- - @n=<name>@ — one or more stored term names (resolved via nameToTerm)
+-- - @h=<hash>@ — one or more full Merkle hashes (validated as 16-64 hex chars)
+--
+-- The bundle manifest receives all resolved (name, hash) pairs as roots
+-- and exports. The node section is the union of all reachable nodes.
+rootsHandler :: Request -> (Response -> IO a) -> IO a
+rootsHandler request respond = do
+ conn <- initContentStore
+ let qs = queryString request
+ nParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "n"]
+ hParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "h"]
+ -- Resolve 'n' params to (name, hash) pairs
+ nResults <- mapM (\nVal -> do
+ stored <- nameToTerm conn (decodeUtf8 nVal)
+ case stored of
+ Nothing -> return Nothing
+ Just t -> return $ Just (decodeUtf8 nVal, termHash t)) nParams
+ let namedHashesFromN = catMaybes nResults
+ -- Validate 'h' params and build (name, hash) pairs
+ namedHashesFromH <- mapM (\hVal -> do
+ let raw = T.pack (dropWhile (=='#') (T.unpack (decodeUtf8 hVal)))
+ if T.all isHexDigit raw && T.length raw >= 16
+ then do
+ stored <- hashToTerm conn raw
+ let names = maybe "root" firstOrRoot (termNames <$> stored)
+ return $ Just (names, raw)
+ else return Nothing)
+ hParams
+ let allNamedHashes = namedHashesFromN ++ catMaybes namedHashesFromH
+ -- Require at least one root
+ when (null allNamedHashes) $ do
+ let resp = responseLBS status400 [] "400 Bad Request: at least one n= or h= parameter required"
+ close conn
+ void $ respond resp
+ -- Build and return the bundle
+ bundleData <- exportNamedBundle conn allNamedHashes
+ let firstHash = snd (head allNamedHashes)
+ cd = T.pack "attachment; filename=roots.bundle"
+ close conn
+ respond $ responseLBS status200
+ (bundleHeaders firstHash cd)
+ (fromStrict bundleData)
+
-- | GET /bundle/name/:name
-- Resolve a stored term name, export it as an Arborix bundle,
-- and return the raw bundle bytes.
diff --git a/src/Wire.hs b/src/Wire.hs
@@ -17,6 +17,7 @@ module Wire
, exportBundle
, exportNamedBundle
, importBundle
+ , defaultExportNames
) where
import ContentStore (getNodeMerkle, loadTree, putMerkleNode, storeTerm)
diff --git a/tricu.cabal b/tricu.cabal
@@ -42,7 +42,6 @@ executable tricu
, base16-bytestring
, base64-bytestring
, bytestring
- , cereal
, cmdargs
, containers
, cryptonite
@@ -96,7 +95,6 @@ test-suite tricu-tests
, base16-bytestring
, base64-bytestring
, bytestring
- , cereal
, cmdargs
, containers
, cryptonite
