feat(haskell): CLI rewrite

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=<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
+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