{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Embedded admin dashboard. Bootstrap 5 CSS and Vue 3, compiled in.
--
-- __Security:__ No built-in authentication. The dashboard calls the arbiter-servant
-- API, which has no authentication. Add auth middleware before you expose either 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\/@.
module Arbiter.Servant.UI
  ( -- * Servant integration
    AdminUI
  , adminUIServer
  , adminUIServerHoisted
  , adminUIServerDev
  , adminUIServerDevHoisted

    -- * Standalone WAI app
  , adminApp
  , adminAppDev

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

import Arbiter.Core.MonadArbiter (HasRegistry)
import Arbiter.Servant.API (ArbiterAPI)
import Arbiter.Servant.Server (ArbiterServerConfig, BuildServer, arbiterServer)
import Codec.Compression.GZip (compress)
import Control.Exception (IOException, catch)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as LBS
import Data.Char (toLower)
import Data.FileEmbed (embedDir)
import Data.Hashable (hash)
import Data.List (isSuffixOf)
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import Data.Text qualified as T
import Network.HTTP.Media (Encoding, matchAccept)
import Network.HTTP.Types
  ( HeaderName
  , hAcceptEncoding
  , hCacheControl
  , hContentEncoding
  , hContentType
  , hLocation
  , status200
  , status301
  , status404
  )
import Network.Wai (Request, pathInfo, rawPathInfo, rawQueryString, requestHeaders, responseLBS)
import Numeric (showHex)
import Servant
import System.FilePath (isAbsolute, takeExtension, (</>))

-- | The dashboard's static files, embedded at compile time.
staticFiles :: [(FilePath, ByteString)]
staticFiles :: [(String, ByteString)]
staticFiles = ((String, ByteString) -> Bool)
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
isServed (String -> Bool)
-> ((String, ByteString) -> String) -> (String, ByteString) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ByteString) -> String
forall a b. (a, b) -> a
fst) $(embedDir "static")

-- | A file the dashboard serves. Type declarations are for the checker only.
isServed :: FilePath -> Bool
isServed :: String -> Bool
isServed = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".d.ts" (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

-- | Embedded files with the build version in each asset URL. Versioned assets
-- can use an immutable cache. A new build produces new URLs.
--
-- Replace a file path in index.html only where it is a whole attribute value.
versionedFiles :: [(FilePath, ByteString)]
versionedFiles :: [(String, ByteString)]
versionedFiles = ((String, ByteString) -> (String, ByteString))
-> [(String, ByteString)] -> [(String, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> (String, ByteString)
stampPage [(String, ByteString)]
staticFiles
  where
    stampPage :: (String, ByteString) -> (String, ByteString)
stampPage (String
path, ByteString
content)
      | String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
indexPath = (String
path, (ByteString -> (String, ByteString) -> ByteString)
-> ByteString -> [(String, ByteString)] -> ByteString
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((String, ByteString) -> ByteString -> ByteString)
-> ByteString -> (String, ByteString) -> ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> ByteString -> ByteString
stamp (String -> ByteString -> ByteString)
-> ((String, ByteString) -> String)
-> (String, ByteString)
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ByteString) -> String
forall a b. (a, b) -> a
fst)) ByteString
content [(String, ByteString)]
staticFiles)
      | Bool
otherwise = (String
path, ByteString
content)
    stamp :: String -> ByteString -> ByteString
stamp String
path = ByteString -> ByteString -> ByteString -> ByteString
replaceAll (String -> ByteString
attribute String
path) (String -> ByteString
attribute (String -> String
versionedPath String
path))
    attribute :: String -> ByteString
attribute String
value = String -> ByteString
BS8.pack (String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
value String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"")

-- | Put an asset below a path segment that identifies the build. Path segments
-- give reverse proxies and build tools stable cache keys.
versionedPath :: FilePath -> FilePath
versionedPath :: String -> String
versionedPath String
path = Text -> String
T.unpack Text
versionPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
buildVersion String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path

-- | The segment that introduces a version.
versionPrefix :: Text
versionPrefix :: Text
versionPrefix = Text
"v"

-- | Remove a version prefix and return its version, if one was present.
stripVersion :: [Text] -> (Maybe Text, [Text])
stripVersion :: [Text] -> (Maybe Text, [Text])
stripVersion (Text
prefix : Text
version : [Text]
rest) | Text
prefix Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
versionPrefix = (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
version, [Text]
rest)
stripVersion [Text]
segments = (Maybe Text
forall a. Maybe a
Nothing, [Text]
segments)

-- | Dashboard entry point. It has no version and is fetched again on each load.
indexPath :: FilePath
indexPath :: String
indexPath = String
"index.html"

