diff options
Diffstat (limited to 'Presence/XMPPServer.hs')
-rw-r--r-- | Presence/XMPPServer.hs | 65 |
1 files changed, 51 insertions, 14 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index eb680002..631f97c3 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -15,6 +15,7 @@ module XMPPServer | |||
15 | , peerKeyToResolvedName | 15 | , peerKeyToResolvedName |
16 | , addrToText | 16 | , addrToText |
17 | , sendModifiedStanzaToPeer | 17 | , sendModifiedStanzaToPeer |
18 | , sendModifiedStanzaToClient | ||
18 | ) where | 19 | ) where |
19 | import Debug.Trace | 20 | import Debug.Trace |
20 | import Control.Monad.Trans.Resource (runResourceT) | 21 | import Control.Monad.Trans.Resource (runResourceT) |
@@ -147,7 +148,7 @@ data XMPPServerParameters = | |||
147 | , xmppTellMyNameToPeer :: SockAddr -> IO Text | 148 | , xmppTellMyNameToPeer :: SockAddr -> IO Text |
148 | , xmppTellClientHisName :: ConnectionKey -> IO Text | 149 | , xmppTellClientHisName :: ConnectionKey -> IO Text |
149 | , xmppTellPeerHisName :: ConnectionKey -> IO Text | 150 | , xmppTellPeerHisName :: ConnectionKey -> IO Text |
150 | , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO () | 151 | , xmppNewConnection :: ConnectionKey -> SockAddr -> TChan Stanza -> IO () |
151 | , xmppEOF :: ConnectionKey -> IO () | 152 | , xmppEOF :: ConnectionKey -> IO () |
152 | , xmppRosterBuddies :: ConnectionKey -> IO [Text] | 153 | , xmppRosterBuddies :: ConnectionKey -> IO [Text] |
153 | , xmppRosterSubscribers :: ConnectionKey -> IO [Text] | 154 | , xmppRosterSubscribers :: ConnectionKey -> IO [Text] |
@@ -181,9 +182,10 @@ peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0" | |||
181 | peerKeyToResolvedName :: ConnectionKey -> IO Text | 182 | peerKeyToResolvedName :: ConnectionKey -> IO Text |
182 | peerKeyToResolvedName k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1" | 183 | peerKeyToResolvedName k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1" |
183 | peerKeyToResolvedName k@(PeerKey { callBackAddress=addr }) = do | 184 | peerKeyToResolvedName k@(PeerKey { callBackAddress=addr }) = do |
184 | ent <- getHostByAddr addr -- AF_UNSPEC addr | 185 | mname <- handleIO_ (return Nothing) $ do |
185 | let names = BSD.hostName ent : BSD.hostAliases ent | 186 | ent <- getHostByAddr addr -- AF_UNSPEC addr |
186 | mname = listToMaybe names | 187 | let names = BSD.hostName ent : BSD.hostAliases ent |
188 | return $ listToMaybe names | ||
187 | return $ maybe (peerKeyToText k) Text.pack mname | 189 | return $ maybe (peerKeyToText k) Text.pack mname |
188 | 190 | ||
189 | 191 | ||
@@ -278,6 +280,17 @@ sendModifiedStanzaToPeer stanza chan = do | |||
278 | where | 280 | where |
279 | c = stanzaToConduit stanza =$= swapNamespace "jabber:client" "jabber:server" =$= fixHeaders stanza | 281 | c = stanzaToConduit stanza =$= swapNamespace "jabber:client" "jabber:server" =$= fixHeaders stanza |
280 | 282 | ||
283 | sendModifiedStanzaToClient stanza chan = do | ||
284 | (echan,clsrs,quitvar) <- conduitToChan c | ||
285 | ioWriteChan chan | ||
286 | stanza { stanzaChan = echan | ||
287 | , stanzaClosers = clsrs | ||
288 | , stanzaInterrupt = quitvar | ||
289 | -- TODO id? origin? | ||
290 | } | ||
291 | where | ||
292 | c = stanzaToConduit stanza =$= swapNamespace "jabber:server" "jabber:client" =$= fixHeaders stanza | ||
293 | |||
281 | -- id,to, and from are taken as-is from reply list | 294 | -- id,to, and from are taken as-is from reply list |
282 | sendReply donevar stype reply replychan = do | 295 | sendReply donevar stype reply replychan = do |
283 | if null reply then return () | 296 | if null reply then return () |
@@ -532,6 +545,7 @@ xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $ | |||
532 | pongfrom = maybe me id mto | 545 | pongfrom = maybe me id mto |
533 | pong = makePong namespace mid pongto pongfrom | 546 | pong = makePong namespace mid pongto pongfrom |
534 | sendReply donevar Pong pong output | 547 | sendReply donevar Pong pong output |
548 | #ifdef PINGNOISE | ||
535 | -- TODO: Remove this, it is only to generate a debug print | 549 | -- TODO: Remove this, it is only to generate a debug print |
536 | ioWriteChan stanzas Stanza | 550 | ioWriteChan stanzas Stanza |
537 | { stanzaType = Ping | 551 | { stanzaType = Ping |
@@ -543,6 +557,7 @@ xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $ | |||
543 | , stanzaInterrupt = donevar | 557 | , stanzaInterrupt = donevar |
544 | , stanzaOrigin = NetworkOrigin k output | 558 | , stanzaOrigin = NetworkOrigin k output |
545 | } | 559 | } |
560 | #endif | ||
546 | stype -> ioWriteChan stanzas Stanza | 561 | stype -> ioWriteChan stanzas Stanza |
547 | { stanzaType = stype | 562 | { stanzaType = stype |
548 | , stanzaId = mid | 563 | , stanzaId = mid |
@@ -745,10 +760,20 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do | |||
745 | fix $ \loop -> do | 760 | fix $ \loop -> do |
746 | what <- atomically $ foldr1 orElse | 761 | what <- atomically $ foldr1 orElse |
747 | [readTChan output >>= \stanza -> return $ do | 762 | [readTChan output >>= \stanza -> return $ do |
748 | dup <- atomically $ cloneStanza stanza | 763 | #ifndef PINGNOISE |
749 | stanzaToConduit dup $$ prettyPrint $ case k of | 764 | let notping f = case stanzaType stanza of Pong -> return () |
750 | ClientKey {} -> "C<-" <> bshow (stanzaType dup) <> " " | 765 | _ -> f |
751 | PeerKey {} -> "P<-" <> bshow (stanzaType dup) <> " " | 766 | #else |
767 | let notping f = f | ||
768 | #endif | ||
769 | notping $ do | ||
770 | dup <- atomically $ cloneStanza stanza | ||
771 | let typ = Strict8.pack $ c ++ "<-"++(concat . take 1 . words $ show (stanzaType dup))++" " | ||
772 | c = case k of | ||
773 | ClientKey {} -> "C" | ||
774 | PeerKey {} -> "P" | ||
775 | wlog "" | ||
776 | stanzaToConduit dup $$ prettyPrint typ | ||
752 | stanzaToConduit stanza | 777 | stanzaToConduit stanza |
753 | $$ awaitForever | 778 | $$ awaitForever |
754 | $ liftIO . atomically . Slotted.push slots Nothing | 779 | $ liftIO . atomically . Slotted.push slots Nothing |
@@ -762,10 +787,12 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do | |||
762 | ping = makePing namespace mid to from | 787 | ping = makePing namespace mid to from |
763 | mapM_ (atomically . Slotted.push slots (Just $ PingSlot)) | 788 | mapM_ (atomically . Slotted.push slots (Just $ PingSlot)) |
764 | ping | 789 | ping |
790 | #ifdef PINGNOISE | ||
765 | wlog "" | 791 | wlog "" |
766 | CL.sourceList ping $$ prettyPrint $ case k of | 792 | CL.sourceList ping $$ prettyPrint $ case k of |
767 | ClientKey {} -> "C<-Ping" | 793 | ClientKey {} -> "C<-Ping" |
768 | PeerKey {} -> "P<-Ping " | 794 | PeerKey {} -> "P<-Ping " |
795 | #endif | ||
769 | loop | 796 | loop |
770 | ,readTMVar rdone >> return (return ()) | 797 | ,readTMVar rdone >> return (return ()) |
771 | ] | 798 | ] |
@@ -912,7 +939,7 @@ monitor sv params xmpp = do | |||
912 | wlog $ tomsg k "Connection" | 939 | wlog $ tomsg k "Connection" |
913 | let (xsrc,xsnk) = xmlStream conread conwrite | 940 | let (xsrc,xsnk) = xmlStream conread conwrite |
914 | outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas | 941 | outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas |
915 | xmppNewConnection xmpp k outs | 942 | xmppNewConnection xmpp k u outs |
916 | return () | 943 | return () |
917 | ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure" | 944 | ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure" |
918 | EOF -> do wlog $ tomsg k "EOF" | 945 | EOF -> do wlog $ tomsg k "EOF" |
@@ -924,7 +951,17 @@ monitor sv params xmpp = do | |||
924 | RequiresPing -> return () -- wlog $ tomsg k "RequiresPing" | 951 | RequiresPing -> return () -- wlog $ tomsg k "RequiresPing" |
925 | _ -> return () | 952 | _ -> return () |
926 | , readTChan stanzas >>= \stanza -> return $ do | 953 | , readTChan stanzas >>= \stanza -> return $ do |
954 | dup <- case stanzaType stanza of | ||
955 | Message {} -> do | ||
956 | dup <- atomically $ cloneStanza stanza -- dupped so we can make debug print | ||
957 | return dup | ||
958 | _ -> return stanza | ||
927 | forkIO $ do | 959 | forkIO $ do |
960 | case stanzaType stanza of | ||
961 | Message {} -> do | ||
962 | let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO | ||
963 | xmppDeliverMessage xmpp fail stanza | ||
964 | _ -> return () | ||
928 | case stanzaOrigin stanza of | 965 | case stanzaOrigin stanza of |
929 | NetworkOrigin k@(ClientKey {}) replyto -> | 966 | NetworkOrigin k@(ClientKey {}) replyto -> |
930 | case stanzaType stanza of | 967 | case stanzaType stanza of |
@@ -940,10 +977,6 @@ monitor sv params xmpp = do | |||
940 | RequestRoster -> do | 977 | RequestRoster -> do |
941 | sendRoster stanza xmpp replyto | 978 | sendRoster stanza xmpp replyto |
942 | xmppSubscribeToRoster xmpp k | 979 | xmppSubscribeToRoster xmpp k |
943 | Message {} -> do | ||
944 | let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO | ||
945 | stanza2 <- atomically $ cloneStanza stanza | ||
946 | xmppDeliverMessage xmpp fail stanza | ||
947 | PresenceStatus {} -> do | 980 | PresenceStatus {} -> do |
948 | xmppInformClientPresence xmpp k stanza | 981 | xmppInformClientPresence xmpp k stanza |
949 | UnrecognizedQuery query -> do | 982 | UnrecognizedQuery query -> do |
@@ -953,7 +986,11 @@ monitor sv params xmpp = do | |||
953 | _ -> return () | 986 | _ -> return () |
954 | _ -> return () | 987 | _ -> return () |
955 | -- We need to clone in the case the stanza is passed on as for Message. | 988 | -- We need to clone in the case the stanza is passed on as for Message. |
956 | dup <- atomically $ cloneStanza stanza | 989 | #ifndef PINGNOISE |
990 | let notping f = case stanzaType stanza of Pong -> return () | ||
991 | _ -> f | ||
992 | notping $ do | ||
993 | #endif | ||
957 | let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" " | 994 | let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" " |
958 | c = case stanzaOrigin stanza of | 995 | c = case stanzaOrigin stanza of |
959 | LocalPeer -> "*" | 996 | LocalPeer -> "*" |