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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
{-# 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.Char8 as S (pack,putStr,putStrLn)
import qualified Data.ByteString.Lazy.Char8 as L
( putStrLn
, fromChunks
)
import Control.Concurrent (forkIO,killThread)
import Control.Concurrent.Async
import Control.Exception (handle,SomeException(..),finally)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Todo
import Control.Monad as Monad
import Text.XML.Stream.Parse
import Text.XML.Stream.Render
import Data.XML.Types as XML
import Network.BSD (getHostName,hostName,hostAliases)
import Data.Text.Encoding as S (decodeUtf8)
import Data.Text.Lazy.Encoding as L (decodeUtf8)
import Data.Text.Lazy (toStrict)
import GetHostByAddr
import Data.Monoid
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
data Commands = Send [XML.Event] | QuitThread
deriving Prelude.Show
getNamesForPeer :: Peer -> IO [ByteString]
getNamesForPeer LocalHost = fmap ((:[]) . S.pack) getHostName
getNamesForPeer peer@(RemotePeer addr) = do
ent <- getHostByAddr addr -- AF_UNSPEC addr
let names = hostName ent : hostAliases ent
return . map S.pack $ names
xmlifyPresenceForClient :: Presence -> IO [XML.Event]
xmlifyPresenceForClient (Presence jid stat) = do
let n = name jid
rsc = resource jid
names <- getNamesForPeer (peer jid)
let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
jidstrs = fmap (toStrict . tostr) names
return (concatMap presenceEvents jidstrs)
where
presenceEvents jidstr =
[ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat)
, EventBeginElement "show" []
, EventContent (ContentText . shw $ stat)
, EventEndElement "show"
, EventEndElement "presence"
]
typ Offline = [("type",[ContentText "unavailable"])]
typ _ = []
shw Available = "chat"
shw Away = "away"
shw Offline = "away" -- Is this right?
prefix ## name = Name name Nothing (Just prefix)
streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
greet host =
[ EventBeginDocument
, EventBeginElement (streamP "stream")
[("from",[ContentText host])
,("id",[ContentText "someid"])
,("xmlns",[ContentText "jabber:client"])
,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
,("version",[ContentText "1.0"])
]
, EventBeginElement (streamP "features") []
, EventBeginElement "bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
, EventEndElement "bind"
{-
-- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
, " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
-- , " <mechanism>DIGEST-MD5</mechanism>"
, " <mechanism>PLAIN</mechanism>"
, " </mechanisms> "
-}
, EventEndElement (streamP "features")
]
-- type Consumer i m r = forall o. ConduitM i o m r
mawait :: Monad m => MaybeT (ConduitM i o m) i
mawait = MaybeT await
elementAttrs expected (EventBeginElement name attrs)
| nameLocalName name==expected
= return attrs
elementAttrs _ _ = mzero
eventIsBeginElement (EventBeginElement _ _) = True
eventIsBeginElement _ = False
eventIsEndElement (EventEndElement _) = True
eventIsEndElement _ = False
gatherElement ::
(Monad m, MonadPlus mp) =>
Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event)
gatherElement opentag empty = gatherElement' (empty `mplus` return opentag) 1
where
gatherElement' ts cnt = do
tag <- mawait
let ts' = ts `mplus` return tag
cnt' = case () of
_ | eventIsEndElement tag -> cnt-1
_ | eventIsBeginElement tag -> cnt+1
_ -> cnt
if (cnt>0) then gatherElement' ts' cnt'
else return ts'
voidMaybeT body = (>> return ()) . runMaybeT $ body
fixMaybeT f = (>> return ()) . runMaybeT . fix $ f
fromClient :: (MonadIO m, XMPPSession session) =>
session -> TChan Commands -> Sink XML.Event m ()
fromClient session cmdChan = voidMaybeT $ do
let log = liftIO . L.putStrLn . ("client-in: " <++>)
send = liftIO . atomically . writeTChan cmdChan . Send
mawait >>= guard . (==EventBeginDocument)
log "begin-doc"
xml <- mawait
stream_attrs <- elementAttrs "stream" xml
log $ "stream " <++> bshow stream_attrs
host <- liftIO $ do
jid <- getJID session
names <- getNamesForPeer (peer jid)
return (S.decodeUtf8 . head $ names)
send $ greet host
fix $ \loop -> do
xml <- mawait
log $ bshow xml
case xml of
_ | eventIsEndElement xml -> return ()
tag@(EventBeginElement _ _) -> do
xs <- gatherElement tag Seq.empty
prettyPrint "client-in: ignoring..." (toList xs)
loop
_ -> loop
log $ "end of stream"
xml <- mawait
log $ "end-of-document: " <++> bshow xml
prettyPrint prefix xs =
liftIO $ do
S.putStrLn prefix
CL.sourceList xs $= renderBytes (def { rsPretty=True }) $$ CL.mapM_ S.putStr
toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event]
toClient pchan cmdChan = fix $ \loop -> do
event <- liftIO . atomically $
orElse (fmap Left $ readTChan pchan)
(fmap Right $ readTChan cmdChan)
case event of
Right QuitThread -> return ()
Right (Send xs) -> yield xs >> loop -- prettyPrint "client-out: " xs >> loop
Left presence -> do
xs <- liftIO $ xmlifyPresenceForClient presence
yield xs
loop
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
writer <- async ( toClient pchan cmdChan $$ renderChunks =$ snk )
finally ( src $= parseBytes def $$ fromClient session cmdChan )
$ do
atomically $ writeTChan cmdChan QuitThread
wait writer
closeSession session
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"
-- TODO
return ()
renderChunks :: (MonadUnsafeIO m, MonadIO m) => ConduitM [Event] ByteString m ()
renderChunks = fixMaybeT $ \loop -> do
xs <- mawait
lift . when (not . null $ xs) $ ( CL.sourceList xs $= renderBytes def $$ CL.mapM_ yield )
loop
|