-- | A served file and, for a text format, its gzip encoding.
data Asset = Asset
  { Asset -> ByteString
assetBody :: ByteString
  , Asset -> Maybe ByteString
assetGzip :: Maybe ByteString
  }

-- | A file served as it is.
plainAsset :: ByteString -> Asset
plainAsset :: ByteString -> Asset
plainAsset ByteString
content = Asset {assetBody :: ByteString
assetBody = ByteString
content, assetGzip :: Maybe ByteString
assetGzip = Maybe ByteString
forall a. Maybe a
Nothing}

-- | The versioned files. Each text format is compressed once, on its first request.
embeddedAssets :: [(FilePath, Asset)]
embeddedAssets :: [(String, Asset)]
embeddedAssets = [(String
path, Asset {assetBody :: ByteString
assetBody = ByteString
content, assetGzip :: Maybe ByteString
assetGzip = String -> ByteString -> Maybe ByteString
gzipFor String
path ByteString
content}) | (String
path, ByteString
content) <- [(String, ByteString)]
versionedFiles]

gzipFor :: FilePath -> ByteString -> Maybe ByteString
gzipFor :: String -> ByteString -> Maybe ByteString
gzipFor String
path ByteString
content
  | FileType -> Bool
compressible (String -> FileType
fileType String
path) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString
compress (ByteString -> ByteString
LBS.fromStrict ByteString
content)))
  | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing

-- | How a file is served.
data FileType = FileType
  { FileType -> ByteString
mediaType :: ByteString
  , FileType -> Bool
compressible :: Bool
  }

-- | A file's type, from its extension.
fileType :: FilePath -> FileType
fileType :: String -> FileType
fileType String
path = FileType -> Maybe FileType -> FileType
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> FileType
binary ByteString
"application/octet-stream") (String -> [(String, FileType)] -> Maybe FileType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> String
takeExtension String
path) [(String, FileType)]
fileTypes)

-- | Served types by extension. Images and fonts other than SVG are compressed already.
fileTypes :: [(String, FileType)]
fileTypes :: [(String, FileType)]
fileTypes =
  [ (String
".html", ByteString -> FileType
text ByteString
"text/html; charset=utf-8")
  , (String
".css", ByteString -> FileType
text ByteString
"text/css; charset=utf-8")
  , (String
".js", ByteString -> FileType
text ByteString
"application/javascript; charset=utf-8")
  , (String
".json", ByteString -> FileType
text ByteString
"application/json")
  , (String
".svg", ByteString -> FileType
text ByteString
"image/svg+xml")
  , (String
".txt", ByteString -> FileType
text ByteString
"text/plain; charset=utf-8")
  , (String
".png", ByteString -> FileType
binary ByteString
"image/png")
  , (String
".ico", ByteString -> FileType
binary ByteString
"image/x-icon")
  , (String
".woff2", ByteString -> FileType
binary ByteString
"font/woff2")
  , (String
".woff", ByteString -> FileType
binary ByteString
"font/woff")
  ]
  where
    text :: ByteString -> FileType
text ByteString
media = FileType {mediaType :: ByteString
mediaType = ByteString
media, compressible :: Bool
compressible = Bool
True}

binary :: ByteString -> FileType
binary :: ByteString -> FileType
binary ByteString
media = FileType {mediaType :: ByteString
mediaType = ByteString
media, compressible :: Bool
compressible = Bool
False}

-- | One version for all files embedded in the binary.
buildVersion :: Text
buildVersion :: Text
buildVersion = String -> Text
T.pack (Word -> String -> String
forall a. Integral a => a -> String -> String
showHex (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([ByteString] -> Int
forall a. Hashable a => a -> Int
hash (((String, ByteString) -> ByteString)
-> [(String, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> ByteString
forall a b. (a, b) -> b
snd [(String, ByteString)]
staticFiles)) :: Word) String
"")

replaceAll :: ByteString -> ByteString -> ByteString -> ByteString
replaceAll :: ByteString -> ByteString -> ByteString -> ByteString
replaceAll ByteString
needle ByteString
new ByteString
haystack
  | ByteString -> Bool
BS.null ByteString
found = ByteString
before
  | Bool
otherwise = ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
new ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> ByteString -> ByteString
replaceAll ByteString
needle ByteString
new (Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
needle) ByteString
found)
  where
    (ByteString
before, ByteString
found) = ByteString -> ByteString -> (ByteString, ByteString)
BS.breakSubstring ByteString
needle ByteString
haystack

-- | The admin UI route, a catch-all sitting behind the API routes.
type AdminUI = Raw

-- | Serve 'AdminUI' from the embedded files.
adminUIServer :: Server AdminUI
adminUIServer :: Server AdminUI
adminUIServer = Application -> Tagged Handler Application
forall {k} (s :: k) b. b -> Tagged s b
Tagged Application
adminApp

-- | Hoisted variant for integration into a route tree using a custom monad.
adminUIServerHoisted :: forall m. (forall x. Handler x -> m x) -> ServerT AdminUI m
adminUIServerHoisted :: forall (m :: * -> *).
(forall x. Handler x -> m x) -> ServerT AdminUI m
adminUIServerHoisted forall x. Handler x -> m x
natTrans = Proxy AdminUI
-> (forall x. Handler x -> m x)
-> Server AdminUI
-> ServerT AdminUI m
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AdminUI) Handler x -> m x
forall x. Handler x -> m x
natTrans Server AdminUI
adminUIServer

