{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}

-- | Embedded admin dashboard for Arbiter.
--
-- Provides a Bootstrap 5 + Alpine.js admin UI served from compiled-in static files.
--
-- __Security:__ This module provides no built-in authentication. The admin
-- UI exposes full queue management (view, delete, retry jobs). Add your own
-- auth middleware before exposing this to untrusted networks.
--
-- = Quick Start
--
-- @
-- run port $ arbiterAppWithAdmin \@MyRegistry config
-- @
--
-- = Custom Composition
--
-- Mount the API and admin UI under a shared prefix:
--
-- @
-- type MyApp = "arbiter" :> (ArbiterAPI MyRegistry :\<|\> AdminUI) :\<|\> MyRoutes
-- run port $ serve (Proxy \@MyApp) ((arbiterServer config :\<|\> adminUIServer) :\<|\> myHandler)
-- @
--
-- The admin UI auto-discovers the API path from its own URL.
-- If it loads at @\/arbiter\/@ it finds the API at @\/arbiter\/api\/v1\/@.
module Arbiter.Servant.UI
  ( -- * Servant integration
    AdminUI
  , adminUIServer
  , adminUIServerDev

    -- * Standalone WAI app
  , adminApplication
  , devAdminApplication

    -- * Combined app helper
  , arbiterAppWithAdmin
  , arbiterAppWithAdminDev
  ) where

import Arbiter.Servant.API (ArbiterAPI)
import Arbiter.Servant.Server (ArbiterServerConfig, BuildServer, arbiterServer)
import Control.Exception (IOException, catch)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.FileEmbed (embedDir)
import Data.List (isSuffixOf)
import Data.Text qualified as T
import Network.HTTP.Types (HeaderName, status200, status301, status404)
import Network.Wai (pathInfo, rawPathInfo, responseLBS)
import Servant
import System.FilePath ((</>))

-- | All static files embedded at compile time
staticFiles :: [(FilePath, ByteString)]
staticFiles :: [([Char], ByteString)]
staticFiles = $(embedDir "static")

-- | Servant API type for the admin UI (catch-all behind API routes)
type AdminUI = Raw

-- | Servant server for 'AdminUI'
adminUIServer :: Server AdminUI
adminUIServer :: Server AdminUI
adminUIServer = Application -> Tagged Handler Application
forall {k} (s :: k) b. b -> Tagged s b
Tagged Application
adminApplication

-- | Standalone WAI Application serving embedded static files.
--
-- Serves @index.html@ for @\/@ and other files by relative path.
adminApplication :: Application
adminApplication :: Application
adminApplication = ([Char] -> IO (Maybe ByteString)) -> Application
serveStaticApp (([Char] -> IO (Maybe ByteString)) -> Application)
-> ([Char] -> IO (Maybe ByteString)) -> Application
forall a b. (a -> b) -> a -> b
$ \[Char]
fp -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [([Char], ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
fp [([Char], ByteString)]
staticFiles)

-- | Dev-mode WAI Application serving static files from disk.
--
-- Reads files on every request — no recompile needed for HTML\/JS\/CSS changes.
devAdminApplication :: FilePath -> Application
devAdminApplication :: [Char] -> Application
devAdminApplication [Char]
dir = ([Char] -> IO (Maybe ByteString)) -> Application
serveStaticApp (([Char] -> IO (Maybe ByteString)) -> Application)
-> ([Char] -> IO (Maybe ByteString)) -> Application
forall a b. (a -> b) -> a -> b
$ \[Char]
fp ->
  (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BS.readFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
fp)) IO (Maybe ByteString)
-> (IOException -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing)

-- | Shared implementation for both embedded and dev-mode applications.
--
-- Takes a file resolver and returns a WAI 'Application' that serves
-- @index.html@ for @\/@ and looks up other files by relative path.
--
-- When the root is requested without a trailing slash, sends a 301 redirect
-- to add one. This ensures relative asset paths (e.g. @css\/dashboard.css@)
-- resolve correctly when the UI is mounted under a prefix like @\/arbiter@.
serveStaticApp :: (FilePath -> IO (Maybe ByteString)) -> Application
serveStaticApp :: ([Char] -> IO (Maybe ByteString)) -> Application
serveStaticApp [Char] -> IO (Maybe ByteString)
resolveFile Request
req Response -> IO ResponseReceived
sendResponse = do
  let segments :: [Text]
segments = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) (Request -> [Text]
pathInfo Request
req)
      path :: Text
path = Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
segments
  if Text -> Bool
