summaryrefslogtreecommitdiff
path: root/dht/Presence/XMPPServer.hs
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /dht/Presence/XMPPServer.hs
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'dht/Presence/XMPPServer.hs')
-rw-r--r--dht/Presence/XMPPServer.hs1812
1 files changed, 1812 insertions, 0 deletions
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
new file mode 100644
index 00000000..fe099fb8
--- /dev/null
+++ b/dht/Presence/XMPPServer.hs
@@ -0,0 +1,1812 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiWayIf #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE TupleSections #-}
10module XMPPServer
11 ( xmppServer
12 , forkXmpp
13 , quitXmpp
14 , ClientAddress
15 , PeerAddress
16 , Local(..)
17 , Remote(..)
18 , ConnectionData(..)
19 , ConnectionType(..)
20 , MUC(..)
21 , XMPPServerParameters(..)
22 , XMPPServer
23 , classifyConnection
24 , addrToPeerKey
25 , addrFromClientKey
26 , xmppConnections
27 , xmppEventChannel
28 , StanzaWrap(..)
29 , Stanza(..)
30 , StanzaType(..)
31 , StanzaOrigin(..)
32 , cloneStanza
33 , LangSpecificMessage(..)
34 , peerKeyToText
35 , addrToText
36 , sendModifiedStanzaToPeer
37 , sendModifiedStanzaToClient
38 , presenceProbe
39 , presenceSolicitation
40 , makePresenceStanza
41 , makeInformSubscription
42 , makeRosterUpdate
43 , makeMessage
44 , JabberShow(..)
45 , Server
46 , flushPassThrough
47 , greet'
48 , (<&>)
49 ) where
50
51import ConnectionKey
52import qualified Control.Concurrent.STM.UpdateStream as Slotted
53import Nesting
54import Connection.Tcp
55import EventUtil
56import ControlMaybe
57import LockedChan
58import Connection (PeerAddress(..))
59import qualified Connection
60import Util
61import Network.Address (getBindAddress, sockAddrPort)
62
63import Debug.Trace
64import Control.Monad.Trans (lift)
65import Control.Monad.IO.Class (MonadIO, liftIO)
66import Control.Monad.Fix (fix)
67import Control.Monad
68#ifdef THREAD_DEBUG
69import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar)
70#else
71import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId)
72import GHC.Conc (labelThread)
73#endif
74import Control.Concurrent.STM
75import Data.List hiding ((\\))
76-- import Control.Concurrent.STM.TChan
77import Network.SocketLike
78import Text.Printf
79import Data.ByteString (ByteString)
80import qualified Data.ByteString.Char8 as Strict8
81-- import qualified Data.ByteString.Lazy.Char8 as Lazy8
82
83import Data.Conduit
84import qualified Data.Conduit.List as CL
85import qualified Data.Conduit.Binary as CB
86#if MIN_VERSION_conduit_extra(1,1,7)
87import Data.Conduit.ByteString.Builder (builderToByteStringFlush)
88#else
89import Data.Conduit.Blaze (builderToByteStringFlush)
90#endif
91
92import Control.Arrow
93import Control.Concurrent.STM.Util
94import DNSCache (withPort)
95import qualified Text.XML.Stream.Render as XML hiding (content)
96import qualified Text.XML.Stream.Parse as XML
97import Data.XML.Types as XML
98import Data.Maybe
99import Data.Monoid ( (<>) )
100import Data.Text (Text)
101import qualified Data.Text as Text
102import qualified Data.Map as Map
103import Data.Set (Set, (\\) )
104import qualified Data.Set as Set
105import Data.String ( IsString(..) )
106import qualified System.Random
107import Data.Void (Void)
108import DPut
109import DebugTag
110import Stanza.Build
111import Stanza.Parse
112import Stanza.Types
113import MUC
114import Chat
115
116-- peerport :: PortNumber
117-- peerport = 5269
118-- clientport :: PortNumber
119-- clientport = 5222
120
121my_uuid :: Text
122my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
123
124
125newtype Local a = Local a deriving (Eq,Ord,Show)
126newtype Remote a = Remote a deriving (Eq,Ord,Show)
127
128data XMPPServerParameters =
129 XMPPServerParameters
130 { -- | Called when a client requests a resource id. The first Maybe indicates
131 -- the name the client referred to this server by. The second Maybe is the
132 -- client's preferred resource name.
133 --
134 -- Note: The returned domain will be discarded and replaced with the result of
135 -- 'xmppTellMyNameToClient'.
136 xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
137 , -- | This should indicate the server's hostname that all client's see.
138 xmppTellMyNameToClient :: ClientAddress -> IO Text
139 , xmppTellMyNameToPeer :: Local SockAddr -> IO Text
140 , xmppTellClientHisName :: ClientAddress -> IO Text
141 , xmppTellPeerHisName :: PeerAddress -> IO Text
142 , xmppNewConnection :: SockAddr -> ConnectionData -> TChan Stanza -> IO ()
143 , xmppEOF :: SockAddr -> ConnectionData -> IO ()
144 , xmppRosterBuddies :: ClientAddress -> IO [Text]
145 , xmppRosterSubscribers :: ClientAddress -> IO [Text]
146 , xmppRosterSolicited :: ClientAddress -> IO [Text]
147 , xmppRosterOthers :: ClientAddress -> IO [Text]
148 , -- | Called when after sending a roster to a client. Usually this means
149 -- the client status should change from "available" to "interested".
150 xmppSubscribeToRoster :: ClientAddress -> IO ()
151 -- , xmppLookupClientJID :: SockAddr -> IO Text
152 , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
153 -- | Called whenever a local client's presence changes.
154 , xmppInformClientPresence :: ClientAddress -> Stanza -> IO ()
155 -- | Called whenever a remote peer's presence changes.
156 , xmppInformPeerPresence :: PeerAddress -> Stanza -> IO ()
157 , -- | Called when a remote peer requests our status.
158 xmppAnswerProbe :: PeerAddress -> Stanza -> TChan Stanza -> IO ()
159 , xmppClientSubscriptionRequest :: IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
160 , -- | Called when a remote peer sends subscription request.
161 xmppPeerSubscriptionRequest :: IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
162 , xmppClientInformSubscription :: IO () -> ClientAddress -> Stanza -> IO ()
163 , -- | Called when a remote peer informs us of our subscription status.
164 xmppPeerInformSubscription :: IO () -> PeerAddress -> Stanza -> IO ()
165 , xmppGroupChat :: Map.Map Text MUC -- Key should be lowercase identifier.
166 , xmppVerbosity :: IO Int
167 , xmppClientBind :: Maybe SockAddr
168 , xmppPeerBind :: Maybe SockAddr
169 }
170
171
172enableClientHacks ::
173 forall t a.
174 (Eq a, IsString a) =>
175 a -> t -> TChan Stanza -> IO ()
176enableClientHacks "Pidgin" version replyto = do
177 wlog "Enabling hack SimulatedChatErrors for client Pidgin"
178 donevar <- atomically newEmptyTMVar
179 sendReply donevar
180 (InternalEnableHack SimulatedChatErrors)
181 []
182 replyto
183enableClientHacks "irssi-xmpp" version replyto = do
184 wlog "Enabling hack SimulatedChatErrors for client irssi-xmpp"
185 donevar <- atomically newEmptyTMVar
186 sendReply donevar
187 (InternalEnableHack SimulatedChatErrors)
188 []
189 replyto
190enableClientHacks _ _ _ = return ()
191
192cacheMessageId :: Text -> TChan Stanza -> IO ()
193cacheMessageId id' replyto = do
194 wlog $ "Caching id " ++ Text.unpack id'
195 donevar <- atomically newEmptyTMVar
196 sendReply donevar
197 (InternalCacheId id')
198 []
199 replyto
200
201
202-- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
203-- client connection
204-- socat script to send stanza fragment
205-- copyToChannel can keep a stack of closers to append to finish-off a stanza
206-- the TMVar () from forkConnection can be passed and with a stanza to detect interruption
207
208addrToText :: SockAddr -> Text
209addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr)
210 where stripColon s = pre where (pre,_) = break (==':') s
211addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
212 where stripColon s = if null bracket then pre else pre ++ "]"
213 where
214 (pre,bracket) = break (==']') s
215
216-- Shows (as Text) the IP address associated with the given SockAddr.
217peerKeyToText :: PeerAddress -> Text
218peerKeyToText (PeerAddress addr) = addrToText addr
219
220
221wlog :: String -> IO ()
222wlog = dput XJabber
223
224wlogb :: ByteString -> IO ()
225wlogb = wlog . Strict8.unpack
226
227flushPassThrough :: Monad m => ConduitT a b m () -> ConduitT (Flush a) (Flush b) m ()
228flushPassThrough c = getZipConduit $ ZipConduit (onlyChunks .| mapOutput Chunk c) <* ZipConduit onlyFlushes
229 where
230 onlyChunks :: Monad m => ConduitT (Flush a) a m ()
231 onlyFlushes :: Monad m => ConduitT (Flush a) (Flush b) m ()
232 onlyChunks = awaitForever yieldChunk
233 onlyFlushes = awaitForever yieldFlush
234 yieldFlush Flush = yield Flush
235 yieldFlush _ = return ()
236 yieldChunk (Chunk x) = yield x
237 yieldChunk _ = return ()
238
239xmlStream :: ReadCommand -> WriteCommand -> ( ConduitT () XML.Event IO ()
240 , ConduitT (Flush XML.Event) Void IO () )
241xmlStream conread conwrite = (xsrc,xsnk)
242 where
243 xsrc = src .| XML.parseBytes XML.def
244 xsnk :: ConduitT (Flush Event) Void IO ()
245 xsnk = -- XML.renderBytes XML.def =$ snk
246 flushPassThrough (XML.renderBuilder XML.def)
247 .| builderToByteStringFlush
248 .| discardFlush
249 .| snk
250 where
251 discardFlush :: Monad m => ConduitM (Flush a) a m ()
252 discardFlush = awaitForever yieldChunk
253 yieldChunk (Chunk x) = yield x
254 yieldChunk _ = return ()
255
256 src = do
257 v <- lift conread
258 maybe (return ()) -- lift . wlog $ "conread: Nothing")
259 (yield >=> const src)
260 v
261 snk = awaitForever $ liftIO . conwrite
262
263
264type FlagCommand = STM Bool
265type ReadCommand = IO (Maybe ByteString)
266type WriteCommand = ByteString -> IO Bool
267
268cloneStanza :: StanzaWrap (LockedChan a) -> IO (StanzaWrap (LockedChan a))
269cloneStanza stanza = do
270 dupped <- cloneLChan (stanzaChan stanza)
271 return stanza { stanzaChan = dupped }
272
273copyToChannel
274 :: MonadIO m =>
275 (Event -> a) -> LockedChan a -> TVar (Maybe [Event]) -> ConduitM Event Event m ()
276copyToChannel f chan closer_stack = awaitForever copy
277 where
278 copy x = do
279 liftIO . atomically $ writeLChan chan (f x)
280 case x of
281 EventBeginDocument {} -> do
282 let clsr = closerFor x
283 liftIO . atomically $
284 modifyTVar' closer_stack (fmap (clsr:))
285 EventEndDocument {} -> do
286 liftIO . atomically $
287 modifyTVar' closer_stack (fmap (drop 1))
288 _ -> return ()
289 yield x
290
291
292prettyPrint :: ByteString -> ConduitM Event Void IO ()
293prettyPrint prefix =
294 XML.renderBytes (XML.def { XML.rsPretty=True })
295 .| CB.lines
296 .| CL.mapM_ (wlogb . (prefix <>))
297
298swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m ()
299swapNamespace old new = awaitForever (yield . swapit old new)
300
301swapit :: Text -> Text -> Event -> Event
302swapit old new (EventBeginElement n as) | nameNamespace n==Just old =
303 EventBeginElement (n { nameNamespace = Just new }) as
304swapit old new (EventEndElement n) | nameNamespace n==Just old =
305 EventEndElement (n { nameNamespace = Just new })
306swapit old new x = x
307
308-- | This is invoked by sendModifiedStanzaTo* before swapping the namespace.
309--
310-- Optionally, when the namespace is jabber:server, this will set a "whitelist"
311-- attribute on a presence tag that indicates a list of users deliminated by
312-- spaces. This is so that a server can communicate to another server which
313-- users are believed to be subscribed.
314fixHeaders :: Monad m => Stanza -> ConduitM Event Event m ()
315fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do
316 x <- await
317 maybe (return ()) f x
318 where
319 f (EventBeginElement n as) = do yield $ EventBeginElement n (update n as)
320 awaitForever yield
321 f x = yield x >> awaitForever yield
322 update n as = as3
323 where
324 as' = maybe as (setAttrib "to" as) mto
325 as'' = maybe as' (setAttrib "from" as') mfrom
326 as3 = case typ of
327 PresenceStatus {} | nameNamespace n == Just "jabber:client"
328 -> delAttrib "whitelist" as'' -- client-to-peer "whitelist" is filtered.
329 PresenceStatus {} | otherwise
330 -- peer-to-client, we may have set a list of subscribed users
331 -- to be communicated to the remote end.
332 -> case presenceWhiteList typ of
333 [] -> delAttrib "whitelist" as''
334 ws -> setAttrib "whitelist" as'' (Text.intercalate " " ws)
335 _ -> as''
336
337 setAttrib akey as aval = attr akey aval:filter ((/=akey) . fst) as
338 delAttrib akey as = filter ((/=akey) . fst) as
339
340conduitToChan
341 :: ConduitT () Event IO ()
342 -> IO (LockedChan Event, TVar (Maybe [Event]), TMVar a)
343conduitToChan c = do
344 chan <- atomically newLockedChan
345 clsrs <- atomically $ newTVar (Just [])
346 quitvar <- atomically $ newEmptyTMVar
347 forkIO $ do
348 runConduit $ c .| copyToChannel id chan clsrs .| awaitForever (const $ return ())
349 atomically $ writeTVar clsrs Nothing
350 return (chan,clsrs,quitvar)
351
352conduitToStanza
353 :: StanzaType
354 -> Maybe Text -- ^ id
355 -> Maybe Text -- ^ from
356 -> Maybe Text -- ^ to
357 -> ConduitT () Event IO ()
358 -> IO Stanza
359conduitToStanza stype mid from to c = do
360 (chan,clsrs,quitvar) <- conduitToChan c
361 return
362 Stanza { stanzaType = stype
363 , stanzaId = mid
364 , stanzaTo = to
365 , stanzaFrom = from
366 , stanzaChan = chan
367 , stanzaClosers = clsrs
368 , stanzaInterrupt = quitvar
369 , stanzaOrigin = LocalPeer
370 }
371
372
373stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
374stanzaToConduit stanza = do
375 let xchan = stanzaChan stanza
376 xfin = stanzaClosers stanza
377 rdone = stanzaInterrupt stanza
378 loop = return ()
379 xchan <- liftIO $ unlockChan xchan
380 fix $ \inner -> do
381 what <- liftIO . atomically $ foldr1 orElse
382 [readTChan xchan >>= \xml -> return $ do
383 yield xml -- atomically $ Slotted.push slots Nothing xml
384 inner
385 ,do mb <- readTVar xfin
386 cempty <- isEmptyTChan xchan
387 if isNothing mb
388 then if cempty then return loop else retry
389 else do done <- tryReadTMVar rdone
390 check (isJust done)
391 trace "todo: send closers" retry
392 ,do isEmptyTChan xchan >>= check
393 readTMVar rdone
394 return (return ())]
395 what
396
397
398sendModifiedStanzaToPeer :: Stanza -> TChan Stanza -> IO ()
399sendModifiedStanzaToPeer stanza chan = do
400 (echan,clsrs,quitvar) <- conduitToChan c
401 ioWriteChan chan
402 stanza { stanzaChan = echan
403 , stanzaClosers = clsrs
404 , stanzaInterrupt = quitvar
405 , stanzaType = processedType (stanzaType stanza)
406 -- TODO id? origin?
407 }
408 where
409 old = "jabber:client"
410 new = "jabber:server"
411 c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza
412 processedType (Error cond tag) = Error cond (swapit old new tag)
413 processedType x = x
414
415
416-- Modifies a server-to-server stanza to send it to a client. This changes the
417-- namespace and also filters some non-supported attributes. Any other
418-- modifications need to be made by the caller.
419sendModifiedStanzaToClient :: Stanza -> TChan Stanza -> IO ()
420sendModifiedStanzaToClient stanza chan = do
421 (echan,clsrs,quitvar) <- conduitToChan c
422 -- wlog $ "send-to-client " ++ show (stanzaId stanza)
423 ioWriteChan chan
424 stanza { stanzaChan = echan
425 , stanzaClosers = clsrs
426 , stanzaInterrupt = quitvar
427 , stanzaType = processedType (stanzaType stanza)
428 -- TODO id? origin?
429 }
430 where
431 old = "jabber:server"
432 new = "jabber:client"
433 c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza
434 processedType (Error cond tag) = Error cond (swapit old new tag)
435 processedType x = x
436
437
438-- id,to, and from are taken as-is from reply list
439-- todo: this should probably be restricted to IO monad
440sendReply :: (Functor m, MonadIO m) => TMVar () -> StanzaType -> [Event] -> TChan Stanza -> m ()
441sendReply donevar stype reply replychan = do
442 let stanzaTag = listToMaybe reply
443 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
444 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
445 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
446 isInternal (InternalEnableHack {}) = True
447 isInternal (InternalCacheId {}) = True
448 isInternal _ = False
449 forM_
450 (fmap (const ()) stanzaTag `mplus` guard (isInternal stype))
451 . const $ do
452 replyStanza <- liftIO . atomically $ do
453 replyChan <- newLockedChan
454 replyClsrs <- newTVar (Just [])
455 return Stanza { stanzaType = stype
456 , stanzaId = mid
457 , stanzaTo = mto -- as-is from reply list
458 , stanzaFrom = mfrom -- as-is from reply list
459 , stanzaChan = replyChan
460 , stanzaClosers = replyClsrs
461 , stanzaInterrupt = donevar
462 , stanzaOrigin = LocalPeer
463 }
464 ioWriteChan replychan replyStanza
465 void . liftIO . forkIO $ do
466 mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply
467 liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
468 -- liftIO $ wlog "finished reply stanza"
469
470
471
472{-
473C->Unrecognized <iq
474C->Unrecognized type="set"
475C->Unrecognized id="purpleae62d88f"
476C->Unrecognized xmlns="jabber:client">
477C->Unrecognized <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
478C->Unrecognized </iq>
479-}
480
481
482-- Sends all stanzas to announce channel except ping, for which it sends a pong
483-- to the output channel.
484xmppInbound :: ConnectionData
485 -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
486 -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused)
487 -> TChan Stanza -- ^ channel to announce incoming stanzas on
488 -> TChan Stanza -- ^ channel used to send stanzas
489 -> TMVar () -- ^ mvar that is filled when the connection quits
490 -> ConduitM Event o IO ()
491xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
492 withXML $ \begindoc -> do
493 when (begindoc==EventBeginDocument) $ do
494 whenJust nextElement $ \xml -> do
495 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
496 -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
497 let stream_name = lookupAttrib "to" stream_attrs
498 stream_remote = lookupAttrib "from" stream_attrs
499 -- xmpp_version = lookupAttrib "version" stream_attrs
500 liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote
501 fix $ \loop -> do
502 -- liftIO . wlog $ "waiting for stanza."
503 (chan,clsrs) <- liftIO . atomically $
504 liftM2 (,) newLockedChan (newTVar (Just []))
505 whenJust nextElement $ \stanzaTag -> do
506 stanza_lvl <- nesting
507 liftIO . atomically $ do
508 writeLChan chan stanzaTag
509 modifyTVar' clsrs (fmap (closerFor stanzaTag:))
510 copyToChannel id chan clsrs .| do
511 let mid = lookupAttrib "id" $ tagAttrs stanzaTag
512 mfrom = lookupAttrib "from" $ tagAttrs stanzaTag
513 mto = lookupAttrib "to" $ tagAttrs stanzaTag
514 dispatch <- grokStanza namespace stanzaTag
515 let unrecog = do
516 let stype = Unrecognized
517 s <- liftIO . atomically $ do
518 return Stanza
519 { stanzaType = stype
520 , stanzaId = mid
521 , stanzaTo = mto
522 , stanzaFrom = mfrom
523 , stanzaChan = chan
524 , stanzaClosers = clsrs
525 , stanzaInterrupt = donevar
526 , stanzaOrigin = mkorigin output
527 }
528 ioWriteChan stanzas s
529 you <- liftIO tellyourname
530 me <- liftIO tellmyname
531 fromMaybe unrecog $ dispatch <&> \dispatch ->
532 case dispatch of
533 -- Checking that the to-address matches this server.
534 -- Otherwise it could be a client-to-client ping or a
535 -- client-to-server for some other server.
536 -- For now, assuming its for the immediate connection.
537 Ping | mto==Just me || mto==Nothing -> do
538 let pongto = maybe you id mfrom
539 pongfrom = maybe me id mto
540 pong = makePong namespace mid pongto pongfrom
541 sendReply donevar Pong pong output
542 do -- TODO: Remove this, it is only to generate a debug print
543 ioWriteChan stanzas Stanza
544 { stanzaType = Ping
545 , stanzaId = mid
546 , stanzaTo = mto
547 , stanzaFrom = mfrom
548 , stanzaChan = chan
549 , stanzaClosers = clsrs
550 , stanzaInterrupt = donevar
551 , stanzaOrigin = mkorigin output
552 }
553 stype -> ioWriteChan stanzas Stanza
554 { stanzaType = case stype of
555 RequestResource _ rsc -> RequestResource stream_name rsc
556 _ -> stype
557 , stanzaId = mid
558 , stanzaTo = mto
559 , stanzaFrom = mfrom
560 , stanzaChan = chan
561 , stanzaClosers = clsrs
562 , stanzaInterrupt = donevar
563 , stanzaOrigin = mkorigin output
564 }
565 awaitCloser stanza_lvl
566 liftIO . atomically $ writeTVar clsrs Nothing
567 loop
568
569
570while :: IO Bool -> IO a -> IO [a]
571while cond body = do
572 b <- cond
573 if b then do x <- body
574 xs <- while cond body
575 return (x:xs)
576 else return []
577
578{-
579readUntilNothing :: TChan (Maybe x) -> IO [x]
580readUntilNothing ch = do
581 x <- atomically $ readTChan ch
582 maybe (return [])
583 (\x -> do
584 xs <- readUntilNothing ch
585 return (x:xs))
586 x
587-}
588
589streamFeatures :: Text -> [XML.Event]
590streamFeatures "jabber:client" =
591 [ EventBeginElement (streamP "features") []
592 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
593 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
594
595 {-
596 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
597 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
598 -- , " <mechanism>DIGEST-MD5</mechanism>"
599 , " <mechanism>PLAIN</mechanism>"
600 , " </mechanisms> "
601 -}
602
603 , EventEndElement (streamP "features")
604 ]
605streamFeatures "jabber:server" =
606 []
607
608
609greet' :: Text -> Text -> [XML.Event]
610greet' namespace host = EventBeginDocument : greet'' namespace host
611
612greet'' :: Text -> Text -> [Event]
613greet'' namespace host =
614 [ EventBeginElement (streamP "stream")
615 [("from",[ContentText host])
616 ,("id",[ContentText "someid"])
617 ,("xmlns",[ContentText namespace])
618 ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
619 ,("version",[ContentText "1.0"])
620 ]
621 ] ++ streamFeatures namespace
622
623consid :: Maybe Text -> [(Name, [Content])] -> [(Name, [Content])]
624consid Nothing = id
625consid (Just sid) = (("id",[ContentText sid]):)
626
627
628data XMPPState
629 = PingSlot
630 deriving (Eq,Ord)
631
632makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
633makePing namespace mid to from =
634 [ EventBeginElement (mkname namespace "iq")
635 $ (case mid of
636 Just c -> (("id",[ContentText c]):)
637 _ -> id )
638 [ ("type",[ContentText "get"])
639 , attr "to" to
640 , attr "from" from
641 ]
642 , EventBeginElement "{urn:xmpp:ping}ping" []
643 , EventEndElement "{urn:xmpp:ping}ping"
644 , EventEndElement $ mkname namespace "iq"]
645
646makeInfo :: Maybe Text -> Text -> Maybe Text -> [Event]
647makeInfo mid from mto = concat
648 [ [ EventBeginElement "{jabber:client}iq"
649 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
650 [("from", [ContentText from])
651 ,("type", [ContentText "result"])]
652 , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
653 , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
654 [("category",[ContentText "server"])
655 ,("type",[ContentText "im"])]
656 , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
657 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
658 [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
659 , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
660 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
661 [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
662 , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
663 , [] -- todo
664 , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
665 , EventEndElement "{jabber:client}iq" ]
666 ]
667
668
669makeNodeInfo :: Maybe Text -> Text -> Text -> Maybe Text -> Maybe Text-> [XML.Event]
670makeNodeInfo mid node from mto mname = concat
671 [ [ EventBeginElement "{jabber:client}iq"
672 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
673 [("from", [ContentText from])
674 ,("type", [ContentText "result"])]
675 , EventBeginElement "{http://jabber.org/protocol/disco#info}query"
676 [("node",[ContentText node])]
677 ]
678 , case mname of
679 Nothing -> []
680 Just name -> [ EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
681 [("category",[ContentText "conference"])
682 ,("type",[ContentText "text"])
683 ,("name",[ContentText name])]
684 , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
685 ]
686 , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
687 , EventEndElement "{jabber:client}iq" ]
688 ]
689
690features :: [Text] -> [XML.Event]
691features fs = do
692 t <- fs
693 [ EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
694 [("var",[ContentText t])],
695 EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
696
697makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [XML.Event] -> [XML.Event]
698makeMUCInfo mid from mto fs = concat
699 [ [ EventBeginElement "{jabber:client}iq"
700 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
701 [("from", [ContentText from])
702 ,("type", [ContentText "result"])]
703 , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
704 , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
705 [("category",[ContentText "conference"])
706 ,("type",[ContentText "text"])]
707 , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
708 {-
709 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
710 [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
711 , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
712 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
713 [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
714 , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
715 -}
716 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
717 [("var",[ContentText "http://jabber.org/protocol/muc"])]
718 , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
719 , fs
720 , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
721 , EventEndElement "{jabber:client}iq" ]
722 ]
723
724makeItemList :: Maybe Text -> [(Text,Maybe Text)] -> Text -> Maybe Text -> [Event]
725makeItemList mid items from mto = concat
726 [ [ EventBeginElement "{jabber:client}iq"
727 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
728 [("from", [ContentText from])
729 ,("type", [ContentText "result"])]
730 , EventBeginElement "{http://jabber.org/protocol/disco#items}query" []]
731 , do (jid,name) <- items
732 [ EventBeginElement "{http://jabber.org/protocol/disco#items}item"
733 $ maybe id (\n -> (("name", [ContentText n]) :)) name [ ("jid", [ContentText jid]) ],
734 EventEndElement "{http://jabber.org/protocol/disco#items}item" ]
735 , [ EventEndElement "{http://jabber.org/protocol/disco#items}query"
736 , EventEndElement "{jabber:client}iq" ]
737 ]
738
739iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
740iq_bind_reply mid jid =
741 [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
742 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
743 [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
744 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
745 , EventContent (ContentText jid)
746 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
747 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
748 , EventEndElement "{jabber:client}iq"
749
750 {-
751 -- query for client version
752 , EventBeginElement "{jabber:client}iq"
753 [ attr "to" jid
754 , attr "from" hostname
755 , attr "type" "get"
756 , attr "id" "version"]
757 , EventBeginElement "{jabber:iq:version}query" []
758 , EventEndElement "{jabber:iq:version}query"
759 , EventEndElement "{jabber:client}iq"
760 -}
761 ]
762
763iq_session_reply :: Maybe Text -> Text -> [XML.Event]
764iq_session_reply mid host =
765 -- Note: similar to Pong
766 [ EventBeginElement "{jabber:client}iq"
767 (consid mid [("from",[ContentText host])
768 ,("type",[ContentText "result"])
769 ])
770 , EventEndElement "{jabber:client}iq"
771 ]
772
773iq_service_unavailable :: Maybe Text -> Text -> XML.Name -> [XML.Event]
774iq_service_unavailable mid host {- mjid -} req =
775 [ EventBeginElement "{jabber:client}iq"
776 (consid mid [attr "type" "error"
777 ,attr "from" host])
778 , EventBeginElement req []
779 , EventEndElement req
780 , EventBeginElement "{jabber:client}error"
781 [ attr "type" "cancel"
782 , attr "code" "503" ]
783 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
784 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
785 , EventEndElement "{jabber:client}error"
786 , EventEndElement "{jabber:client}iq"
787 ]
788
789
790wrapStanzaList :: [XML.Event] -> STM [Either (StanzaWrap XML.Event) XML.Event]
791wrapStanzaList xs = do
792 wrap <- do
793 clsrs <- newTVar Nothing
794 donev <- newTMVar ()
795 return $ \ x ->
796 Stanza { stanzaType = Unrecognized
797 , stanzaId = mid
798 , stanzaTo = mto
799 , stanzaFrom = mfrom
800 , stanzaClosers = clsrs
801 , stanzaInterrupt = donev
802 , stanzaOrigin = LocalPeer
803 , stanzaChan = x
804 }
805 return $ map (Left . wrap) (take 1 xs) ++ map Right (drop 1 xs)
806 where
807 m = listToMaybe xs
808 mto = m >>= lookupAttrib "to" . tagAttrs
809 mfrom = m >>= lookupAttrib "from" . tagAttrs
810 mid = m >>= lookupAttrib "id" . tagAttrs
811
812wrapStanzaConduit :: Monad m => StanzaWrap a -> ConduitM Event (Either (StanzaWrap Event) Event) m ()
813wrapStanzaConduit stanza = do
814 mfirst <- await
815 forM_ mfirst $ \first -> do
816 yield . Left $ stanza { stanzaChan = first }
817 awaitForever $ yield . Right
818
819
820
821{-
822greet namespace =
823 [ EventBeginDocument
824 , EventBeginElement (streamP "stream")
825 [ attr "xmlns" namespace
826 , attr "version" "1.0"
827 ]
828 ]
829-}
830
831{-
832goodbye :: [XML.Event]
833goodbye =
834 [ EventEndElement (streamP "stream")
835 , EventEndDocument
836 ]
837-}
838
839simulateChatError :: StanzaError -> Maybe Text -> [Event]
840simulateChatError err mfrom =
841 [ EventBeginElement "{jabber:client}message"
842 ((maybe id (\t->(attr "from" t:)) mfrom)
843 [attr "type" "normal" ])
844 , EventBeginElement "{jabber:client}body" []
845 , EventContent $ ContentText ("/me " <> errorText err)
846 , EventEndElement "{jabber:client}body"
847 , EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
848 , EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
849 , EventBeginElement "{http://www.w3.org/1999/xhtml}p"
850 [ attr "style" "font-weight:bold; color:red"
851 ]
852 , EventContent $ ContentText ("/me " <> errorText err)
853 , EventEndElement "{http://www.w3.org/1999/xhtml}p"
854 , EventEndElement "{http://www.w3.org/1999/xhtml}body"
855 , EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
856 , EventEndElement "{jabber:client}message"
857 ]
858
859
860-- | Create a friend-request stanza.
861presenceSolicitation :: Text -- ^ JID of sender making request.
862 -> Text -- ^ JID of recipient who needs to approve it.
863 -> IO Stanza
864presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe"
865
866presenceProbe :: Text -> Text -> IO Stanza
867presenceProbe = presenceStanza PresenceRequestStatus "probe"
868
869presenceStanza :: StanzaType -> Text -> Text -> Text -> IO Stanza
870presenceStanza stanza_type type_attr me jid =
871 stanzaFromList stanza_type
872 [ EventBeginElement "{jabber:server}presence"
873 [ attr "to" jid
874 , attr "from" me
875 , attr "type" type_attr
876 ]
877 , EventEndElement "{jabber:server}presence" ]
878
879slotsToSource ::
880 Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
881 -> TVar Int
882 -> TVar (Maybe (StanzaWrap XML.Event))
883 -> TVar Bool
884 -> TMVar ()
885 -> ConduitT () (Flush XML.Event) IO ()
886slotsToSource slots nesting lastStanza needsFlush rdone =
887 fix $ \slot_src -> join . lift . atomically $ foldr1 orElse
888 [Slotted.pull slots >>= \x -> do
889 x <- case x of
890 Left wrapped -> do
891 writeTVar nesting 1
892 writeTVar lastStanza (Just wrapped)
893 return $ stanzaChan wrapped
894 Right x -> do
895 when (isEventBeginElement x)
896 $ modifyTVar' nesting (+1)
897 when (isEventEndElement x) $ do
898 n <- readTVar nesting
899 when (n==1) $ writeTVar lastStanza Nothing
900 modifyTVar' nesting (subtract 1)
901 return x
902 writeTVar needsFlush True
903 return $ do
904 -- liftIO $ wlog $ "yielding Chunk: " ++ show x
905 yield (Chunk x)
906 slot_src
907 ,do Slotted.isEmpty slots >>= check
908 readTVar needsFlush >>= check
909 writeTVar needsFlush False
910 return $ do
911 -- liftIO $ wlog "yielding Flush"
912 yield Flush
913 slot_src
914 ,readTMVar rdone >> return (return ())
915 ]
916
917forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event
918 -> XMPPServerParameters
919 -> PeerAddress -- SockAddr (XXX(what?): remote for peer, local for client)
920 -> ConnectionData
921 -> FlagCommand
922 -> ConduitT () XML.Event IO ()
923 -> ConduitT (Flush XML.Event) Void IO ()
924 -> TChan Stanza
925 -> MVar ()
926 -> IO (TChan Stanza)
927forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
928 let auxAddr = cdAddr cdta
929 clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
930 Right _ -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr)
931 , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr)
932 , ClientOrigin (ClientAddress $ peerAddress saddr))
933 Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr
934 , xmppTellPeerHisName xmpp saddr
935 , PeerOrigin saddr)
936 me <- tellmyname
937 rdone <- atomically newEmptyTMVar
938 let isStarter (Left _) = True
939 isStarter (Right e) | isEventBeginElement e = True
940 isStarter _ = False
941 isStopper (Left _) = False
942 isStopper (Right e) | isEventEndElement e = True
943 isStopper _ = False
944 slots <- atomically $ Slotted.new isStarter isStopper
945 needsFlush <- atomically $ newTVar False
946 lastStanza <- atomically $ newTVar Nothing
947 nesting <- atomically $ newTVar 0
948 let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
949 let greet_src = do
950 CL.sourceList (greet' namespace me) .| CL.map Chunk
951 yield Flush
952 slot_src = slotsToSource slots nesting lastStanza needsFlush rdone
953 -- client.PeerAddress {peerAddress = [::1]:5222}
954 let lbl n = concat [ n
955 , Text.unpack (Text.drop 7 namespace) -- "client" or "server"
956 , "."
957 , case cdProfile cdta of
958 _ | Right _ <- cdAddr cdta -> show saddr
959 "." -> show saddr
960 mytoxname -> show saddr {- TODO: remote tox peer name? -} ]
961
962 forkIO $ do myThreadId >>= flip labelThread (lbl "xmpp-post.")
963 -- This thread handles messages after they are pulled out of
964 -- the slots-queue. Hence, xmpp-post, for post- slots-queue.
965
966 -- Read all slots-queued XML events or stanzas and yield them
967 -- upstream. This should continue until the connection is
968 -- closed.
969 runConduit $ (greet_src >> slot_src) .| snk
970
971 -- Connection is now closed. Here we handle any unsent stanzas.
972 last <- atomically $ readTVar lastStanza
973 es <- while (atomically . fmap not $ Slotted.isEmpty slots)
974 (atomically . Slotted.pull $ slots)
975 let es' = mapMaybe metadata es -- We only care about full stanzas.
976 metadata (Left s) = Just s
977 metadata _ = Nothing
978 -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
979 -- and protocol violation
980 -- TODO: IDMangler can be used for better targetted error delivery.
981 let fail stanza = do
982 wlog $ "failed delivery: " ++ show (stanzaId stanza)
983 quitVar <- atomically newEmptyTMVar
984 reply <- makeErrorStanza stanza
985 tag <- stanzaFirstTag stanza
986 -- sendReply quitVar (Error RecipientUnavailable tag) reply replyto
987 replystanza <- stanzaFromList (Error RecipientUnavailable tag) reply
988 xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza
989 notError s = case stanzaType s of
990 Error {} -> False
991 _ -> True
992 -- TODO: Probably some stanzas should be queued or saved for re-connect.
993 mapM_ fail $ filter notError (maybeToList last ++ es')
994 wlog $ "end xmpp-post fork: " ++ (lbl "")
995
996 output <- atomically newTChan
997 hacks <- atomically $ newTVar Map.empty
998 msgids <- atomically $ newTVar []
999 forkIO $ do
1000 -- Here is the pre- slots-queue thread which handles messages as they
1001 -- arrive and assigns slots to them if that is appropriate.
1002
1003 -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
1004 myThreadId >>= flip labelThread (lbl "xmpp-pre.")
1005
1006 verbosity <- xmppVerbosity xmpp
1007 fix $ \loop -> do
1008 what <- atomically $ foldr1 orElse
1009 [readTChan output >>= \stanza -> return $ do
1010 wantStanzas <- getVerbose XJabber
1011 let notping f
1012 | not wantStanzas = return ()
1013 | (verbosity==1) = case stanzaType stanza of Pong -> return ()
1014 _ -> f
1015 | (verbosity>=2) = f
1016 | otherwise = return ()
1017 -- isempty <- atomically $ isEmptyTChan (stanzaChan stanza)
1018 -- kwlog $ "queuing: "++show (isempty, stanzaId stanza)
1019 notping $ do
1020 dup <- cloneStanza stanza
1021 let typ = Strict8.pack $ c ++ "<-" ++ stanzaTypeString dup ++ " "
1022 c = case auxAddr of
1023 Right _ -> "C"
1024 Left _ -> "P"
1025 wlog ""
1026 liftIO $ takeMVar pp_mvar
1027 runConduit $ stanzaToConduit dup .| prettyPrint typ
1028 liftIO $ putMVar pp_mvar ()
1029 -- wlog $ "hacks: "++show (stanzaId stanza)
1030 case stanzaType stanza of
1031 InternalEnableHack hack -> do
1032 -- wlog $ "enable hack: " ++ show hack
1033 atomically $ modifyTVar' hacks (Map.insert hack ())
1034 InternalCacheId x -> do
1035 -- wlog $ "cache id thread: " ++ show x
1036 atomically $ modifyTVar' msgids (take 3 . (x:))
1037 _ -> return ()
1038 runConduit $ stanzaToConduit stanza .| wrapStanzaConduit stanza
1039 .| awaitForever
1040 -- TODO: PresenceStatus stanzas should be pushed to appropriate slots
1041 (liftIO . atomically . Slotted.push slots Nothing)
1042 case stanzaType stanza of
1043 Error err tag | tagName tag=="{jabber:client}message" -> do
1044 wlog $ "handling Error hacks"
1045 b <- atomically $ do m <- readTVar hacks
1046 cached <- readTVar msgids
1047 fromMaybe (return False) $ stanzaId stanza <&> \id' -> do
1048 return $ Map.member SimulatedChatErrors m
1049 && elem id' cached
1050 ids <- atomically $ readTVar msgids
1051 wlog $ "ids = " ++ show (b,stanzaId stanza, ids)
1052 when b $ do
1053 let sim = simulateChatError err (stanzaFrom stanza)
1054 wlog $ "sending simulated chat for error message."
1055 runConduit $ CL.sourceList sim .| wrapStanzaConduit stanza -- not quite right, but whatever
1056 .| awaitForever
1057 (liftIO . atomically . Slotted.push slots Nothing)
1058 Error e _ -> do
1059 wlog $ "no hacks for error: " ++ show e
1060 _ -> return ()
1061 loop
1062 ,do pingflag >>= check
1063 return $ do
1064 to <- telltheirname
1065 let from = me -- Look it up from Server object
1066 -- or pass it with Connection event.
1067 mid = Just "ping"
1068 ping0 = makePing namespace mid to from
1069 ping <- atomically $ wrapStanzaList ping0
1070 mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
1071 ping
1072 wlog ""
1073 runConduit $ CL.sourceList ping0 .| prettyPrint (case auxAddr of
1074 Right _ -> "C<-Ping"
1075 Left _ -> "P<-Ping ")
1076 loop
1077 ,readTMVar rdone >> return (return ())
1078 ]
1079 what
1080 wlog $ "end xmpp-pre fork: " ++ show (lbl "")
1081 forkIO $ do
1082 myThreadId >>= flip labelThread (lbl "xmpp-reader.")
1083 -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
1084 runConduit $ src .| xmppInbound cdta clientOrServer pingflag stanzas output rdone
1085 atomically $ putTMVar rdone ()
1086 wlog $ "end reader fork: " ++ lbl ""
1087 return output
1088
1089{-
1090data Peer = Peer
1091 { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis
1092 , peerState :: TVar PeerState
1093 }
1094data PeerState
1095 = PeerPendingConnect UTCTime
1096 | PeerPendingAccept UTCTime
1097 | PeerConnected (TChan Stanza)
1098-}
1099
1100peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (PeerAddress,ConnectionData)
1101peerKey bind_addr sock = do
1102 laddr <- getSocketName sock
1103 raddr <-
1104 sIsConnected sock >>= \c ->
1105 if c then getPeerName sock -- addr is normally socketName
1106 else return laddr -- Weird hack: addr is would-be peer name
1107 -- Assume remote peers are listening on the same port that we do.
1108 let peerport = fromIntegral $ fromMaybe 5269 $ do
1109 p <- bind_addr >>= sockAddrPort
1110 guard (p /= 0) -- Make sure we never use port 0 because it is used
1111 -- to distinguish fake address connection keys.
1112 return p
1113 rname <- atomically $ newTVar Nothing
1114 -- dput XMan $ "peerKey " ++ show (PeerAddress $ raddr `withPort` peerport,laddr)
1115 return $ ( PeerAddress $ raddr `withPort` peerport
1116 , ConnectionData { cdAddr = Left (Local laddr)
1117 , cdType = XMPP
1118 , cdProfile = "."
1119 , cdRemoteName = rname } )
1120
1121clientKey :: SocketLike sock => sock -> IO (PeerAddress,ConnectionData)
1122clientKey sock = do
1123 laddr <- getSocketName sock -- [::1]:5222 bind address, same for all clients
1124 raddr <- getPeerName sock -- [::1]:????? unique key
1125 when (Just 0 == sockAddrPort raddr) $ do
1126 dput XMan $ unwords [ "BUG: XMPP Client"
1127 , show (laddr,raddr)
1128 , "is using port zero. This could interfere"
1129 , "with Tox peer sessions." ]
1130 rname <- atomically $ newTVar Nothing
1131 -- dput XMan $ "clientKey " ++ show (PeerAddress laddr,raddr)
1132 return $ ( PeerAddress raddr -- Actually a ClientAddress, but _xmpp_sv conkey type is PeerAddress.
1133 , ConnectionData { cdAddr = Right (Remote raddr) -- FIXME: This is a bad way to detect client/peer.
1134 , cdType = XMPP
1135 , cdProfile = "."
1136 , cdRemoteName = rname } )
1137
1138
1139xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
1140xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
1141 where
1142 item jid = do yield $ EventBeginElement "{jabber:iq:roster}item"
1143 ([ attr "jid" jid
1144 , attr "subscription" stype
1145 ]++if Set.member jid solicited
1146 then [attr "ask" "subscribe"]
1147 else [] )
1148 yield $ EventEndElement "{jabber:iq:roster}item"
1149
1150sendRoster ::
1151 StanzaWrap a
1152 -> XMPPServerParameters
1153 -> ClientAddress
1154 -> TChan Stanza
1155 -> IO ()
1156sendRoster query xmpp clientKey replyto = do
1157 let maddr = case stanzaOrigin query of
1158 ClientOrigin addr _ -> Just addr
1159 PeerOrigin {} -> Nothing -- remote peer requested roster?
1160 LocalPeer -> Nothing -- local peer requested roster?
1161 forM_ maddr $ \k -> do
1162 hostname <- xmppTellMyNameToClient xmpp clientKey
1163 let getlist f = do
1164 bs <- f xmpp k
1165 return (Set.fromList bs) -- js)
1166 buddies <- getlist xmppRosterBuddies
1167 subscribers <- getlist xmppRosterSubscribers
1168 solicited <- getlist xmppRosterSolicited
1169 subnone0 <- getlist xmppRosterOthers
1170 jid <- xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
1171 let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
1172 let subto = buddies \\ subscribers
1173 let subfrom = subscribers \\ buddies
1174 let subboth = Set.intersection buddies subscribers
1175 let roster = do
1176 yield $ EventBeginElement "{jabber:client}iq"
1177 (consid (stanzaId query)
1178 [ attr "to" jid
1179 , attr "type" "result" ])
1180 yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver?
1181 xmlifyRosterItems solicited "to" subto
1182 xmlifyRosterItems solicited "from" subfrom
1183 xmlifyRosterItems solicited "both" subboth
1184 xmlifyRosterItems solicited "none" subnone
1185 yield $ EventEndElement "{jabber:iq:roster}query"
1186 yield $ EventEndElement "{jabber:client}iq"
1187
1188 conduitToStanza Roster
1189 (stanzaId query)
1190 Nothing
1191 (Just jid)
1192 roster >>= ioWriteChan replyto
1193 {-
1194 let debugpresence =
1195 [ EventBeginElement "{jabber:client}presence"
1196 [ attr "from" "guest@oxio4inifatsetlx.onion"
1197 , attr "to" jid]
1198 , EventEndElement "{jabber:client}presence"
1199 ]
1200 quitvar <- atomically newEmptyTMVar
1201 sendReply quitvar Unrecognized debugpresence replyto
1202 -}
1203
1204
1205socketFromKey :: Server PeerAddress ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr)
1206socketFromKey sv (ClientAddress addr) = do
1207 map <- atomically $ readTVar (conmap sv)
1208 let mcd = Map.lookup (PeerAddress addr) map
1209 oops = Remote addr -- No connection data, so using incorrect address.
1210 case mcd of
1211 Nothing -> return oops
1212 Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd
1213
1214eventContent :: Maybe [Content] -> Text
1215eventContent cs = maybe "" (foldr1 (<>) . map content1) cs
1216 where content1 (ContentText t) = t
1217 content1 (ContentEntity t) = t
1218
1219makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event]
1220makeErrorStanza stanza = makeErrorStanza' stanza RecipientUnavailable []
1221
1222makeErrorStanza' :: StanzaFirstTag a =>
1223 StanzaWrap a -> StanzaError -> [(Name, [Content])] -> IO [Event]
1224makeErrorStanza' stanza err attrs = do
1225 startTag <- stanzaFirstTag stanza
1226 let n = tagName startTag
1227 endTag = EventEndElement n
1228 amap0 = Map.fromList (tagAttrs startTag)
1229 mto = Map.lookup "to" amap0
1230 mfrom = Map.lookup "from" amap0
1231 mtype = Map.lookup "type" amap0
1232 -- mid = Map.lookup "id" amap0
1233 amap1 = Map.alter (const mto) "from" amap0
1234 -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1
1235 amap2 = Map.alter (const mfrom) "to" amap1
1236 amap3 = Map.insert "type" [XML.ContentText "error"] amap2
1237 startTag' = EventBeginElement
1238 (tagName startTag)
1239 (Map.toList amap3)
1240 -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable
1241 errname = n { nameLocalName = "error" }
1242 -- errattrs = [attr "type" "wait"] -- "modify"]
1243 errorAttribs e xs = ys ++ xs -- todo replace instead of append
1244 where (typ,code) = xep0086 e
1245 ys = [attr "type" typ, attr "code" (Text.pack . show $ code)]
1246 errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas"
1247 , nameLocalName = errorTagLocalName err
1248 , namePrefix = Nothing }
1249 errattrs = errorAttribs err attrs
1250 {-
1251 let wlogd v s = do
1252 wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s
1253 wlogd "amap0" amap0
1254 wlogd "mto" mto
1255 wlogd "mfrom" mfrom
1256 wlogd "amap3" amap3
1257 -}
1258 if eventContent mtype=="error" then return [] else do
1259 return [ startTag'
1260 , EventBeginElement errname errattrs
1261 , EventBeginElement errorTagName []
1262 , EventEndElement errorTagName
1263 , EventEndElement errname
1264 {-
1265 , EventBeginElement "{jabber:client}body" []
1266 , EventContent (ContentText "what?")
1267 , EventEndElement "{jabber:client}body"
1268 -}
1269 {-
1270 , EventBeginElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy" []
1271 , EventEndElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy"
1272 -}
1273 , endTag
1274 ]
1275
1276monitor ::
1277 Server PeerAddress ConnectionData releaseKey XML.Event
1278 -> ConnectionParameters PeerAddress ConnectionData
1279 -> XMPPServerParameters
1280 -> IO b
1281monitor sv params xmpp = do
1282 chan <- return $ serverEvent sv
1283 stanzas <- atomically newTChan
1284 quitVar <- atomically newEmptyTMVar
1285 pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log.
1286 joined_rooms <- atomically
1287 $ newTVar (Map.empty :: Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
1288 fix $ \loop -> do
1289 action <- atomically $ foldr1 orElse
1290 [ readTChan chan >>= \((addr,u),e) -> return $ do
1291 case e of
1292 Connection pingflag xsrc xsnk
1293 -> do wlog $ tomsg addr "Connection"
1294 outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar
1295 -- /addr/ may be a peer or a client. So we'll strip off
1296 -- the PeerAddress constructor before exposing it.
1297 xmppNewConnection xmpp (peerAddress addr) u outs
1298 ConnectFailure addr
1299 -> do return () -- wlog $ tomsg k "ConnectFailure"
1300 EOF -> do wlog $ tomsg addr "EOF"
1301 -- /addr/ may be a peer or a client. So we'll strip off
1302 -- the PeerAddress constructor before exposing it.
1303 xmppEOF xmpp (peerAddress addr) u
1304 HalfConnection In
1305 -> do wlog $ tomsg addr "ReadOnly"
1306 case cdAddr u of
1307 Left (Local _) -> control sv (Connect (peerAddress addr) params)
1308 _ -> return () -- Don't call-back client connections.
1309 HalfConnection Out
1310 -> do wlog $ tomsg addr "WriteOnly"
1311 RequiresPing
1312 -> do return () -- wlog $ tomsg k "RequiresPing"
1313 , readTChan stanzas >>= \stanza -> return $ do
1314 {-
1315 dup <- case stanzaType stanza of
1316 -- Must dup anything that is going to be delivered...
1317 Message {} -> do
1318 dup <- cloneStanza stanza -- dupped so we can make debug print
1319 return dup
1320 Error {} -> do
1321 dup <- cloneStanza stanza -- dupped so we can make debug print
1322 return dup
1323 _ -> return stanza
1324 -}
1325 dup <- cloneStanza stanza
1326
1327 t <- forkIO $ do applyStanza sv joined_rooms quitVar xmpp stanza
1328 forwardStanza quitVar xmpp stanza
1329 labelThread t $ "process." ++ stanzaTypeString stanza
1330
1331 -- We need to clone in the case the stanza is passed on as for Message.
1332 wantStanzas <- getVerbose XJabber
1333 verbosity <- xmppVerbosity xmpp
1334 let notping f | not wantStanzas = return ()
1335 | (verbosity==1) = case stanzaType stanza of Pong -> return ()
1336 _ -> f
1337 | (verbosity>=2) = f
1338 | otherwise = return ()
1339 notping $ do
1340 let typ = Strict8.pack $ c ++ "->" ++ stanzaTypeString stanza ++ " "
1341 c = case stanzaOrigin stanza of
1342 LocalPeer -> "*"
1343 ClientOrigin {} -> "C"
1344 PeerOrigin {} -> "P"
1345 wlog ""
1346 liftIO $ takeMVar pp_mvar
1347 runConduit $ stanzaToConduit dup .| prettyPrint typ
1348 liftIO $ putMVar pp_mvar ()
1349 , do
1350 m <- readTVar joined_rooms
1351 foldr orElse retry $ (`map` (do (k,rs) <- Map.toList m
1352 i <- Map.toList rs
1353 return (k,i)))
1354 $ \(k,((rkey,muckey),(replyto,r))) -> do
1355 (mine,ChatTransaction no cjid cnick es) <- readRoom k r
1356 return $ do
1357 me <- xmppTellMyNameToClient xmpp k
1358 dput XJabber $ "CHAT " ++ Text.unpack rkey ++ ": <" ++ Text.unpack cnick ++ "> " ++ show es
1359 forM_ es $ \case
1360 Join | mine -> sendRoomOccupants muckey me cnick rkey r replyto
1361 Join -> do
1362 stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Available
1363 [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
1364 , EventEndElement "{http://jabber.org/protocol/muc#user}x"
1365 ]
1366 ioWriteChan replyto stanza
1367 Part -> do
1368 stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Offline
1369 $ [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] ]
1370 ++ (do guard mine
1371 [ EventBeginElement "{http://jabber.org/protocol/muc#user}status"
1372 [ ("code",[ContentText "110"]) -- self-presence code.
1373 ]
1374 , EventEndElement "{http://jabber.org/protocol/muc#user}status" ])
1375 ++ [ EventEndElement "{http://jabber.org/protocol/muc#user}x" ]
1376 ioWriteChan replyto stanza
1377 when mine $ atomically $ do
1378 jrs <- readTVar joined_rooms
1379 let m = Map.findWithDefault Map.empty k jrs
1380 m' = Map.delete (rkey,muckey) m
1381 jrs' = if Map.null m' then Map.delete k jrs
1382 else Map.insert k m' jrs
1383 writeTVar joined_rooms jrs'
1384 Talk talk -> do
1385 them <- xmppTellClientHisName xmpp k
1386 stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk
1387 ioWriteChan replyto stanza
1388 return ()
1389 _ -> return ()
1390 ]
1391 action
1392 loop
1393 where
1394 tomsg k str = printf "%12s %s" str (show k)
1395 where
1396 _ = str :: String
1397
1398roomjid :: Text {- ^ service -} -> Text {- ^ hostname -} -> Text {- ^ room -} -> Text {- ^ nick -} -> Text
1399roomjid a me room n = room <> "@" <> a <> "." <> me <> "/" <> n
1400
1401sendRoomOccupants :: Text -> Text -> Text -> Text -> JoinedRoom k -> TChan Stanza -> IO ()
1402sendRoomOccupants a me them room r replyto = do
1403 xs <- map (\(n,m) -> (roomjid a me room n, m))
1404 <$> atomically (roomOccupants $ joinedRoom r)
1405 let (ys,xs') = partition (\(jid,_) -> jid == roomjid a me room them) xs
1406 forM_ xs $ \(jid,_) -> do
1407 stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
1408 [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
1409 , EventEndElement "{http://jabber.org/protocol/muc#user}x"
1410 ]
1411 ioWriteChan replyto stanza
1412 forM_ ys $ \(jid,_) -> do
1413 stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
1414 [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
1415 , EventBeginElement "{http://jabber.org/protocol/muc#user}status"
1416 [ ("code",[ContentText "110"]) -- self-presence code.
1417 ]
1418 , EventEndElement "{http://jabber.org/protocol/muc#user}status"
1419 , EventEndElement "{http://jabber.org/protocol/muc#user}x"
1420 ]
1421 ioWriteChan replyto stanza
1422
1423
1424stanzaTypeString :: StanzaWrap a -> String
1425stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza)
1426
1427data ServiceMatch a
1428 = NotMe -- ^ Hostname of another server.
1429 | UnknownService Text -- ^ Unknown subdomain of this host.
1430 | Service (Maybe Text) Text a -- ^ A known subdomain of this host. Optionally, a specific room name.
1431 | TopLevelService -- ^ This server's exact hostname.
1432
1433
1434lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a)
1435lookupService me mucs to = case Text.toLower to of
1436 nm | nm == Text.toLower me
1437 -> TopLevelService
1438 nm | let (a,hostname) = second (Text.drop 1) $ Text.break (=='@') nm
1439 (service,b) = Text.break (=='.') $ if Text.null hostname then a else hostname
1440 , Text.drop 1 b == Text.toLower me
1441 -> case Map.lookup service mucs of
1442 Just muc -> Service (if Text.null hostname then Nothing else Just a) service muc
1443 Nothing -> UnknownService service
1444 _ -> NotMe
1445
1446applyStanza :: Server PeerAddress ConnectionData releaseKey Event
1447 -> TVar (Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
1448 -> TMVar ()
1449 -> XMPPServerParameters
1450 -> StanzaWrap (LockedChan Event)
1451 -> IO ()
1452
1453applyStanza sv joined_rooms quitVar xmpp stanza = do
1454 dput XJabber $ "applyStanza: " ++ show (stanzaType stanza)
1455 case stanzaOrigin stanza of
1456 ClientOrigin k replyto ->
1457 case stanzaType stanza of
1458 RequestResource clientsNameForMe wanted -> do
1459 sockaddr <- socketFromKey sv k
1460 rsc0 <- xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted
1461 hostname <- xmppTellMyNameToClient xmpp k
1462 let rsc = unsplitJID (n,hostname,r) where (n,_,r) = splitJID rsc0
1463 let reply = iq_bind_reply (stanzaId stanza) rsc
1464 -- sendReply quitVar SetResource reply replyto
1465 let requestVersion :: ConduitT i XML.Event IO ()
1466 requestVersion = do
1467 yield $ EventBeginElement "{jabber:client}iq"
1468 [ attr "to" rsc
1469 , attr "from" hostname
1470 , attr "type" "get"
1471 , attr "id" "version"]
1472 yield $ EventBeginElement "{jabber:iq:version}query" []
1473 yield $ EventEndElement "{jabber:iq:version}query"
1474 yield $ EventEndElement "{jabber:client}iq"
1475 {-
1476 -- XXX Debug chat:
1477 yield $ EventBeginElement "{jabber:client}message"
1478 [ attr "from" $ eventContent (Just [ContentText rsc])
1479 , attr "type" "normal" ] -- "blackbird" ]
1480 yield $ EventBeginElement "{jabber:client}body" []
1481 yield $ EventContent $ ContentText ("hello?")
1482 yield $ EventEndElement "{jabber:client}body"
1483 yield $ EventEndElement "{jabber:client}message"
1484 -}
1485 sendReply quitVar SetResource reply replyto
1486 conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
1487 Nothing -- id
1488 (Just hostname) -- from
1489 (Just rsc) -- to
1490 requestVersion
1491 >>= ioWriteChan replyto
1492 SessionRequest -> do
1493 me <- xmppTellMyNameToClient xmpp k
1494 let reply = iq_session_reply (stanzaId stanza) me
1495 sendReply quitVar Pong reply replyto
1496 RequestRoster -> do
1497 sendRoster stanza xmpp k replyto
1498 xmppSubscribeToRoster xmpp k
1499 PresenceStatus {} -> do
1500 let mucs = xmppGroupChat xmpp
1501 me <- xmppTellMyNameToClient xmpp k
1502 if | Just to <- stanzaTo stanza
1503 , (Just room,h,mnick) <- splitJID to
1504 , let roomjid = unsplitJID ((Just room,h,Nothing))
1505 , Service (Just _) mucname muc <- lookupService me mucs roomjid
1506 -> case mnick of
1507 Nothing -> do
1508 -- Missing nick.
1509 reply <- makeErrorStanza' stanza JidMalformed
1510 [ ("by", [ContentText roomjid]) ]
1511 sendReply quitVar (Error JidMalformed (head reply)) reply replyto
1512 Just nick -> case presenceShow (stanzaType stanza) of
1513 Offline -> do
1514 jid <- xmppTellClientHisName xmpp k
1515 atomically $ do
1516 jrs <- readTVar joined_rooms
1517 let m = Map.findWithDefault Map.empty k jrs
1518 case Map.lookup (room,mucname) m of
1519 Just (_,r) -> do
1520 partRoom r (Just jid) -- joinedNick r == nick
1521 {-
1522 let m' = Map.delete (room,mucname) m
1523 jrs' = if Map.null m' then Map.delete k jrs
1524 else Map.insert k m' jrs
1525 writeTVar joined_rooms jrs'
1526 -}
1527 _ -> return ()
1528 -- Anything other than type="unavailable" is treated as a join.
1529 _ -> do
1530 jid <- xmppTellClientHisName xmpp k
1531 join $ atomically $ do
1532 jrs <- readTVar joined_rooms
1533 let m = Map.findWithDefault Map.empty k jrs
1534 case Map.lookup (room,mucname) m of
1535 Nothing -> do r <- mucJoinRoom muc jid nick room k -- stanza
1536 jrs <- readTVar joined_rooms
1537 let m = Map.findWithDefault Map.empty k jrs
1538 writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs
1539 return $ return ()
1540 Just r -> return $ dput XJabber "MUC: already joined."
1541 | otherwise -> do
1542 -- Handle presence stanza that is not a chatroom join.
1543 xmppInformClientPresence xmpp k stanza
1544 PresenceRequestSubscription {} -> do
1545 let fail = return () -- todo
1546 xmppClientSubscriptionRequest xmpp fail k stanza replyto
1547 PresenceInformSubscription {} -> do
1548 let fail = return () -- todo
1549 xmppClientInformSubscription xmpp fail k stanza
1550 NotifyClientVersion name version -> do
1551 enableClientHacks name version replyto
1552 RequestInfo mnode -> do
1553 me <- xmppTellMyNameToClient xmpp k
1554 let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
1555 reply = iq_service_unavailable (stanzaId stanza) me query
1556 in return (Error ServiceUnavailable (head reply), reply)
1557 sto = fromMaybe me (stanzaTo stanza)
1558 (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of
1559 NotMe -> unavail
1560 (UnknownService a) -> unavail -- TODO ItemNotFound instead?
1561 (Service Nothing a muc)
1562 -> case mnode of
1563 Just _ -> unavail
1564 Nothing -> let reply = makeMUCInfo (stanzaId stanza) (a <> "." <> me) (stanzaFrom stanza) []
1565 in return (Info, reply)
1566 (Service (Just room) a muc) | Nothing <- mnode
1567 -> let reply = makeMUCInfo (stanzaId stanza) (room <> "@" <> a <> "." <> me) (stanzaFrom stanza)
1568 $ features
1569 [ "http://jabber.org/protocol/muc#stable_id" ]
1570 in return (Info, reply)
1571 (Service (Just room) a muc) | Just "x-roomuser-item" <- mnode
1572 -> do
1573 mgetnick <- mucReservedNick muc room
1574 case mgetnick of
1575 Nothing -> do
1576 reply <- makeErrorStanza' stanza FeatureNotImplemented
1577 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1578 return (Error FeatureNotImplemented (head reply), reply)
1579 Just getnick -> do
1580 who <- xmppTellClientHisName xmpp k
1581 n <- getnick who
1582 let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me)
1583 (stanzaFrom stanza) n
1584 return (Info, reply)
1585 (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#traffic" <- mnode
1586 -> do
1587 dput XJabber $ "TODO: 18.1.1 Allowable Traffic"
1588 reply <- makeErrorStanza' stanza FeatureNotImplemented
1589 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1590 return (Error FeatureNotImplemented (head reply), reply)
1591 (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#rooms" <- mnode
1592 -> do
1593 dput XJabber $ "TODO: 6.7 Discovering Client Support for MUC"
1594 reply <- makeErrorStanza' stanza FeatureNotImplemented
1595 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1596 return (Error FeatureNotImplemented (head reply), reply)
1597 (Service (Just room) a muc) | Just nodename <- mnode
1598 -> do
1599 dput XJabber $ "Uknown info node: " ++ Text.unpack nodename
1600 reply <- makeErrorStanza' stanza FeatureNotImplemented
1601 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1602 return (Error FeatureNotImplemented (head reply), reply)
1603 TopLevelService
1604 -> case mnode of
1605 Just _ -> unavail
1606 Nothing -> let reply = makeInfo (stanzaId stanza) me (stanzaFrom stanza)
1607 in return (Info, reply)
1608 sendReply quitVar rtyp reply replyto
1609 RequestItems mnode -> do
1610 -- let query = "{http://jabber.org/protocol/disco#items}query"
1611 me <- xmppTellMyNameToClient xmpp k
1612 let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
1613 reply = iq_service_unavailable (stanzaId stanza) me query
1614 in return (Error ServiceUnavailable (head reply), reply)
1615 sto = fromMaybe me (stanzaTo stanza)
1616 (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of
1617 NotMe -> unavail
1618 (UnknownService a) -> unavail -- TODO ItemNotFound instead?
1619 (Service Nothing a muc) -> do
1620 items <- map (\(n,m) -> (n <> "@" <> a <> "." <> me, m))
1621 <$> mucRoomList muc
1622 let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
1623 return (Items, reply)
1624 (Service (Just room) a muc) -> do
1625 items <- map (\(n,m) -> (room <> "@" <> a <> "." <> me <> "/" <> n, m))
1626 <$> mucRoomOccupants muc room
1627 -- Note: I'm assuming 'mucRoomOccupants' returns an empty list for
1628 -- private rooms.
1629 let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
1630 return (Items, reply)
1631 TopLevelService -> do
1632 let items = do (name,MUC {}) <- Map.toList $ xmppGroupChat xmpp
1633 return (name <> "." <> me, Nothing)
1634 reply = makeItemList (stanzaId stanza) items me (stanzaFrom stanza)
1635 return (Items, reply)
1636 sendReply quitVar rtyp reply replyto
1637 UnrecognizedQuery query -> do
1638 me <- xmppTellMyNameToClient xmpp k
1639 let reply = iq_service_unavailable (stanzaId stanza) me query
1640 sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
1641 Message { msgType = GroupChatMsg } -> do
1642 let mucs = xmppGroupChat xmpp
1643 me <- xmppTellMyNameToClient xmpp k
1644 if | Just to <- stanzaTo stanza
1645 , (Just room,h,mnick) <- splitJID to
1646 , let roomjid = unsplitJID ((Just room,h,Nothing))
1647 , Service (Just _) mucname muc <- lookupService me mucs roomjid
1648 -> case mnick of
1649 Nothing -> do
1650 -- Send message.
1651 jid <- xmppTellClientHisName xmpp k -- This should match stanzaFrom
1652 join $ atomically $ do
1653 jrs <- readTVar joined_rooms
1654 let m = Map.findWithDefault Map.empty k jrs
1655 case Map.lookup (room,mucname) m of
1656 Just (_,r) -> do
1657 let RH v = roomHandle r
1658 oldt <- readTVar v
1659 expected <- readTVar (roomFutureSeqNo $ joinedRoom r)
1660 b <- sendChat r (Just jid) $ do
1661 (_,msg) <- msgLangMap (stanzaType stanza)
1662 talk <- maybeToList $ msgBody msg
1663 [ Talk talk ]
1664 return $ dput XJabber $ "sendChat: " ++ show (b,expected,oldt,msgLangMap (stanzaType stanza))
1665 _ -> return $ dput XJabber $ "uknown room" ++ show (room,mucname)
1666 Just nick -> do
1667 -- Private message. TODO
1668 dput XJabber $ "TODO: Private messasge. " ++ show nick
1669
1670 | otherwise -> dput XJabber $ "Failed groupchat parse. to=" ++ show (stanzaTo stanza)
1671 Message {} -> do
1672 -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza))
1673 maybe (return ()) (flip cacheMessageId replyto) $ do
1674 guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
1675 stanzaId stanza
1676 _ -> return ()
1677 PeerOrigin k replyto ->
1678 case stanzaType stanza of
1679 PresenceRequestStatus {} -> do
1680 xmppAnswerProbe xmpp k stanza replyto
1681 PresenceStatus {} -> do
1682 xmppInformPeerPresence xmpp k stanza
1683 PresenceRequestSubscription {} -> do
1684 let fail = return () -- todo
1685 xmppPeerSubscriptionRequest xmpp fail k stanza replyto
1686 PresenceInformSubscription {} -> do
1687 let fail = return () -- todo
1688 xmppPeerInformSubscription xmpp fail k stanza
1689 _ -> return ()
1690 _ -> return ()
1691
1692forwardStanza :: TMVar () -> XMPPServerParameters -> StanzaWrap (LockedChan Event) -> IO ()
1693forwardStanza quitVar xmpp stanza = do
1694 let deliver replyto = do
1695 -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
1696 -- and protocol violation
1697 let fail = do
1698 wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
1699 reply <- makeErrorStanza stanza
1700 tag <- stanzaFirstTag stanza
1701 sendReply quitVar (Error RecipientUnavailable tag) reply replyto
1702 xmppDeliverMessage xmpp fail stanza
1703 -- -- bad idea:
1704 -- let newStream = greet'' "jabber:client" "blackbird"
1705 -- sendReply quitVar Error newStream replyto
1706 case stanzaType stanza of
1707 Message { msgType = GroupChatMsg } -> return () -- Group chat handled elsewhere.
1708 Message {} -> do
1709 case stanzaOrigin stanza of
1710 LocalPeer {} -> return ()
1711 ClientOrigin _ replyto -> deliver replyto
1712 PeerOrigin _ replyto -> deliver replyto
1713 Error {} -> do
1714 case stanzaOrigin stanza of
1715 LocalPeer {} -> return ()
1716 ClientOrigin _ replyto -> deliver replyto
1717 PeerOrigin _ replyto -> deliver replyto
1718 _ -> return ()
1719
1720data ConnectionType = XMPP | Tox
1721 deriving (Eq,Ord,Enum,Show,Read)
1722
1723data ConnectionData = ConnectionData
1724 { cdAddr :: Either (Local SockAddr) -- Peer connection local address
1725 (Remote SockAddr) -- unused, todo:remove. (was client connection remote address).
1726 , cdType :: ConnectionType
1727 , cdProfile :: Text -- Currently ignored for clients. Instead, see
1728 -- 'clientProfile' field of 'ClientState'.
1729 --
1730 -- For peers: "." for XMPP, otherwise the ".tox" hostname
1731 -- of this local node.
1732
1733 -- Initially Nothing, when the remote end identifies itself by a given name,
1734 -- the result will be stored here.
1735 , cdRemoteName :: TVar (Maybe Text)
1736 }
1737
1738addrToPeerKey :: Remote SockAddr -> PeerAddress
1739addrToPeerKey (Remote raddr) = PeerAddress raddr
1740
1741addrFromClientKey :: ClientAddress -> Local SockAddr
1742addrFromClientKey (ClientAddress laddr) = Local laddr
1743
1744classifyConnection :: SockAddr -> ConnectionData -> Either (PeerAddress, Local SockAddr)
1745 (ClientAddress, Remote SockAddr)
1746classifyConnection saddr dta = case cdAddr dta of
1747 Left laddr -> Left (PeerAddress saddr, laddr)
1748 Right raddr -> Right (ClientAddress saddr, raddr)
1749
1750data XMPPServer
1751 = forall releaseKey.
1752 XMPPServer { _xmpp_sv :: Server PeerAddress ConnectionData releaseKey XML.Event
1753 -- ^ Internally, we're using PeerAddress for both clients
1754 -- and peers. For the external interface, we mark client
1755 -- addresses as 'ClientAddress' and not 'PeerAddress'.
1756 , _xmpp_man :: Connection.Manager TCPStatus Text
1757 , _xmpp_peer_params :: ConnectionParameters PeerAddress ConnectionData
1758 , _xmpp_peer_bind :: SockAddr
1759 }
1760
1761xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text)
1762xmppConnections xsv@XMPPServer{_xmpp_man = m} = return m
1763
1764xmppEventChannel :: XMPPServer -> TChan ((PeerAddress, ConnectionData), ConnectionEvent Event)
1765xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
1766
1767quitXmpp :: XMPPServer -> IO ()
1768quitXmpp XMPPServer{_xmpp_sv=sv} = control sv Quit
1769
1770xmppServer :: MonadIO m => Allocate releaseKey m
1771 -> Maybe SockAddr -- ^ Listen address for server-to-server protocol.
1772 -> m XMPPServer
1773xmppServer allocate bind_addr = do
1774 sv <- server allocate xmlStream
1775 liftIO $ do
1776 gen <- System.Random.getStdGen
1777 peer_bind <- maybe (getBindAddress "5269" True) return bind_addr
1778 let (r, _) = System.Random.next gen
1779 fuzz = r `mod` 2000 -- maximum 2 seconds of ping fuzz
1780 peer_params :: ConnectionParameters PeerAddress ConnectionData
1781 peer_params = (connectionDefaults $ peerKey $ Just peer_bind)
1782 { pingInterval = 15000 + fuzz
1783 , timeout = 2000
1784 , duplex = False }
1785 tcp <- tcpManager (\(PeerAddress addr) -> (addr, peer_params, 10000)) sv
1786 return XMPPServer { _xmpp_sv = sv
1787 , _xmpp_man = tcp
1788 , _xmpp_peer_params = peer_params
1789 , _xmpp_peer_bind = peer_bind
1790 }
1791
1792forkXmpp :: MonadIO m => XMPPServer -> XMPPServerParameters -> m ThreadId
1793forkXmpp XMPPServer { _xmpp_sv = sv
1794 , _xmpp_peer_params = peer_params
1795 , _xmpp_peer_bind = peer_bind
1796 }
1797 xmpp = liftIO $ do
1798 let client_params :: ConnectionParameters PeerAddress ConnectionData
1799 client_params = (connectionDefaults clientKey)
1800 { pingInterval = 0
1801 , timeout = 0
1802 }
1803 mt <- forkIO $ do myThreadId >>= flip labelThread ("XMPP.monitor")
1804 monitor sv peer_params xmpp
1805 dput XMisc $ "Starting peer listen"
1806 control sv (Listen peer_bind peer_params)
1807 dput XMisc $ "Starting client listen"
1808 client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp
1809 control sv (Listen client_bind client_params)
1810 return mt
1811
1812
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 17:24:34 +0000