-- | The dashboard as a standalone WAI application over the embedded files.
adminApp :: Application
adminApp :: Application
adminApp = Caching -> (String -> IO (Maybe Asset)) -> Application
serveStaticApp Caching
Versioned ((String -> IO (Maybe Asset)) -> Application)
-> (String -> IO (Maybe Asset)) -> Application
forall a b. (a -> b) -> a -> b
$ \String
filePath -> Maybe Asset -> IO (Maybe Asset)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [(String, Asset)] -> Maybe Asset
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
filePath [(String, Asset)]
embeddedAssets)

-- | The dashboard served from disk, read per request.
adminAppDev
  :: FilePath
  -- ^ The static directory.
  -> Application
adminAppDev :: String -> Application
adminAppDev String
dir = Caching -> (String -> IO (Maybe Asset)) -> Application
serveStaticApp Caching
AlwaysFresh ((String -> IO (Maybe Asset)) -> Application)
-> (String -> IO (Maybe Asset)) -> Application
forall a b. (a -> b) -> a -> b
$ \String
filePath ->
  if String -> Bool
isServed String
filePath
    then (Asset -> Maybe Asset
forall a. a -> Maybe a
Just (Asset -> Maybe Asset)
-> (ByteString -> Asset) -> ByteString -> Maybe Asset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Asset
plainAsset (ByteString -> Maybe Asset) -> IO ByteString -> IO (Maybe Asset)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile (String
dir String -> String -> String
</> String
filePath)) IO (Maybe Asset)
-> (IOException -> IO (Maybe Asset)) -> IO (Maybe Asset)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe Asset -> IO (Maybe Asset)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Asset
forall a. Maybe a
Nothing)
    else Maybe Asset -> IO (Maybe Asset)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Asset
forall a. Maybe a
Nothing

-- | Serve files through a resolver. The root returns @index.html@ and other
-- paths return the named file. Redirect a root path without a trailing slash.
-- Refuse a path with a segment that could leave the served directory.
--
-- Cache an asset under the current build's version as immutable. Make other
-- responses revalidate. A version prefix is valid for asset paths. Send the gzip
-- encoding to a client that accepts it.
serveStaticApp :: Caching -> (FilePath -> IO (Maybe Asset)) -> Application
serveStaticApp :: Caching -> (String -> IO (Maybe Asset)) -> Application
serveStaticApp Caching
caching String -> IO (Maybe Asset)
resolveFile Request
req Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> IO Response -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Response
reply
  where
    (Maybe Text
version, [Text]
segments) = [Text] -> (Maybe Text, [Text])
stripVersion ((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
    isIndex :: Bool
isIndex = Text -> Bool
T.null Text
path Bool -> Bool -> Bool
|| Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack String
indexPath
    filePath :: String
filePath = if Bool
isIndex then String
indexPath else Text -> String
T.unpack Text
path
    reply :: IO Response
reply
      | Bool
isIndex Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
version = Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
notFound
      | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
unsafeSegment [Text]
segments = Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
notFound
      | Text -> Bool
T.null Text
path Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString
"/" ByteString -> ByteString -> Bool
`BS.isSuffixOf` Request -> ByteString
rawPathInfo Request
req) =
          Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status301 [(HeaderName
hLocation, Request -> ByteString
rawPathInfo Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
rawQueryString Request
req)] ByteString
""
      | Bool
otherwise = Response -> (Asset -> Response) -> Maybe Asset -> Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Response
notFound Asset -> Response
found (Maybe Asset -> Response) -> IO (Maybe Asset) -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Asset)
resolveFile String
filePath
    found :: Asset -> Response
found Asset
asset =
      let (ByteString
body, ResponseHeaders
encodingHeaders) = Request -> Asset -> (ByteString, ResponseHeaders)
negotiate Request
req Asset
asset
       in Status -> ResponseHeaders -> ByteString -> Response
