git.iko.soy/project-m36
on f10d564 help sign in
44feeff
swap
0 ahead, 2 behind
4 files changed+18−55
since splitsnapshots
unifiedsplit
project-m36.cabal+1−1 src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+3−17 src/lib/ProjectM36/Server/Config.hs−6 src/lib/ProjectM36/Server/ParseArgs.hs+14−31
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, warp-tls
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
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+3−17
@@ -2,14 +2,11 @@
22
33import Control.Concurrent
44import Control.Exception
5−import Control.Monad (when)
6−import Data.Maybe (isJust)
75import Data.String (fromString)
86import Network.HTTP.Types (status400)
97import Network.Socket
108import Network.Wai (Application, responseLBS)
119import Network.Wai.Handler.Warp
12−import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
1310import qualified Network.Wai.Handler.WebSockets as WS
1411import Network.WebSockets (defaultConnectionOptions)
1512import ProjectM36.Server
@@ -21,20 +18,12 @@ main :: IO ()
2118main = do
2219 -- launch normal project-m36-server
2320 addressMVar <- newEmptyMVar
24− wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})
25−
21+ serverConfig <- parseConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})
2622 --usurp the serverConfig for our websocket server and make the proxied server run locally
27− let serverConfig = wsServerConfig wsConfig
28− wsHost = bindHost serverConfig
23+ let wsHost = bindHost serverConfig
2924 wsPort = bindPort serverConfig
3025 serverHost = "127.0.0.1"
3126 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−
3827 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)
3928 --wait for server to be listening
4029 addr <- takeMVar addressMVar
@@ -45,10 +34,7 @@ main = do
4534 wsApp = websocketProxyServer port serverHost
4635 waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp
4736 settings = warpSettings wsHost (fromIntegral wsPort)
48−
49− case (configCertificateFile, configKeyFile) of
50− (Just certificate, Just key) -> runTLS (tlsSettings certificate key) settings waiApp
51− _ -> runSettings settings waiApp
37+ runSettings settings waiApp
5238
5339backupApp :: Application
5440backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"
src/lib/ProjectM36/Server/Config.hs−6
@@ -12,12 +12,6 @@ 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−
2115defaultServerConfig :: ServerConfig
2216defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,
2317 checkFS = True,
src/lib/ProjectM36/Server/ParseArgs.hs+14−31
@@ -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,60 +34,43 @@ 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")
9174
9275helpOption :: Parser (a -> a)
9376helpOption = abortOption helpText $ mconcat
@@ -97,6 +80,6 @@ helpOption = abortOption helpText $ mconcat
9780 where
9881#if MIN_VERSION_optparse_applicative(0,16,0)
9982 helpText = ShowHelpText Nothing
100−#else
83+#else
10184 helpText = ShowHelpText
10285#endif