{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}

module Simplex.Messaging.Server.Web
  ( EmbeddedWebParams (..),
    WebHttpsParams (..),
    EmbeddedContent (..),
    serveStaticFiles,
    attachStaticFiles,
    serveStaticPageH2,
    generateSite,
    serverInfoSubsts,
    render,
    section_,
    item_,
    timedTTLText,
  ) where

import qualified Codec.Compression.GZip as GZip
import Control.Logger.Simple
import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString.Builder (byteString, lazyByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Char (toUpper)
import Data.IORef (readIORef)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Network.HPACK.Token (tokenKey)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Server as H
import Network.Socket (getPeerName)
import Network.Wai (Application, Request (..), responseLBS)
import Network.Wai.Application.Static (StaticSettings (..))
import qualified Network.Wai.Application.Static as S
import qualified Network.Wai.Handler.Warp as W
import qualified Network.Wai.Handler.Warp.Internal as WI
import qualified Network.Wai.Handler.WarpTLS as WT
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Server (AttachHTTP)
import Simplex.Messaging.Server.CLI (simplexmqCommit)
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Util (tshow)
import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist)
import System.FilePath
import UnliftIO.Concurrent (forkFinally)
import UnliftIO.Exception (bracket, finally)
import qualified WaiAppStatic.Types as WAT

data EmbeddedWebParams = EmbeddedWebParams
  { EmbeddedWebParams -> [Char]
webStaticPath :: FilePath,
    EmbeddedWebParams -> Maybe Int
webHttpPort :: Maybe Int,
    EmbeddedWebParams -> Maybe WebHttpsParams
webHttpsParams :: Maybe WebHttpsParams
  }

data WebHttpsParams = WebHttpsParams
  { WebHttpsParams -> Int
port :: Int,
    WebHttpsParams -> [Char]
cert :: FilePath,
    WebHttpsParams -> [Char]
key :: FilePath
  }

data EmbeddedContent = EmbeddedContent
  { EmbeddedContent -> ByteString
indexHtml :: ByteString,
    EmbeddedContent -> ByteString
linkHtml :: ByteString,
    EmbeddedContent -> [([Char], ByteString)]
mediaContent :: [(FilePath, ByteString)],
    EmbeddedContent -> [([Char], ByteString)]
wellKnown :: [(FilePath, ByteString)]
  }

serveStaticFiles :: EmbeddedWebParams -> IO ()
serveStaticFiles :: EmbeddedWebParams -> IO ()
serveStaticFiles EmbeddedWebParams {[Char]
webStaticPath :: EmbeddedWebParams -> [Char]
webStaticPath :: [Char]
webStaticPath, Maybe Int
webHttpPort :: EmbeddedWebParams -> Maybe Int
webHttpPort :: Maybe Int
webHttpPort, Maybe WebHttpsParams
webHttpsParams :: EmbeddedWebParams -> Maybe WebHttpsParams
webHttpsParams :: Maybe WebHttpsParams
webHttpsParams} = do
  Application
