55 |
55 |
56 |
56 |
57 sendAnswers [] _ clients _ = return clients |
57 sendAnswers [] _ clients _ = return clients |
58 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
58 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
59 let recipients = handlesFunc client clients rooms |
59 let recipients = handlesFunc client clients rooms |
60 unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
60 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
61 |
61 |
62 clHandles' <- forM recipients $ |
62 clHandles' <- forM recipients $ |
63 \ch -> Control.Exception.handle |
63 \ch -> Control.Exception.handle |
64 (\e -> putStrLn ("handle exception: " ++ show e) >> |
64 (\e -> putStrLn ("handle exception: " ++ show e) >> |
65 if head answer == "BYE" then |
65 if head answer == "BYE" then |
80 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
80 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
81 |
81 |
82 |
82 |
83 reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
83 reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
84 reactCmd cmd client clients rooms = do |
84 reactCmd cmd client clients rooms = do |
85 putStrLn ("> " ++ show cmd) |
85 --putStrLn ("> " ++ show cmd) |
86 |
86 |
87 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
87 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
88 let mrooms = roomsFunc rooms |
88 let mrooms = roomsFunc rooms |
89 let mclients = (clientsFunc clients) |
89 let mclients = (clientsFunc clients) |
90 let mclient = fromMaybe client $ find (== client) mclients |
90 let mclient = fromMaybe client $ find (== client) mclients |
91 |
91 |
92 clientsIn <- sendAnswers answers mclient mclients mrooms |
92 clientsIn <- sendAnswers answers mclient mclients mrooms |
93 let quitClient = find forceQuit $ clientsIn |
93 let quitClient = find forceQuit $ clientsIn |
94 if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) |
94 if isJust quitClient then |
|
95 reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms |
|
96 else |
|
97 return (clientsIn, mrooms) |
95 |
98 |
96 |
99 |
97 mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
100 mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
98 mainLoop servSock acceptChan messagesChan clients rooms = do |
101 mainLoop servSock acceptChan messagesChan clients rooms = do |
99 r <- atomically $ (Accept `fmap` readTChan acceptChan) `orElse` (ClientMessage `fmap` tselect clients) `orElse` (CoreMessage `fmap` readTChan messagesChan) |
102 r <- atomically $ |
|
103 (Accept `fmap` readTChan acceptChan) `orElse` |
|
104 (ClientMessage `fmap` tselect clients) `orElse` |
|
105 (CoreMessage `fmap` readTChan messagesChan) |
100 case r of |
106 case r of |
101 Accept ci -> |
107 Accept ci -> |
102 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
108 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
103 ClientMessage (cmd, client) -> do |
109 ClientMessage (cmd, client) -> do |
104 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
110 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
105 |
111 |
106 let hadRooms = (not $ null rooms) && (null mrooms) |
112 let hadRooms = (not $ null rooms) && (null mrooms) |
107 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
113 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
108 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
114 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
109 CoreMessage msg -> if not $ null $ clients then |
115 CoreMessage msg -> |
110 do |
116 if not $ null $ clients then |
|
117 do |
111 let client = head clients -- don't care |
118 let client = head clients -- don't care |
112 (clientsIn, mrooms) <- reactCmd msg client clients rooms |
119 (clientsIn, mrooms) <- reactCmd msg client clients rooms |
113 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
120 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
114 else |
121 else |
115 mainLoop servSock acceptChan messagesChan clients rooms |
122 mainLoop servSock acceptChan messagesChan clients rooms |