T.null Text
path Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString
"/" ByteString -> ByteString -> Bool
`BS.isSuffixOf` Request -> ByteString
rawPathInfo Request
req)
    then
      Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status301 [(HeaderName
"Location", Request -> ByteString
rawPathInfo Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/")] ByteString
""
    else do
      let filePath :: [Char]
filePath =
            if Text -> Bool
T.null Text
path Bool -> Bool -> Bool
|| Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"index.html"
              then [Char]
"index.html"
              else Text -> [Char]
T.unpack Text
path
      mContent <- [Char] -> IO (Maybe ByteString)
resolveFile [Char]
filePath
      case mContent of
        Just ByteString
content ->
          Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 (ResponseHeaders
securityHeaders ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ [[Char] -> (HeaderName, ByteString)
contentTypeHeader [Char]
filePath]) (ByteString -> ByteString
LBS.fromStrict ByteString
content)
        Maybe ByteString
Nothing ->
          Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [(HeaderName
"Content-Type", ByteString
"text/plain")] ByteString
"Not found"

-- | Security headers included on all static responses.
securityHeaders :: [(HeaderName, ByteString)]
securityHeaders :: ResponseHeaders
securityHeaders =
  [ (HeaderName
"X-Content-Type-Options", ByteString
"nosniff")
  , (HeaderName
"X-Frame-Options", ByteString
"DENY")
  ]

-- | Infer Content-Type from file extension
contentTypeHeader :: FilePath -> (HeaderName, ByteString)
contentTypeHeader :: [Char] -> (HeaderName, ByteString)
contentTypeHeader [Char]
path
  | [Char]
".html" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")
  | [Char]
".css" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"text/css; charset=utf-8")
  | [Char]
".js" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"application/javascript; charset=utf-8")
  | [Char]
".json" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"application/json")
  | [Char]
".png" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"image/png")
  | [Char]
".svg" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"image/svg+xml")
  | [Char]
".ico" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"image/x-icon")
  | Bool
otherwise = (HeaderName
"Content-Type", ByteString
"application/octet-stream")

-- | Dev-mode Servant server for 'AdminUI' — serves from disk.
adminUIServerDev :: FilePath -> Server AdminUI
adminUIServerDev :: [Char] -> Server AdminUI
adminUIServerDev [Char]
dir = Application -> Tagged Handler Application
forall {k} (s :: k) b. b -> Tagged s b
Tagged ([Char] -> Application
devAdminApplication [Char]
dir)

-- | Combine arbiterApp with admin UI
--
-- Serves the API at @\/api\/v1\/...@ and admin UI at @\/@
arbiterAppWithAdmin
  :: forall registry
   . ( BuildServer registry registry
     , HasServer (ArbiterAPI registry) '[]
     )
  => ArbiterServerConfig registry
  -> Application
arbiterAppWithAdmin :: forall (registry :: [(Symbol, *)]).
(BuildServer registry registry,
 HasServer (ArbiterAPI registry) '[]) =>
ArbiterServerConfig registry -> Application
arbiterAppWithAdmin ArbiterServerConfig registry
config =
  Proxy (ArbiterAPI registry :<|> AdminUI)
-> Server (ArbiterAPI registry :<|> AdminUI) -> Application
forall {k} (api :: k).
HasServer api '[] =>
Proxy api -> Server api -> Application
serve
    (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ArbiterAPI registry :<|> AdminUI))
    (ArbiterServerConfig registry
-> ServerT (ArbiterAPI registry) Handler
forall (registry :: [(Symbol, *)]).
BuildServer registry registry =>
ArbiterServerConfig registry
-> ServerT (ArbiterAPI registry) Handler
arbiterServer ArbiterServerConfig registry
config ServerT (RegistryToAPI registry) Handler
-> Tagged Handler Application
-> ServerT (RegistryToAPI registry) Handler
   :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> Server AdminUI
Tagged Handler Application
adminUIServer)

-- | Like 'arbiterAppWithAdmin' but serves static files from disk for development.
arbiterAppWithAdminDev
  :: forall registry
   . ( BuildServer registry registry
     , HasServer (ArbiterAPI registry) '[]
     )
  => FilePath
  -> ArbiterServerConfig registry
  -> Application
arbiterAppWithAdminDev :: forall (registry :: [(Symbol, *)]).
(BuildServer registry registry,
 HasServer (ArbiterAPI registry) '[]) =>
[Char] -> ArbiterServerConfig registry -> Application
arbiterAppWithAdminDev [Char]
dir ArbiterServerConfig registry
config =
  Proxy (ArbiterAPI registry :<|> AdminUI)
-> Server (ArbiterAPI registry :<|> AdminUI) -> Application
forall {k} (api :: k).
HasServer api '[] =>
Proxy api -> Server api -> Application
serve
    (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ArbiterAPI registry :<|> AdminUI))
    (ArbiterServerConfig registry
-> ServerT (ArbiterAPI registry) Handler
forall (registry :: [(Symbol, *)]).
BuildServer registry registry =>
ArbiterServerConfig registry
-> ServerT (ArbiterAPI registry) Handler
arbiterServer ArbiterServerConfig registry
config ServerT (RegistryToAPI registry) Handler
-> Tagged Handler Application
-> ServerT (RegistryToAPI registry) Handler
   :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> [Char] -> Server AdminUI
adminUIServerDev [Char]
dir)