pidgin hack, error message in simulated chat.

1 files changed, 368 insertions, 37 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index d41e06cb..bd4c56c4 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-} -- instance for TChan Event
 module XMPPServer
     ( xmppServer
     , ConnectionKey(..)
@@ -49,7 +50,7 @@ import Data.Maybe
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack,unpack)
-import Data.Char (toUpper)
+import Data.Char (toUpper,chr,ord)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set, (\\) )
@@ -112,6 +113,9 @@ data RosterEventType
     | RejectSubscriber
  deriving (Show,Read,Ord,Eq,Enum)
 
+data ClientHack = SimulatedChatErrors
+ deriving (Show,Read,Ord,Eq,Enum)
+
 data StanzaType
     = Unrecognized
     | Ping
@@ -125,7 +129,7 @@ data StanzaType
     | RosterEvent { rosterEventType :: RosterEventType
                   , rosterUser :: Text
                   , rosterContact :: Text }
-    | Error
+    | Error StanzaError XML.Event
     | PresenceStatus { presenceShow :: JabberShow
                      , presencePriority :: Maybe Int8
                      , presenceStatus :: [(Lang,Text)]
@@ -137,7 +141,11 @@ data StanzaType
     | Message { msgThread :: Maybe MessageThread
               , msgLangMap :: [(Lang,LangSpecificMessage)]
               }
- deriving Show
+    | NotifyClientVersion { versionName :: Text
+                          , versionVersion :: Text }
+    | InternalEnableHack ClientHack
+    | InternalCacheId Text
+ deriving (Show,Eq)
 
 data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
 
@@ -175,6 +183,24 @@ data XMPPServerParameters =
     }
 
 
