equal
deleted
inserted
replaced
1 {-# LANGUAGE CPP, ScopedTypeVariables #-} |
1 {-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-} |
2 |
2 |
3 module Main where |
3 module Main where |
4 |
4 |
5 import Network |
5 import Network |
6 import IO |
6 import IO |
18 |
18 |
19 #if !defined(mingw32_HOST_OS) |
19 #if !defined(mingw32_HOST_OS) |
20 import System.Posix |
20 import System.Posix |
21 #endif |
21 #endif |
22 |
22 |
23 -- #define IOException Exception |
|
24 |
23 |
25 data Messages = |
24 data Messages = |
26 Accept ClientInfo |
25 Accept ClientInfo |
27 | ClientMessage ([String], ClientInfo) |
26 | ClientMessage ([String], ClientInfo) |
28 | CoreMessage [String] |
27 | CoreMessage [String] |
38 threadDelay (60 * 10^6) -- 60 seconds |
37 threadDelay (60 * 10^6) -- 60 seconds |
39 atomically $ writeTChan messagesChan ["MINUTELY"] |
38 atomically $ writeTChan messagesChan ["MINUTELY"] |
40 |
39 |
41 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
40 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
42 acceptLoop servSock acceptChan = |
41 acceptLoop servSock acceptChan = |
43 Control.Exception.handle (\(_ :: IOException) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
42 Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
44 do |
43 do |
45 (cHandle, host, _) <- accept servSock |
44 (cHandle, host, _) <- accept servSock |
46 |
45 |
47 currentTime <- getCurrentTime |
46 currentTime <- getCurrentTime |
48 putStrLn $ (show currentTime) ++ " new client: " ++ host |
47 putStrLn $ (show currentTime) ++ " new client: " ++ host |
75 |
74 |
76 clientSendLoop :: Handle -> TChan[String] -> TChan[String] -> IO() |
75 clientSendLoop :: Handle -> TChan[String] -> TChan[String] -> IO() |
77 clientSendLoop handle clChan chan = do |
76 clientSendLoop handle clChan chan = do |
78 answer <- atomically $ readTChan chan |
77 answer <- atomically $ readTChan chan |
79 doClose <- Control.Exception.handle |
78 doClose <- Control.Exception.handle |
80 (\(e :: IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
79 (\(e :: Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
81 forM_ answer (\str -> hPutStrLn handle str) |
80 forM_ answer (\str -> hPutStrLn handle str) |
82 hPutStrLn handle "" |
81 hPutStrLn handle "" |
83 hFlush handle |
82 hFlush handle |
84 return $ isQuit answer |
83 return $ isQuit answer |
85 |
84 |
86 if doClose then |
85 if doClose then |
87 Control.Exception.handle (\(_ :: IOException) -> putStrLn "error on hClose") $ hClose handle |
86 Control.Exception.handle (\(_ :: Exception) -> putStrLn "error on hClose") $ hClose handle |
88 else |
87 else |
89 clientSendLoop handle clChan chan |
88 clientSendLoop handle clChan chan |
90 |
89 |
91 where |
90 where |
92 sendQuit e = atomically $ writeTChan clChan ["QUIT", show e] |
91 sendQuit e = atomically $ writeTChan clChan ["QUIT", show e] |