diff options
Diffstat (limited to 'Server.hs')
-rw-r--r-- | Server.hs | 40 |
1 files changed, 32 insertions, 8 deletions
@@ -10,6 +10,7 @@ import Log import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.WebSockets +import Network.WebSockets hiding (Message) import qualified Network.WebSockets as WS import Network.HTTP.Types import Control.Concurrent.STM @@ -23,6 +24,8 @@ import Data.Time.Clock.POSIX server :: ServerOpts -> IO () server o = run (serverPort o) . app o =<< newServerState +-- | A server is a map of sessions, each of which consists of a broadcast +-- TMChan, which both users and developers write messages to. type ServerState = M.Map SessionID (TMChan Log) newServerState :: IO (TVar ServerState) @@ -46,7 +49,8 @@ websocketApp o ssv pending_conn = do Just sid -> developer o ssv sid conn user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO () -user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> +user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> do + sendTextData conn sid bracket (setup sid) (cleanup sid) (go logh) where setup sid = do @@ -66,7 +70,14 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> `concurrently` relayfromuser bchan return () - -- Read from logchan and store each value to the log file. + -- Relay all messages from the user's websocket to the + -- broadcast channel. + relayfromuser bchan = relayFromSocket conn $ \msg -> do + print ("got from user", msg) + l <- mkLog (User msg) <$> getPOSIXTime + atomically $ writeTMChan bchan l + + -- Read from logchan and store each message to the log file. storelog logh logchan = do v <- atomically $ readTMChan logchan case v of @@ -75,6 +86,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> writeLogHandle l logh storelog logh logchan + -- Relay developer messages from the channel to the user's websocket. relaytouser userchan = relayToSocket conn $ do v <- atomically $ readTMChan userchan return $ case v of @@ -82,10 +94,6 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> Developer m -> Just m User _ -> Nothing Nothing -> Nothing - - relayfromuser bchan = relayFromSocket conn $ \msg -> do - l <- mkLog (User msg) <$> getPOSIXTime - atomically $ writeTMChan bchan l developer :: ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO () developer o ssv sid conn = bracket setup cleanup go @@ -93,8 +101,24 @@ developer o ssv sid conn = bracket setup cleanup go setup = atomically $ M.lookup sid <$> readTVar ssv cleanup _ = return () go Nothing = error "Invalid session id!" - go (Just logchan) = relayToSocket conn $ do - v <- atomically $ readTMChan logchan + go (Just bchan) = do + sendTextData conn sid + -- TODO replay backlog + devchan <- atomically $ dupTMChan bchan + _ <- relayfromdeveloper bchan + `concurrently` relaytodeveloper devchan + return () + + -- Relay all messages from the developer's websocket to the + -- broadcast channel. + relayfromdeveloper bchan = relayFromSocket conn $ \msg -> do + print ("got from developer", msg) + l <- mkLog (Developer msg) <$> getPOSIXTime + atomically $ writeTMChan bchan l + + -- Relay user messages from the channel to the developer's websocket. + relaytodeveloper devchan = relayToSocket conn $ do + v <- atomically $ readTMChan devchan return $ case v of Just l -> case loggedMessage l of User m -> Just m |