git.iko.soy/project-m36
on master help sign in
Replace server from websockets for warp server using wai-websockets middlware
commit5b384e04a5958e7e2967ff0be8e04d7d168b93d6 authorDiogo Biazus <diogo@biazus.ca> dateSat 3 Jul 2021, 20:22 (5 years ago) parent9282cfd
2 files changed+28−9
compare with master
unifiedsplit
project-m36.cabal+1−1 src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+27−8
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
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+27−8
@@ -1,18 +1,24 @@
11{-# LANGUAGE CPP #-}
2−import ProjectM36.Server.WebSocket
3−import ProjectM36.Server.Config
4−import ProjectM36.Server.ParseArgs
5−import ProjectM36.Server
2+
63import Control.Concurrent
7−import qualified Network.WebSockets as WS
84import Control.Exception
5+import Data.String (fromString)
6+import Network.HTTP.Types (status400)
97import Network.Socket
8+import Network.Wai (Application, responseLBS)
9+import Network.Wai.Handler.Warp
10+import qualified Network.Wai.Handler.WebSockets as WS
11+import Network.WebSockets (defaultConnectionOptions)
12+import ProjectM36.Server
13+import ProjectM36.Server.Config
14+import ProjectM36.Server.ParseArgs
15+import ProjectM36.Server.WebSocket
1016
1117main :: IO ()
1218main = do
1319 -- launch normal project-m36-server
1420 addressMVar <- newEmptyMVar
15− serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })
21+ serverConfig <- parseConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})
1622 --usurp the serverConfig for our websocket server and make the proxied server run locally
1723 let wsHost = bindHost serverConfig
1824 wsPort = bindPort serverConfig
@@ -25,6 +31,19 @@ main = do
2531 case addr of
2632 SockAddrInet port' _ -> fromIntegral port'
2733 _ -> error "unsupported socket address (IPv4 only currently)"
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)
34+ wsApp = websocketProxyServer port serverHost
35+ waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp
36+ settings = warpSettings wsHost (fromIntegral wsPort)
37+ runSettings settings waiApp
38+
39+backupApp :: Application
40+backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"
3041
42+warpSettings :: HostName -> Port -> Settings
43+warpSettings host port =
44+ setHost (fromString host)
45+ . setPort port
46+ . setServerName "project-m36"
47+ . setTimeout 3600
48+ . setGracefulShutdownTimeout (Just 5)
49+ $ defaultSettings