summaryrefslogtreecommitdiff
path: root/KikiD/PortServer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'KikiD/PortServer.hs')
-rw-r--r--KikiD/PortServer.hs43
1 files changed, 6 insertions, 37 deletions
diff --git a/KikiD/PortServer.hs b/KikiD/PortServer.hs
index 31101a7..b42e340 100644
--- a/KikiD/PortServer.hs
+++ b/KikiD/PortServer.hs
@@ -22,28 +22,13 @@ import Control.Monad.Loops
22import KikiD.Multiplex (pipeTransHookMicroseconds) 22import KikiD.Multiplex (pipeTransHookMicroseconds)
23import Control.Exception 23import Control.Exception
24import Control.Concurrent.Async 24import Control.Concurrent.Async
25import Data.Serialize 25import Data.Bytes.Serial as R
26import Data.Bytes.Put as Put
26 27
27import Control.Arrow (second) 28import Control.Arrow (second)
28--import qualified Merv.GetLine as MG
29 29
30{-instance Serialize IRC.Message where
31 put = putByteString . IRC.encode
32 get = do
33 x <- MG.getLine
34 case IRC.decode x of
35 Just x -> return x
36 Nothing -> fail ("IRC PARSE ERROR:'" <> B.unpack x <> "'")
37 30
38 31createTCPPortListener :: Serial a => PortNumber -> B.ByteString -> Int -> Int -> Int
39createIRCPortListener :: PortNumber -> B.ByteString -> Int -> Int -> Int
40 -> TBMQueue (ThreadId,TBMQueue IRC.Message) -> TBMQueue IRC.Message -> IO ()
41createIRCPortListener port name delay qsize maxconns postNewTChans outq =
42 createTCPPortListener port name delay qsize maxconns postNewTChans outq ircReact
43
44-}
45
46createTCPPortListener :: Serialize a => PortNumber -> B.ByteString -> Int -> Int -> Int
47 -> TBMQueue (ThreadId,TBMQueue a) -> TBMQueue a 32 -> TBMQueue (ThreadId,TBMQueue a) -> TBMQueue a
48 -> (Handle -> TBMQueue a -> IO ()) -> IO () 33 -> (Handle -> TBMQueue a -> IO ()) -> IO ()
49createTCPPortListener port name delay qsize maxconns postNewTChans outq react = 34createTCPPortListener port name delay qsize maxconns postNewTChans outq react =
@@ -65,7 +50,7 @@ createTCPPortListener port name delay qsize maxconns postNewTChans outq react =
65 sockAcceptLoop sock name delay qsize postNewTChans outq react 50 sockAcceptLoop sock name delay qsize postNewTChans outq react
66 ) 51 )
67 52
68sockAcceptLoop :: Serialize a => Socket -> B.ByteString -> Int -> Int -> TBMQueue (ThreadId,TBMQueue a) -> TBMQueue a 53sockAcceptLoop :: Serial a => Socket -> B.ByteString -> Int -> Int -> TBMQueue (ThreadId,TBMQueue a) -> TBMQueue a
69 -> (Handle -> TBMQueue a -> IO ()) -> IO () 54 -> (Handle -> TBMQueue a -> IO ()) -> IO ()
70sockAcceptLoop listenSock name delay qsize postNewTChans outq react = 55sockAcceptLoop listenSock name delay qsize postNewTChans outq react =
71 whileM_ (atomically $ fmap not (isClosedTBMQueue postNewTChans)) $ do 56 whileM_ (atomically $ fmap not (isClosedTBMQueue postNewTChans)) $ do
@@ -98,7 +83,7 @@ sockAcceptLoop listenSock name delay qsize postNewTChans outq react =
98 waitBoth async1 async2 83 waitBoth async1 async2
99 ) 84 )
100 85
101runConn :: Serialize a => Handle -> B.ByteString -> TBMQueue a -> TBMQueue a -> Int 86runConn :: Serial a => Handle -> B.ByteString -> TBMQueue a -> TBMQueue a -> Int
102 -> (Handle -> TBMQueue a -> IO ()) -> IO () 87 -> (Handle -> TBMQueue a -> IO ()) -> IO ()
103runConn hdl name q outq delay react = do 88runConn hdl name q outq delay react = do
104 --send sock (encode (Message Nothing "NOTICE" ["*", ("Hi " <> name <> "!\n")])) 89 --send sock (encode (Message Nothing "NOTICE" ["*", ("Hi " <> name <> "!\n")]))
@@ -115,7 +100,7 @@ runConn hdl name q outq delay react = do
115 whileM_ pending $ do 100 whileM_ pending $ do
116 m <- atomically (readTBMQueue q) 101 m <- atomically (readTBMQueue q)
117 case m of 102 case m of
118 Just m -> B.hPutStrLn hdl (encode m) 103 Just m -> B.hPutStrLn hdl (runPutS $ R.serialize m)
119 -- Nothing means the Queue is closed and empty, so dont loop 104 -- Nothing means the Queue is closed and empty, so dont loop
120 Nothing -> return () 105 Nothing -> return ()
121 threadDelay delay 106 threadDelay delay
@@ -127,19 +112,3 @@ runConn hdl name q outq delay react = do
127 (whileM_ (atomically . fmap not $ isClosedTBMQueue outq) $ react hdl outq ) 112 (whileM_ (atomically . fmap not $ isClosedTBMQueue outq) $ react hdl outq )
128 113
129 114
130{-
131ircReact hdl outq = do
132 line <- B.hGetLine hdl
133 -- debugging
134 dir <- getAppUserDataDirectory "merv"
135 tid <- myThreadId
136 let bQuit = (B.isPrefixOf "/quit") line
137 appendFile (dir </> "xdebug")
138 (printf "%s:%s\n(bQuit=%s) %s\n" (show tid) (show line) (show bQuit) (show $ IRC.parseMessage line))
139 -- end debugging
140 case IRC.decode line of
141 Just (IRC.msg_command -> "QUIT") -> atomically $ closeTBMQueue outq
142 Just m -> atomically $ writeTBMQueue outq m
143 Nothing | "/q" `B.isPrefixOf` line -> atomically $ closeTBMQueue outq
144 _ -> return undefined
145-}