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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module XMPP
( module XMPPTypes
, listenForXmppClients
, listenForRemotePeers
, seekRemotePeers
, quitListening
) where
import ServerC
import XMPPTypes
import SocketLike
import ByteStringOperators
import Data.HList
import Network.Socket (Family)
import Network.BSD (PortNumber)
import Control.Concurrent.STM
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
( putStrLn
)
import Control.Concurrent (forkIO,killThread)
import Control.Exception (handle,SomeException(..),finally)
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Todo
import Control.Monad as Monad
import Text.XML.Stream.Parse
data Commands x = Send [x] | QuitThread
deriving Prelude.Show
xmlifyPresenceForClient :: Presence -> IO [x]
xmlifyPresenceForClient presence = todo
handleClient
:: (SocketLike sock, HHead l (XMPPClass session),
XMPPSession session) =>
HCons sock (HCons t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
handleClient st src snk = do
let HCons sock (HCons _ st') = st
session_factory = hHead st'
pname <- getPeerName sock
session <- newSession session_factory sock
Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
pchan <- subscribe session Nothing
cmdChan <- atomically newTChan
{-
reader <- forkIO $ do
flip ($$) snk $
handle (\(SomeException e) -> liftIO (L.putStrLn $ "quit reader via exception: "<++>bshow e) >> return ()) $
fix $ \loop -> do
event <- liftIO . atomically $
(fmap Left $ readTChan pchan)
`orElse`
(fmap Right $ readTChan cmdChan)
case event of
Left presence -> do
liftIO (L.putStrLn $ "PRESENCE: " <++> bshow presence)
-- TODO: it violates spec to send presence information before
-- a resource is bound.
-- r <- xmlifyPresenceForClient presence
-- yield r
-- -- hPutStrLn h r
-- liftIO (L.putStrLn $ "\nOUT client:\n" <++> r)
Right (Send r) ->
mapM_ yield r
-- yield r
-- -- hPutStrLn h r
loop
-}
let outgoing = do
event <- liftIO . atomically $
(fmap Left $ readTChan pchan)
`orElse`
(fmap Right $ readTChan cmdChan)
case event of
Right QuitThread -> return ()
Left presence -> do
xs <- liftIO $ xmlifyPresenceForClient presence
Monad.mapM_ yield xs
outgoing
incomming = do
mb <- await
maybe (return ())
(\packet -> do
liftIO (L.putStrLn $ "client-in: " <++> bshow packet)
incomming)
mb
sendingThread <- forkIO (outgoing $$ snk)
let quit = do
atomically $ writeTChan cmdChan QuitThread
closeSession session
-- killThread sendingThread
finally ( src $= parseBytes def $$ incomming )
quit
listenForXmppClients ::
(HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
HExtend e l1 (HCons PortNumber l), XMPPSession session) =>
Family -> e1 -> e -> l2 -> IO ServerHandle
listenForXmppClients addr_family session_factory port st = do
doServer (addr_family .*. port .*. session_factory .*. st) handleClient
listenForRemotePeers
:: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) =>
Family -> XMPPClass t -> e -> l -> IO ServerHandle
listenForRemotePeers addrfamily session_factory port st = do
putStrLn "unimplemented: listenForRemotePeers"
dummyServerHandle
-- TODO
seekRemotePeers :: XMPPConfig config =>
config -> TChan Presence -> IO ()
seekRemotePeers config chan = do
putStrLn "unimplemented: seekRemotePeers"
return ()
|
