git.iko.soy/project-m36
on master help sign in
switch default websocket server port to 8000
c8ffbf4AgentM
src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+3−2
compare with master
unifiedsplit
@@ -5,18 +5,19 @@ import ProjectM36.Server
5import Control.Concurrent
5import Control.Concurrent
6import qualified Network.WebSockets as WS
6import qualified Network.WebSockets as WS
7import Network.Transport.TCP (decodeEndPointAddress)
7import Network.Transport.TCP (decodeEndPointAddress)
8+import Control.Exception
8
9
9main :: IO ()
10main :: IO ()
10main = do
11main = do
11 -- launch normal project-m36-server
12 -- launch normal project-m36-server
12 addressMVar <- newEmptyMVar
13 addressMVar <- newEmptyMVar
13− serverConfig <- parseConfig
14+ serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000 })
14 --usurp the serverConfig for our websocket server and make the proxied server run locally
15 --usurp the serverConfig for our websocket server and make the proxied server run locally
15 let wsHost = bindHost serverConfig
16 let wsHost = bindHost serverConfig
16 wsPort = bindPort serverConfig
17 wsPort = bindPort serverConfig
17 serverHost = "127.0.0.1"
18 serverHost = "127.0.0.1"
18 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}
19 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}
19− _ <- forkFinally (launchServer serverConfig' (Just addressMVar)) failureHandler
20+ _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)
20 --wait for server to be listening
21 --wait for server to be listening
21 address <- takeMVar addressMVar
22 address <- takeMVar addressMVar
22 let Just (_, serverPort, _) = decodeEndPointAddress address
23 let Just (_, serverPort, _) = decodeEndPointAddress address
src/lib/ProjectM36/Server/ParseArgs.hs+22−13
@@ -5,9 +5,16 @@ import Options.Applicative
5import ProjectM36.Server.Config
5import ProjectM36.Server.Config
6import Data.Monoid
6import Data.Monoid
7
7
8−parseArgs :: Parser ServerConfig
8+parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig
9−parseArgs = ServerConfig <$> parsePersistenceStrategy <*> parseDatabaseName <*> parseHostname <*> parsePort <*> many parseGhcPkgPaths <*> parseTimeout <*> pure False
9+parseArgsWithDefaults defaults = ServerConfig <$>
10−
10+ parsePersistenceStrategy <*>
11+ parseDatabaseName <*>
12+ parseHostname (bindHost defaults) <*>
13+ parsePort (bindPort defaults) <*>
14+ many parseGhcPkgPaths <*>
15+ parseTimeout (perRequestTimeout defaults) <*>
16+ pure False
17+
11parsePersistenceStrategy :: Parser PersistenceStrategy
18parsePersistenceStrategy :: Parser PersistenceStrategy
12parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
19parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
13 MinimalPersistence <$> dbdirOpt <|>
20 MinimalPersistence <$> dbdirOpt <|>
@@ -27,27 +34,29 @@ parseDatabaseName = strOption (short 'n' <>
27 long "database" <>
34 long "database" <>
28 metavar "DATABASE_NAME")
35 metavar "DATABASE_NAME")
29
36
30−parseHostname :: Parser Hostname
37+parseHostname :: Hostname -> Parser Hostname
31−parseHostname = strOption (short 'h' <>
38+parseHostname defHostname = strOption (short 'h' <>
32 long "hostname" <>
39 long "hostname" <>
33 metavar "HOST_NAME" <>
40 metavar "HOST_NAME" <>
34− value (bindHost defaultServerConfig))
41+ value defHostname)
35
42
36−parsePort :: Parser Port
43+parsePort :: Port -> Parser Port
37−parsePort = option auto (short 'p' <>
44+parsePort defPort = option auto (short 'p' <>
38 long "port" <>
45 long "port" <>
39 metavar "PORT_NUMBER" <>
46 metavar "PORT_NUMBER" <>
40− value (bindPort defaultServerConfig))
47+ value defPort)
41
48
42parseGhcPkgPaths :: Parser String
49parseGhcPkgPaths :: Parser String
43parseGhcPkgPaths = strOption (long "ghc-pkg-dir" <>
50parseGhcPkgPaths = strOption (long "ghc-pkg-dir" <>
44 metavar "GHC_PACKAGE_DIRECTORY")
51 metavar "GHC_PACKAGE_DIRECTORY")
45
52
46−parseTimeout :: Parser Int
53+parseTimeout :: Int -> Parser Int
47−parseTimeout = option auto (long "timeout" <>
54+parseTimeout defTimeout = option auto (long "timeout" <>
48 metavar "MICROSECONDS" <>
55 metavar "MICROSECONDS" <>
49− value (perRequestTimeout defaultServerConfig))
56+ value defTimeout)
50
57
51parseConfig :: IO ServerConfig
58parseConfig :: IO ServerConfig
52−parseConfig = execParser $ info parseArgs idm
59+parseConfig = parseConfigWithDefaults defaultServerConfig
53
60
61+parseConfigWithDefaults :: ServerConfig -> IO ServerConfig
62+parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults) idm)