{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Arbiter.Servant.UI
(
AdminUI
, adminUIServer
, adminUIServerHoisted
, adminUIServerDev
, adminUIServerDevHoisted
, adminApplication
, devAdminApplication
, 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.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as LBS
import Data.FileEmbed (embedDir)
import Data.Hashable (hash)
import Data.List (isSuffixOf)
import Data.Text (Text)
import Data.Text qualified as T
import Network.HTTP.Types (HeaderName, status200, status301, status404)
import Network.Wai (pathInfo, rawPathInfo, responseLBS)
import Numeric (showHex)
import Servant
import System.FilePath ((</>))
staticFiles :: [(FilePath, ByteString)]
staticFiles :: [([Char], ByteString)]
staticFiles = $(embedDir "static")
versionedFiles :: [(FilePath, ByteString)]
versionedFiles :: [([Char], ByteString)]
versionedFiles = (([Char], ByteString) -> ([Char], ByteString))
-> [([Char], ByteString)] -> [([Char], ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], ByteString) -> ([Char], ByteString)
stampPage [([Char], ByteString)]
staticFiles
where
stampPage :: ([Char], ByteString) -> ([Char], ByteString)
stampPage ([Char]
path, ByteString
content)
| [Char]
path [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
indexPath = ([Char]
path, (([Char], ByteString) -> ByteString -> ByteString)
-> ByteString -> [([Char], ByteString)] -> ByteString
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Char] -> ByteString -> ByteString
stamp ([Char] -> ByteString -> ByteString)
-> (([Char], ByteString) -> [Char])
-> ([Char], ByteString)
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], ByteString) -> [Char]
forall a b. (a, b) -> a
fst) ByteString
content [([Char], ByteString)]
staticFiles)
| Bool
otherwise = ([Char]
path, ByteString
content)
stamp :: [Char] -> ByteString -> ByteString
stamp [Char]
path = ByteString -> ByteString -> ByteString -> ByteString
replaceAll ([Char] -> ByteString
attribute [Char]
path) ([Char] -> ByteString
attribute ([Char] -> [Char]
versionedPath [Char]
path))
attribute :: [Char] -> ByteString
attribute [Char]
value = [Char] -> ByteString
BS8.pack ([Char]
value [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\"")
versionedPath :: FilePath -> FilePath
versionedPath :: [Char] -> [Char]
versionedPath [Char]
path = Text -> [Char]
T.unpack Text
versionPrefix [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
BS8.unpack ByteString
buildVersion [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
path
versionPrefix :: Text
versionPrefix :: Text
versionPrefix = Text
"v"
stripVersion :: [Text] -> (Bool, [Text])
stripVersion :: [Text] -> (Bool, [Text])
stripVersion (Text
prefix : Text
_version : [Text]
rest) | Text
prefix Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
versionPrefix = (Bool
True, [Text]
rest)
stripVersion [Text]
segments = (Bool
False, [Text]
segments)
indexPath :: FilePath
indexPath :: [Char]
indexPath = [Char]
"index.html"
buildVersion :: ByteString
buildVersion :: ByteString
buildVersion = [Char] -> ByteString
BS8.pack (Word -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showHex (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([ByteString] -> Int
forall a. Hashable a => a -> Int
hash ((([Char], ByteString) -> ByteString)
-> [([Char], ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], ByteString) -> ByteString
forall a b. (a, b) -> b
snd [([Char], ByteString)]
staticFiles)) :: Word) [Char]
"")
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
type AdminUI = Raw
adminUIServer :: Server AdminUI
adminUIServer :: Server AdminUI
adminUIServer = Application -> Tagged Handler Application
forall {k} (s :: k) b. b -> Tagged s b
Tagged Application
adminApplication
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
adminApplication :: Application
adminApplication :: Application
adminApplication = Caching -> ([Char] -> IO (Maybe ByteString)) -> Application
serveStaticApp Caching
Versioned (([Char] -> IO (Maybe ByteString)) -> Application)
-> ([Char] -> IO (Maybe ByteString)) -> Application
forall a b. (a -> b) -> a -> b
$ \[Char]
filePath -> 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]
filePath [([Char], ByteString)]
versionedFiles)
devAdminApplication :: FilePath -> Application
devAdminApplication :: [Char] -> Application
devAdminApplication [Char]
dir = Caching -> ([Char] -> IO (Maybe ByteString)) -> Application
serveStaticApp Caching
AlwaysFresh (([Char] -> IO (Maybe ByteString)) -> Application)
-> ([Char] -> IO (Maybe ByteString)) -> Application
forall a b. (a -> b) -> a -> b
$ \[Char]
filePath ->
(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]
filePath)) 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)
serveStaticApp :: Caching -> (FilePath -> IO (Maybe ByteString)) -> Application
serveStaticApp :: Caching -> ([Char] -> IO (Maybe ByteString)) -> Application
serveStaticApp Caching
caching [Char] -> IO (Maybe ByteString)
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
(Bool
versioned, [Text]
segments) = [Text] -> (Bool, [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
== [Char] -> Text
T.pack [Char]
indexPath
filePath :: [Char]
filePath = if Bool
isIndex then [Char]
indexPath else Text -> [Char]
T.unpack Text
path
reply :: IO Response
reply
| Bool
isIndex Bool -> Bool -> Bool
&& Bool
versioned = 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
"Location", Request -> ByteString
rawPathInfo Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/")] ByteString
""
| Bool
otherwise = Response
-> (ByteString -> Response) -> Maybe ByteString -> Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Response
notFound ByteString -> Response
found (Maybe ByteString -> Response)
-> IO (Maybe ByteString) -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe ByteString)
resolveFile [Char]
filePath
found :: ByteString -> Response
found ByteString
content =
Status -> ResponseHeaders -> ByteString -> Response
responseLBS
Status
status200
(ResponseHeaders
securityHeaders ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ Caching -> Bool -> ResponseHeaders
cacheHeaders Caching
caching Bool
versioned ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ [[Char] -> (HeaderName, ByteString)
contentTypeHeader [Char]
filePath])
(ByteString -> ByteString
LBS.fromStrict ByteString
content)
notFound :: Response
notFound = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [(HeaderName
"Content-Type", ByteString
"text/plain")] ByteString
"Not found"
data Caching = Versioned | AlwaysFresh
cacheHeaders :: Caching -> Bool -> [(HeaderName, ByteString)]
Caching
Versioned Bool
True =
[ByteString -> (HeaderName, ByteString)
cacheControl (ByteString
"public, max-age=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
BS8.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
immutableMaxAge) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
", immutable")]
cacheHeaders Caching
_ Bool
_ = [ByteString -> (HeaderName, ByteString)
cacheControl ByteString
"no-cache"]
cacheControl :: ByteString -> (HeaderName, ByteString)
cacheControl :: ByteString -> (HeaderName, ByteString)
cacheControl = (,) HeaderName
"Cache-Control"
immutableMaxAge :: Int
immutableMaxAge :: Int
immutableMaxAge = Int
31536000
securityHeaders :: [(HeaderName, ByteString)]
=
[ (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)
]
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'"
]
contentTypeHeader :: FilePath -> (HeaderName, ByteString)
[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")
| [Char]
".woff2" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"font/woff2")
| [Char]
".woff" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
path = (HeaderName
"Content-Type", ByteString
"font/woff")
| Bool
otherwise = (HeaderName
"Content-Type", ByteString
"application/octet-stream")
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)
adminUIServerDevHoisted
:: forall m. (forall x. Handler x -> m x) -> FilePath -> ServerT AdminUI m
adminUIServerDevHoisted :: forall (m :: * -> *).
(forall x. Handler x -> m x) -> [Char] -> ServerT AdminUI m
adminUIServerDevHoisted forall x. Handler x -> m x
natTrans [Char]
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 ([Char] -> Server AdminUI
adminUIServerDev [Char]
dir)
arbiterAppWithAdmin
:: forall registry
. ( BuildServer registry registry
, HasServer (ArbiterAPI registry) '[]
)
=> ArbiterServerConfig registry
-> Application
arbiterAppWithAdmin :: forall (registry :: JobPayloadRegistry).
(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 :: JobPayloadRegistry).
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
:<|> Tagged Handler Application
Server AdminUI
adminUIServer)
arbiterAppWithAdminDev
:: forall registry
. ( BuildServer registry registry
, HasServer (ArbiterAPI registry) '[]
)
=> FilePath
-> ArbiterServerConfig registry
-> Application
arbiterAppWithAdminDev :: forall (registry :: JobPayloadRegistry).
(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 :: JobPayloadRegistry).
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)