+enableClientHacks "Pidgin" version replyto = do
+    wlog "Enabling hack SimulatedChatErrors for client Pidgin"
+    donevar <- atomically newEmptyTMVar
+    sendReply donevar
+              (InternalEnableHack SimulatedChatErrors) 
+              []
+              replyto
+enableClientHacks _ _ _ = return ()
+
+cacheMessageId id' replyto = do
+    wlog $ "Caching id " ++ Text.unpack id'
+    donevar <- atomically newEmptyTMVar
+    sendReply donevar
+              (InternalCacheId id')
+              []
+              replyto
+    
+
 -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
 -- client connection
 -- socat script to send stanza fragment
@@ -303,6 +329,27 @@ conduitToChan c = do
         atomically $ writeTVar clsrs Nothing
     return (chan,clsrs,quitvar)
 
+conduitToStanza
+  :: StanzaType
+     -> Maybe Text -- ^ id
+     -> Maybe Text -- ^ from
+     -> Maybe Text -- ^ to
+     -> Conduit () IO Event
+     -> IO Stanza
+conduitToStanza stype mid from to c = do
+    (chan,clsrs,quitvar) <- conduitToChan c
+    return
+        Stanza  { stanzaType = stype
+                , stanzaId = mid
+                , stanzaTo = to
+                , stanzaFrom = from
+                , stanzaChan = chan
+                , stanzaClosers = clsrs
+                , stanzaInterrupt = quitvar
+                , stanzaOrigin = LocalPeer
+                }
+
+
 ioWriteChan :: MonadIO m => TChan a -> a -> m ()
 ioWriteChan c v = liftIO . atomically $ writeTChan c v
 
@@ -358,12 +405,16 @@ sendModifiedStanzaToClient stanza chan = do
 -- todo: this should probably be restricted to IO monad
 sendReply :: (Functor m, MonadIO m) => TMVar () -> StanzaType -> [Event] -> TChan Stanza -> m ()
 sendReply donevar stype reply replychan = do
-    if null reply then return ()
-    else do
-    let stanzaTag = head reply
-        mid   = lookupAttrib "id" (tagAttrs stanzaTag)
-        mfrom = lookupAttrib "from" (tagAttrs stanzaTag)
-        mto = lookupAttrib "to" (tagAttrs stanzaTag)
+    let stanzaTag = listToMaybe reply
+        mid   = stanzaTag >>= lookupAttrib "id" . tagAttrs
+        mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
+        mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
+        isInternal (InternalEnableHack {}) = True
+        isInternal (InternalCacheId {}) = True
+        isInternal _ = False
+    flip (maybe $ return ())
+         (fmap (const ()) stanzaTag `mplus` guard (isInternal stype))
+         . const $ do
     replyStanza <- liftIO . atomically $ do
         replyChan <- newTChan
         replyClsrs <- newTVar (Just [])
@@ -391,11 +442,34 @@ grokStanzaIQGet stanza = do
         "{jabber:iq:roster}query" -> return $ Just RequestRoster
         name -> return . Just $ UnrecognizedQuery name
 
-grokStanzaIQResult :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
+parseClientVersion :: NestingXML o IO (Maybe StanzaType)
+parseClientVersion = parseit Nothing Nothing
+ where
+    reportit mname mver = return $ do
+        name <- mname
+        ver <- mver
+        return NotifyClientVersion { versionName=name, versionVersion=ver }
+    parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
+    parseit mname mver = do
+        mtag <- nextElement
+        flip (maybe $ reportit mname mver) mtag $ \tag -> do
+        case tagName tag of
+            "{jabber:iq:version}name" -> do
+                x <- XML.content
+                parseit (Just x) mver
+            "{jabber:iq:version}version" -> do
+                x <- XML.content
+                parseit mname (Just x)
+            _ -> parseit mname mver
+
+
+grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
 grokStanzaIQResult stanza = do
     mtag <- nextElement 
     flip (maybe $ return (Just Pong))  mtag $ \tag -> do
     case tagName tag of
+        "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
+            -> parseClientVersion
         _ -> return Nothing
 
 grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
@@ -598,13 +672,12 @@ xmppInbound :: Server ConnectionKey SockAddr
                 -> XMPPServerParameters
                 -> ConnectionKey
                 -> SockAddr
-                -> FlagCommand 
-                -> Source IO XML.Event
-                -> TChan Stanza
-                -> TChan Stanza
-                -> TMVar ()
+                -> FlagCommand -- ^ action to check whether the connection needs a ping
+                -> TChan Stanza -- ^ channel to announce incomming stanzas on
+                -> TChan Stanza -- ^ channel used to send stanzas
+                -> TMVar () -- ^ mvar that is filled when the connection quits
                 -> Sink XML.Event IO ()
-xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $ do
+xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
     let (namespace,tellmyname,tellyourname) = case k of
             ClientKey {} -> ( "jabber:client"
                             , xmppTellMyNameToClient xmpp
@@ -726,9 +799,10 @@ streamFeatures "jabber:server" =
 
 
 greet' :: Text -> Text -> [XML.Event]
-greet' namespace host =
-    [ EventBeginDocument
-    , EventBeginElement (streamP "stream")
+greet' namespace host = EventBeginDocument : greet'' namespace host
+
+greet'' namespace host =
+    [ EventBeginElement (streamP "stream")
         [("from",[ContentText host])
         ,("id",[ContentText "someid"])
         ,("xmlns",[ContentText namespace])
@@ -770,6 +844,18 @@ iq_bind_reply mid jid =
     , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
     , EventEndElement  "{urn:ietf:params:xml:ns:xmpp-bind}bind"
     , EventEndElement "{jabber:client}iq"
+
+    {-
+    -- query for client version
+    , EventBeginElement "{jabber:client}iq"
+                            [ attr "to" jid
+                            , attr "from" hostname
+                            , attr "type" "get"
+                            , attr "id" "version"]
+    , EventBeginElement "{jabber:iq:version}query" []
+    , EventEndElement "{jabber:iq:version}query"
+    , EventEndElement "{jabber:client}iq"
+    -}
     ]
 
 iq_session_reply :: Maybe Text -> Text -> [XML.Event]
@@ -845,6 +931,26 @@ goodbye =
     , EventEndDocument
     ]
 
+simulateChatError err mfrom =
+    [ EventBeginElement "{jabber:client}message"
+         ((maybe id (\t->(attr "from" t:)) mfrom)
+           [attr "type" "normal" ])
+    , EventBeginElement "{jabber:client}body" []
+    , EventContent $ ContentText ("/me " <> errorText err)
+    , EventEndElement "{jabber:client}body"
+    , EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
+      , EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
+        , EventBeginElement "{http://www.w3.org/1999/xhtml}p"
+             [ attr "style" "font-weight:bold; color:red"
+             ]
+        , EventContent $ ContentText ("/me " <> errorText err)
+        , EventEndElement "{http://www.w3.org/1999/xhtml}p"
+      , EventEndElement "{http://www.w3.org/1999/xhtml}body"
+    , EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
+    , EventEndElement "{jabber:client}message"
+    ]
+
+
 forkConnection :: Server ConnectionKey SockAddr
                 -> XMPPServerParameters
                 -> ConnectionKey
@@ -917,6 +1023,8 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
                 mapM_ fail es' -- TODO: queue or save these for re-connect?
                 wlog $ "end post-queue fork: " ++ show k
     output <- atomically newTChan
+    hacks <- atomically $ newTVar Map.empty
+    msgids <- atomically $ newTVar []
     forkIO $ do
         -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
         fix $ \loop -> do
@@ -936,9 +1044,33 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
                                     PeerKey {}   -> "P"
                         wlog ""
                         stanzaToConduit dup $$ prettyPrint typ
+                    case stanzaType stanza of
+                        InternalEnableHack hack -> do
+                            -- wlog $ "enable hack: " ++ show hack
+                            atomically $ modifyTVar' hacks (Map.insert hack ())
+                        InternalCacheId x -> do
+                            -- wlog $ "cache id thread: " ++ show x
+                            atomically $ modifyTVar' msgids (take 3 . (x:))
+                        _ -> return ()
                     stanzaToConduit stanza =$= wrapStanzaConduit stanza
                         $$ awaitForever
                             $ liftIO . atomically . Slotted.push slots Nothing
+                    case stanzaType stanza of
+                        Error err tag | tagName tag=="{jabber:client}message" -> do
+                            -- ids <- atomically $ readTVar msgids
+                            -- wlog $ "ids = " ++ show (stanzaId stanza, ids)
+                            b <- atomically $ do m <- readTVar hacks
+                                                 cached <- readTVar msgids
+                                                 flip (maybe $ return False) (stanzaId stanza) $ \id' -> do
+                                                 return $ Map.member SimulatedChatErrors m
+                                                            && elem id' cached
+                            when b $ do
+                            let sim = simulateChatError err (stanzaFrom stanza)
+                            wlog $ "sending simulated chat for error message."
+                            CL.sourceList sim =$= wrapStanzaConduit stanza -- not quite right, but whatever
+                                $$ awaitForever
+                                    $ liftIO . atomically . Slotted.push slots Nothing
+                        _ -> return ()
                     loop
                 ,do pingflag >>= check
                     return $ do
@@ -963,7 +1095,7 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
         wlog $ "end pre-queue fork: " ++ show k
     forkIO $ do
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        src $$ xmppInbound sv xmpp k laddr pingflag src stanzas output rdone
+        src $$ xmppInbound sv xmpp k laddr pingflag stanzas output rdone
         atomically $ putTMVar rdone ()
         wlog $ "end reader fork: " ++ show k
     return output
@@ -1017,6 +1149,7 @@ sendRoster query xmpp replyto = do
     jid <- case k of
                 ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
                 PeerKey {}   -> xmppTellClientNameOfPeer xmpp k
+    hostname <- xmppTellMyNameToClient xmpp
     let getlist f = do
             bs <- f xmpp k
             -- js <- mapM parseHostNameJID bs
@@ -1041,17 +1174,23 @@ sendRoster query xmpp replyto = do
             xmlifyRosterItems solicited "none" subnone
             yield $ EventEndElement "{jabber:iq:roster}query"
             yield $ EventEndElement "{jabber:client}iq"
-    (chan,clsrs,quitvar) <- conduitToChan roster
-    ioWriteChan replyto
-        Stanza  { stanzaType = Roster
-                , stanzaId = (stanzaId query)
-                , stanzaTo = Just jid
-                , stanzaFrom = Nothing
-                , stanzaChan = chan
-                , stanzaClosers = clsrs
-                , stanzaInterrupt = quitvar
-                , stanzaOrigin = LocalPeer
-                }
+
+    conduitToStanza Roster
+                    (stanzaId query)
+                    Nothing
+                    (Just jid)
+                    roster >>= ioWriteChan replyto
+    {-
+    let debugpresence =
+                [ EventBeginElement "{jabber:client}presence"
+                    [ attr "from" "guest@oxio4inifatsetlx.onion"
+                    , attr "to" jid]
+                , EventEndElement "{jabber:client}presence"
+                ]
+    quitvar <- atomically newEmptyTMVar
+    sendReply quitvar Unrecognized debugpresence replyto
+    -}
+
 
 socketFromKey :: Server ConnectionKey SockAddr -> ConnectionKey -> IO SockAddr
 socketFromKey sv k = do
@@ -1065,6 +1204,152 @@ socketFromKey sv k = do
                         -- Shouldnt happen anyway.
         Just cd -> return $ cdata cd
 
+class StanzaFirstTag a where
+    stanzaFirstTag :: StanzaWrap a -> IO XML.Event
+instance StanzaFirstTag (TChan XML.Event) where
+    stanzaFirstTag stanza = do
+        e <-atomically $ peekTChan (stanzaChan stanza)
+        return e
+
+data StanzaError
+    = BadRequest
+    | Conflict
+    | FeatureNotImplemented
+    | Forbidden
+    | Gone
+    | InternalServerError
+    | ItemNotFound
+    | JidMalformed
+    | NotAcceptable
+    | NotAllowed
+    | NotAuthorized
+    | PaymentRequired
+    | RecipientUnavailable
+    | Redirect
+    | RegistrationRequired
+    | RemoteServerNotFound
+    | RemoteServerTimeout
+    | ResourceConstraint
+    | ServiceUnavailable
+    | SubscriptionRequired
+    | UndefinedCondition
+    | UnexpectedRequest
+ deriving (Show,Enum,Ord,Eq)
+
+xep0086 e =
+  case e of
+    BadRequest            -> ("modify", 400)
+    Conflict              -> ("cancel", 409)
+    FeatureNotImplemented -> ("cancel", 501)
+    Forbidden             -> ("auth", 403)
+    Gone                  -> ("modify", 302)
+    InternalServerError   -> ("wait", 500)
+    ItemNotFound          -> ("cancel", 404)
+    JidMalformed          -> ("modify", 400)
+    NotAcceptable         -> ("modify", 406)
+    NotAllowed            -> ("cancel", 405)
+    NotAuthorized         -> ("auth", 401)
+    PaymentRequired       -> ("auth", 402)
+    RecipientUnavailable  -> ("wait", 404)
+    Redirect              -> ("modify", 302)
+    RegistrationRequired  -> ("auth", 407)
+    RemoteServerNotFound  -> ("cancel", 404)
+    RemoteServerTimeout   -> ("wait", 504)
+    ResourceConstraint    -> ("wait", 500)
+    ServiceUnavailable    -> ("cancel", 503)
+    SubscriptionRequired  -> ("auth", 407)
+    UndefinedCondition    -> ("", 500)
+    UnexpectedRequest     -> ("wait", 400)
+
+errorText :: StanzaError -> Text
+errorText e = 
+ case e of
+    BadRequest            -> "Bad request"
+    Conflict              -> "Conflict"
+    FeatureNotImplemented -> "This feature is not implemented"
+    Forbidden             -> "Forbidden"
+    Gone                  -> "Recipient can no longer be contacted"
+    InternalServerError   -> "Internal server error"
+    ItemNotFound          -> "Item not found"
+    JidMalformed          -> "JID Malformed"
+    NotAcceptable         -> "Message was rejected"
+    NotAllowed            -> "Not allowed"
+    NotAuthorized         -> "Not authorized"
+    PaymentRequired       -> "Payment is required"
+    RecipientUnavailable  -> "Recipient is unavailable"
+    Redirect              -> "Redirect"
+    RegistrationRequired  -> "Registration required"
+    RemoteServerNotFound  -> "Recipient's server not found"
+    RemoteServerTimeout   -> "Remote server timeout"
+    ResourceConstraint    -> "The server is low on resources"
+    ServiceUnavailable    -> "The service is unavailable"
+    SubscriptionRequired  -> "A subscription is required"
+    UndefinedCondition    -> "Undefined condition"
+    UnexpectedRequest     -> "Unexpected request"
+
+eventContent cs = maybe "" (foldr1 (<>) . map content1) cs
+            where content1 (ContentText t)   = t
+                  content1 (ContentEntity t) = t
+
+makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event]
+makeErrorStanza stanza = do
+    startTag <- stanzaFirstTag stanza
+    let n = tagName startTag
+        endTag = EventEndElement n
+        amap0 = Map.fromList (tagAttrs startTag)
+        mto   = Map.lookup "to" amap0
+        mfrom = Map.lookup "from" amap0
+        mtype = Map.lookup "type" amap0
+        mid = Map.lookup "id" amap0
+        amap1 = Map.alter (const mto) "from" amap0
+        -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1
+        amap2 = Map.alter (const mfrom) "to" amap1
+        amap3 = Map.insert "type" [XML.ContentText "error"] amap2
+        startTag' = EventBeginElement
+                        (tagName startTag)
+                        (Map.toList amap3)
+        -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable
+        err = RecipientUnavailable
+        errname = n { nameLocalName = "error" }
+        -- errattrs = [attr "type" "wait"] --  "modify"]
+        errorAttribs e xs = ys ++ xs -- todo replace instead of append
+            where (typ,code) = xep0086 e
+                  ys = [attr "type" typ, attr "code" (Text.pack . show $ code)]
+        errorTagLocalName e = Text.pack . drop 1 $ do
+            c <- show e
+            if 'A' <= c && c <= 'Z'
+            then [ '-', chr( ord c - ord 'A' + ord 'a') ]
+            else return c
+        errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas"
+                            , nameLocalName = errorTagLocalName err
+                            , namePrefix = Nothing }
+        errattrs = errorAttribs err []
+    let wlogd v s = do
+            wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s
+    {-
+    wlogd "amap0" amap0
+    wlogd "mto" mto
+    wlogd "mfrom" mfrom
+    wlogd "amap3" amap3
+    -}
+    if eventContent mtype=="error" then return [] else do
+    return [ startTag'
+           , EventBeginElement errname errattrs
+           , EventBeginElement errorTagName []
+           , EventEndElement errorTagName
+           , EventEndElement errname
+            {-
+           , EventBeginElement "{jabber:client}body" []
+           , EventContent (ContentText "what?")
+           , EventEndElement "{jabber:client}body"
+            -}
+           {-
+           , EventBeginElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy" []
+           , EventEndElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy"
+           -}
+           , endTag
+           ]
+
 monitor ::
     Server ConnectionKey SockAddr
     -> ConnectionParameters ConnectionKey SockAddr