responseLBS
            Status
status200
            ( ResponseHeaders
securityHeaders
                ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> Bool -> ResponseHeaders
cacheHeaders (Caching -> Maybe Text -> Bool
currentBuild Caching
caching Maybe Text
version)
                ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> [(HeaderName
hContentType, FileType -> ByteString
mediaType (String -> FileType
fileType String
filePath))]
                ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
encodingHeaders
            )
            (ByteString -> ByteString
LBS.fromStrict ByteString
body)
    notFound :: Response
notFound = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [(HeaderName
hContentType, ByteString
"text/plain")] ByteString
"Not found"

-- | The body for a request and the headers that describe its encoding.
negotiate :: Request -> Asset -> (ByteString, [(HeaderName, ByteString)])
negotiate :: Request -> Asset -> (ByteString, ResponseHeaders)
negotiate Request
req Asset
asset = case Asset -> Maybe ByteString
assetGzip Asset
asset of
  Just ByteString
gzipped | Request -> Bool
acceptsGzip Request
req -> (ByteString
gzipped, [(HeaderName
hContentEncoding, ByteString
"gzip"), (HeaderName, ByteString)
varyEncoding])
  Just ByteString
_ -> (Asset -> ByteString
assetBody Asset
asset, [(HeaderName, ByteString)
varyEncoding])
  Maybe ByteString
Nothing -> (Asset -> ByteString
assetBody Asset
asset, [])
  where
    varyEncoding :: (HeaderName, ByteString)
varyEncoding = (HeaderName
"Vary", ByteString
"Accept-Encoding")

-- | The client accepts gzip, by name or through @*@, with a nonzero quality.
acceptsGzip :: Request -> Bool
acceptsGzip :: Request -> Bool
acceptsGzip Request
req = Maybe Encoding -> Bool
forall a. Maybe a -> Bool
isJust ([Encoding] -> ByteString -> Maybe Encoding
forall a. Accept a => [a] -> ByteString -> Maybe a
matchAccept [Encoding
gzip] (ByteString -> Maybe Encoding)
-> Maybe ByteString -> Maybe Encoding
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAcceptEncoding (Request -> ResponseHeaders
requestHeaders Request
req))
  where
    gzip :: Encoding
gzip = Encoding
"gzip" :: Encoding

-- | A decoded path segment that could name a file outside the served directory.
unsafeSegment :: Text -> Bool
unsafeSegment :: Text -> Bool
unsafeSegment Text
segment =
  Text
segment Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
".", Text
".."] Bool -> Bool -> Bool
|| (Char -> Bool) -> Text -> Bool
T.any (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'/', Char
'\\']) Text
segment Bool -> Bool -> Bool
|| String -> Bool
isAbsolute (Text -> String
T.unpack Text
segment)

-- | A version that names the embedded build.
currentBuild :: Caching -> Maybe Text -> Bool
currentBuild :: Caching -> Maybe Text -> Bool
currentBuild Caching
Versioned (Just Text
version) = Text
version Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
buildVersion
currentBuild Caching
_ Maybe Text
_ = Bool
False

-- | Response caching mode. Embedded, versioned files are immutable while the
-- server runs. Files read from disk can change between requests.
data Caching = Versioned | AlwaysFresh

-- | Cache a response as immutable, or require revalidation. Relative URLs in a
-- stylesheet inherit its versioned path.
cacheHeaders :: Bool -> [(HeaderName, ByteString)]
cacheHeaders :: Bool -> ResponseHeaders
cacheHeaders Bool
True = [ByteString -> (HeaderName, ByteString)
cacheControl (ByteString
"public, max-age=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (Int -> String
forall a. Show a => a -> String
show Int
immutableMaxAge) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
", immutable")]
cacheHeaders Bool
False = [ByteString -> (HeaderName, ByteString)
cacheControl ByteString
"no-cache"]

cacheControl :: ByteString -> (HeaderName, ByteString)
cacheControl :: ByteString -> (HeaderName, ByteString)
cacheControl = (,) HeaderName
hCacheControl

-- | One-year cache duration for a versioned asset.
immutableMaxAge :: Int
immutableMaxAge :: Int
immutableMaxAge = Int
31536000

-- | Security headers for all static responses. The dashboard uses resources
-- from its own origin.
securityHeaders :: [(HeaderName, ByteString)]
securityHeaders :: ResponseHeaders
securityHeaders =
  [ (HeaderName
"X-Content-Type-Options", ByteString
"nosniff")
  , (HeaderName
"X-Frame-Options", ByteString
"DENY")
  , (HeaderName
"Referrer-Policy", ByteString
"same-origin")
  , (HeaderName
"Content-Security-Policy", ByteString
contentSecurityPolicy)
  ]

