diff options
Diffstat (limited to 'KikiD/PortServer.hs')
-rw-r--r-- | KikiD/PortServer.hs | 114 |
1 files changed, 0 insertions, 114 deletions
diff --git a/KikiD/PortServer.hs b/KikiD/PortServer.hs deleted file mode 100644 index b42e340..0000000 --- a/KikiD/PortServer.hs +++ /dev/null | |||
@@ -1,114 +0,0 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE ViewPatterns #-} | ||
3 | {-# LANGUAGE BangPatterns #-} | ||
4 | module KikiD.PortServer (createTCPPortListener) where | ||
5 | |||
6 | import qualified Data.ByteString.Char8 as B | ||
7 | import Network.Socket hiding (send) | ||
8 | import Network.Socket.ByteString | ||
9 | import Data.Monoid ((<>)) | ||
10 | --import qualified Network.IRC as IRC | ||
11 | import Network.HTTP.Base (catchIO,catchIO_) | ||
12 | import Control.Concurrent.STM | ||
13 | import Control.Concurrent | ||
14 | import Control.Monad | ||
15 | import Control.Monad.Fix | ||
16 | import System.IO | ||
17 | import System.Directory (getAppUserDataDirectory) | ||
18 | import Text.Printf (printf) | ||
19 | import System.FilePath ((</>)) | ||
20 | import Control.Concurrent.STM.TBMQueue | ||
21 | import Control.Monad.Loops | ||
22 | import KikiD.Multiplex (pipeTransHookMicroseconds) | ||
23 | import Control.Exception | ||
24 | import Control.Concurrent.Async | ||
25 | import Data.Bytes.Serial as R | ||
26 | import Data.Bytes.Put as Put | ||
27 | |||
28 | import Control.Arrow (second) | ||
29 | |||
30 | |||
31 | createTCPPortListener :: Serial a => PortNumber -> B.ByteString -> Int -> Int -> Int | ||
32 | -> TBMQueue (ThreadId,TBMQueue a) -> TBMQueue a | ||
33 | -> (Handle -> TBMQueue a -> IO ()) -> IO () | ||
34 | createTCPPortListener port name delay qsize maxconns postNewTChans outq react = | ||
35 | bracket | ||
36 | -- aquire resources | ||
37 | (socket AF_INET Stream 0) | ||
38 | |||
39 | -- release resources | ||
40 | sClose | ||
41 | |||
42 | -- operate on resources | ||
43 | (\sock -> do | ||
44 | -- make socket immediately reusable - eases debugging. | ||
45 | setSocketOption sock ReuseAddr 1 | ||
46 | -- listen on TCP port 4242 | ||
47 | bindSocket sock (SockAddrInet port iNADDR_ANY) | ||
48 | -- allow a maximum of 15 outstanding connections | ||
49 | listen sock maxconns | ||
50 | sockAcceptLoop sock name delay qsize postNewTChans outq react | ||
51 | ) | ||
52 | |||
53 | sockAcceptLoop :: Serial a => Socket -> B.ByteString -> Int -> Int -> TBMQueue (ThreadId,TBMQueue a) -> TBMQueue a | ||
54 | -> (Handle -> TBMQueue a -> IO ()) -> IO () | ||
55 | sockAcceptLoop listenSock name delay qsize postNewTChans outq react = | ||
56 | whileM_ (atomically $ fmap not (isClosedTBMQueue postNewTChans)) $ do | ||
57 | -- accept one connection and handle it | ||
58 | conn@(sock,_) <- accept listenSock | ||
59 | async $ bracket (do | ||
60 | -- acquire resources | ||
61 | hdl <- socketToHandle sock ReadWriteMode | ||
62 | q <- atomically $ newTBMQueue qsize | ||
63 | thisChildOut <- atomically $ newTBMQueue qsize | ||
64 | async1 <- async (runConn hdl name q thisChildOut delay react) | ||
65 | async2 <- async (pipeTransHookMicroseconds thisChildOut outq 5000 | ||
66 | (\() -> Just) -- no translation on outgoing | ||
67 | (\m -> return ())) | ||
68 | return (hdl,q,thisChildOut,(async1,async2)) | ||
69 | ) | ||
70 | -- release resources | ||
71 | (\(hdl,q,thisChildOut,(async1,async2)) -> do | ||
72 | cancel async1 | ||
73 | cancel async2 | ||
74 | atomically $ closeTBMQueue q | ||
75 | atomically $ closeTBMQueue thisChildOut | ||
76 | hClose hdl | ||
77 | ) | ||
78 | -- run opration on async | ||
79 | (\(_,q,_,(async1,async2)) -> do | ||
80 | let tid = asyncThreadId async1 | ||
81 | atomically $ writeTBMQueue postNewTChans (tid,q) | ||
82 | --link2 async1 async2 -- Do I need this? | ||
83 | waitBoth async1 async2 | ||
84 | ) | ||
85 | |||
86 | runConn :: Serial a => Handle -> B.ByteString -> TBMQueue a -> TBMQueue a -> Int | ||
87 | -> (Handle -> TBMQueue a -> IO ()) -> IO () | ||
88 | runConn hdl name q outq delay react = do | ||
89 | --send sock (encode (Message Nothing "NOTICE" ["*", ("Hi " <> name <> "!\n")])) | ||
90 | -- B.hPutStrLn hdl (encode (Message Nothing "NOTICE" ["*", ("Hi " <> name <> "!\n")])) | ||
91 | -- OnConnect Message... | ||
92 | |||
93 | race_ | ||
94 | -- continuously read q and output to handle (socket) | ||
95 | -- to terminate thread, close q | ||
96 | (do | ||
97 | let pending = fmap not (atomically $ isEmptyTBMQueue q) | ||
98 | closed = atomically . isClosedTBMQueue $ q | ||
99 | whileM_ (fmap not closed) $ do | ||
100 | whileM_ pending $ do | ||
101 | m <- atomically (readTBMQueue q) | ||
102 | case m of | ||
103 | Just m -> B.hPutStrLn hdl (runPutS $ R.serialize m) | ||
104 | -- Nothing means the Queue is closed and empty, so dont loop | ||
105 | Nothing -> return () | ||
106 | threadDelay delay | ||
107 | --B.hPutStrLn hdl (encode (quit (Just "Bye!")) ) | ||
108 | ) | ||
109 | |||
110 | -- continuously input from handle and | ||
111 | -- send to provided outq | ||
112 | (whileM_ (atomically . fmap not $ isClosedTBMQueue outq) $ react hdl outq ) | ||
113 | |||
114 | |||