Arboricx bundle format 1.1

We don't need SHA verification or Merkle dags in our transport bundle. Content
stores can handle both bundle and term verification and hashing.

src/FileEval.hs

@@ -11,20 +11,19 @@ import Eval (evalTricu, evalTricuWithStore)
 import Lexer
 import Parser
 import Research
-import ContentStore (newContentStore, storeTerm, hashTerm)
+import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))
 import Database.SQLite.Simple (Connection)
-import Wire (exportNamedBundle, defaultExportNames)
 
-import Control.Monad   (forM_)
 import Data.List       (partition)
 import Data.Maybe      (mapMaybe)
 import System.FilePath (takeDirectory, normalise, (</>))
 import System.Exit (die)
-import Database.SQLite.Simple (close)
 
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import qualified Data.Sequence as Seq
 import qualified Data.Text as T
 
 extractMain :: Env -> Either String T
@@ -176,37 +175,27 @@ nsVariable "" name = name
 nsVariable moduleName name = moduleName ++ "." ++ name
 
 -- | Compile a tricu source file to a standalone Arboricx bundle.
--- Uses a temp content store so it does not collide with the global one.
--- Supports multiple named exports; each is stored separately in the
--- temp store so that resolveExportTarget can look them up by name.
+-- Emits a canonical indexed bundle with no SHA-256 hashing.
 compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
 compileFile inputPath outputPath maybeNames = do
-  -- Evaluate the file to get the full environment
   env <- evaluateFile inputPath
-  -- 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 in-memory content store
-  conn <- newContentStore
-  -- 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
+    Just t  -> return (T.pack n, t)) wantedNamesUnpacked
+  let bundle = buildBundle compiledTerms
+      bundleData = encodeBundle bundle
+      nodeCount = Seq.length (bundleNodes bundle)
+      bundleSize = BS.length bundleData
   BL.writeFile outputPath (BL.fromStrict bundleData)
-  close conn
   putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
-  putStrLn $ "  exports: " ++ T.unpack (T.intercalate ", " expNames)
+  putStrLn $ "  exports: " ++ T.unpack (T.intercalate ", " (map fst compiledTerms))
+  putStrLn $ "  nodes: " ++ show nodeCount
+  putStrLn $ "  size: " ++ show bundleSize ++ " bytes"
+  case decodeBundle bundleData of
+    Left err -> putStrLn $ "  round-trip decode failed: " ++ err
+    Right decoded -> case verifyBundle decoded of
+      Left err -> putStrLn $ "  round-trip verify failed: " ++ err
+      Right () -> putStrLn $ "  round-trip: OK"

src/Main.hs

@@ -1,6 +1,6 @@
 module Main where
 
-import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, resolveExportTarget)
+import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
 import System.Exit (die)
 import Server (runServerWithPath)
 import Eval (evalTricu, evalTricuWithStore, mainResult, result)
@@ -8,7 +8,7 @@ import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
 import Parser (parseTricu)
 import REPL (repl)
 import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
-import Wire (exportNamedBundle, defaultExportNames, importBundle)
+import Wire (buildBundle, encodeBundle, importBundle, defaultExportNames, Bundle(..))
 
 import Control.Monad (foldM, unless, when)
 import Data.Text (unpack, pack)
@@ -17,7 +17,9 @@ import Data.Version (showVersion)
 import Paths_tricu (version)
 import Options.Applicative
 
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Sequence as Seq
 import Database.SQLite.Simple (Connection, close)
 
 import qualified Data.Map as Map
@@ -36,10 +38,10 @@ data TricuArgs
       , evalDb      :: Maybe FilePath
       }
   | ArboricxCompile
