44feeff · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge pull request #297 from diogob/tls-server

Run TLS server in case certificate and key path are passed as parameters

commit44feeff60ceea2ae26b0856a91518dfaf14645aa authorAgentM <agentm@themactionfaction.com> dateFri 30 Jul 2021, 18:28 (5 years ago) parentf10d564 0471172

4 files changed+55−18

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 @@

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