blob: 1de02a4b9a7f523902c0feb0d6d4a066abaf2958 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
{-# LANGUAGE OverloadedStrings #-}
module Server where
import CmdLine
import WebSockets
import SessionID
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
import Control.Concurrent.STM.TMChan
import Control.Concurrent.Async
import qualified Data.Map as M
import qualified Data.Text as T
import Control.Exception
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)
newServerState = newTVarIO M.empty
app :: ServerOpts -> TVar ServerState -> Application
app o ssv = websocketsOr WS.defaultConnectionOptions (websocketApp o ssv) webapp
where
webapp _ respond = respond $
responseLBS status400 [] "Not a WebSocket request"
websocketApp :: ServerOpts -> TVar ServerState -> WS.ServerApp
websocketApp o ssv pending_conn = do
conn <- WS.acceptRequest pending_conn
_v <- negotiateWireVersion conn
theirmode <- getMode conn
case theirmode of
InitMode _ -> user o ssv conn
ConnectMode t -> case mkSessionID (T.unpack t) of
Nothing -> error "Invalid session id!"
Just sid -> developer o ssv sid conn
user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO ()
user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> do
sendTextData conn sid
bracket (setup sid) (cleanup sid) (go logh)
where
setup sid = do
bchan <- newBroadcastTMChanIO
atomically $ modifyTVar' ssv $ M.insert sid bchan
return bchan
cleanup sid bchan = atomically $ do
closeTMChan bchan
modifyTVar' ssv $ M.delete sid
go logh bchan = do
logchan <- atomically $ dupTMChan bchan
userchan <- atomically $ dupTMChan bchan
_ <- storelog logh logchan
`concurrently` relaytouser userchan
`concurrently` relayfromuser bchan
return ()
-- 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
Nothing -> return ()
Just l -> do
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
Just l -> case loggedMessage l of
Developer m -> Just m
User _ -> Nothing
Nothing -> Nothing
developer :: ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO ()
developer o ssv sid conn = bracket setup cleanup go
where
setup = atomically $ M.lookup sid <$> readTVar ssv
cleanup _ = return ()
go Nothing = error "Invalid session id!"
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
Developer _ -> Nothing
Nothing -> Nothing
|
