89 sendAnswers answers client mclients rooms |
89 sendAnswers answers client mclients rooms |
90 where |
90 where |
91 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
91 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
92 |
92 |
93 |
93 |
94 reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
94 reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
95 reactCmd cmd client clients rooms = do |
95 reactCmd serverInfo cmd client clients rooms = do |
96 --putStrLn ("> " ++ show cmd) |
96 --putStrLn ("> " ++ show cmd) |
97 |
97 |
98 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
98 let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd |
99 let mrooms = roomsFunc rooms |
99 let mrooms = roomsFunc rooms |
100 let mclients = (clientsFunc clients) |
100 let mclients = (clientsFunc clients) |
101 let mclient = fromMaybe client $ find (== client) mclients |
101 let mclient = fromMaybe client $ find (== client) mclients |
|
102 let answers = map (\x -> x serverInfo) answerFuncs |
102 |
103 |
103 clientsIn <- sendAnswers answers mclient mclients mrooms |
104 clientsIn <- sendAnswers answers mclient mclients mrooms |
104 mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn |
105 mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn |
105 |
106 |
106 return (clientsIn, mrooms) |
107 return (clientsIn, mrooms) |
107 |
108 |
108 |
109 |
109 mainLoop :: TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
110 mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
110 mainLoop acceptChan messagesChan clients rooms = do |
111 mainLoop serverInfo acceptChan messagesChan clients rooms = do |
111 r <- atomically $ |
112 r <- atomically $ |
112 (Accept `fmap` readTChan acceptChan) `orElse` |
113 (Accept `fmap` readTChan acceptChan) `orElse` |
113 (ClientMessage `fmap` tselect clients) `orElse` |
114 (ClientMessage `fmap` tselect clients) `orElse` |
114 (CoreMessage `fmap` readTChan messagesChan) |
115 (CoreMessage `fmap` readTChan messagesChan) |
115 |
116 |
121 when haveJustConnected $ do |
122 when haveJustConnected $ do |
122 atomically $ do |
123 atomically $ do |
123 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
124 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
124 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
125 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
125 |
126 |
126 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
127 mainLoop serverInfo acceptChan messagesChan (clients ++ [ci]) rooms |
127 |
128 |
128 ClientMessage (cmd, client) -> do |
129 ClientMessage (cmd, client) -> do |
129 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
130 (clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms |
130 |
131 |
131 let hadRooms = (not $ null rooms) && (null mrooms) |
132 let hadRooms = (not $ null rooms) && (null mrooms) |
132 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
133 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
133 mainLoop acceptChan messagesChan clientsIn mrooms |
134 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
134 |
135 |
135 CoreMessage msg -> |
136 CoreMessage msg -> |
136 if not $ null $ clients then |
137 if not $ null $ clients then |
137 do |
138 do |
138 let client = head clients -- don't care |
139 let client = head clients -- don't care |
139 (clientsIn, mrooms) <- reactCmd msg client clients rooms |
140 (clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms |
140 mainLoop acceptChan messagesChan clientsIn mrooms |
141 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
141 else |
142 else |
142 mainLoop acceptChan messagesChan clients rooms |
143 mainLoop serverInfo acceptChan messagesChan clients rooms |
143 |
144 |
144 startServer :: Socket -> IO() |
145 startServer :: ServerInfo -> Socket -> IO() |
145 startServer serverSocket = do |
146 startServer serverInfo serverSocket = do |
146 acceptChan <- atomically newTChan |
147 acceptChan <- atomically newTChan |
147 forkIO $ acceptLoop serverSocket acceptChan |
148 forkIO $ acceptLoop serverSocket acceptChan |
148 |
149 |
149 messagesChan <- atomically newTChan |
150 messagesChan <- atomically newTChan |
150 forkIO $ messagesLoop messagesChan |
151 forkIO $ messagesLoop messagesChan |
151 |
152 |
152 mainLoop acceptChan messagesChan [] [] |
153 mainLoop serverInfo acceptChan messagesChan [] [] |
153 |
154 |
154 |
155 |
155 main = withSocketsDo $ do |
156 main = withSocketsDo $ do |
156 #if !defined(mingw32_HOST_OS) |
157 #if !defined(mingw32_HOST_OS) |
157 installHandler sigPIPE Ignore Nothing; |
158 installHandler sigPIPE Ignore Nothing; |
158 #endif |
159 #endif |
159 putStrLn $ "Listening on port " ++ show (listenPort globalOptions) |
160 serverInfo <- getOpts newServerInfo |
160 serverSocket <- listenOn $ PortNumber (listenPort globalOptions) |
161 |
161 startServer serverSocket `finally` sClose serverSocket |
162 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
|
163 |
|
164 serverSocket <- listenOn $ PortNumber (listenPort serverInfo) |
|
165 startServer serverInfo serverSocket `finally` sClose serverSocket |