feat: HTTP server for exporting Arborix bundles
Introduces a read-only HTTP server (WAI/Warp) backed by the content store, exposing three bundle-export endpoints: - GET /bundle/name/:name — export by stored term name - GET /bundle/hash/:hash — export by full Merkle hash - GET /terms — plain-text listing (debug) Also adds `tricu server` (aka `--serve`) CLI mode, move `resolveExportTarget` / `namesForHash` / `looksLikeHash` out of `Main.hs` into `ContentStore.hs`, and cleans up unused exports and imports across `FileEval.hs` and `Wire.hs`.
This commit is contained in:
80
src/Main.hs
80
src/Main.hs
@@ -1,6 +1,7 @@
|
||||
module Main where
|
||||
|
||||
import ContentStore (getContentStorePath, initContentStore, termNames, hashToTerm, loadEnvironment, parseNameList)
|
||||
import ContentStore (initContentStore, loadEnvironment, resolveExportTarget)
|
||||
import Server (runServer)
|
||||
import Eval (evalTricu, mainResult, result)
|
||||
import FileEval
|
||||
import Parser (parseTricu)
|
||||
@@ -9,8 +10,6 @@ import Research
|
||||
import Wire
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.Char (isHexDigit)
|
||||
import Control.Monad.IO.Class ()
|
||||
import Data.Text (Text, unpack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Version (showVersion)
|
||||
@@ -18,12 +17,10 @@ import Paths_tricu (version)
|
||||
import System.Console.CmdArgs
|
||||
import System.Environment (lookupEnv)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.Exit (die)
|
||||
import Text.Megaparsec ()
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Database.SQLite.Simple (Connection, Only(..), close)
|
||||
import qualified Database.SQLite.Simple as DB (query)
|
||||
import Database.SQLite.Simple (close)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
@@ -34,6 +31,7 @@ data TricuArgs
|
||||
| Compile { inputFile :: FilePath, outFile :: FilePath, exportNameOpt :: String }
|
||||
| Export { hash :: String, exportNameOpt :: String, outFile :: FilePath }
|
||||
| Import { inFile :: FilePath }
|
||||
| Serve { host :: String, port :: Int }
|
||||
deriving (Show, Data, Typeable)
|
||||
|
||||
replMode :: TricuArgs
|
||||
@@ -101,10 +99,19 @@ compileMode = Compile
|
||||
&= explicit
|
||||
&= name "compile"
|
||||
|
||||
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 Arborix bundles."
|
||||
&= explicit
|
||||
&= name "server"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
|
||||
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode]
|
||||
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode, serveMode]
|
||||
&= help "tricu: Exploring Tree Calculus"
|
||||
&= program "tricu"
|
||||
&= summary versionStr
|
||||
@@ -119,7 +126,7 @@ main = do
|
||||
evalResult <- case filePaths of
|
||||
[] -> do
|
||||
initialEnv <- case maybeDbPath of
|
||||
Just dbPath -> do
|
||||
Just _ -> do
|
||||
conn <- initContentStore
|
||||
env <- loadEnvironment conn
|
||||
close conn
|
||||
@@ -127,7 +134,7 @@ main = do
|
||||
Nothing -> return Map.empty
|
||||
input <- getContents
|
||||
pure $ runTricuTEnv initialEnv input
|
||||
(filePath:restFilePaths) -> do
|
||||
(_:restFilePaths) -> do
|
||||
initialEnv <- case maybeDbPath of
|
||||
Just _ -> do
|
||||
conn <- initContentStore
|
||||
@@ -144,24 +151,30 @@ main = do
|
||||
[] -> getContents
|
||||
(filePath:_) -> readFile filePath
|
||||
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
|
||||
Export { hash = hashStr, exportNameOpt = exportNameArg, outFile = outFile } -> do
|
||||
Export { hash = hashStr, exportNameOpt = exportNameArg, outFile = outFilePath } -> do
|
||||
conn <- initContentStore
|
||||
(resolvedHash, storedNames) <- resolveExportTarget conn hashStr
|
||||
exportName <- chooseExportName exportNameArg hashStr storedNames
|
||||
bundleData <- exportNamedBundle conn [(exportName, resolvedHash)]
|
||||
BL.writeFile outFile (BL.fromStrict bundleData)
|
||||
putStrLn $ "Exported bundle export " ++ unpack exportName ++ " -> " ++ unpack resolvedHash ++ " to " ++ outFile
|
||||
expName <- chooseExportName exportNameArg hashStr storedNames
|
||||
bundleData <- exportNamedBundle conn [(expName, resolvedHash)]
|
||||
BL.writeFile outFilePath (BL.fromStrict bundleData)
|
||||
putStrLn $ "Exported bundle export " ++ unpack expName ++ " -> " ++ unpack resolvedHash ++ " to " ++ outFilePath
|
||||
close conn
|
||||
Import { inFile = inFile } -> do
|
||||
Import { inFile = importFile } -> do
|
||||
conn <- initContentStore
|
||||
bundleData <- BL.readFile inFile
|
||||
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 = inputFile', outFile = outFile', exportNameOpt = exportNameArg } ->
|
||||
let exportName = if null exportNameArg then Nothing else Just (T.pack exportNameArg)
|
||||
in compileFile inputFile' outFile' exportName
|
||||
Compile { inputFile = compileInputFile, outFile = compileOutFile, exportNameOpt = exportNameArg } ->
|
||||
let bundleExportName = if null exportNameArg then Nothing else Just (T.pack exportNameArg)
|
||||
in compileFile compileInputFile compileOutFile bundleExportName
|
||||
Serve { host = hostStr, port = portNum } -> do
|
||||
putStrLn $ "Starting Arborix 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.arborix.bundle"
|
||||
runServer hostStr portNum
|
||||
|
||||
runTricu :: String -> String
|
||||
runTricu = formatT TreeCalculus . runTricuT
|
||||
@@ -207,30 +220,6 @@ runTricuEnvWithEnv env input =
|
||||
res = result finalEnv
|
||||
in (finalEnv, formatT TreeCalculus res)
|
||||
|
||||
resolveExportTarget :: Connection -> String -> IO (Text, [Text])
|
||||
resolveExportTarget conn input = do
|
||||
let raw = T.pack $ dropWhile (== '#') input
|
||||
byName <- DB.query conn
|
||||
"SELECT hash FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC"
|
||||
(raw, raw <> T.pack ",%", T.pack "," <> raw <> T.pack ",%", T.pack "%," <> raw) :: IO [Only T.Text]
|
||||
case byName of
|
||||
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
|
||||
(_:_) -> die $ "Ambiguous term name: " ++ input
|
||||
[] -> do
|
||||
byHash <- DB.query conn "SELECT hash FROM terms WHERE hash LIKE ? ORDER BY created_at DESC"
|
||||
(Only (raw <> T.pack "%")) :: IO [Only T.Text]
|
||||
case byHash of
|
||||
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
|
||||
[] -> if looksLikeHash raw
|
||||
then return (raw, [])
|
||||
else die $ "No term found matching: " ++ input
|
||||
_ -> die $ "Ambiguous hash prefix: " ++ input
|
||||
|
||||
namesForHash :: Connection -> Text -> IO [Text]
|
||||
namesForHash conn h = do
|
||||
stored <- hashToTerm conn h
|
||||
return $ maybe [] (parseNameList . termNames) stored
|
||||
|
||||
chooseExportName :: String -> String -> [Text] -> IO Text
|
||||
chooseExportName explicitName input storedNames
|
||||
| not (null explicitName) = return $ T.pack explicitName
|
||||
@@ -248,8 +237,3 @@ firstNonEmpty = go
|
||||
go (x:xs)
|
||||
| T.null x = go xs
|
||||
| otherwise = Just x
|
||||
|
||||
looksLikeHash :: Text -> Bool
|
||||
looksLikeHash t =
|
||||
let len = T.length t
|
||||
in len >= 16 && len <= 64 && T.all isHexDigit t
|
||||
|
||||
Reference in New Issue
Block a user