app <- [Char] -> IO Application
staticFiles [Char]
webStaticPath
  Maybe Int -> (Int -> IO ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
webHttpPort ((Int -> IO ThreadId) -> IO ()) -> (Int -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
port -> (IO () -> (Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO () -> IO ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally (\Either SomeException ()
e -> Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"HTTP server crashed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either SomeException () -> Text
forall a. Show a => a -> Text
tshow Either SomeException ()
e) (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Serving static site on port " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
port
    Settings -> Application -> IO ()
W.runSettings (Int -> Settings
mkSettings Int
port) Application
app
  Maybe WebHttpsParams -> (WebHttpsParams -> IO ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe WebHttpsParams
webHttpsParams ((WebHttpsParams -> IO ThreadId) -> IO ())
-> (WebHttpsParams -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WebHttpsParams {Int
port :: WebHttpsParams -> Int
port :: Int
port, [Char]
cert :: WebHttpsParams -> [Char]
cert :: [Char]
cert, [Char]
key :: WebHttpsParams -> [Char]
key :: [Char]
key} -> (IO () -> (Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO () -> IO ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally (\Either SomeException ()
e -> Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"HTTPS server crashed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either SomeException () -> Text
forall a. Show a => a -> Text
tshow Either SomeException ()
e) (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Serving static site on port " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
port Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (TLS)"
    TLSSettings -> Settings -> Application -> IO ()
WT.runTLS ([Char] -> [Char] -> TLSSettings
WT.tlsSettings [Char]
cert [Char]
key) (Int -> Settings
mkSettings Int
port) Application
app
  where
    mkSettings :: Int -> Settings
mkSettings Int
port = Int -> Settings -> Settings
W.setPort Int
port Settings
warpSettings

-- | Prepare context and prepare HTTP handler for TLS connections that already passed TLS.handshake and ALPN check.
attachStaticFiles :: FilePath -> (AttachHTTP -> IO ()) -> IO ()
attachStaticFiles :: [Char] -> (AttachHTTP -> IO ()) -> IO ()
attachStaticFiles [Char]
path AttachHTTP -> IO ()
action = do
  Application
app <- [Char] -> IO Application
staticFiles [Char]
path
  -- Initialize global internal state for http server.
  Settings -> (InternalInfo -> IO ()) -> IO ()
forall a. Settings -> (InternalInfo -> IO a) -> IO a
WI.withII Settings
warpSettings ((InternalInfo -> IO ()) -> IO ())
-> (InternalInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InternalInfo
ii -> do
    AttachHTTP -> IO ()
action (AttachHTTP -> IO ()) -> AttachHTTP -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
socket Context
cxt -> do
      -- Initialize internal per-connection resources.
      SockAddr
addr <- Socket -> IO SockAddr
getPeerName Socket
socket
      SockAddr -> Context -> ((Connection, Transport) -> IO ()) -> IO ()
forall {c}.
SockAddr -> Context -> ((Connection, Transport) -> IO c) -> IO c
withConnection SockAddr
addr Context
cxt (((Connection, Transport) -> IO ()) -> IO ())
-> ((Connection, Transport) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Connection
conn, Transport
transport) ->
        InternalInfo -> Connection -> (Handle -> IO ()) -> IO ()
forall {c}. InternalInfo -> Connection -> (Handle -> IO c) -> IO c
withTimeout InternalInfo
ii Connection
conn ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
th ->
          -- Run Warp connection handler to process HTTP requests for static files.
          Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Transport
-> Settings
-> Application
-> IO ()
WI.serveConnection Connection
conn InternalInfo
ii Handle
th SockAddr
addr Transport
transport Settings
warpSettings Application
app
  where
    -- from warp-tls
    withConnection :: SockAddr -> Context -> ((Connection, Transport) -> IO c) -> IO c
withConnection SockAddr
socket Context
cxt = IO (Connection, Transport)
-> ((Connection, Transport) -> IO ())
-> ((Connection, Transport) -> IO c)
-> IO c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (SockAddr -> Context -> IO (Connection, Transport)
WT.attachConn SockAddr
socket Context
cxt) (Connection -> IO ()
terminate (Connection -> IO ())
-> ((Connection, Transport) -> Connection)
-> (Connection, Transport)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection, Transport) -> Connection
forall a b. (a, b) -> a
fst)
    -- from warp
    withTimeout :: InternalInfo -> Connection -> (Handle -> IO c) -> IO c
withTimeout InternalInfo
ii Connection
conn =
      IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        (Manager -> IO () -> IO Handle
WI.registerKillThread (InternalInfo -> Manager
WI.timeoutManager InternalInfo
ii) (Connection -> IO ()
WI.connClose Connection
conn))
        Handle -> IO ()
WI.cancel
    -- shared clean up
    terminate :: Connection -> IO ()
terminate Connection
conn = Connection -> IO ()
WI.connClose Connection
conn IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` (IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
readIORef (Connection -> IORef WriteBuffer
WI.connWriteBuffer Connection
conn) IO WriteBuffer -> (WriteBuffer -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBuffer -> IO ()
WI.bufFree)

warpSettings :: W.Settings
warpSettings :: Settings
warpSettings = Maybe Int -> Settings -> Settings
W.setGracefulShutdownTimeout (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Settings
W.defaultSettings

staticFiles :: FilePath -> IO Application
staticFiles :: [Char] -> IO Application
staticFiles [Char]
root = do
  [Char]
canonRoot <- [Char] -> IO [Char]
canonicalizePath [Char]
root
  Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ [Char] -> Application -> Application
withGzipFiles [Char]
canonRoot (StaticSettings -> Application
S.staticApp StaticSettings
settings) Application -> (Request -> Request) -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
changeWellKnownPath
  where
    settings :: StaticSettings
settings = StaticSettings
defSettings {ssListing = Nothing, ssGetMimeType = getMimeType}
    defSettings :: StaticSettings
defSettings = [Char] -> StaticSettings
S.defaultFileServerSettings [Char]
root
    getMimeType :: File -> IO ByteString
getMimeType File
f
      | Piece -> Text
WAT.fromPiece (File -> Piece
WAT.fileName File
f) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"apple-app-site-association" = ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"application/json"
      | Bool
otherwise = (StaticSettings -> File -> IO ByteString
ssGetMimeType StaticSettings
defSettings) File
f
    changeWellKnownPath :: Request -> Request
changeWellKnownPath Request
req = case Request -> [Text]
pathInfo Request
req of
      Text
".well-known" : [Text]
rest ->
        Request
req
          { pathInfo = "well-known" : rest,
            rawPathInfo = rewriteWellKnown (rawPathInfo req)
          }
      [Text]
_ -> Request
req

-- | WAI middleware that gzip-compresses static files on the fly when client accepts gzip.
-- Falls through to the wrapped app for non-compressible files or when gzip is not accepted.
withGzipFiles :: FilePath -> Application -> Application
withGzipFiles :: [Char] -> Application -> Application
withGzipFiles [Char]
canonRoot Application
app Request
req Response -> IO ResponseReceived
respond
  | Request -> Bool
acceptsGzipWAI Request
req =
      [Char] -> ByteString -> IO (Maybe ([Char], ByteString))
resolveStaticFile [Char]
canonRoot (Request -> ByteString
rawPathInfo Request
req) IO (Maybe ([Char], ByteString))
-> (Maybe ([Char], ByteString) -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ([Char]
file, ByteString
mime) | [Char] -> Bool
isCompressible [Char]
file -> do
          ByteString
content <- [Char] -> IO ByteString
B.readFile [Char]
file
          Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
N.ok200 (ByteString -> Bool -> ResponseHeaders
staticResponseHeaders ByteString
mime Bool
True) (ByteString -> ByteString
GZip.compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.fromStrict ByteString
content)
        Maybe ([Char], ByteString)
_ -> Application
app Request
req Response -> IO ResponseReceived
respond
  | Bool
otherwise = Application
app Request
req Response -> IO ResponseReceived
respond

generateSite :: EmbeddedContent -> ByteString -> [String] -> FilePath -> IO ()
generateSite :: EmbeddedContent -> ByteString -> [[Char]] -> [Char] -> IO ()
generateSite EmbeddedContent
embedded ByteString
indexContent [[Char]]
linkPages [Char]
sitePath = do
  Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
sitePath
  [Char] -> ByteString -> IO ()
B.writeFile ([Char]
sitePath [Char] -> [Char] -> [Char]
</> [Char]
"index.html") ByteString
indexContent
  [Char] -> [([Char], ByteString)] -> IO ()
forall {t :: * -> *}.
Foldable t =>
[Char] -> t ([Char], ByteString) -> IO ()
copyDir [Char]
"media" ([([Char], ByteString)] -> IO ())
-> [([Char], ByteString)] -> IO ()
forall a b. (a -> b) -> a -> b
$ EmbeddedContent -> [([Char], ByteString)]
mediaContent EmbeddedContent
embedded
  -- `.well-known` path is re-written in changeWellKnownPath,
  -- staticApp does not allow hidden folders.
  [Char] -> [([Char], ByteString)] -> IO ()
forall {t :: * -> *}.
Foldable t =>
[Char] -> t ([Char], ByteString) -> IO ()
copyDir [Char]
"well-known" ([([Char], ByteString)] -> IO ())
-> [([Char], ByteString)] -> IO ()
forall a b. (a -> b) -> a -> b
$ EmbeddedContent -> [([Char], ByteString)]
wellKnown EmbeddedContent
embedded
  [[Char]] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
linkPages [Char] -> IO ()
createLinkPage
  Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Generated static site contents at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
tshow [Char]
sitePath
  where
    copyDir :: [Char] -> t ([Char], ByteString) -> IO ()
copyDir [Char]
dir t ([Char], ByteString)
content = do
      Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
sitePath [Char] -> [Char] -> [Char]
</> [Char]
dir
      t ([Char], ByteString) -> (([Char], ByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t ([Char], ByteString)
content ((([Char], ByteString) -> IO ()) -> IO ())
-> (([Char], ByteString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Char]
path, ByteString
s) -> [Char] -> ByteString -> IO ()
B.writeFile ([Char]
sitePath [Char] -> [Char] -> [Char]
</> [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
path) ByteString
s
    createLinkPage :: [Char] -> IO ()
createLinkPage [Char]
path = do
      Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
sitePath [Char] -> [Char] -> [Char]
</> [Char]
path
      [Char] -> ByteString -> IO ()
B.writeFile ([Char]
sitePath [Char] -> [Char] -> [Char]
</> [Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"index.html") (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ EmbeddedContent -> ByteString
linkHtml EmbeddedContent
embedded

-- | Serve static files via HTTP/2 directly (without WAI).
-- Path traversal protection: resolved path must stay under canonicalRoot.
-- canonicalRoot must be pre-computed via 'canonicalizePath'.
serveStaticPageH2 :: FilePath -> H.Request -> (H.Response -> IO ()) -> IO Bool
serveStaticPageH2 :: [Char] -> Request -> (Response -> IO ()) -> IO Bool
serveStaticPageH2 [Char]
canonRoot Request
req Response -> IO ()
sendResponse = do
  let rawPath :: ByteString
rawPath = ByteString -> ByteString
rewriteWellKnown (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"/" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
H.requestPath Request
req
  [Char] -> ByteString -> IO (Maybe ([Char], ByteString))
resolveStaticFile [Char]
canonRoot ByteString
rawPath IO (Maybe ([Char], ByteString))
-> (Maybe ([Char], ByteString) -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just ([Char]
file, ByteString
mime) -> do
      ByteString
content <- [Char] -> IO ByteString
B.readFile [Char]
file
      let gz :: Bool
gz = Request -> Bool
acceptsGzipH2 Request
req Bool -> Bool -> Bool
&& [Char] -> Bool
isCompressible [Char]
file
          body :: Builder
body
            | Bool
gz = ByteString -> Builder
lazyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
GZip.compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.fromStrict ByteString
content
            | Bool
otherwise = ByteString -> Builder
byteString ByteString
content
      Response -> IO ()
sendResponse (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
H.responseBuilder Status
N.ok200 (ByteString -> Bool -> ResponseHeaders
staticResponseHeaders ByteString
mime Bool
gz) Builder
body
      Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Maybe ([Char], ByteString)
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Resolve a static file request to a file path.
-- Handles index.html fallback and path traversal protection.
-- canonRoot must be pre-computed via 'canonicalizePath'.
resolveStaticFile :: FilePath -> ByteString -> IO (Maybe (FilePath, ByteString))
resolveStaticFile :: [Char] -> ByteString -> IO (Maybe ([Char], ByteString))
resolveStaticFile [Char]
canonRoot ByteString
path = do
  let relPath :: [Char]
relPath = ByteString -> [Char]
B.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') ByteString
path
      requestedPath :: [Char]
requestedPath
        | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
relPath = [Char]
canonRoot [Char] -> [Char] -> [Char]
</> [Char]
"index.html"
        | Bool
otherwise = [Char]
canonRoot [Char] -> [Char] -> [Char]
</> [Char]
relPath
  [Char] -> IO (Maybe ([Char], ByteString))
tryResolve [Char]
requestedPath
    IO (Maybe ([Char], ByteString))
-> (Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString)))
-> IO (Maybe ([Char], ByteString))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe ([Char], ByteString))
-> (([Char], ByteString) -> IO (Maybe ([Char], ByteString)))
-> Maybe ([Char], ByteString)
-> IO (Maybe ([Char], ByteString))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO (Maybe ([Char], ByteString))
tryResolve ([Char]
requestedPath [Char] -> [Char] -> [Char]
</> [Char]
"index.html")) (Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString)))
-> (([Char], ByteString) -> Maybe ([Char], ByteString))
-> ([Char], ByteString)
-> IO (Maybe ([Char], ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], ByteString) -> Maybe ([Char], ByteString)
forall a. a -> Maybe a
Just)
  where
    tryResolve :: [Char] -> IO (Maybe ([Char], ByteString))
tryResolve [Char]
filePath = do
      Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
filePath
      if Bool
exists
        then do
          [Char]
canonFile <- [Char] -> IO [Char]
canonicalizePath [Char]
filePath
          if ([Char]
canonRoot [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/") [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
canonFile Bool -> Bool -> Bool
|| [Char]
canonRoot [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
canonFile
            then Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString)))
-> Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString))
forall a b. (a -> b) -> a -> b
$ ([Char], ByteString) -> Maybe ([Char], ByteString)
forall a. a -> Maybe a
Just ([Char]
canonFile, [Char] -> ByteString
staticMimeType [Char]
canonFile)
            else Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ([Char], ByteString)
forall a. Maybe a
Nothing -- path traversal attempt
        else Maybe ([Char], ByteString) -> IO (Maybe ([Char], ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ([Char], ByteString)
forall a. Maybe a
Nothing

rewriteWellKnown :: ByteString -> ByteString
rewriteWellKnown :: ByteString -> ByteString
rewriteWellKnown ByteString
p
  | ByteString
"/.well-known/" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
p = ByteString
"/well-known/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
"/.well-known/") ByteString
p
  | ByteString
p ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"/.well-known" = ByteString
"/well-known"
  | Bool
otherwise = ByteString
p

acceptsGzipH2 :: H.Request -> Bool
acceptsGzipH2 :: Request -> Bool
acceptsGzipH2 Request
req = ((Token, ByteString) -> Bool) -> [(Token, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Token
t, ByteString
v) -> Token -> HeaderName
tokenKey Token
t HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"accept-encoding" Bool -> Bool -> Bool
&& ByteString
"gzip" ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
v) (([(Token, ByteString)], ValueTable) -> [(Token, ByteString)]
forall a b. (a, b) -> a
fst (([(Token, ByteString)], ValueTable) -> [(Token, ByteString)])
-> ([(Token, ByteString)], ValueTable) -> [(Token, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> ([(Token, ByteString)], ValueTable)
H.requestHeaders Request
req)

acceptsGzipWAI :: Request -> Bool
acceptsGzipWAI :: Request -> Bool
acceptsGzipWAI Request
req = Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString
"gzip" ByteString -> ByteString -> Bool
`B.isInfixOf`) (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept-Encoding" (Request -> ResponseHeaders
requestHeaders Request
req)

isCompressible :: FilePath -> Bool
isCompressible :: [Char] -> Bool
isCompressible [Char]
fp =
  ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp) [[Char]
".html", [Char]
".css", [Char]
".js", [Char]
".svg", [Char]
".json"]
    Bool -> Bool -> Bool
|| [Char]
"apple-app-site-association" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp

staticResponseHeaders :: ByteString -> Bool -> [N.Header]
staticResponseHeaders :: ByteString -> Bool -> ResponseHeaders
staticResponseHeaders ByteString
mime Bool
gz
  | Bool
gz = [(HeaderName
"Content-Type", ByteString
mime), (HeaderName
"Content-Encoding", ByteString
"gzip"), (HeaderName
"Vary", ByteString
"Accept-Encoding")]
  | Bool
otherwise = [(HeaderName
"Content-Type", ByteString
mime)]

staticMimeType :: FilePath -> ByteString
staticMimeType :: [Char] -> ByteString
staticMimeType [Char]
fp
  | [Char]
".html" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"text/html"
  | [Char]
".css" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"text/css"
  | [Char]
".js" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"application/javascript"
  | [Char]
".svg" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"image/svg+xml"
  | [Char]
".png" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"image/png"
  | [Char]
".ico" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"image/x-icon"
  | [Char]
".json" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"application/json"
  | [Char]
"apple-app-site-association" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"application/json"
  | [Char]
".woff" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"font/woff"
  | [Char]
".woff2" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"font/woff2"
  | [Char]
".ttf" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp = ByteString
"font/ttf"
  | Bool
otherwise = ByteString
"application/octet-stream"

-- | Substitutions for server information fields shared between SMP and XFTP pages.
serverInfoSubsts :: String -> Maybe ServerPublicInfo -> [(ByteString, Maybe ByteString)]
serverInfoSubsts :: [Char]
-> Maybe ServerPublicInfo -> [(ByteString, Maybe ByteString)]
serverInfoSubsts [Char]
simplexmqSource Maybe ServerPublicInfo
information =
  [[(ByteString, Maybe ByteString)]]
-> [(ByteString, Maybe ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [(ByteString, Maybe ByteString)]
basic,
      [(ByteString, Maybe ByteString)]
-> (ServerConditions -> [(ByteString, Maybe ByteString)])
-> Maybe ServerConditions
-> [(ByteString, Maybe ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(ByteString
"usageConditions", Maybe ByteString
forall a. Maybe a
Nothing), (ByteString
"usageAmendments", Maybe ByteString
forall a. Maybe a
Nothing)] ServerConditions -> [(ByteString, Maybe ByteString)]
forall {a}.
IsString a =>
ServerConditions -> [(a, Maybe ByteString)]
conds (ServerPublicInfo -> Maybe ServerConditions
usageConditions ServerPublicInfo
spi),
      [(ByteString, Maybe ByteString)]
-> (Entity -> [(ByteString, Maybe ByteString)])
-> Maybe Entity
-> [(ByteString, Maybe ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(ByteString
"operator", Maybe ByteString
forall a. Maybe a
Nothing)] Entity -> [(ByteString, Maybe ByteString)]
forall {a}. IsString a => Entity -> [(a, Maybe ByteString)]
operatorE (ServerPublicInfo -> Maybe Entity
operator ServerPublicInfo
spi),
      [(ByteString, Maybe ByteString)]
-> (ServerContactAddress -> [(ByteString, Maybe ByteString)])
-> Maybe ServerContactAddress
-> [(ByteString, Maybe ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(ByteString
"admin", Maybe ByteString
forall a. Maybe a
Nothing)] ServerContactAddress -> [(ByteString, Maybe ByteString)]
forall {a}.
IsString a =>
ServerContactAddress -> [(a, Maybe ByteString)]
admin (ServerPublicInfo -> Maybe ServerContactAddress
adminContacts ServerPublicInfo
spi),
      [(ByteString, Maybe ByteString)]
-> (ServerContactAddress -> [(ByteString, Maybe ByteString)])
-> Maybe ServerContactAddress
-> [(ByteString, Maybe ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(ByteString
"complaints", Maybe ByteString
forall a. Maybe a
Nothing)] ServerContactAddress -> [(ByteString, Maybe ByteString)]
forall {a}.
IsString a =>
ServerContactAddress -> [(a, Maybe ByteString)]
complaints (ServerPublicInfo -> Maybe ServerContactAddress
complaintsContacts ServerPublicInfo
spi),
      [(ByteString, Maybe ByteString)]
-> (Entity -> [(ByteString, Maybe ByteString)])
-> Maybe Entity
-> [(ByteString, Maybe ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(ByteString
"hosting", Maybe ByteString
forall a. Maybe a
Nothing)] Entity -> [(ByteString, Maybe ByteString)]
forall {a}. IsString a => Entity -> [(a, Maybe ByteString)]
hostingE (ServerPublicInfo -> Maybe Entity
hosting ServerPublicInfo
spi),
      [(ByteString, Maybe ByteString)]
server
    ]
  where
    basic :: [(ByteString, Maybe ByteString)]
basic =
      [ (ByteString
"sourceCode", if Text -> Bool
T.null Text
sc then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
encodeUtf8 Text
sc)),
        (ByteString
"noSourceCode", if Text -> Bool
T.null Text
sc then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"none" else Maybe ByteString
forall a. Maybe a
Nothing),
        (ByteString
"version", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
B.pack [Char]
simplexMQVersion),
        (ByteString
"commitSourceCode", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
-> (ServerPublicInfo -> Text) -> Maybe ServerPublicInfo -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Text
T.pack [Char]
simplexmqSource) ServerPublicInfo -> Text
sourceCode Maybe ServerPublicInfo
information),
        (ByteString
"shortCommit", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
B.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
7 [Char]
simplexmqCommit),
        (ByteString
"commit", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
B.pack [Char]
simplexmqCommit),
        (ByteString
"website", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerPublicInfo -> Maybe Text
website ServerPublicInfo
spi)
      ]
    spi :: ServerPublicInfo
spi = ServerPublicInfo -> Maybe ServerPublicInfo -> ServerPublicInfo
forall a. a -> Maybe a -> a
fromMaybe (Text -> ServerPublicInfo
emptyServerInfo Text
"") Maybe ServerPublicInfo
information
    sc :: Text
sc = ServerPublicInfo -> Text
sourceCode ServerPublicInfo
spi
    conds :: ServerConditions -> [(a, Maybe ByteString)]
conds ServerConditions {Text
conditions :: Text
$sel:conditions:ServerConditions :: ServerConditions -> Text
conditions, Maybe Text
amendments :: Maybe Text
$sel:amendments:ServerConditions :: ServerConditions -> Maybe Text
amendments} =
      [ (a
"usageConditions", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
conditions),
        (a
"usageAmendments", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
amendments)
      ]
    operatorE :: Entity -> [(a, Maybe ByteString)]
operatorE Entity {Text
name :: Text
$sel:name:Entity :: Entity -> Text
name, Maybe Text
country :: Maybe Text
$sel:country:Entity :: Entity -> Maybe Text
country} =
      [ (a
"operator", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
""),
        (a
"operatorEntity", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
name),
        (a
"operatorCountry", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
country)
      ]
    admin :: ServerContactAddress -> [(a, Maybe ByteString)]
admin ServerContactAddress {Maybe (ConnectionLink 'CMContact)
simplex :: Maybe (ConnectionLink 'CMContact)
$sel:simplex:ServerContactAddress :: ServerContactAddress -> Maybe (ConnectionLink 'CMContact)
simplex, Maybe Text
email :: Maybe Text
$sel:email:ServerContactAddress :: ServerContactAddress -> Maybe Text
email, Maybe PGPKey
pgp :: Maybe PGPKey
$sel:pgp:ServerContactAddress :: ServerContactAddress -> Maybe PGPKey
pgp} =
      [ (a
"admin", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
""),
        (a
"adminSimplex", ConnectionLink 'CMContact -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ConnectionLink 'CMContact -> ByteString)
-> Maybe (ConnectionLink 'CMContact) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ConnectionLink 'CMContact)
simplex),
        (a
"adminEmail", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
email),
        (a
"adminPGP", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (PGPKey -> Text) -> PGPKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGPKey -> Text
pkURI (PGPKey -> ByteString) -> Maybe PGPKey -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PGPKey
pgp),
        (a
"adminPGPFingerprint", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (PGPKey -> Text) -> PGPKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGPKey -> Text
pkFingerprint (PGPKey -> ByteString) -> Maybe PGPKey -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PGPKey
pgp)
      ]
    complaints :: ServerContactAddress -> [(a, Maybe ByteString)]
complaints ServerContactAddress {Maybe (ConnectionLink 'CMContact)
$sel:simplex:ServerContactAddress :: ServerContactAddress -> Maybe (ConnectionLink 'CMContact)
simplex :: Maybe (ConnectionLink 'CMContact)
simplex, Maybe Text
$sel:email:ServerContactAddress :: ServerContactAddress -> Maybe Text
email :: Maybe Text
email, Maybe PGPKey
$sel:pgp:ServerContactAddress :: ServerContactAddress -> Maybe PGPKey
pgp :: Maybe PGPKey
pgp} =
      [ (a
"complaints", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
""),
        (a
"complaintsSimplex", ConnectionLink 'CMContact -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ConnectionLink 'CMContact -> ByteString)
-> Maybe (ConnectionLink 'CMContact) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ConnectionLink 'CMContact)
simplex),
        (a
"complaintsEmail", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
email),
        (a
"complaintsPGP", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (PGPKey -> Text) -> PGPKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGPKey -> Text
pkURI (PGPKey -> ByteString) -> Maybe PGPKey -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PGPKey
pgp),
        (a
"complaintsPGPFingerprint", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (PGPKey -> Text) -> PGPKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGPKey -> Text
pkFingerprint (PGPKey -> ByteString) -> Maybe PGPKey -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PGPKey
pgp)
      ]
    hostingE :: Entity -> [(a, Maybe ByteString)]
hostingE Entity {Text
$sel:name:Entity :: Entity -> Text
name :: Text
name, Maybe Text
$sel:country:Entity :: Entity -> Maybe Text
country :: Maybe Text
country} =
      [ (a
"hosting", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
""),
        (a
"hostingEntity", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
name),
        (a
"hostingCountry", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
country)
      ]
    server :: [(ByteString, Maybe ByteString)]
server =
      [ (ByteString
"serverCountry", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerPublicInfo -> Maybe Text
serverCountry ServerPublicInfo
spi),
        (ByteString
"hostingType", (\ByteString
s -> ByteString
-> ((Char, ByteString) -> ByteString)
-> Maybe (Char, ByteString)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
s (\(Char
c, ByteString
rest) -> Char -> Char
toUpper Char
c Char -> ByteString -> ByteString
`B.cons` ByteString
rest) (Maybe (Char, ByteString) -> ByteString)
-> Maybe (Char, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
s) (ByteString -> ByteString)
-> (HostingType -> ByteString) -> HostingType -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostingType -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (HostingType -> ByteString)
-> Maybe HostingType -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerPublicInfo -> Maybe HostingType
hostingType ServerPublicInfo
spi)
      ]

-- Copy-pasted from simplex-chat Simplex.Chat.Types.Preferences
{-# INLINE timedTTLText #-}
timedTTLText :: (Integral i, Show i) => i -> String
timedTTLText :: forall i. (Integral i, Show i) => i -> [Char]
timedTTLText i
0 = [Char]
"0 sec"
timedTTLText i
ttl = do
  let (i
m', i
s) = i
ttl i -> i -> (i, i)
forall a. Integral a => a -> a -> (a, a)
`quotRem` i
60
      (i
h', i
m) = i
m' i -> i -> (i, i)
forall a. Integral a => a -> a -> (a, a)
`quotRem` i
60
      (i
d', i
h) = i
h' i -> i -> (i, i)
forall a. Integral a => a -> a -> (a, a)
`quotRem` i
24
      (i
mm, i
d) = i
d' i -> i -> (i, i)
forall a. Integral a => a -> a -> (a, a)
`quotRem` i
30
  [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
    [i -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
mms i
mm | i
mm i -> i -> Bool
forall a. Eq a => a -> a -> Bool
/= i
0]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [i -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
ds i
d | i
d i -> i -> Bool
forall a. Eq a => a -> a -> Bool
/= i
0]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [i -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
hs i
h | i
h i -> i -> Bool
forall a. Eq a => a -> a -> Bool
/= i
0]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [i -> [Char]
forall {a}. Show a => a -> [Char]
ms i
m | i
m i -> i -> Bool
forall a. Eq a => a -> a -> Bool
/= i
0]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [i -> [Char]
forall {a}. Show a => a -> [Char]
ss i
s | i
s i -> i -> Bool
forall a. Eq a => a -> a -> Bool
/= i
0]
  where
    ss :: a -> [Char]
ss a
s = a -> [Char]
forall {a}. Show a => a -> [Char]
show a
s [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" sec"
    ms :: a -> [Char]
ms a
m = a -> [Char]
forall {a}. Show a => a -> [Char]
show a
m [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" min"
    hs :: a -> [Char]
hs a
1 = [Char]
"1 hour"
    hs a
h = a -> [Char]
forall {a}. Show a => a -> [Char]
show a
h [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" hours"
    ds :: a -> [Char]
ds a
1 = [Char]
"1 day"
    ds a
7 = [Char]
"1 week"
    ds a
14 = [Char]
"2 weeks"
    ds a
d = a -> [Char]
forall {a}. Show a => a -> [Char]
show a
d [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" days"
    mms :: a -> [Char]
mms a
1 = [Char]
"1 month"
    mms a
mm = a -> [Char]
forall {a}. Show a => a -> [Char]
show a
mm [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" months"

-- | Rewrite source with provided substitutions
render :: ByteString -> [(ByteString, Maybe ByteString)] -> ByteString
render :: ByteString -> [(ByteString, Maybe ByteString)] -> ByteString
render ByteString
src = \case
  [] -> ByteString
src
  (ByteString
label, Maybe ByteString
content') : [(ByteString, Maybe ByteString)]
rest -> ByteString -> [(ByteString, Maybe ByteString)] -> ByteString
render (ByteString -> Maybe ByteString -> ByteString -> ByteString
section_ ByteString
label Maybe ByteString
content' ByteString
src) [(ByteString, Maybe ByteString)]
rest

-- | Rewrite section content inside @<x-label>...</x-label>@ markers.
-- Markers are always removed when found. Closing marker is mandatory.
-- If content is absent, whole section is removed.
-- Section content is delegated to `item_`. If no sections found, the whole source is delegated.
section_ :: ByteString -> Maybe ByteString -> ByteString -> ByteString
section_ :: ByteString -> Maybe ByteString -> ByteString -> ByteString
section_ ByteString
label Maybe ByteString
content' ByteString
src =
  case ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
startMarker ByteString
src of
    (ByteString
_, ByteString
"") -> ByteString -> ByteString -> ByteString -> ByteString
item_ ByteString
label (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
content') ByteString
src -- no section, just replace items
    (ByteString
before, ByteString
afterStart') ->
      -- found section start, search for end too
      case ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
endMarker (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
startMarker) ByteString
afterStart' of
        (ByteString
_, ByteString
"") -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"missing section end: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall {a}. Show a => a -> [Char]
show ByteString
endMarker
        (ByteString
inside, ByteString
next') ->
          let next :: ByteString
next = Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
endMarker) ByteString
next'
           in case Maybe ByteString
content' of
                Just ByteString
content -> ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> ByteString -> ByteString
item_ ByteString
label ByteString
content ByteString
inside ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Maybe ByteString -> ByteString -> ByteString
section_ ByteString
label Maybe ByteString
content' ByteString
next
                Maybe ByteString
Nothing -> ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Maybe ByteString -> ByteString -> ByteString
section_ ByteString
label Maybe ByteString
forall a. Maybe a
Nothing ByteString
next -- collapse section
  where
    startMarker :: ByteString
startMarker = ByteString
"<x-" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
label ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
">"
    endMarker :: ByteString
endMarker = ByteString
"</x-" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
label ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
">"

-- | Replace all occurrences of @${label}@ with provided content.
item_ :: ByteString -> ByteString -> ByteString -> ByteString
item_ :: ByteString -> ByteString -> ByteString -> ByteString
item_ ByteString
label ByteString
content' ByteString
src =
  case ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
marker ByteString
src of
    (ByteString
done, ByteString
"") -> ByteString
done
    (ByteString
before, ByteString
after') -> ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
content' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> ByteString -> ByteString
item_ ByteString
label ByteString
content' (Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
marker) ByteString
after')
  where
    marker :: ByteString
marker = ByteString
"${" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
label ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"}"