-      { compileInput  :: FilePath
-      , compileOutput :: FilePath
-      , compileNames  :: [String]
-      , compileDb     :: Maybe FilePath
+      { compileInput   :: FilePath
+      , compileOutput  :: FilePath
+      , compileNames   :: [String]
+      , compileDb      :: Maybe FilePath
       }
   | ArboricxImport
       { importFile :: FilePath
@@ -292,9 +294,9 @@ runImport opts = do
   when (null file) $ die "tricu arboricx import: input file is required"
   withContentStore (importDb opts) $ \conn -> do
     bundleData <- BL.readFile file
-    roots <- importBundle conn (BL.toStrict bundleData)
+    roots <- map T.unpack <$> importBundle conn (BL.toStrict bundleData)
     putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
-    mapM_ (\r -> putStrLn $ "  " ++ unpack r) roots
+    mapM_ (\r -> putStrLn $ "  " ++ r) roots
 
 runExport :: TricuArgs -> IO ()
 runExport opts =
@@ -310,18 +312,24 @@ runExportBundle opts = do
   when (null out)     $ die "tricu arboricx export: --output is required"
   when (null targets) $ die "tricu arboricx export: at least one --target is required"
   withContentStore (exportDb opts) $ \conn -> do
-    hashes <- mapM (\t -> do
+    terms <- mapM (\t -> do
       (h, _) <- resolveExportTarget conn t
-      return h) targets
+      maybeTree <- loadTree conn h
+      case maybeTree of
+        Nothing -> die $ "Term not found in store: " ++ t
+        Just tree -> return tree) targets
     let expNames = if null names
-          then defaultExportNames (length hashes)
+          then defaultExportNames (length terms)
           else map T.pack names
-    when (length expNames /= length hashes) $
+    when (length expNames /= length terms) $
       die "tricu arboricx export: number of --name values must match number of TARGETs"
-    let exports = zip expNames hashes
-    bundleData <- exportNamedBundle conn exports
+    let namedTerms = zip expNames terms
+        bundle = buildBundle namedTerms
+        bundleData = encodeBundle bundle
     BL.writeFile out (BL.fromStrict bundleData)
-    putStrLn $ "Exported bundle with " ++ show (length exports) ++ " export(s) to " ++ out
+    putStrLn $ "Exported bundle with " ++ show (length namedTerms) ++ " export(s) to " ++ out
+    putStrLn $ "  nodes: " ++ show (Seq.length (bundleNodes bundle))
+    putStrLn $ "  size: " ++ show (BS.length bundleData) ++ " bytes"
 
 runExportDag :: TricuArgs -> IO ()
 runExportDag opts = do

src/REPL.hs

@@ -6,7 +6,7 @@ import FileEval
 import Lexer ()
 import Parser
 import Research
-import Wire
+import Wire (buildBundle, encodeBundle, importBundle)
 
 import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
 import Control.Exception         (SomeException, catch, displayException)
@@ -483,13 +483,20 @@ repl = do
                         _ -> do
                           printError $ "Ambiguous match for: " ++ cleanHash
                           return h
-                bundleData <- liftIO $ exportBundle conn [hash]
-                liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
-                liftIO $ do
-                  printSuccess $ "Exported bundle with root "
-                  displayColoredHash hash
-                  putStrLn $ " to " ++ outFile
-                loop state
+                maybeTree <- liftIO $ loadTree conn hash
+                case maybeTree of
+                  Nothing -> do
+                    liftIO $ printError $ "Term not found in store: " ++ T.unpack hash
+                    loop state
+                  Just tree -> do
+                    let bundle = buildBundle [(T.pack "root", tree)]
+                        bundleData = encodeBundle bundle
+                    liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
+                    liftIO $ do
+                      printSuccess $ "Exported bundle with root "
+                      displayColoredHash hash
+                      putStrLn $ " to " ++ outFile
+                    loop state
 
     handleBundleImport :: REPLState -> InputT IO ()
     handleBundleImport state = do

src/Server.hs

@@ -4,9 +4,9 @@ module Server
   ) where
 
 import ContentStore (initContentStore, initContentStoreWithPath, nameToTerm, hashToTerm, listStoredTerms,
-                     parseNameList, StoredTerm(..), termHash)
+                     parseNameList, StoredTerm(..), termHash, loadTree)
 import Database.SQLite.Simple (Connection, close)
-import Wire (exportNamedBundle)
+import Wire (buildBundle, encodeBundle)
 
 import Control.Monad (when, void)
 import Data.Maybe (catMaybes)
@@ -19,6 +19,7 @@ import Data.String (fromString)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.Char (isHexDigit, toLower)
+import Data.ByteString (ByteString)
 import Data.ByteString.Char8 (unpack)
 import Data.ByteString.Lazy (fromStrict)
 import qualified Data.Text as T
@@ -103,7 +104,7 @@ rootsHandler mkConn request respond = do
     close conn
     void $ respond resp
   -- Build and return the bundle
-  bundleData <- exportNamedBundle conn allNamedHashes
+  bundleData <- buildAndEncodeBundle conn allNamedHashes
   let firstHash = snd (head allNamedHashes)
       cd = T.pack "attachment; filename=roots.bundle"
   close conn
@@ -123,7 +124,7 @@ nameHandler mkConn nameText = do
     Just term' -> do
       let th = termHash term'
           namedHashes = [(firstOrRoot (termNames term'), th)]
-      bundleData <- exportNamedBundle conn namedHashes
+      bundleData <- buildAndEncodeBundle conn namedHashes
       let cd = T.pack $ "attachment; filename=" ++ safeFileName (T.unpack nameText) ++ ".bundle"
       close conn
       return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData)
@@ -144,12 +145,24 @@ hashHandler mkConn hashText =
             Just term' -> do
               let th = termHash term'
                   namedHashes' = [(firstOrRoot (termNames term'), th)]
-              bundleData <- exportNamedBundle conn namedHashes'
+              bundleData <- buildAndEncodeBundle conn namedHashes'
               close conn
               return $ responseLBS status200
                 (bundleHeaders th "attachment; filename=hash.bundle")
                 (fromStrict bundleData)
 
+-- | Helper: load terms by hash and build an indexed bundle.
+buildAndEncodeBundle :: Connection -> [(Text, Text)] -> IO ByteString
+buildAndEncodeBundle conn namedHashes = do
+  terms <- mapM (\(_, h) -> do
+    maybeTree <- loadTree conn h
+    case maybeTree of
+      Nothing -> error $ "Server: hash not found in store: " ++ T.unpack h
+      Just tree -> return tree) namedHashes
+  let namedTerms = zip (map fst namedHashes) terms
+      bundle = buildBundle namedTerms
+  return $ encodeBundle bundle
+
 -- | GET /terms
 termsResponse :: IO Connection -> IO Response
 termsResponse mkConn = do