-- | Content security policy for bundled dashboard assets. @connect-src@ permits
-- same-origin API and event-stream requests. Vue compiles its templates at
-- runtime, which requires @unsafe-eval@. Style bindings require @unsafe-inline@.
contentSecurityPolicy :: ByteString
contentSecurityPolicy :: ByteString
contentSecurityPolicy =
  ByteString -> [ByteString] -> ByteString
BS.intercalate
    ByteString
"; "
    [ ByteString
"default-src 'none'"
    , ByteString
"script-src 'self' 'unsafe-eval'"
    , ByteString
"style-src 'self' 'unsafe-inline'"
    , ByteString
"img-src 'self' data:"
    , ByteString
"font-src 'self'"
    , ByteString
"connect-src 'self'"
    , ByteString
"form-action 'none'"
    , ByteString
"base-uri 'none'"
    , ByteString
"frame-ancestors 'none'"
    ]

-- | Serve 'AdminUI' from disk.
adminUIServerDev
  :: FilePath
  -- ^ The static directory.
  -> Server AdminUI
adminUIServerDev :: String -> Server AdminUI
adminUIServerDev String
dir = Application -> Tagged Handler Application
forall {k} (s :: k) b. b -> Tagged s b
Tagged (String -> Application
adminAppDev String
dir)

-- | Hoisted dev-mode variant for integration into a route tree using a custom monad.
adminUIServerDevHoisted
  :: forall m
   . (forall x. Handler x -> m x)
  -> FilePath
  -- ^ The static directory.
  -> ServerT AdminUI m
adminUIServerDevHoisted :: forall (m :: * -> *).
(forall x. Handler x -> m x) -> String -> ServerT AdminUI m
adminUIServerDevHoisted forall x. Handler x -> m x
natTrans String
dir = Proxy AdminUI
-> (forall x. Handler x -> m x)
-> Server AdminUI
-> ServerT AdminUI m
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AdminUI) Handler x -> m x
forall x. Handler x -> m x
natTrans (String -> Server AdminUI
adminUIServerDev String
dir)

-- | The API at @\/api@ and the admin UI at the root, in one application.
arbiterAppWithAdmin
  :: forall registry m
   . ( BuildServer registry registry
     , HasRegistry m registry
     , HasServer (ArbiterAPI registry) '[]
     )
  => ArbiterServerConfig m registry
  -> Application
arbiterAppWithAdmin :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
(BuildServer registry registry, HasRegistry m registry,
 HasServer (ArbiterAPI registry) '[]) =>
ArbiterServerConfig m registry -> Application
arbiterAppWithAdmin ArbiterServerConfig m 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 m registry
-> ServerT (ArbiterAPI registry) Handler
forall (registry :: JobPayloadRegistry) (m :: * -> *).
(BuildServer registry registry, HasRegistry m registry) =>
ArbiterServerConfig m registry
-> ServerT (ArbiterAPI registry) Handler
arbiterServer ArbiterServerConfig m registry
config ServerT (RegistryToAPI registry) Handler
-> Tagged Handler Application
-> ServerT (RegistryToAPI registry) Handler
   :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> Tagged Handler Application
Server AdminUI
adminUIServer)

-- | 'arbiterAppWithAdmin' serving the UI from disk.
arbiterAppWithAdminDev
  :: forall registry m
   . ( BuildServer registry registry
     , HasRegistry m registry
     , HasServer (ArbiterAPI registry) '[]
     )
  => FilePath
  -- ^ The static directory.
  -> ArbiterServerConfig m registry
  -> Application
arbiterAppWithAdminDev :: forall (registry :: JobPayloadRegistry) (m :: * -> *).
(BuildServer registry registry, HasRegistry m registry,
 HasServer (ArbiterAPI registry) '[]) =>
String -> ArbiterServerConfig m registry -> Application
arbiterAppWithAdminDev String
dir ArbiterServerConfig m 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 m registry
-> ServerT (ArbiterAPI registry) Handler
forall (registry :: JobPayloadRegistry) (m :: * -> *).
(BuildServer registry registry, HasRegistry m registry) =>
ArbiterServerConfig m registry
-> ServerT (ArbiterAPI registry) Handler
arbiterServer ArbiterServerConfig m registry
config ServerT (RegistryToAPI registry) Handler
-> Tagged Handler Application
-> ServerT (RegistryToAPI registry) Handler
   :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> String -> Server AdminUI
adminUIServerDev String
dir)