git.iko.soy/project-m36
on 77cc32d help sign in
44feeff
swap
0 ahead, 8 behind
6 files changed+25−83
since splitsnapshots
unifiedsplit
.github/workflows/ci.yaml−2 docs/introduction_to_the_relational_algebra.markdown+1−1 project-m36.cabal+1−1 src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+9−42 src/lib/ProjectM36/Server/Config.hs−6 src/lib/ProjectM36/Server/ParseArgs.hs+14−31
.github/workflows/ci.yaml−2
@@ -53,8 +53,6 @@ jobs:
5353 restore-keys: |
5454 ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}
5555 ${{ runner.os }}-build-stack-${{ matrix.ghc }}
56− - name: Fix macOS cache bug
57− run: rm -rf ~/.stack/setup-exe-cache
5856 - name: Build
5957 run: stack build --ghc-options -O2 --local-bin-path out --copy-bins
6058 - name: Test
docs/introduction_to_the_relational_algebra.markdown+1−1
@@ -202,7 +202,7 @@ Join (Instructor relation)
202202
203203(Course Relation)
204204
205−|(Course Name, Course Name Type)|(Instructor Name, Instructor Name Type)|(Course Room Number, Room Number Type)|
205+|(Course Name, Course Name Type)|(Instructor, Instructor Name Type)|(Course Room Number, Room Number Type)|
206206|-------------------------------|----------------------------------|--------------------------------------|
207207|English 1|Steve|Room 104|
208208|French 2|Bob|Room 103|
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
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+9−42
@@ -1,40 +1,23 @@
11{-# LANGUAGE CPP #-}
2−
2+import ProjectM36.Server.WebSocket
3+import ProjectM36.Server.Config
4+import ProjectM36.Server.ParseArgs
5+import ProjectM36.Server
36import Control.Concurrent
7+import qualified Network.WebSockets as WS
48import Control.Exception
5−import Control.Monad (when)
6−import Data.Maybe (isJust)
7−import Data.String (fromString)
8−import Network.HTTP.Types (status400)
99import Network.Socket
10−import Network.Wai (Application, responseLBS)
11−import Network.Wai.Handler.Warp
12−import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
13−import qualified Network.Wai.Handler.WebSockets as WS
14−import Network.WebSockets (defaultConnectionOptions)
15−import ProjectM36.Server
16−import ProjectM36.Server.Config
17−import ProjectM36.Server.ParseArgs
18−import ProjectM36.Server.WebSocket
1910
2011main :: IO ()
2112main = do
2213 -- launch normal project-m36-server
2314 addressMVar <- newEmptyMVar
24− wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})
25−
15+ serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })
2616 --usurp the serverConfig for our websocket server and make the proxied server run locally
27− let serverConfig = wsServerConfig wsConfig
28− wsHost = bindHost serverConfig
17+ let wsHost = bindHost serverConfig
2918 wsPort = bindPort serverConfig
3019 serverHost = "127.0.0.1"
3120 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−
3821 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)
3922 --wait for server to be listening
4023 addr <- takeMVar addressMVar
@@ -42,22 +25,6 @@ main = do
4225 case addr of
4326 SockAddrInet port' _ -> fromIntegral port'
4427 _ -> error "unsupported socket address (IPv4 only currently)"
45− wsApp = websocketProxyServer port serverHost
46− waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp
47− 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
52−
53−backupApp :: Application
54−backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"
28+ --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces
29+ WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer port serverHost)
5530
56−warpSettings :: HostName -> Port -> Settings
57−warpSettings host port =
58− setHost (fromString host)
59− . setPort port
60− . setServerName "project-m36"
61− . setTimeout 3600
62− . setGracefulShutdownTimeout (Just 5)
63− $ defaultSettings
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