@@ -1100,11 +1385,6 @@ monitor sv params xmpp = do
                     return dup
                 _ -> return stanza
         forkIO $ do
-            case stanzaType stanza of
-                Message {} -> do
-                    let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
-                    xmppDeliverMessage xmpp fail stanza
-                _ -> return ()
             case stanzaOrigin stanza of
                 NetworkOrigin k@(ClientKey {}) replyto -> 
                     case stanzaType stanza of
@@ -1112,7 +1392,34 @@ monitor sv params xmpp = do
                             sockaddr <- socketFromKey sv k
                             rsc <- xmppChooseResourceName xmpp k sockaddr wanted
                             let reply = iq_bind_reply (stanzaId stanza) rsc
+                            -- sendReply quitVar SetResource reply replyto
+                            hostname <- xmppTellMyNameToClient xmpp
+                            let requestVersion = do
+                                  yield $ EventBeginElement "{jabber:client}iq"
+                                              [ attr "to" rsc 
+                                              , attr "from" hostname
+                                              , attr "type" "get"
+                                              , attr "id" "version"]
+                                  yield $ EventBeginElement "{jabber:iq:version}query" []
+                                  yield $ EventEndElement "{jabber:iq:version}query"
+                                  yield $ EventEndElement "{jabber:client}iq"
+                                  {-
+                                  -- XXX Debug chat:
+                                  yield $ EventBeginElement "{jabber:client}message"
+                                          [ attr "from" $ eventContent (Just [ContentText rsc])
+                                          , attr "type" "normal" ] -- "blackbird" ]
+                                  yield $ EventBeginElement "{jabber:client}body" []
+                                  yield $ EventContent $ ContentText ("hello?")
+                                  yield $ EventEndElement "{jabber:client}body"
+                                  yield $ EventEndElement "{jabber:client}message"
+                                  -}
                             sendReply quitVar SetResource reply replyto
