diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 4c6b30f..7dce4e5 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -1,6 +1,7 @@ module Main (main) where -import Lib +import ClassyPrelude +import Lib (runBothServers) main :: IO () -main = someFunc +main = runBothServers diff --git a/backend/jitsi-rooms.cabal b/backend/jitsi-rooms.cabal index 6e16372..e9c92d4 100644 --- a/backend/jitsi-rooms.cabal +++ b/backend/jitsi-rooms.cabal @@ -26,13 +26,22 @@ source-repository head library exposed-modules: Lib + WebServer + WebSocket other-modules: Paths_jitsi_rooms hs-source-dirs: src + default-extensions: + NoImplicitPrelude,OverloadedStrings,ImportQualifiedPost ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , classy-prelude + , http-types + , wai + , warp + , websockets default-language: Haskell2010 executable jitsi-rooms-exe @@ -41,10 +50,17 @@ executable jitsi-rooms-exe Paths_jitsi_rooms hs-source-dirs: app + default-extensions: + NoImplicitPrelude,OverloadedStrings,ImportQualifiedPost ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , classy-prelude + , http-types , jitsi-rooms + , wai + , warp + , websockets default-language: Haskell2010 test-suite jitsi-rooms-test @@ -54,8 +70,15 @@ test-suite jitsi-rooms-test Paths_jitsi_rooms hs-source-dirs: test + default-extensions: + NoImplicitPrelude,OverloadedStrings,ImportQualifiedPost ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , classy-prelude + , http-types , jitsi-rooms + , wai + , warp + , websockets default-language: Haskell2010 diff --git a/backend/package.yaml b/backend/package.yaml index 46307d1..186a455 100644 --- a/backend/package.yaml +++ b/backend/package.yaml @@ -1,14 +1,14 @@ -name: jitsi-rooms -version: 0.1.0.0 -github: "githubuser/jitsi-rooms" -license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2023 Author name here" +name: jitsi-rooms +version: 0.1.0.0 +github: "githubuser/jitsi-rooms" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2023 Author name here" extra-source-files: -- README.md -- CHANGELOG.md + - README.md + - CHANGELOG.md # Metadata used when publishing your package # synopsis: Short description of your package @@ -17,43 +17,49 @@ extra-source-files: # To avoid duplicated efforts in documentation and dealing with the # complications of embedding Haddock markup inside cabal files, it is # common to point users to the README.md file. -description: Please see the README on GitHub at +description: Please see the README on GitHub at dependencies: -- base >= 4.7 && < 5 + - base >= 4.7 && < 5 + - classy-prelude + - wai + - http-types + - warp + - websockets ghc-options: -- -Wall -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wmissing-export-lists -- -Wmissing-home-modules -- -Wpartial-fields -- -Wredundant-constraints + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wmissing-export-lists + - -Wmissing-home-modules + - -Wpartial-fields + - -Wredundant-constraints library: source-dirs: src executables: jitsi-rooms-exe: - main: Main.hs - source-dirs: app + main: Main.hs + source-dirs: app ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N + - -threaded + - -rtsopts + - -with-rtsopts=-N dependencies: - - jitsi-rooms + - jitsi-rooms tests: jitsi-rooms-test: - main: Spec.hs - source-dirs: test + main: Spec.hs + source-dirs: test ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N + - -threaded + - -rtsopts + - -with-rtsopts=-N dependencies: - - jitsi-rooms + - jitsi-rooms +default-extensions: NoImplicitPrelude,OverloadedStrings,ImportQualifiedPost diff --git a/backend/src/Lib.hs b/backend/src/Lib.hs index 58a29cb..006e912 100644 --- a/backend/src/Lib.hs +++ b/backend/src/Lib.hs @@ -1,7 +1,14 @@ module Lib - ( someFunc - ) where + ( runBothServers, + ) +where -someFunc :: IO () -someFunc = putS +import ClassyPrelude +import WebServer (runWebServer) +import WebSocket (initMVarState, runWebSocketServer) +runBothServers :: IO () +runBothServers = do + mVarState <- initMVarState + _ <- concurrently (runWebSocketServer mVarState) (runWebServer mVarState) + return () diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs new file mode 100644 index 0000000..88e228f --- /dev/null +++ b/backend/src/WebServer.hs @@ -0,0 +1,24 @@ +module WebServer (runWebServer) where + +import ClassyPrelude +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp (run) +import WebSocket (ServerState, broadcast) + +app :: MVar ServerState -> Application +app state _ respond = do + putStrLn "I've done some IO here" + currentState <- takeMVar state + broadcast "dsa" currentState + putMVar state currentState + respond $ + responseLBS + status200 + [("Content-Type", "text/plain")] + "Hello, Web!" + +runWebServer :: MVar ServerState -> IO () +runWebServer state = do + putStrLn $ "http://localhost:8080/" + run 8080 $ app state diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs new file mode 100644 index 0000000..f8da264 --- /dev/null +++ b/backend/src/WebSocket.hs @@ -0,0 +1,52 @@ +module WebSocket (broadcast, initMVarState, runWebSocketServer, ServerState, Client) where + +import ClassyPrelude +import Network.WebSockets qualified as WS + +type Client = (Text, WS.Connection) + +type ServerState = [Client] + +addClient :: Client -> ServerState -> ServerState +addClient client clients = client : clients + +removeClient :: Client -> ServerState -> ServerState +removeClient client = filter ((/= fst client) . fst) + +newServerState :: ServerState +newServerState = [] + +broadcast :: Text -> ServerState -> IO () +broadcast message clients = do + putStrLn message + forM_ clients $ \(_, conn) -> WS.sendTextData conn message + +initMVarState :: IO (MVar ServerState) +initMVarState = newMVar newServerState + +runWebSocketServer :: MVar ServerState -> IO () +runWebSocketServer state = do + WS.runServer "127.0.0.1" 9160 $ webSocketApplication state + +webSocketApplication :: MVar ServerState -> WS.ServerApp +webSocketApplication state pending = do + putStrLn "pending request" + conn <- WS.acceptRequest pending + WS.withPingThread conn 30 (return ()) $ do + msg <- WS.receiveData conn + putStrLn msg + let client = ("hall", conn) + flip finally (disconnect client) $ do + modifyMVar_ state $ \s -> do + let s' = addClient client s + return s' + forever $ do + currentMsg <- WS.receiveData conn + putStrLn currentMsg + where + disconnect client = do + putStrLn "disconnect" + modifyMVar state $ \s -> + let s' = removeClient client s + in return + (s', s') diff --git a/backend/stack.yaml b/backend/stack.yaml index 078a301..f1eab7a 100644 --- a/backend/stack.yaml +++ b/backend/stack.yaml @@ -53,7 +53,7 @@ packages: # # Require a specific version of stack, using version ranges # require-stack-version: -any # Default -# require-stack-version: ">=2.7" +# require-stack-version: ">=2.9" # # Override the architecture used by stack, especially useful on Windows # arch: i386