blob: 37316c3253051cbe02e25462713dacb4ecbfbafb (
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
|
{-# 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 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 System.IO
import Control.Exception
import Data.Time.Clock.POSIX
server :: ServerOpts -> IO ()
server o = run (serverPort o) . app o =<< newServerState
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
print ("new connection" :: String)
conn <- WS.acceptRequest pending_conn
sendWireVersions conn
print ("new connection open" :: String)
-- wv <- negotiateWireVersion conn
-- print ("version negotiated" :: String, wv)
theirmode <- getMode conn
print ("Connected" :: String, theirmode)
case theirmode of
InitMode _ -> user o ssv conn
ConnectMode t -> case mkSessionID 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) ->
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 ()
-- Read from logchan and store each value 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
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
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
where
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
return $ case v of
Just l -> case loggedMessage l of
User m -> Just m
Developer _ -> Nothing
Nothing -> Nothing
|
