blob: 50818dd66a5e87150f5902f1a267f71d40131d7f (
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
|
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 Server
wlog s = putStrLn s
control sv = atomically . putTMVar (serverCommand sv)
monitor sv params = do
chan <- return $ serverEvent sv
fix $ \loop -> do
(k,e) <- atomically $ readTChan chan
case e of
Connection -> 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)
{ 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
return ()
|
