equal
deleted
inserted
replaced
1 {-# LANGUAGE CPP #-} |
1 {-# LANGUAGE CPP, PatternSignatures #-} |
|
2 |
2 module Main where |
3 module Main where |
3 |
4 |
4 import Network |
5 import Network |
5 import IO |
6 import IO |
6 import System.IO |
7 import System.IO |
7 import Control.Concurrent |
8 import Control.Concurrent |
8 import Control.Concurrent.STM |
9 import Control.Concurrent.STM |
9 import Control.Exception (handle, finally) |
10 import Control.Exception (handle, finally, Exception, IOException) |
10 import Control.Monad |
11 import Control.Monad |
11 import Maybe (fromMaybe, isJust, fromJust) |
12 import Maybe (fromMaybe, isJust, fromJust) |
12 import Data.List |
13 import Data.List |
13 import Miscutils |
14 import Miscutils |
14 import HWProto |
15 import HWProto |
36 atomically $ writeTChan messagesChan ["MINUTELY"] |
37 atomically $ writeTChan messagesChan ["MINUTELY"] |
37 |
38 |
38 socketCloseLoop :: TChan Handle -> IO() |
39 socketCloseLoop :: TChan Handle -> IO() |
39 socketCloseLoop closingChan = forever $ do |
40 socketCloseLoop closingChan = forever $ do |
40 h <- atomically $ readTChan closingChan |
41 h <- atomically $ readTChan closingChan |
41 Control.Exception.handle (const $ putStrLn "error on hClose") $ hClose h |
42 Control.Exception.handle (\(_ :: Exception) -> putStrLn "error on hClose") $ hClose h |
42 |
43 |
43 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
44 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
44 acceptLoop servSock acceptChan = |
45 acceptLoop servSock acceptChan = |
45 Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
46 Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
46 do |
47 do |
47 (cHandle, host, _) <- accept servSock |
48 (cHandle, host, _) <- accept servSock |
48 |
49 |
49 currentTime <- getCurrentTime |
50 currentTime <- getCurrentTime |
50 putStrLn $ (show currentTime) ++ " new client: " ++ host |
51 putStrLn $ (show currentTime) ++ " new client: " ++ host |
80 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
81 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
81 when (head answer == "NICK") $ putStrLn (show answer) |
82 when (head answer == "NICK") $ putStrLn (show answer) |
82 |
83 |
83 clHandles' <- forM recipients $ |
84 clHandles' <- forM recipients $ |
84 \ch -> Control.Exception.handle |
85 \ch -> Control.Exception.handle |
85 (\e -> if head answer == "BYE" then |
86 (\(e :: Exception) -> if head answer == "BYE" then |
86 return [ch] |
87 return [ch] |
87 else |
88 else |
88 atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT", show e] >> return [] -- cannot just remove |
89 atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT", show e] >> return [] -- cannot just remove |
89 ) $ |
90 ) $ |
90 do |
91 do |
129 (CoreMessage `fmap` readTChan messagesChan) |
130 (CoreMessage `fmap` readTChan messagesChan) |
130 |
131 |
131 case r of |
132 case r of |
132 Accept ci -> do |
133 Accept ci -> do |
133 let sameHostClients = filter (\cl -> host ci == host cl) clients |
134 let sameHostClients = filter (\cl -> host ci == host cl) clients |
134 let haveJustConnected = False--not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
135 let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
135 |
136 |
136 when haveJustConnected $ do |
137 when haveJustConnected $ do |
137 atomically $ do |
138 atomically $ do |
138 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
|
139 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
139 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
140 |
140 |
141 currentTime <- getCurrentTime |
141 currentTime <- getCurrentTime |
142 let newServerInfo = serverInfo{ |
142 let newServerInfo = serverInfo{ |
143 loginsNumber = loginsNumber serverInfo + 1, |
143 loginsNumber = loginsNumber serverInfo + 1, |