xmppDeliverMessage

2 files changed, 14 insertions, 0 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index d3df48d0..4c87ba65 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -7,6 +7,7 @@ module XMPPServer
     , StanzaType(..)
     , StanzaOrigin(..)
     , cloneStanza
+    , LangSpecificMessage(..)
     ) where
 import Debug.Trace
 import Control.Monad.Trans.Resource (runResourceT)
@@ -129,6 +130,7 @@ data XMPPServerParameters =
     , xmppRosterOthers       :: ConnectionKey -> IO [Text]
     , xmppLookupClientJID :: ConnectionKey -> IO Text
     , xmppLookupPeerName  :: ConnectionKey -> IO Text
+    , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
     }
 
 -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
@@ -835,6 +837,9 @@ monitor sv params xmpp = do
                             sendReply quitVar Pong reply replyto
                         RequestRoster ->
                             sendRoster stanza xmpp replyto
+                        Message {} -> do
+                            let fail = return () -- todo
+                            xmppDeliverMessage xmpp fail stanza
                         UnrecognizedQuery query -> do
                             let reply = iq_service_unavailable (stanzaId stanza) "localhost" query
                             sendReply quitVar Error reply replyto
diff --git a/xmppServer.hs b/xmppServer.hs
index 4601dbe9..ae3561db 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -10,6 +10,9 @@ import Network.Socket
     , addrFlags
     , AddrInfoFlag(AI_CANONNAME)
     )
+import Data.Monoid ( (<>) )
+import qualified Data.Text.IO as Text
+import Control.Monad
 
 
 import XMPPServer
@@ -27,6 +30,12 @@ main = runResourceT $ do
         , xmppRosterOthers = \k -> return []
         , xmppLookupPeerName = \k ->  return "localhost"
         , xmppLookupClientJID = \k -> return "nobody@localhost/tty666"
+        , xmppDeliverMessage = \fail msg -> do
+            let msgs = msgLangMap (stanzaType msg)
+                body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs
+            when (not $ null body) $ do
+            Text.putStrLn $ "MESSAGE " <> head body
+            return ()
         }
     liftIO $ do
     let testaddr0 = "fd97:ca88:fa7c:b94b:c8b8:fad4:1021:a54d"