mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 22:55:50 +00:00
e48bedeaf2
* smp server: fix server pages when source code is not specified * servers: include git commit in version * flexible alpn * fix test * fix ghc 8.10.7 build
254 lines
11 KiB
Haskell
254 lines
11 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Static where
|
|
|
|
import Control.Logger.Simple
|
|
import Control.Monad
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Char (toUpper)
|
|
import Data.IORef (readIORef)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.String (fromString)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Network.Socket (getPeerName)
|
|
import Network.Wai (Application, Request (..))
|
|
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.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..), simplexmqSource)
|
|
import Simplex.Messaging.Transport (simplexMQVersion)
|
|
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
|
import Simplex.Messaging.Util (tshow)
|
|
import Static.Embedded as E
|
|
import System.Directory (createDirectoryIfMissing)
|
|
import System.FilePath
|
|
import UnliftIO.Concurrent (forkFinally)
|
|
import UnliftIO.Exception (bracket, finally)
|
|
import qualified WaiAppStatic.Types as WAT
|
|
|
|
serveStaticFiles :: EmbeddedWebParams -> IO ()
|
|
serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams} = do
|
|
forM_ webHttpPort $ \port -> flip forkFinally (\e -> logError $ "HTTP server crashed: " <> tshow e) $ do
|
|
logInfo $ "Serving static site on port " <> tshow port
|
|
W.runSettings (mkSettings port) app
|
|
forM_ webHttpsParams $ \WebHttpsParams {port, cert, key} -> flip forkFinally (\e -> logError $ "HTTPS server crashed: " <> tshow e) $ do
|
|
logInfo $ "Serving static site on port " <> tshow port <> " (TLS)"
|
|
WT.runTLS (WT.tlsSettings cert key) (mkSettings port) app
|
|
where
|
|
app = staticFiles webStaticPath
|
|
mkSettings port = W.setPort port warpSettings
|
|
|
|
-- | Prepare context and prepare HTTP handler for TLS connections that already passed TLS.handshake and ALPN check.
|
|
attachStaticFiles :: FilePath -> (AttachHTTP -> IO ()) -> IO ()
|
|
attachStaticFiles path action =
|
|
-- Initialize global internal state for http server.
|
|
WI.withII warpSettings $ \ii -> do
|
|
action $ \socket cxt -> do
|
|
-- Initialize internal per-connection resources.
|
|
addr <- getPeerName socket
|
|
withConnection addr cxt $ \(conn, transport) ->
|
|
withTimeout ii conn $ \th ->
|
|
-- Run Warp connection handler to process HTTP requests for static files.
|
|
WI.serveConnection conn ii th addr transport warpSettings app
|
|
where
|
|
app = staticFiles path
|
|
-- from warp-tls
|
|
withConnection socket cxt = bracket (WT.attachConn socket cxt) (terminate . fst)
|
|
-- from warp
|
|
withTimeout ii conn =
|
|
bracket
|
|
(WI.registerKillThread (WI.timeoutManager ii) (WI.connClose conn))
|
|
WI.cancel
|
|
-- shared clean up
|
|
terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
|
|
|
|
warpSettings :: W.Settings
|
|
warpSettings = W.setGracefulShutdownTimeout (Just 1) W.defaultSettings
|
|
|
|
staticFiles :: FilePath -> Application
|
|
staticFiles root = S.staticApp settings . changeWellKnownPath
|
|
where
|
|
settings = defSettings {ssListing = Nothing, ssGetMimeType = getMimeType}
|
|
defSettings = S.defaultFileServerSettings root
|
|
getMimeType f
|
|
| WAT.fromPiece (WAT.fileName f) == "apple-app-site-association" = pure "application/json"
|
|
| otherwise = (ssGetMimeType defSettings) f
|
|
changeWellKnownPath req = case pathInfo req of
|
|
".well-known" : rest ->
|
|
req
|
|
{ pathInfo = "well-known" : rest,
|
|
rawPathInfo = "/well-known/" <> B.drop pfxLen (rawPathInfo req)
|
|
}
|
|
_ -> req
|
|
pfxLen = B.length "/.well-known/"
|
|
|
|
generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO ()
|
|
generateSite si onionHost sitePath = do
|
|
createDirectoryIfMissing True sitePath
|
|
B.writeFile (sitePath </> "index.html") $ serverInformation si onionHost
|
|
copyDir "media" E.mediaContent
|
|
-- `.well-known` path is re-written in changeWellKnownPath,
|
|
-- staticApp does not allow hidden folders.
|
|
copyDir "well-known" E.wellKnown
|
|
createLinkPage "contact"
|
|
createLinkPage "invitation"
|
|
createLinkPage "a"
|
|
createLinkPage "c"
|
|
createLinkPage "g"
|
|
createLinkPage "r"
|
|
createLinkPage "i"
|
|
logInfo $ "Generated static site contents at " <> tshow sitePath
|
|
where
|
|
copyDir dir content = do
|
|
createDirectoryIfMissing True $ sitePath </> dir
|
|
forM_ content $ \(path, s) -> B.writeFile (sitePath </> dir </> path) s
|
|
createLinkPage path = do
|
|
createDirectoryIfMissing True $ sitePath </> path
|
|
B.writeFile (sitePath </> path </> "index.html") E.linkHtml
|
|
|
|
serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString
|
|
serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs
|
|
where
|
|
substs = substConfig <> substInfo <> [("onionHost", strEncode <$> onionHost)]
|
|
substConfig =
|
|
[ ( "persistence",
|
|
Just $ case persistence config of
|
|
SPMMemoryOnly -> "In-memory only"
|
|
SPMQueues -> "Queues"
|
|
SPMMessages -> "Queues and messages"
|
|
),
|
|
("messageExpiration", Just $ maybe "Never" (fromString . timedTTLText) $ messageExpiration config),
|
|
("statsEnabled", Just . yesNo $ statsEnabled config),
|
|
("newQueuesAllowed", Just . yesNo $ newQueuesAllowed config),
|
|
("basicAuthEnabled", Just . yesNo $ basicAuthEnabled config)
|
|
]
|
|
yesNo True = "Yes"
|
|
yesNo False = "No"
|
|
substInfo =
|
|
concat
|
|
[ basic,
|
|
maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi),
|
|
maybe [("operator", Nothing)] operatorE (operator spi),
|
|
maybe [("admin", Nothing)] admin (adminContacts spi),
|
|
maybe [("complaints", Nothing)] complaints (complaintsContacts spi),
|
|
maybe [("hosting", Nothing)] hostingE (hosting spi),
|
|
server
|
|
]
|
|
where
|
|
basic =
|
|
[ ("sourceCode", if T.null sc then Nothing else Just (encodeUtf8 sc)),
|
|
("noSourceCode", if T.null sc then Just "none" else Nothing),
|
|
("version", Just $ B.pack simplexMQVersion),
|
|
("commitSourceCode", Just $ encodeUtf8 $ maybe (T.pack simplexmqSource) sourceCode information),
|
|
("shortCommit", Just $ B.pack $ take 7 simplexmqCommit),
|
|
("commit", Just $ B.pack simplexmqCommit),
|
|
("website", encodeUtf8 <$> website spi)
|
|
]
|
|
spi = fromMaybe (emptyServerInfo "") information
|
|
sc = sourceCode spi
|
|
conds ServerConditions {conditions, amendments} =
|
|
[ ("usageConditions", Just $ encodeUtf8 conditions),
|
|
("usageAmendments", encodeUtf8 <$> amendments)
|
|
]
|
|
operatorE Entity {name, country} =
|
|
[ ("operator", Just ""),
|
|
("operatorEntity", Just $ encodeUtf8 name),
|
|
("operatorCountry", encodeUtf8 <$> country)
|
|
]
|
|
admin ServerContactAddress {simplex, email, pgp} =
|
|
[ ("admin", Just ""),
|
|
("adminSimplex", strEncode <$> simplex),
|
|
("adminEmail", encodeUtf8 <$> email),
|
|
("adminPGP", encodeUtf8 . pkURI <$> pgp),
|
|
("adminPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
|
|
]
|
|
complaints ServerContactAddress {simplex, email, pgp} =
|
|
[ ("complaints", Just ""),
|
|
("complaintsSimplex", strEncode <$> simplex),
|
|
("complaintsEmail", encodeUtf8 <$> email),
|
|
("complaintsPGP", encodeUtf8 . pkURI <$> pgp),
|
|
("complaintsPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
|
|
]
|
|
hostingE Entity {name, country} =
|
|
[ ("hosting", Just ""),
|
|
("hostingEntity", Just $ encodeUtf8 name),
|
|
("hostingCountry", encodeUtf8 <$> country)
|
|
]
|
|
server =
|
|
[ ("serverCountry", encodeUtf8 <$> serverCountry spi),
|
|
("hostingType", (\s -> maybe s (\(c, rest) -> toUpper c `B.cons` rest) $ B.uncons s) . strEncode <$> hostingType spi)
|
|
]
|
|
|
|
-- Copy-pasted from simplex-chat Simplex.Chat.Types.Preferences
|
|
{-# INLINE timedTTLText #-}
|
|
timedTTLText :: (Integral i, Show i) => i -> String
|
|
timedTTLText 0 = "0 sec"
|
|
timedTTLText ttl = do
|
|
let (m', s) = ttl `quotRem` 60
|
|
(h', m) = m' `quotRem` 60
|
|
(d', h) = h' `quotRem` 24
|
|
(mm, d) = d' `quotRem` 30
|
|
unwords $
|
|
[mms mm | mm /= 0]
|
|
<> [ds d | d /= 0]
|
|
<> [hs h | h /= 0]
|
|
<> [ms m | m /= 0]
|
|
<> [ss s | s /= 0]
|
|
where
|
|
ss s = show s <> " sec"
|
|
ms m = show m <> " min"
|
|
hs 1 = "1 hour"
|
|
hs h = show h <> " hours"
|
|
ds 1 = "1 day"
|
|
ds 7 = "1 week"
|
|
ds 14 = "2 weeks"
|
|
ds d = show d <> " days"
|
|
mms 1 = "1 month"
|
|
mms mm = show mm <> " months"
|
|
|
|
-- | Rewrite source with provided substitutions
|
|
render :: ByteString -> [(ByteString, Maybe ByteString)] -> ByteString
|
|
render src = \case
|
|
[] -> src
|
|
(label, content') : rest -> render (section_ label content' src) 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_ label content' src =
|
|
case B.breakSubstring startMarker src of
|
|
(_, "") -> item_ label (fromMaybe "" content') src -- no section, just replace items
|
|
(before, afterStart') ->
|
|
-- found section start, search for end too
|
|
case B.breakSubstring endMarker $ B.drop (B.length startMarker) afterStart' of
|
|
(_, "") -> error $ "missing section end: " <> show endMarker
|
|
(inside, next') ->
|
|
let next = B.drop (B.length endMarker) next'
|
|
in case content' of
|
|
Just content | not (B.null content) -> before <> item_ label content inside <> section_ label content' next
|
|
_ -> before <> next -- collapse section
|
|
where
|
|
startMarker = "<x-" <> label <> ">"
|
|
endMarker = "</x-" <> label <> ">"
|
|
|
|
-- | Replace all occurences of @${label}@ with provided content.
|
|
item_ :: ByteString -> ByteString -> ByteString -> ByteString
|
|
item_ label content' src =
|
|
case B.breakSubstring marker src of
|
|
(done, "") -> done
|
|
(before, after') -> before <> content' <> item_ label content' (B.drop (B.length marker) after')
|
|
where
|
|
marker = "${" <> label <> "}"
|