diff options
Diffstat (limited to 'dht/Presence/XMPPServer.hs')
-rw-r--r-- | dht/Presence/XMPPServer.hs | 68 |
1 files changed, 39 insertions, 29 deletions
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs index 65d882bd..0aef1ed6 100644 --- a/dht/Presence/XMPPServer.hs +++ b/dht/Presence/XMPPServer.hs | |||
@@ -476,23 +476,16 @@ C->Unrecognized </iq> | |||
476 | 476 | ||
477 | -- Sends all stanzas to announce channel except ping, for which it sends a pong | 477 | -- Sends all stanzas to announce channel except ping, for which it sends a pong |
478 | -- to the output channel. | 478 | -- to the output channel. |
479 | xmppInbound :: ConnectionData | 479 | xmppInbound :: Maybe Text -- ^ "to" attribute sent from remote |
480 | -> Maybe Text -- ^ "from" attribute sent from remote | ||
481 | -> ConnectionData | ||
480 | -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) | 482 | -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) |
481 | -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused) | 483 | -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused) |
482 | -> TChan Stanza -- ^ channel to announce incoming stanzas on | 484 | -> TChan Stanza -- ^ channel to announce incoming stanzas on |
483 | -> TChan Stanza -- ^ channel used to send stanzas | 485 | -> TChan Stanza -- ^ channel used to send stanzas |
484 | -> TMVar () -- ^ mvar that is filled when the connection quits | 486 | -> TMVar () -- ^ mvar that is filled when the connection quits |
485 | -> ConduitM Event o IO () | 487 | -> NestingXML o IO () |
486 | xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do | 488 | xmppInbound stream_name stream_remote cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = |
487 | withXML $ \begindoc -> do | ||
488 | when (begindoc==EventBeginDocument) $ do | ||
489 | whenJust nextElement $ \xml -> do | ||
490 | withJust (elementAttrs "stream" xml) $ \stream_attrs -> do | ||
491 | -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs | ||
492 | let stream_name = lookupAttrib "to" stream_attrs | ||
493 | stream_remote = lookupAttrib "from" stream_attrs | ||
494 | -- xmpp_version = lookupAttrib "version" stream_attrs | ||
495 | liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote | ||
496 | fix $ \loop -> do | 489 | fix $ \loop -> do |
497 | -- liftIO . wlog $ "waiting for stanza." | 490 | -- liftIO . wlog $ "waiting for stanza." |
498 | (chan,clsrs) <- liftIO . atomically $ | 491 | (chan,clsrs) <- liftIO . atomically $ |
@@ -920,7 +913,17 @@ forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event | |||
920 | -> MVar () | 913 | -> MVar () |
921 | -> IO (TChan Stanza) | 914 | -> IO (TChan Stanza) |
922 | forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do | 915 | forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do |
923 | let auxAddr = cdAddr cdta | 916 | -- client.PeerAddress {peerAddress = [::1]:5222} |
917 | let lbl n = concat [ n | ||
918 | , Text.unpack (Text.drop 7 namespace) -- "client" or "server" | ||
919 | , "." | ||
920 | , case cdProfile cdta of | ||
921 | _ | Right _ <- cdAddr cdta -> show saddr | ||
922 | "." -> show saddr | ||
923 | mytoxname -> show saddr {- TODO: remote tox peer name? -} ] | ||
924 | |||
925 | auxAddr = cdAddr cdta | ||
926 | |||
924 | clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of | 927 | clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of |
925 | Right _ -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr) | 928 | Right _ -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr) |
926 | , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr) | 929 | , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr) |
@@ -928,8 +931,28 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do | |||
928 | Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr | 931 | Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr |
929 | , xmppTellPeerHisName xmpp saddr | 932 | , xmppTellPeerHisName xmpp saddr |
930 | , PeerOrigin saddr) | 933 | , PeerOrigin saddr) |
931 | me <- tellmyname | 934 | |
935 | output <- atomically newTChan | ||
932 | rdone <- atomically newEmptyTMVar | 936 | rdone <- atomically newEmptyTMVar |
937 | forkLabeled (lbl "xmpp-reader.") $ do | ||
938 | -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show) | ||
939 | runConduit $ (.|) src $ | ||
940 | -- :: ConduitM Event o IO () | ||
941 | doNestingXML $ do | ||
942 | withXML $ \begindoc -> do | ||
943 | when (begindoc==EventBeginDocument) $ do | ||
944 | whenJust nextElement $ \xml -> do | ||
945 | withJust (elementAttrs "stream" xml) $ \stream_attrs -> do | ||
946 | -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs | ||
947 | let stream_name = lookupAttrib "to" stream_attrs | ||
948 | stream_remote = lookupAttrib "from" stream_attrs | ||
949 | -- xmpp_version = lookupAttrib "version" stream_attrs | ||
950 | liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote | ||
951 | xmppInbound stream_name stream_remote cdta clientOrServer pingflag stanzas output rdone | ||
952 | atomically $ putTMVar rdone () | ||
953 | wlog $ "end reader fork: " ++ lbl "" | ||
954 | |||
955 | me <- tellmyname | ||
933 | let isStarter (Left _) = True | 956 | let isStarter (Left _) = True |
934 | isStarter (Right e) | isEventBeginElement e = True | 957 | isStarter (Right e) | isEventBeginElement e = True |
935 | isStarter _ = False | 958 | isStarter _ = False |
@@ -940,19 +963,12 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do | |||
940 | needsFlush <- atomically $ newTVar False | 963 | needsFlush <- atomically $ newTVar False |
941 | lastStanza <- atomically $ newTVar Nothing | 964 | lastStanza <- atomically $ newTVar Nothing |
942 | nesting <- atomically $ newTVar 0 | 965 | nesting <- atomically $ newTVar 0 |
966 | |||
943 | let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event) | 967 | let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event) |
944 | let greet_src = do | 968 | greet_src = do |
945 | CL.sourceList (greet' namespace me) .| CL.map Chunk | 969 | CL.sourceList (greet' namespace me) .| CL.map Chunk |
946 | yield Flush | 970 | yield Flush |
947 | slot_src = slotsToSource slots nesting lastStanza needsFlush rdone | 971 | slot_src = slotsToSource slots nesting lastStanza needsFlush rdone |
948 | -- client.PeerAddress {peerAddress = [::1]:5222} | ||
949 | let lbl n = concat [ n | ||
950 | , Text.unpack (Text.drop 7 namespace) -- "client" or "server" | ||
951 | , "." | ||
952 | , case cdProfile cdta of | ||
953 | _ | Right _ <- cdAddr cdta -> show saddr | ||
954 | "." -> show saddr | ||
955 | mytoxname -> show saddr {- TODO: remote tox peer name? -} ] | ||
956 | 972 | ||
957 | forkLabeled (lbl "xmpp-post.") $ do | 973 | forkLabeled (lbl "xmpp-post.") $ do |
958 | -- This thread handles messages after they are pulled out of | 974 | -- This thread handles messages after they are pulled out of |
@@ -988,7 +1004,6 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do | |||
988 | mapM_ fail $ filter notError (maybeToList last ++ es') | 1004 | mapM_ fail $ filter notError (maybeToList last ++ es') |
989 | wlog $ "end xmpp-post fork: " ++ (lbl "") | 1005 | wlog $ "end xmpp-post fork: " ++ (lbl "") |
990 | 1006 | ||
991 | output <- atomically newTChan | ||
992 | hacks <- atomically $ newTVar Map.empty | 1007 | hacks <- atomically $ newTVar Map.empty |
993 | msgids <- atomically $ newTVar [] | 1008 | msgids <- atomically $ newTVar [] |
994 | forkLabeled (lbl "xmpp-pre.") $ do | 1009 | forkLabeled (lbl "xmpp-pre.") $ do |
@@ -1072,11 +1087,6 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do | |||
1072 | ] | 1087 | ] |
1073 | what | 1088 | what |
1074 | wlog $ "end xmpp-pre fork: " ++ show (lbl "") | 1089 | wlog $ "end xmpp-pre fork: " ++ show (lbl "") |
1075 | forkLabeled (lbl "xmpp-reader.") $ do | ||
1076 | -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show) | ||
1077 | runConduit $ src .| xmppInbound cdta clientOrServer pingflag stanzas output rdone | ||
1078 | atomically $ putTMVar rdone () | ||
1079 | wlog $ "end reader fork: " ++ lbl "" | ||
1080 | return output | 1090 | return output |
1081 | 1091 | ||
1082 | {- | 1092 | {- |