+                            conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
+                                  Nothing -- id
+                                  (Just hostname) -- from
+                                  (Just rsc) -- to
+                                  requestVersion
+                              >>= ioWriteChan replyto
                         SessionRequest -> do
                             me <- xmppTellMyNameToClient xmpp
                             let reply = iq_session_reply (stanzaId stanza) me
@@ -1122,12 +1429,36 @@ monitor sv params xmpp = do
                             xmppSubscribeToRoster xmpp k
                         PresenceStatus {} -> do
                             xmppInformClientPresence xmpp k stanza
+                        NotifyClientVersion name version -> do
+                            enableClientHacks name version replyto
                         UnrecognizedQuery query -> do
                             me <- xmppTellMyNameToClient xmpp
                             let reply = iq_service_unavailable (stanzaId stanza) me query
-                            sendReply quitVar Error reply replyto
+                            sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
+                        Message {} -> do
+                            -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza))
+                            maybe (return ()) (flip cacheMessageId replyto) $ do
+                                guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
+                                stanzaId stanza
                         _ -> return ()
                 _ -> return ()
+            case stanzaType stanza of
+                Message {} -> do
+                  case stanzaOrigin stanza of
+                    LocalPeer {} -> return ()
+                    NetworkOrigin _ replyto -> do
+                    let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
+                    xmppDeliverMessage xmpp fail stanza
+                    {-
+                    -- test error
+                    reply <- makeErrorStanza stanza
+                    tag <- stanzaFirstTag stanza
+                    sendReply quitVar (Error RecipientUnavailable tag) reply replyto
+                    -}
+                    -- -- bad idea:
+                    -- let newStream = greet'' "jabber:client" "blackbird"
+                    -- sendReply quitVar Error newStream replyto
+                _ -> return ()
         -- We need to clone in the case the stanza is passed on as for Message.
 #ifndef PINGNOISE
         let notping f = case stanzaType stanza of Pong -> return ()