tricu/src/Server.hs

module Server
  ( runServer
  , runServerWithPath
  ) where

import ContentStore (initContentStore, initContentStoreWithPath, nameToTerm, hashToTerm, listStoredTerms,
                     parseNameList, StoredTerm(..), termHash, loadTree)
import Database.SQLite.Simple (Connection, close)
import Wire (buildBundle, encodeBundle)

import Control.Monad (when, void)
import Data.Maybe (catMaybes)

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 (ByteString)
import Data.ByteString.Char8 (unpack)
import Data.ByteString.Lazy (fromStrict)
import qualified Data.Text as T

-- | Start an HTTP server that serves Arboricx bundles from the
--   local content store.
runServer :: String -> Int -> IO ()
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.
app :: IO Connection -> Application
app mkConn request respond = case (requestMethod request, pathInfo request) of
  ("GET", ["health"]) ->
    respond $ healthResponse

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

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

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

  ("GET", ["terms"]) -> do
    body <- termsResponse mkConn
    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...
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"]
  -- 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 <- buildAndEncodeBundle 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
nameHandler :: IO Connection -> Text -> IO Response
nameHandler mkConn nameText = do
  conn <- mkConn
  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 <- buildAndEncodeBundle 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
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 <- mkConn
          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 <- 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
  conn <- mkConn
  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.arboricx.bundle")
  , ("X-Arboricx-Root-Hash", encodeUtf8 root)
  , ("Content-Disposition", encodeUtf8 cd)
  ]

firstOrRoot :: Text -> Text
firstOrRoot names =
  case parseNameList names of
    [] -> "root"
    (x:_) -> x

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 = '_'