tricu/src/Server.hs

module Server
  ( runServer
  ) where

import ContentStore (initContentStore, nameToTerm, hashToTerm, listStoredTerms,
                     parseNameList, StoredTerm(..), termHash)
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, 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
--   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
  where
    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
  ("GET", ["health"]) ->
    respond $ healthResponse

  ("GET", ["bundle", "roots"]) ->
    rootsHandler request respond

  ("GET", ["bundle", "name", nameText]) -> do
    body <- nameHandler nameText
    respond body

  ("GET", ["bundle", "hash", hashText]) -> do
    body <- hashHandler hashText
    respond body

  ("GET", ["terms"]) -> do
    body <- termsResponse
    respond body

  ("POST", _) ->
    respond $ responseLBS status405 [] "Method not allowed"

  ("PUT", _) ->
    respond $ responseLBS status405 [] "Method not allowed"

  ("DELETE", _) ->
    respond $ responseLBS status405 [] "Method not allowed"

  _ ->
    respond $ responseLBS status404 [] "not found"

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.
--
--   Sets @Content-Type@ and @X-Arborix-Root-Hash@ headers.
--   Returns 404 when the name does not resolve to any stored term.
nameHandler :: Text -> IO Response
nameHandler nameText = do
  conn <- initContentStore
  stored <- nameToTerm conn nameText
  case stored of
    Nothing -> do
      close conn
      return $ textResponse status404 ("not found: " <> nameText)
    Just term' -> do
      let th = termHash term'
          namedHashes = [(firstOrRoot (termNames term'), th)]
      bundleData <- exportNamedBundle conn namedHashes
      let cd = T.pack $ "attachment; filename=" ++ safeFileName (T.unpack nameText) ++ ".bundle"
      close conn
      return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData)

-- | GET /bundle/hash/:hash
--   Resolve a full Merkle hash and export the root as an Arborix
--   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 =
  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
          stored <- hashToTerm conn raw
          case stored of
            Nothing -> do
              close conn
              return $ textResponse status404 ("not found: " <> hashText)
            Just term' -> do
              let th = termHash term'
                  namedHashes' = [(firstOrRoot (termNames term'), th)]
              bundleData <- exportNamedBundle conn namedHashes'
              close conn
              return $ responseLBS status200
                (bundleHeaders th "attachment; filename=hash.bundle")
                (fromStrict bundleData)

-- | GET /terms
--   Plain-text listing of all stored terms (debugging only).
termsResponse :: IO Response
termsResponse = do
  conn <- initContentStore
  terms <- listStoredTerms conn
  close conn
  let lines' = [ names <> "  " <> hash <> "  " <> T.pack (show created)
               | term <- terms
               , let names = termNames term
               , let hash = termHash term
               , let created = termCreatedAt term ]
  return $ responseLBS status200
    [ (hContentType, encodeUtf8 "text/plain; charset=utf-8")
    ]
    (fromStrict $ encodeUtf8 $ T.unlines lines')

textResponse :: Status -> Text -> Response
textResponse status body =
  responseLBS status
    [ (hContentType, encodeUtf8 "text/plain; charset=utf-8") ]
    (fromStrict $ encodeUtf8 body)

bundleHeaders :: Text -> Text -> [Header]
bundleHeaders root cd =
  [ (hContentType, encodeUtf8 "application/vnd.arborix.bundle")
  , ("X-Arborix-Root-Hash", encodeUtf8 root)
  , ("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
    go c
      | c >= 'a' && c <= 'z' = c
      | c >= 'A' && c <= 'Z' = c
      | c >= '0' && c <= '9' = c
      | c == '-' = c
      | c == '_' = c
      | otherwise = '_'