blob: c720ea5f65e872a6156630e80958726a9fda32c7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Trans (lift)
import Control.Monad.Fix (fix)
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
-- import Control.Concurrent.STM.TChan
import Network.Socket
import XMPPTypes (withPort)
import Text.Printf
import System.Posix.Signals
import Data.Conduit
import qualified Text.XML.Stream.Render as XML
import qualified Text.XML.Stream.Parse as XML
import Server
wlog s = putStrLn s
control sv = atomically . putTMVar (serverCommand sv)
xmlStream conread conwrite = (xsrc,xsnk)
where
xsrc = src $= XML.parseBytes XML.def
xsnk = XML.renderBytes XML.def =$ snk
src = do
v <- lift conread
maybe (return ()) -- lift . wlog $ "conread: Nothing")
(\v -> yield v >> src)
v
snk = awaitForever $ lift . conwrite
forkConnection k pingflag src snk = do
forkIO $ do
src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
wlog $ "end fork: " ++ show k
return ()
monitor sv params = do
chan <- return $ serverEvent sv
fix $ \loop -> do
(k,e) <- atomically $ readTChan chan
case e of
Connection pingflag conread conwrite -> do
let (xsrc,xsnk) = xmlStream conread conwrite
forkConnection k pingflag xsrc xsnk
wlog $ tomsg k "Connection"
EOF -> wlog $ tomsg k "EOF"
HalfConnection In -> do
wlog $ tomsg k "ReadOnly"
control sv (Connect (callBackAddress k) params)
HalfConnection Out -> wlog $ tomsg k "WriteOnly"
RequiresPing -> wlog $ tomsg k "RequiresPing"
_ -> return ()
loop
where
tomsg k str = printf "%12s %s" str (show k)
data ConnectionKey
= PeerKey { callBackAddress :: SockAddr }
| ClientKey { localAddress :: SockAddr }
deriving (Show, Ord, Eq)
peerKey (sock,addr) = do
peer <- getPeerName sock
return $ PeerKey (peer `withPort` fromIntegral peerport)
clientKey (sock,addr) = return $ ClientKey addr
peerport = 5269
clientport = 5222
main = runResourceT $ do
sv <- server
lift $ do
peer_params <- return (connectionDefaults peerKey)
{ pingInterval = 2000, duplex = False }
client_params <- return $ connectionDefaults clientKey
forkIO $ monitor sv peer_params
control sv (Listen peerport peer_params)
control sv (Listen clientport client_params)
-- atomically $ newEmptyTMVar >>= readTMVar -- Wait for control-c
quitVar <- newEmptyTMVarIO
installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
installHandler sigINT (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
quitMessage <- atomically $ takeTMVar quitVar
wlog "goodbye."
return ()
|
