From e0b1e95729ae79479684ff92a563bca4f50a5004 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Mon, 11 May 2026 15:29:12 -0500 Subject: [PATCH] feat(haskell): CLI rewrite --- src/ContentStore.hs | 11 +- src/Eval.hs | 37 +++ src/FileEval.hs | 24 +- src/Main.hs | 588 +++++++++++++++++++++++++------------------- src/REPL.hs | 2 +- src/Research.hs | 10 +- src/Server.hs | 93 +++---- tricu.cabal | 6 +- 8 files changed, 441 insertions(+), 330 deletions(-) diff --git a/src/ContentStore.hs b/src/ContentStore.hs index 891f015..21c4957 100644 --- a/src/ContentStore.hs +++ b/src/ContentStore.hs @@ -40,8 +40,15 @@ serializeNameList :: [Text] -> Text serializeNameList = T.intercalate "," . nub . sort initContentStore :: IO Connection -initContentStore = do - dbPath <- getContentStorePath +initContentStore = initContentStoreWithPath Nothing + +-- | Initialise a content store with an explicit path, or fall back +-- to the environment variable / default location. +initContentStoreWithPath :: Maybe FilePath -> IO Connection +initContentStoreWithPath mPath = do + dbPath <- case mPath of + Just p -> return p + Nothing -> getContentStorePath createDirectoryIfMissing True (takeDirectory dbPath) conn <- open dbPath setupDatabase conn diff --git a/src/Eval.hs b/src/Eval.hs index 64fbc88..fcc4118 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -93,6 +93,43 @@ evalAST mconn selectedVersions ast = do resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames return $ evalASTSync resolvedEnv ast +-- | Evaluate a single AST term using a local environment augmented by +-- lazily-resolved store terms. +evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T +evalASTWithEnv mconn localEnv ast = do + let varNames = collectVarNames ast + storeEnv <- resolveTermsFromStore mconn Map.empty varNames + let combinedEnv = Map.union localEnv storeEnv + return $ evalASTSync combinedEnv ast + +-- | Store-aware version of 'evalSingle'. +evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env +evalSingleWithStore mconn env term + | SDef name [] body <- term = do + res <- evalASTWithEnv mconn env body + case Map.lookup name env of + Just existingValue + | existingValue == res -> return env + | otherwise -> return $ Map.insert "!result" res (Map.insert name res env) + Nothing -> return $ Map.insert "!result" res (Map.insert name res env) + | otherwise = do + res <- evalASTWithEnv mconn env term + return $ Map.insert "!result" res env + +-- | Store-aware version of 'evalTricu'. Does not preload the entire +-- content store; terms are resolved on demand as variables are +-- encountered. +evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env +evalTricuWithStore mconn env x = go env (reorderDefs env x) + where + go env' [] = return env' + go env' [def] = do + updatedEnv <- evalSingleWithStore mconn env' def + return $ Map.insert "!result" (result updatedEnv) updatedEnv + go env' (def:xs) = do + updatedEnv <- evalSingleWithStore mconn env' def + evalTricuWithStore mconn updatedEnv xs + collectVarNames :: TricuAST -> [(String, Maybe String)] collectVarNames = go [] where diff --git a/src/FileEval.hs b/src/FileEval.hs index e0d4d64..6d4c49c 100644 --- a/src/FileEval.hs +++ b/src/FileEval.hs @@ -2,21 +2,22 @@ module FileEval ( preprocessFile , evaluateFile , evaluateFileWithContext + , evaluateFileWithStore , evaluateFileResult , compileFile ) where -import Eval (evalTricu) +import Eval (evalTricu, evalTricuWithStore) import Lexer import Parser import Research -import ContentStore (initContentStore, storeTerm, hashTerm) +import ContentStore (newContentStore, storeTerm, hashTerm) +import Database.SQLite.Simple (Connection) import Wire (exportNamedBundle, defaultExportNames) import Control.Monad (forM_) import Data.List (partition) import Data.Maybe (mapMaybe) -import System.Environment (setEnv) import System.FilePath (takeDirectory, normalise, ()) import System.Exit (die) import Database.SQLite.Simple (close) @@ -79,6 +80,18 @@ evaluateFileWithContext env filePath = do ast <- preprocessFile filePath pure $ evalTricu env ast +-- | File evaluation that lazily resolves missing names from the +-- content store instead of pre-loading the entire store into memory. +evaluateFileWithStore :: Maybe Connection -> Env -> FilePath -> IO Env +evaluateFileWithStore mconn env filePath = do + contents <- readFile filePath + let tokens = lexTricu contents + case parseProgram tokens of + Left err -> errorWithoutStackTrace (handleParseError err) + Right _ast -> do + ast <- preprocessFile filePath + evalTricuWithStore mconn env ast + preprocessFile :: FilePath -> IO [TricuAST] preprocessFile p = preprocessFile' Set.empty p p @@ -181,9 +194,8 @@ compileFile inputPath outputPath maybeNames = do $ 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 + -- 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 diff --git a/src/Main.hs b/src/Main.hs index 61537ff..ea6cc96 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,280 +1,374 @@ module Main where -import ContentStore (initContentStore, loadEnvironment, loadTerm, resolveExportTarget) +import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, resolveExportTarget) import System.Exit (die) -import Server (runServer) -import Eval (evalTricu, mainResult, result) -import FileEval -import Parser (parseTricu) -import REPL -import Research -import Wire +import Server (runServerWithPath) +import Eval (evalTricu, evalTricuWithStore, mainResult, result) +import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile) +import Parser (parseTricu) +import REPL (repl) +import Research (T, EvaluatedForm(..), Env, formatT, exportDag) +import Wire (exportNamedBundle, defaultExportNames, importBundle) -import Control.Monad (foldM) -import Data.Text (Text, unpack) -import qualified Data.Text as T -import Data.Version (showVersion) -import Paths_tricu (version) -import System.Console.CmdArgs -import System.Environment (lookupEnv) -import System.IO (hPutStrLn, stderr) -import Text.Megaparsec () +import Control.Monad (foldM, unless, when) +import Data.Text (unpack, pack) +import qualified Data.Text as T +import Data.Version (showVersion) +import Paths_tricu (version) +import Options.Applicative import qualified Data.ByteString.Lazy as BL -import Database.SQLite.Simple (close) +import Database.SQLite.Simple (Connection, close) import qualified Data.Map as Map +import System.Environment (lookupEnv) + +-- --------------------------------------------------------------------------- +-- CLI argument types +-- --------------------------------------------------------------------------- data TricuArgs = Repl - | Evaluate { file :: [FilePath], form :: EvaluatedForm, outFile :: FilePath } - | TDecode { file :: [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 } - | ExportDag { target :: String, outFile :: FilePath } - deriving (Show, Data, Typeable) + | Eval + { evalFiles :: [FilePath] + , evalFormat :: EvaluatedForm + , evalOutput :: FilePath + , evalDb :: Maybe FilePath + } + | ArboricxCompile + { compileInput :: FilePath + , compileOutput :: FilePath + , compileNames :: [String] + , compileDb :: Maybe FilePath + } + | ArboricxImport + { importFile :: FilePath + , importDb :: Maybe FilePath + } + | ArboricxExport + { exportTargets :: [String] + , exportOutput :: FilePath + , exportNames :: [String] + , exportDb :: Maybe FilePath + , dag :: Bool + } + | ArboricxServe + { serveHost :: String + , servePort :: Int + , serveDb :: Maybe FilePath + } + deriving (Show) -replMode :: TricuArgs -replMode = Repl - &= help "Start interactive REPL" - &= auto - &= name "repl" +-- --------------------------------------------------------------------------- +-- optparse-applicative parsers +-- --------------------------------------------------------------------------- -evaluateMode :: TricuArgs -evaluateMode = Evaluate - { file = def &= help "Input file path(s) for evaluation.\n \ - \ Defaults to stdin." - &= name "f" &= typ "FILE" - , form = TreeCalculus &= typ "FORM" - &= help "Optional output form: (tree|fsl|ast|ternary|ascii|decode).\n \ - \ Defaults to tricu-compatible `t` tree form." - &= name "t" - , outFile = def &= help "Optional output file path. Defaults to stdout." - &= name "o" &= typ "FILE" - } - &= help "Evaluate tricu and return the result of the final expression." - &= explicit - &= name "eval" +readEvaluatedForm :: ReadM EvaluatedForm +readEvaluatedForm = eitherReader $ \s -> case s of + "tree" -> Right Tree + "fsl" -> Right FSL + "ast" -> Right AST + "ternary" -> Right Ternary + "ascii" -> Right Ascii + "decode" -> Right Decode + _ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode" -decodeMode :: TricuArgs -decodeMode = TDecode - { file = def - &= help "Optional input file path to attempt decoding.\n \ - \ Defaults to stdin." - &= name "f" &= typ "FILE" - } - &= help "Decode a Tree Calculus value into a string representation." - &= explicit - &= name "decode" +evalParser :: Parser TricuArgs +evalParser = Eval + <$> many (argument str (metavar "FILE...")) + <*> option readEvaluatedForm + ( long "format" + <> short 'f' + <> metavar "FORM" + <> value Tree + <> help "Output format: tree, fsl, ast, ternary, ascii, decode" + ) + <*> option str + ( long "output" + <> short 'o' + <> metavar "FILE" + <> value "" + <> help "Write output to file instead of stdout" + ) + <*> optional (option str + ( long "db" + <> short 'd' + <> metavar "PATH" + <> help "Content store database path" + )) -exportMode :: TricuArgs -exportMode = 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 (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 - &= name "export" +compileParser :: Parser TricuArgs +compileParser = ArboricxCompile + <$> option str + ( long "file" + <> short 'f' + <> metavar "FILE" + <> value "" + <> help "Input .tri source file" + ) + <*> option str + ( long "output" + <> short 'o' + <> metavar "FILE" + <> value "" + <> help "Output bundle file path (required)" + ) + <*> many (option str + ( long "name" + <> short 'n' + <> metavar "NAME" + <> help "Definition name(s) to export as bundle roots (repeatable)" + )) + <*> optional (option str + ( long "db" + <> short 'd' + <> metavar "PATH" + <> help "Content store database path" + )) -importMode :: TricuArgs -importMode = Import - { inFile = def &= help "Path to the bundle file to import." - &= name "f" &= typ "FILE" - } - &= help "Import a Merkle bundle into the content store." - &= explicit - &= name "import" +importParser :: Parser TricuArgs +importParser = ArboricxImport + <$> option str + ( long "file" + <> short 'f' + <> metavar "FILE" + <> value "" + <> help "Bundle file to import" + ) + <*> optional (option str + ( long "db" + <> short 'd' + <> metavar "PATH" + <> help "Content store database path" + )) -compileMode :: TricuArgs -compileMode = Compile - { inputFile = def &= help "Path to the tricu source file (.tri) to compile." - &= name "f" &= typ "FILE" - , outFile = def &= help "Output bundle file path (.tri.bundle)." - &= name "o" &= typ "FILE" - , 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 Arboricx portable bundle." - &= explicit - &= name "compile" +exportParser :: Parser TricuArgs +exportParser = ArboricxExport + <$> many (option str + ( long "target" + <> short 't' + <> metavar "TARGET" + <> help "Target hash or name (repeatable)" + )) + <*> option str + ( long "output" + <> short 'o' + <> metavar "FILE" + <> value "" + <> help "Output file path (required for bundle export)" + ) + <*> many (option str + ( long "name" + <> short 'n' + <> metavar "NAME" + <> help "Export name(s) for the bundle manifest (repeatable)" + )) + <*> optional (option str + ( long "db" + <> short 'd' + <> metavar "PATH" + <> help "Content store database path" + )) + <*> switch + ( long "dag" + <> help "Export as a topologically-sorted DAG node table instead of a bundle" + ) -serveMode :: TricuArgs -serveMode = Serve - { host = "127.0.0.1" &= help "Host to bind the server to." &= name "h" &= typ "HOST" - , port = 8787 &= help "HTTP port to listen on." &= name "p" &= typ "PORT" - } - &= help "Start a read-only HTTP server for exporting Arboricx bundles." - &= explicit - &= name "server" +serveParser :: Parser TricuArgs +serveParser = ArboricxServe + <$> option str + ( long "host" + <> metavar "HOST" + <> value "127.0.0.1" + <> help "Host to bind the server to" + ) + <*> option auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> value 8787 + <> help "HTTP port to listen on" + ) + <*> optional (option str + ( long "db" + <> short 'd' + <> metavar "PATH" + <> help "Content store database path" + )) -exportDagMode :: TricuArgs -exportDagMode = ExportDag - { target = def &= help "Stored term name or hash to export as a DAG node table." - &= name "t" &= typ "NAME_OR_HASH" - , outFile = def &= help "Optional output file path. Defaults to stdout." - &= name "o" &= typ "FILE" - } - &= help "Export a term's Merkle DAG as a topologically-sorted node table for host embedding." - &= explicit - &= name "export-dag" +versionStr :: String +versionStr = "tricu " ++ showVersion version + +tricuParser :: Parser TricuArgs +tricuParser = (subparser topCommands <|> pure Repl) + <**> infoOption versionStr (long "version" <> help "Show version") + where + topCommands = mconcat + [ command "eval" (info (evalParser <**> helper) + (progDesc "Evaluate tricu source and print the result of the final expression")) + , command "arboricx" (info (arboricxParser <**> helper) + (progDesc "Arboricx bundle operations")) + ] + +arboricxParser :: Parser TricuArgs +arboricxParser = subparser $ mconcat + [ command "compile" (info (compileParser <**> helper) + (progDesc "Compile a .tri file into a standalone Arboricx bundle")) + , command "import" (info (importParser <**> helper) + (progDesc "Import an Arboricx bundle into the content store")) + , command "export" (info (exportParser <**> helper) + (progDesc "Export one or more terms from the content store")) + , command "serve" (info (serveParser <**> helper) + (progDesc "Start a read-only HTTP server for Arboricx bundles")) + ] + +-- --------------------------------------------------------------------------- +-- Entry point +-- --------------------------------------------------------------------------- main :: IO () main = do - let versionStr = "tricu Evaluator and REPL " ++ showVersion version - cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode, serveMode, exportDagMode] - &= help "tricu: Exploring Tree Calculus" - &= program "tricu" - &= summary versionStr - &= versionArg [explicit, name "version", summary versionStr] - case cmdArgsParsed of - Repl -> do - putStrLn "Welcome to the tricu REPL" - putStrLn "You may exit with `CTRL+D` or the `!exit` command." - repl - Evaluate { file = filePaths, form = outputForm, outFile = evalOutFile } -> do - maybeDbPath <- lookupEnv "TRICU_DB_PATH" - evalResult <- case filePaths of - [] -> do - initialEnv <- case maybeDbPath of - Just _ -> do - conn <- initContentStore - env <- loadEnvironment conn - close conn - return env - Nothing -> return Map.empty - input <- getContents - pure $ runTricuTEnv initialEnv input - filePaths@(_:_) -> do - initialEnv <- case maybeDbPath of - Just _ -> do - conn <- initContentStore - env <- loadEnvironment conn - close conn - return env - Nothing -> return Map.empty - finalEnv <- foldM evaluateFileWithContext initialEnv filePaths - pure $ mainResult finalEnv - let fRes = formatT outputForm evalResult - if null evalOutFile - then putStr fRes - else writeFile evalOutFile fRes - TDecode { file = filePaths } -> do - value <- case filePaths of - [] -> getContents - (filePath:_) -> readFile filePath - putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value - Export { hash = hashStr, exportNameOpt = legacyName, names = namesArg, outFile = outFilePath } -> do - conn <- initContentStore - 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 with " ++ show (length exports) ++ " export(s) to " ++ outFilePath - close conn - Import { inFile = importFile } -> do - conn <- initContentStore - bundleData <- BL.readFile importFile - roots <- importBundle conn (BL.toStrict bundleData) - putStrLn $ "Imported " ++ show (length roots) ++ " root(s):" - mapM_ (\r -> putStrLn $ " " ++ unpack r) roots - close conn - 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 Arboricx bundle server on " ++ hostStr ++ ":" ++ show portNum - putStrLn $ " GET /bundle/hash/:hash -- primary endpoint" - putStrLn $ " GET /bundle/name/:name -- convenience endpoint" - putStrLn $ " Content-Type: application/vnd.arboricx.bundle" - runServer hostStr portNum - ExportDag { target = targetName, outFile = dagOutFile } -> do - conn <- initContentStore - maybeTerm <- loadTerm conn targetName - close conn + args <- execParser $ info (tricuParser <**> helper) + ( fullDesc + <> progDesc "Exploring Tree Calculus" + <> header versionStr + ) + case args of + Repl -> runRepl + Eval {} -> runEval args + ArboricxCompile {} -> runCompile args + ArboricxImport {} -> runImport args + ArboricxExport {} -> runExport args + ArboricxServe {} -> runServe args + +-- --------------------------------------------------------------------------- +-- Command runners +-- --------------------------------------------------------------------------- + +runRepl :: IO () +runRepl = do + putStrLn "Welcome to the tricu REPL" + putStrLn "You may exit with `CTRL+D` or the `!exit` command." + repl + +runEval :: TricuArgs -> IO () +runEval opts = do + let files = evalFiles opts + form = evalFormat opts + out = evalOutput opts + mconn <- case evalDb opts of + Just dbPath -> Just <$> initContentStoreWithPath (Just dbPath) + Nothing -> do + mDbPath <- lookupEnv "TRICU_DB_PATH" + case mDbPath of + Just _ -> Just <$> initContentStoreWithPath Nothing + Nothing -> return Nothing + resultT <- case files of + [] -> do + input <- getContents + env <- evalTricuWithStore mconn Map.empty (parseTricu input) + return $ result env + _ -> do + finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files + return $ mainResult finalEnv + case mconn of + Just conn -> close conn + Nothing -> return () + writeOutput out (formatT form resultT) + +runCompile :: TricuArgs -> IO () +runCompile opts = do + let input = compileInput opts + out = compileOutput opts + names = compileNames opts + when (null out) $ die "tricu arboricx compile: --output is required" + when (null input) $ die "tricu arboricx compile: input file is required" + let nameTexts = if null names then [] else map T.pack names + compileFile input out nameTexts + +runImport :: TricuArgs -> IO () +runImport opts = do + let file = importFile opts + 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) + putStrLn $ "Imported " ++ show (length roots) ++ " root(s):" + mapM_ (\r -> putStrLn $ " " ++ unpack r) roots + +runExport :: TricuArgs -> IO () +runExport opts = + if dag opts + then runExportDag opts + else runExportBundle opts + +runExportBundle :: TricuArgs -> IO () +runExportBundle opts = do + let targets = exportTargets opts + out = exportOutput opts + names = exportNames opts + 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 + (h, _) <- resolveExportTarget conn t + return h) targets + let expNames = if null names + then defaultExportNames (length hashes) + else map T.pack names + when (length expNames /= length hashes) $ + die "tricu arboricx export: number of --name values must match number of TARGETs" + let exports = zip expNames hashes + bundleData <- exportNamedBundle conn exports + BL.writeFile out (BL.fromStrict bundleData) + putStrLn $ "Exported bundle with " ++ show (length exports) ++ " export(s) to " ++ out + +runExportDag :: TricuArgs -> IO () +runExportDag opts = do + let targets = exportTargets opts + out = exportOutput opts + case targets of + [target] -> withContentStore (exportDb opts) $ \conn -> do + maybeTerm <- loadTerm conn target case maybeTerm of - Nothing -> die $ "Term not found: " ++ targetName + Nothing -> die $ "Term not found: " ++ target Just term -> do - let (rootIdx, nodes) = exportDag term - output = unlines $ show rootIdx : map (\(tag, refs) -> unwords (tag : map show refs)) nodes - if null dagOutFile - then putStr output - else writeFile dagOutFile output + let (rootIdx, nodes) = Research.exportDag term + output = unlines $ + show rootIdx : + map (\(tag, refs) -> unwords (tag : map show refs)) nodes + writeOutput out output + [] -> die "tricu arboricx export --dag: exactly one --target is required" + _ -> die "tricu arboricx export --dag: exactly one --target is required" -runTricu :: String -> String -runTricu = formatT TreeCalculus . runTricuT +runServe :: TricuArgs -> IO () +runServe opts = do + let hostStr = serveHost opts + portNum = servePort opts + putStrLn $ "Starting Arboricx bundle server on " ++ hostStr ++ ":" ++ show portNum + putStrLn $ " GET /bundle/hash/:hash -- primary endpoint" + putStrLn $ " GET /bundle/name/:name -- convenience endpoint" + putStrLn $ " Content-Type: application/vnd.arboricx.bundle" + runServerWithPath (serveDb opts) hostStr portNum -runTricuT :: String -> T -runTricuT input = - let asts = parseTricu input - finalEnv = evalTricu Map.empty asts - in result finalEnv +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- -runTricuEnv :: Env -> String -> String -runTricuEnv env = formatT TreeCalculus . runTricuTEnv env +withContentStore :: Maybe FilePath -> (Connection -> IO a) -> IO a +withContentStore mPath act = do + conn <- initContentStoreWithPath mPath + result <- act conn + close conn + return result + +writeOutput :: FilePath -> String -> IO () +writeOutput path content + | null path = putStr content + | otherwise = writeFile path content runTricuTEnv :: Env -> String -> T runTricuTEnv env input = let asts = parseTricu input finalEnv = evalTricu env asts in result finalEnv - -runTricuWithEnvT :: String -> (Env, T) -runTricuWithEnvT input = - let asts = parseTricu input - finalEnv = evalTricu Map.empty asts - in (finalEnv, result finalEnv) - -runTricuWithEnv :: String -> (Env, String) -runTricuWithEnv input = - let asts = parseTricu input - finalEnv = evalTricu Map.empty asts - res = result finalEnv - in (finalEnv, formatT TreeCalculus res) - -runTricuEnvWithEnvT :: Env -> String -> (Env, T) -runTricuEnvWithEnvT env input = - let asts = parseTricu input - finalEnv = evalTricu env asts - in (finalEnv, result finalEnv) - -runTricuEnvWithEnv :: Env -> String -> (Env, String) -runTricuEnvWithEnv env input = - let asts = parseTricu input - finalEnv = evalTricu env asts - res = result finalEnv - in (finalEnv, formatT TreeCalculus res) - -chooseExportName :: String -> String -> [Text] -> IO Text -chooseExportName explicitName input storedNames - | not (null explicitName) = return $ T.pack explicitName - | Just firstName <- firstNonEmpty storedNames = return firstName - | otherwise = do - hPutStrLn stderr $ - "No stored name found for export target " ++ input ++ "; using export name 'root'. " - ++ "Use export -n NAME to preserve a semantic name." - return "root" - -firstNonEmpty :: [Text] -> Maybe Text -firstNonEmpty = go - where - go [] = Nothing - go (x:xs) - | T.null x = go xs - | otherwise = Just x diff --git a/src/REPL.hs b/src/REPL.hs index 09582d3..f35c067 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -130,7 +130,7 @@ repl = do handleOutput :: REPLState -> InputT IO () handleOutput state = do - let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii] + let formats = [Decode, Tree, FSL, AST, Ternary, Ascii] outputStrLn "Available output formats:" mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f) (zip [1..] formats) diff --git a/src/Research.hs b/src/Research.hs index 7427395..c801486 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -8,8 +8,6 @@ import Data.Map () import Data.Text (Text, replace) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word8) -import System.Console.CmdArgs (Data, Typeable) - import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Set as Set @@ -55,8 +53,8 @@ data LToken deriving (Eq, Show, Ord) -- Output formats -data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode - deriving (Show, Data, Typeable) +data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode + deriving (Show) -- Environment containing previously evaluated TC terms type Env = Map.Map String T @@ -243,7 +241,7 @@ toList _ = Left "Invalid Tree Calculus list" -- Outputs formatT :: EvaluatedForm -> T -> String -formatT TreeCalculus = toSimpleT . show +formatT Tree = toSimpleT . show formatT FSL = show formatT AST = show . toAST formatT Ternary = toTernaryString @@ -289,7 +287,7 @@ decodeResult tc = (_, _, Right n) -> show n (_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]" (_, Right [], _) -> "[]" - _ -> formatT TreeCalculus tc + _ -> formatT Tree tc where isCommonChar c = let n = fromEnum c diff --git a/src/Server.hs b/src/Server.hs index c2c55ea..b85c60c 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,15 +1,15 @@ module Server ( runServer + , runServerWithPath ) where -import ContentStore (initContentStore, nameToTerm, hashToTerm, listStoredTerms, +import ContentStore (initContentStore, initContentStoreWithPath, nameToTerm, hashToTerm, listStoredTerms, parseNameList, StoredTerm(..), termHash) -import Database.SQLite.Simple (close) +import Database.SQLite.Simple (Connection, close) import Wire (exportNamedBundle) -import Control.Monad (when) +import Control.Monad (when, void) import Data.Maybe (catMaybes) -import Control.Monad (void) import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType) import Network.Wai @@ -25,48 +25,36 @@ import qualified Data.Text as T -- | Start an HTTP server that serves Arboricx bundles from the -- local content store. --- --- This is a read-only export surface. Clients fetch bundle bytes --- and independently inspect / verify / run them. The server does --- not execute bundles. --- --- Bind host defaults to @127.0.0.1@. --- --- Endpoints --- --------- --- 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 = - runSettings settings app +runServer = runServerWithPath Nothing + +-- | Start an HTTP server with an explicit database path. +runServerWithPath :: Maybe FilePath -> String -> Int -> IO () +runServerWithPath mDbPath hostStr port = + runSettings settings (app mkConn) where + mkConn = initContentStoreWithPath mDbPath settings = setPort port $ setHost (fromString hostStr) defaultSettings -- | WAI application backed by the content store. --- Uses the same database path as @eval@ mode (env var --- @TRICU_DB_PATH@ or the default location). -app :: Application -app request respond = case (requestMethod request, pathInfo request) of +app :: IO Connection -> Application +app mkConn request respond = case (requestMethod request, pathInfo request) of ("GET", ["health"]) -> respond $ healthResponse ("GET", ["bundle", "roots"]) -> - rootsHandler request respond + rootsHandler mkConn request respond ("GET", ["bundle", "name", nameText]) -> do - body <- nameHandler nameText + body <- nameHandler mkConn nameText respond body ("GET", ["bundle", "hash", hashText]) -> do - body <- hashHandler hashText + body <- hashHandler mkConn hashText respond body ("GET", ["terms"]) -> do - body <- termsResponse + body <- termsResponse mkConn respond body ("POST", _) -> @@ -85,18 +73,9 @@ 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=@ — one or more stored term names (resolved via nameToTerm) --- - @h=@ — 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 +rootsHandler :: IO Connection -> Request -> (Response -> IO a) -> IO a +rootsHandler mkConn request respond = do + conn <- mkConn 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"] @@ -133,14 +112,9 @@ rootsHandler request respond = do (fromStrict bundleData) -- | GET /bundle/name/:name --- Resolve a stored term name, export it as an Arboricx bundle, --- and return the raw bundle bytes. --- --- Sets @Content-Type@ and @X-Arboricx-Root-Hash@ headers. --- Returns 404 when the name does not resolve to any stored term. -nameHandler :: Text -> IO Response -nameHandler nameText = do - conn <- initContentStore +nameHandler :: IO Connection -> Text -> IO Response +nameHandler mkConn nameText = do + conn <- mkConn stored <- nameToTerm conn nameText case stored of Nothing -> do @@ -155,19 +129,13 @@ nameHandler nameText = do return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData) -- | GET /bundle/hash/:hash --- Resolve a full Merkle hash and export the root as an Arboricx --- bundle. --- --- - Malformed hash (non-hex or < 16 chars): 400 --- - Well-formed but absent: 404 --- - Present: 200 with bundle bytes -hashHandler :: Text -> IO Response -hashHandler hashText = +hashHandler :: IO Connection -> Text -> IO Response +hashHandler mkConn hashText = let raw = T.pack (dropWhile (== '#') (T.unpack hashText)) in if not (T.all isHexDigit raw) || T.length raw < 16 then return $ responseLBS status400 [] "400 Bad Request: invalid hash" else do - conn <- initContentStore + conn <- mkConn stored <- hashToTerm conn raw case stored of Nothing -> do @@ -183,10 +151,9 @@ hashHandler hashText = (fromStrict bundleData) -- | GET /terms --- Plain-text listing of all stored terms (debugging only). -termsResponse :: IO Response -termsResponse = do - conn <- initContentStore +termsResponse :: IO Connection -> IO Response +termsResponse mkConn = do + conn <- mkConn terms <- listStoredTerms conn close conn let lines' = [ names <> " " <> hash <> " " <> T.pack (show created) @@ -212,14 +179,12 @@ bundleHeaders root cd = , ("Content-Disposition", encodeUtf8 cd) ] --- | Pick the first stored name, falling back to "root" when names are empty. firstOrRoot :: Text -> Text firstOrRoot names = case parseNameList names of [] -> "root" (x:_) -> x --- | Sanitise a string to a safe filename prefix. safeFileName :: String -> String safeFileName = map go where diff --git a/tricu.cabal b/tricu.cabal index 048b6f8..2bed284 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -17,7 +17,6 @@ executable tricu hs-source-dirs: src default-extensions: - DeriveDataTypeable LambdaCase MultiWayIf OverloadedStrings @@ -41,7 +40,7 @@ executable tricu , base16-bytestring , base64-bytestring , bytestring - , cmdargs + , optparse-applicative , containers , cryptonite , directory @@ -82,7 +81,6 @@ test-suite tricu-tests main-is: Spec.hs hs-source-dirs: test, src default-extensions: - DeriveDataTypeable LambdaCase MultiWayIf OverloadedStrings @@ -93,7 +91,7 @@ test-suite tricu-tests , base16-bytestring , base64-bytestring , bytestring - , cmdargs + , optparse-applicative , containers , cryptonite , directory