git.iko.soy/project-m36
on master help sign in
Add configuration type for websockets server so we can take TLS certificate config. Run warp-tls if we have certificate and key.
commit04711727e3dfcd44419e36c68701114eb808f24d authorDiogo Biazus <diogo@biazus.ca> dateSat 17 Jul 2021, 20:44 (5 years ago) parentf10d564
4 files changed+55−18
compare with master
unifiedsplit
project-m36.cabal+1−1 src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+17−3 src/lib/ProjectM36/Server/Config.hs+6 src/lib/ProjectM36/Server/ParseArgs.hs+31−14
project-m36.cabal+1−1
@@ -433,7 +433,7 @@ Test-Suite test-scripts
433433
434434Executable project-m36-websocket-server
435435 Default-Language: Haskell2010
436− Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp
436+ Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls
437437 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs
438438 Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer
439439 GHC-Options: -Wall -threaded
src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+17−3
@@ -2,11 +2,14 @@
22
33import Control.Concurrent
44import Control.Exception
5+import Control.Monad (when)
6+import Data.Maybe (isJust)
57import Data.String (fromString)
68import Network.HTTP.Types (status400)
79import Network.Socket
810import Network.Wai (Application, responseLBS)
911import Network.Wai.Handler.Warp
12+import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
1013import qualified Network.Wai.Handler.WebSockets as WS
1114import Network.WebSockets (defaultConnectionOptions)
1215import ProjectM36.Server
@@ -18,12 +21,20 @@ main :: IO ()
1821main = do
1922 -- launch normal project-m36-server
2023 addressMVar <- newEmptyMVar
21− serverConfig <- parseConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})
24+ wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})
25+
2226 --usurp the serverConfig for our websocket server and make the proxied server run locally
23− let wsHost = bindHost serverConfig
27+ let serverConfig = wsServerConfig wsConfig
28+ wsHost = bindHost serverConfig
2429 wsPort = bindPort serverConfig
2530 serverHost = "127.0.0.1"
2631 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}
32+ configCertificateFile = tlsCertificatePath wsConfig
33+ configKeyFile = tlsKeyPath wsConfig
34+
35+ when (isJust configCertificateFile /= isJust configKeyFile) $
36+ throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem"
37+
2738 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)
2839 --wait for server to be listening
2940 addr <- takeMVar addressMVar
@@ -34,7 +45,10 @@ main = do
3445 wsApp = websocketProxyServer port serverHost
3546 waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp
3647 settings = warpSettings wsHost (fromIntegral wsPort)
37− runSettings settings waiApp
48+
49+ case (configCertificateFile, configKeyFile) of
50+ (Just certificate, Just key) -> runTLS (tlsSettings certificate key) settings waiApp
51+ _ -> runSettings settings waiApp
3852
3953backupApp :: Application
4054backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"
src/lib/ProjectM36/Server/Config.hs+6
@@ -12,6 +12,12 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,
1212 }
1313 deriving (Show)
1414
15+data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig,
16+ tlsCertificatePath :: Maybe String,
17+ tlsKeyPath :: Maybe String
18+ }
19+ deriving (Show)
20+
1521defaultServerConfig :: ServerConfig
1622defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,
1723 checkFS = True,
src/lib/ProjectM36/Server/ParseArgs.hs+31−14
@@ -17,14 +17,14 @@ parseArgsWithDefaults defaults = ServerConfig <$>
1717 many parseGhcPkgPath <*>
1818 parseTimeout (perRequestTimeout defaults) <*>
1919 parseTestMode
20−
20+
2121parsePersistenceStrategy :: Parser PersistenceStrategy
2222parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
2323 MinimalPersistence <$> dbdirOpt <|>
2424 pure NoPersistence
25− where
26− dbdirOpt = strOption (short 'd' <>
27− long "database-directory" <>
25+ where
26+ dbdirOpt = strOption (short 'd' <>
27+ long "database-directory" <>
2828 metavar "DIRECTORY" <>
2929 showDefaultWith show
3030 )
@@ -34,43 +34,60 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
3434
3535parseTestMode :: Parser Bool
3636parseTestMode = flag True False (long "test-mode" <> hidden)
37−
38−parseCheckFS :: Parser Bool
37+
38+parseCheckFS :: Parser Bool
3939parseCheckFS = flag True False (long "disable-fscheck" <>
4040 help "Disable filesystem check for journaling.")
41−
41+
4242parseDatabaseName :: Parser DatabaseName
4343parseDatabaseName = strOption (short 'n' <>
4444 long "database" <>
4545 metavar "DATABASE_NAME")
4646
47−parseHostname :: Hostname -> Parser Hostname
47+parseHostname :: Hostname -> Parser Hostname
4848parseHostname defHostname = strOption (short 'h' <>
4949 long "hostname" <>
5050 metavar "HOST_NAME" <>
5151 value defHostname)
52−
52+
5353parsePort :: Port -> Parser Port
5454parsePort defPort = option auto (short 'p' <>
5555 long "port" <>
5656 metavar "PORT_NUMBER" <>
5757 value defPort)
58−
58+
5959parseGhcPkgPath :: Parser String
6060parseGhcPkgPath = strOption (long "ghc-pkg-dir" <>
6161 metavar "GHC_PACKAGE_DIRECTORY")
62−
63−parseTimeout :: Int -> Parser Int
62+
63+parseTimeout :: Int -> Parser Int
6464parseTimeout defTimeout = option auto (long "timeout" <>
6565 metavar "MICROSECONDS" <>
6666 value defTimeout)
6767
6868parseConfig :: IO ServerConfig
6969parseConfig = parseConfigWithDefaults defaultServerConfig
70−
70+
7171parseConfigWithDefaults :: ServerConfig -> IO ServerConfig
7272parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm)
7373
74+parseWSConfigWithDefaults :: ServerConfig -> IO WebsocketServerConfig
75+parseWSConfigWithDefaults defaults = execParser (info (parseWSArgsWithDefaults defaults <**> helpOption) idm)
76+
77+parseWSArgsWithDefaults :: ServerConfig -> Parser WebsocketServerConfig
78+parseWSArgsWithDefaults defaults = WebsocketServerConfig <$>
79+ parseArgsWithDefaults defaults <*>
80+ parseTlsCertificatePath <*>
81+ parseTlsKeyPath
82+
83+
84+parseTlsCertificatePath :: Parser (Maybe String)
85+parseTlsCertificatePath = optional $ strOption (long "tls-certificate-path" <>
86+ metavar "TLS_CERTIFICATE_PATH")
87+
88+parseTlsKeyPath :: Parser (Maybe String)
89+parseTlsKeyPath = optional $ strOption (long "tls-key-path" <>
90+ metavar "TLS_KEY_PATH")
7491
7592helpOption :: Parser (a -> a)
7693helpOption = abortOption helpText $ mconcat
@@ -80,6 +97,6 @@ helpOption = abortOption helpText $ mconcat
8097 where
8198#if MIN_VERSION_optparse_applicative(0,16,0)
8299 helpText = ShowHelpText Nothing
83−#else
100+#else
84101 helpText = ShowHelpText
85102#endif