diff options
-rw-r--r-- | Presence/XMPPServer.hs | 7 |
1 files changed, 6 insertions, 1 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 60cfec74..c037eb63 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -1089,6 +1089,9 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do | |||
1089 | let es' = mapMaybe metadata es | 1089 | let es' = mapMaybe metadata es |
1090 | metadata (Left s) = Just s | 1090 | metadata (Left s) = Just s |
1091 | metadata _ = Nothing | 1091 | metadata _ = Nothing |
1092 | -- TODO: Issuing RecipientUnavailable for all errors is a presence leak | ||
1093 | -- and protocol violation | ||
1094 | -- TODO: IDMangler can be used for better targetted error delivery. | ||
1092 | let fail stanza = do | 1095 | let fail stanza = do |
1093 | wlog $ "failed delivery: " ++ show (stanzaId stanza) | 1096 | wlog $ "failed delivery: " ++ show (stanzaId stanza) |
1094 | quitVar <- atomically newEmptyTMVar | 1097 | quitVar <- atomically newEmptyTMVar |
@@ -1097,10 +1100,10 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do | |||
1097 | -- sendReply quitVar (Error RecipientUnavailable tag) reply replyto | 1100 | -- sendReply quitVar (Error RecipientUnavailable tag) reply replyto |
1098 | replystanza <- stanzaFromList (Error RecipientUnavailable tag) reply | 1101 | replystanza <- stanzaFromList (Error RecipientUnavailable tag) reply |
1099 | xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza | 1102 | xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza |
1100 | -- TODO: queue or save es' stanzas for re-connect? | ||
1101 | notError s = case stanzaType s of | 1103 | notError s = case stanzaType s of |
1102 | Error {} -> False | 1104 | Error {} -> False |
1103 | _ -> True | 1105 | _ -> True |
1106 | -- TODO: Probably some stanzas should be queued or saved for re-connect. | ||
1104 | mapM_ fail $ filter notError (maybeToList last ++ es') | 1107 | mapM_ fail $ filter notError (maybeToList last ++ es') |
1105 | wlog $ "end post-queue fork: " ++ show k | 1108 | wlog $ "end post-queue fork: " ++ show k |
1106 | output <- atomically newTChan | 1109 | output <- atomically newTChan |
@@ -1530,6 +1533,8 @@ monitor sv params xmpp = do | |||
1530 | _ -> return () | 1533 | _ -> return () |
1531 | _ -> return () | 1534 | _ -> return () |
1532 | let deliver replyto = do | 1535 | let deliver replyto = do |
1536 | -- TODO: Issuing RecipientUnavailable for all errors is a presence leak | ||
1537 | -- and protocol violation | ||
1533 | let fail = do | 1538 | let fail = do |
1534 | wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO | 1539 | wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO |
1535 | reply <- makeErrorStanza stanza | 1540 | reply <- makeErrorStanza stanza |