diff options
author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
tree | 5716463275c2d3e902889db619908ded2a73971c /Presence/XMPPServer.hs | |
parent | add2c76bced51fde5e9917e7449ef52be70faf87 (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 'Presence/XMPPServer.hs')
-rw-r--r-- | Presence/XMPPServer.hs | 1812 |
1 files changed, 0 insertions, 1812 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs deleted file mode 100644 index fe099fb8..00000000 --- a/Presence/XMPPServer.hs +++ /dev/null | |||
@@ -1,1812 +0,0 @@ | |||
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 #-} | ||
10 | module 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 | |||
51 | import ConnectionKey | ||
52 | import qualified Control.Concurrent.STM.UpdateStream as Slotted | ||
53 | import Nesting | ||
54 | import Connection.Tcp | ||
55 | import EventUtil | ||
56 | import ControlMaybe | ||
57 | import LockedChan | ||
58 | import Connection (PeerAddress(..)) | ||
59 | import qualified Connection | ||
60 | import Util | ||
61 | import Network.Address (getBindAddress, sockAddrPort) | ||
62 | |||
63 | import Debug.Trace | ||
64 | import Control.Monad.Trans (lift) | ||
65 | import Control.Monad.IO.Class (MonadIO, liftIO) | ||
66 | import Control.Monad.Fix (fix) | ||
67 | import Control.Monad | ||
68 | #ifdef THREAD_DEBUG | ||
69 | import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar) | ||
70 | #else | ||
71 | import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId) | ||
72 | import GHC.Conc (labelThread) | ||
73 | #endif | ||
74 | import Control.Concurrent.STM | ||
75 | import Data.List hiding ((\\)) | ||
76 | -- import Control.Concurrent.STM.TChan | ||
77 | import Network.SocketLike | ||
78 | import Text.Printf | ||
79 | import Data.ByteString (ByteString) | ||
80 | import qualified Data.ByteString.Char8 as Strict8 | ||
81 | -- import qualified Data.ByteString.Lazy.Char8 as Lazy8 | ||
82 | |||
83 | import Data.Conduit | ||
84 | import qualified Data.Conduit.List as CL | ||
85 | import qualified Data.Conduit.Binary as CB | ||
86 | #if MIN_VERSION_conduit_extra(1,1,7) | ||
87 | import Data.Conduit.ByteString.Builder (builderToByteStringFlush) | ||
88 | #else | ||
89 | import Data.Conduit.Blaze (builderToByteStringFlush) | ||
90 | #endif | ||
91 | |||
92 | import Control.Arrow | ||
93 | import Control.Concurrent.STM.Util | ||
94 | import DNSCache (withPort) | ||
95 | import qualified Text.XML.Stream.Render as XML hiding (content) | ||
96 | import qualified Text.XML.Stream.Parse as XML | ||
97 | import Data.XML.Types as XML | ||
98 | import Data.Maybe | ||
99 | import Data.Monoid ( (<>) ) | ||
100 | import Data.Text (Text) | ||
101 | import qualified Data.Text as Text | ||
102 | import qualified Data.Map as Map | ||
103 | import Data.Set (Set, (\\) ) | ||
104 | import qualified Data.Set as Set | ||
105 | import Data.String ( IsString(..) ) | ||
106 | import qualified System.Random | ||
107 | import Data.Void (Void) | ||
108 | import DPut | ||
109 | import DebugTag | ||
110 | import Stanza.Build | ||
111 | import Stanza.Parse | ||
112 | import Stanza.Types | ||
113 | import MUC | ||
114 | import Chat | ||
115 | |||
116 | -- peerport :: PortNumber | ||
117 | -- peerport = 5269 | ||
118 | -- clientport :: PortNumber | ||
119 | -- clientport = 5222 | ||
120 | |||
121 | my_uuid :: Text | ||
122 | my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574" | ||
123 | |||
124 | |||
125 | newtype Local a = Local a deriving (Eq,Ord,Show) | ||
126 | newtype Remote a = Remote a deriving (Eq,Ord,Show) | ||
127 | |||
128 | data 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 | |||
172 | enableClientHacks :: | ||
173 | forall t a. | ||
174 | (Eq a, IsString a) => | ||
175 | a -> t -> TChan Stanza -> IO () | ||
176 | enableClientHacks "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 | ||
183 | enableClientHacks "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 | ||
190 | enableClientHacks _ _ _ = return () | ||
191 | |||
192 | cacheMessageId :: Text -> TChan Stanza -> IO () | ||
193 | cacheMessageId 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 | |||
208 | addrToText :: SockAddr -> Text | ||
209 | addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr) | ||
210 | where stripColon s = pre where (pre,_) = break (==':') s | ||
211 | addrToText (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. | ||
217 | peerKeyToText :: PeerAddress -> Text | ||
218 | peerKeyToText (PeerAddress addr) = addrToText addr | ||
219 | |||
220 | |||
221 | wlog :: String -> IO () | ||
222 | wlog = dput XJabber | ||
223 | |||
224 | wlogb :: ByteString -> IO () | ||
225 | wlogb = wlog . Strict8.unpack | ||
226 | |||
227 | flushPassThrough :: Monad m => ConduitT a b m () -> ConduitT (Flush a) (Flush b) m () | ||
228 | flushPassThrough 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 | |||
239 | xmlStream :: ReadCommand -> WriteCommand -> ( ConduitT () XML.Event IO () | ||
240 | , ConduitT (Flush XML.Event) Void IO () ) | ||
241 | xmlStream 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 | |||
264 | type FlagCommand = STM Bool | ||
265 | type ReadCommand = IO (Maybe ByteString) | ||
266 | type WriteCommand = ByteString -> IO Bool | ||
267 | |||
268 | cloneStanza :: StanzaWrap (LockedChan a) -> IO (StanzaWrap (LockedChan a)) | ||
269 | cloneStanza stanza = do | ||
270 | dupped <- cloneLChan (stanzaChan stanza) | ||
271 | return stanza { stanzaChan = dupped } | ||
272 | |||
273 | copyToChannel | ||
274 | :: MonadIO m => | ||
275 | (Event -> a) -> LockedChan a -> TVar (Maybe [Event]) -> ConduitM Event Event m () | ||
276 | copyToChannel 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 | |||
292 | prettyPrint :: ByteString -> ConduitM Event Void IO () | ||
293 | prettyPrint prefix = | ||
294 | XML.renderBytes (XML.def { XML.rsPretty=True }) | ||
295 | .| CB.lines | ||
296 | .| CL.mapM_ (wlogb . (prefix <>)) | ||
297 | |||
298 | swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m () | ||
299 | swapNamespace old new = awaitForever (yield . swapit old new) | ||
300 | |||
301 | swapit :: Text -> Text -> Event -> Event | ||
302 | swapit old new (EventBeginElement n as) | nameNamespace n==Just old = | ||
303 | EventBeginElement (n { nameNamespace = Just new }) as | ||
304 | swapit old new (EventEndElement n) | nameNamespace n==Just old = | ||
305 | EventEndElement (n { nameNamespace = Just new }) | ||
306 | swapit 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. | ||
314 | fixHeaders :: Monad m => Stanza -> ConduitM Event Event m () | ||
315 | fixHeaders 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 | |||
340 | conduitToChan | ||
341 | :: ConduitT () Event IO () | ||
342 | -> IO (LockedChan Event, TVar (Maybe [Event]), TMVar a) | ||
343 | conduitToChan 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 | |||
352 | conduitToStanza | ||
353 | :: StanzaType | ||
354 | -> Maybe Text -- ^ id | ||
355 | -> Maybe Text -- ^ from | ||
356 | -> Maybe Text -- ^ to | ||
357 | -> ConduitT () Event IO () | ||
358 | -> IO Stanza | ||
359 | conduitToStanza 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 | |||
373 | stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m () | ||
374 | stanzaToConduit 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 | |||
398 | sendModifiedStanzaToPeer :: Stanza -> TChan Stanza -> IO () | ||
399 | sendModifiedStanzaToPeer 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. | ||
419 | sendModifiedStanzaToClient :: Stanza -> TChan Stanza -> IO () | ||
420 | sendModifiedStanzaToClient 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 | ||
440 | sendReply :: (Functor m, MonadIO m) => TMVar () -> StanzaType -> [Event] -> TChan Stanza -> m () | ||
441 | sendReply 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 | {- | ||
473 | C->Unrecognized <iq | ||
474 | C->Unrecognized type="set" | ||
475 | C->Unrecognized id="purpleae62d88f" | ||
476 | C->Unrecognized xmlns="jabber:client"> | ||
477 | C->Unrecognized <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/> | ||
478 | C->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. | ||
484 | xmppInbound :: 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 () | ||
491 | xmppInbound 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 | |||
570 | while :: IO Bool -> IO a -> IO [a] | ||
571 | while 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 | {- | ||
579 | readUntilNothing :: TChan (Maybe x) -> IO [x] | ||
580 | readUntilNothing 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 | |||
589 | streamFeatures :: Text -> [XML.Event] | ||
590 | streamFeatures "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 | ] | ||
605 | streamFeatures "jabber:server" = | ||
606 | [] | ||
607 | |||
608 | |||
609 | greet' :: Text -> Text -> [XML.Event] | ||
610 | greet' namespace host = EventBeginDocument : greet'' namespace host | ||
611 | |||
612 | greet'' :: Text -> Text -> [Event] | ||
613 | greet'' 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 | |||
623 | consid :: Maybe Text -> [(Name, [Content])] -> [(Name, [Content])] | ||
624 | consid Nothing = id | ||
625 | consid (Just sid) = (("id",[ContentText sid]):) | ||
626 | |||
627 | |||
628 | data XMPPState | ||
629 | = PingSlot | ||
630 | deriving (Eq,Ord) | ||
631 | |||
632 | makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event] | ||
633 | makePing 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 | |||
646 | makeInfo :: Maybe Text -> Text -> Maybe Text -> [Event] | ||
647 | makeInfo 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 | |||
669 | makeNodeInfo :: Maybe Text -> Text -> Text -> Maybe Text -> Maybe Text-> [XML.Event] | ||
670 | makeNodeInfo 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 | |||
690 | features :: [Text] -> [XML.Event] | ||
691 | features 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 | |||
697 | makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [XML.Event] -> [XML.Event] | ||
698 | makeMUCInfo 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 | |||
724 | makeItemList :: Maybe Text -> [(Text,Maybe Text)] -> Text -> Maybe Text -> [Event] | ||
725 | makeItemList 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 | |||
739 | iq_bind_reply :: Maybe Text -> Text -> [XML.Event] | ||
740 | iq_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 | |||
763 | iq_session_reply :: Maybe Text -> Text -> [XML.Event] | ||
764 | iq_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 | |||
773 | iq_service_unavailable :: Maybe Text -> Text -> XML.Name -> [XML.Event] | ||
774 | iq_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 | |||
790 | wrapStanzaList :: [XML.Event] -> STM [Either (StanzaWrap XML.Event) XML.Event] | ||
791 | wrapStanzaList 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 | |||
812 | wrapStanzaConduit :: Monad m => StanzaWrap a -> ConduitM Event (Either (StanzaWrap Event) Event) m () | ||
813 | wrapStanzaConduit stanza = do | ||
814 | mfirst <- await | ||
815 | forM_ mfirst $ \first -> do | ||
816 | yield . Left $ stanza { stanzaChan = first } | ||
817 | awaitForever $ yield . Right | ||
818 | |||
819 | |||
820 | |||
821 | {- | ||
822 | greet namespace = | ||
823 | [ EventBeginDocument | ||
824 | , EventBeginElement (streamP "stream") | ||
825 | [ attr "xmlns" namespace | ||
826 | , attr "version" "1.0" | ||
827 | ] | ||
828 | ] | ||
829 | -} | ||
830 | |||
831 | {- | ||
832 | goodbye :: [XML.Event] | ||
833 | goodbye = | ||
834 | [ EventEndElement (streamP "stream") | ||
835 | , EventEndDocument | ||
836 | ] | ||
837 | -} | ||
838 | |||
839 | simulateChatError :: StanzaError -> Maybe Text -> [Event] | ||
840 | simulateChatError 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. | ||
861 | presenceSolicitation :: Text -- ^ JID of sender making request. | ||
862 | -> Text -- ^ JID of recipient who needs to approve it. | ||
863 | -> IO Stanza | ||
864 | presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe" | ||
865 | |||
866 | presenceProbe :: Text -> Text -> IO Stanza | ||
867 | presenceProbe = presenceStanza PresenceRequestStatus "probe" | ||
868 | |||
869 | presenceStanza :: StanzaType -> Text -> Text -> Text -> IO Stanza | ||
870 | presenceStanza 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 | |||
879 | slotsToSource :: | ||
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 () | ||
886 | slotsToSource 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 | |||
917 | forkConnection :: 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) | ||
927 | forkConnection 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 | {- | ||
1090 | data Peer = Peer | ||
1091 | { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis | ||
1092 | , peerState :: TVar PeerState | ||
1093 | } | ||
1094 | data PeerState | ||
1095 | = PeerPendingConnect UTCTime | ||
1096 | | PeerPendingAccept UTCTime | ||
1097 | | PeerConnected (TChan Stanza) | ||
1098 | -} | ||
1099 | |||
1100 | peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (PeerAddress,ConnectionData) | ||
1101 | peerKey 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 | |||
1121 | clientKey :: SocketLike sock => sock -> IO (PeerAddress,ConnectionData) | ||
1122 | clientKey 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 | |||
1139 | xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m () | ||
1140 | xmlifyRosterItems 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 | |||
1150 | sendRoster :: | ||
1151 | StanzaWrap a | ||
1152 | -> XMPPServerParameters | ||
1153 | -> ClientAddress | ||
1154 | -> TChan Stanza | ||
1155 | -> IO () | ||
1156 | sendRoster 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 | |||
1205 | socketFromKey :: Server PeerAddress ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr) | ||
1206 | socketFromKey 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 | |||
1214 | eventContent :: Maybe [Content] -> Text | ||
1215 | eventContent cs = maybe "" (foldr1 (<>) . map content1) cs | ||
1216 | where content1 (ContentText t) = t | ||
1217 | content1 (ContentEntity t) = t | ||
1218 | |||
1219 | makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event] | ||
1220 | makeErrorStanza stanza = makeErrorStanza' stanza RecipientUnavailable [] | ||
1221 | |||
1222 | makeErrorStanza' :: StanzaFirstTag a => | ||
1223 | StanzaWrap a -> StanzaError -> [(Name, [Content])] -> IO [Event] | ||
1224 | makeErrorStanza' 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 | |||
1276 | monitor :: | ||
1277 | Server PeerAddress ConnectionData releaseKey XML.Event | ||
1278 | -> ConnectionParameters PeerAddress ConnectionData | ||
1279 | -> XMPPServerParameters | ||
1280 | -> IO b | ||
1281 | monitor 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 | |||
1398 | roomjid :: Text {- ^ service -} -> Text {- ^ hostname -} -> Text {- ^ room -} -> Text {- ^ nick -} -> Text | ||
1399 | roomjid a me room n = room <> "@" <> a <> "." <> me <> "/" <> n | ||
1400 | |||
1401 | sendRoomOccupants :: Text -> Text -> Text -> Text -> JoinedRoom k -> TChan Stanza -> IO () | ||
1402 | sendRoomOccupants 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 | |||
1424 | stanzaTypeString :: StanzaWrap a -> String | ||
1425 | stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza) | ||
1426 | |||
1427 | data 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 | |||
1434 | lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a) | ||
1435 | lookupService 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 | |||
1446 | applyStanza :: 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 | |||
1453 | applyStanza 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 | |||
1692 | forwardStanza :: TMVar () -> XMPPServerParameters -> StanzaWrap (LockedChan Event) -> IO () | ||
1693 | forwardStanza 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 | |||
1720 | data ConnectionType = XMPP | Tox | ||
1721 | deriving (Eq,Ord,Enum,Show,Read) | ||
1722 | |||
1723 | data 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 | |||
1738 | addrToPeerKey :: Remote SockAddr -> PeerAddress | ||
1739 | addrToPeerKey (Remote raddr) = PeerAddress raddr | ||
1740 | |||
1741 | addrFromClientKey :: ClientAddress -> Local SockAddr | ||
1742 | addrFromClientKey (ClientAddress laddr) = Local laddr | ||
1743 | |||
1744 | classifyConnection :: SockAddr -> ConnectionData -> Either (PeerAddress, Local SockAddr) | ||
1745 | (ClientAddress, Remote SockAddr) | ||
1746 | classifyConnection saddr dta = case cdAddr dta of | ||
1747 | Left laddr -> Left (PeerAddress saddr, laddr) | ||
1748 | Right raddr -> Right (ClientAddress saddr, raddr) | ||
1749 | |||
1750 | data 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 | |||
1761 | xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text) | ||
1762 | xmppConnections xsv@XMPPServer{_xmpp_man = m} = return m | ||
1763 | |||
1764 | xmppEventChannel :: XMPPServer -> TChan ((PeerAddress, ConnectionData), ConnectionEvent Event) | ||
1765 | xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv | ||
1766 | |||
1767 | quitXmpp :: XMPPServer -> IO () | ||
1768 | quitXmpp XMPPServer{_xmpp_sv=sv} = control sv Quit | ||
1769 | |||
1770 | xmppServer :: MonadIO m => Allocate releaseKey m | ||
1771 | -> Maybe SockAddr -- ^ Listen address for server-to-server protocol. | ||
1772 | -> m XMPPServer | ||
1773 | xmppServer 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 | |||
1792 | forkXmpp :: MonadIO m => XMPPServer -> XMPPServerParameters -> m ThreadId | ||
1793 | forkXmpp 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 | |||