1 files changed, 158 insertions, 3 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 6c802fb4..1c6336b9 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -24,12 +24,14 @@ import ControlMaybe
 import XMLToByteStrings
 import SendMessage
 import Logging
+import Todo
 
 import Data.Maybe (catMaybes)
 import Data.HList
 import Network.Socket ( Family )
 import Control.Concurrent.STM
 import Data.Conduit
+import Data.Maybe
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as L
     ( fromChunks
@@ -42,7 +44,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
 import Text.XML.Stream.Parse (def,parseBytes,content)
 import Data.XML.Types as XML
-import qualified Data.Text as S (takeWhile)
+import qualified Data.Text as S (Text,takeWhile)
 import Data.Text.Encoding      as S (decodeUtf8,encodeUtf8)
 import Data.Text.Lazy.Encoding as L (decodeUtf8)
 import Data.Text.Lazy (toStrict)
@@ -383,6 +385,7 @@ handleClientPresence session stanza = do
     log $ "requesting presence: "<++>bshow stat'
     return ()
 
+
 fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) => 
     session -> TChan ClientCommands -> Sink XML.Event m ()
 fromClient session cmdChan = doNestingXML $ do
@@ -421,6 +424,7 @@ fromClient session cmdChan = doNestingXML $ do
                                            -> clientRejectsSubscription session stanza
              _ | stanza `isClientPresenceOf` presenceTypeOnline
                                            -> handleClientPresence session stanza
+             _ | isMessageStanza stanza    -> handleClientMessage session stanza
              _ | otherwise                 -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -474,6 +478,7 @@ toClient session pchan cmdChan rchan = toClient' False False
       CmdChan InterestedInRoster -> do
         liftIO . debugStr $ "Roster: interested"
         toClient' isBound True
+      CmdChan (Chat msg) -> return () -- TODO
       -- CmdChan cmd        -> liftIO (debugStr $ "unhandled event: "++show cmd) >> loop
       RChan   (RequestedSubscription who contact) ->  do
         jid <- liftIO $ getJID session
@@ -667,6 +672,23 @@ handlePeerPresence session stanza True = do
     liftIO $ announcePresence session (Presence pjid stat')
     log $ bshow (Presence pjid stat')
 
+handlePeerMessage session stanza = do
+    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \fromstr-> do
+    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \tostr -> do
+    fromjid <- liftIO $ parseAddressJID (textToByteString fromstr)
+    tojid <- liftIO $ parseAddressJID (textToByteString tostr)
+    let log  = liftIO . debugL . ("(P) " <++>)
+    log $ "handlePeerMessage "<++>bshow stanza
+    msg <- parseMessage ("{jabber:server}body"
+                        ,"{jabber:server}subject"
+                        ,"{jabber:server}thread"
+                        )
+                        log
+                        fromjid
+                        tojid
+                        stanza
+    liftIO $ sendChatToClient session msg
+
 matchAttribMaybe name (Just value) attrs = 
     case find ( (==name) . fst) attrs of
         Just (_,[ContentText x])   | x==value -> True
@@ -692,6 +714,14 @@ isPresenceOf (EventBeginElement name attrs) testType
     = True
 isPresenceOf _ _ = False
 
+isMessageStanza (EventBeginElement name attrs) 
+    | name=="{jabber:client}message"
+    = True
+isMessageStanza (EventBeginElement name attrs) 
+    | name=="{jabber:server}message"
+    = True
+isMessageStanza _ = False
+
 isClientPresenceOf (EventBeginElement name attrs) testType
     | name=="{jabber:client}presence"
     && matchAttribMaybe "type" testType attrs
@@ -878,6 +908,8 @@ fromPeer session = doNestingXML $ do
                     -> peerApprovesSubscription session stanza
               _ | stanza `isPresenceOf` presenceTypeUnsubscribed
                     -> peerRejectsSubscription session stanza
+              _ | isMessageStanza stanza 
+                    -> handlePeerMessage session stanza
               _ -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -914,6 +946,7 @@ instance CommandCache CachedMessages where
                 cache { approvals= mmInsert (True,from) to $ approvals cache }
     updateCache (Rejection from to) cache =
                 cache { approvals= mmInsert (False,from) to $ approvals cache }
+    updateCache (OutBoundMessage msg) cache = cache -- TODO
 
 instance ThreadChannelCommand OutBoundMessage where
     isQuitCommand Disconnect = True
@@ -991,12 +1024,15 @@ toPeer sock cache chan fail = do
                           (if approve then "subscribed" else "unsubscribed"))
                        (if approve then Approval from to
                                    else Rejection from to)
+        sendMessage msg =
+            sendOrFail (xmlifyMessageForPeer sock msg)
+                       (OutBoundMessage msg)
 
 
     send greetPeer
     forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do
         forM_ (Set.toList froms) $ \(approve,from) -> do
-            liftIO $ debugL "sending cached approval..."
+            liftIO $ debugL "sending cached approval/rejection..."
             sendApproval approve from to
     forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
         sendPresence (Presence jid st)
@@ -1027,9 +1063,13 @@ toPeer sock cache chan fail = do
           Rejection from to -> do
             liftIO . debugL $ "sending rejection "<++>bshow (from,to)
             sendApproval False from to
+          OutBoundMessage msg -> sendMessage msg
           Disconnect -> return ()
         when (not . isQuitCommand $ event) loop
-    send goodbyePeer
+    return ()
+    -- send goodbyePeer -- TODO: why does this cause an exception?
+                        --   Text/XML/Stream/Render.hs:169:5-15: 
+                        --      Irrefutable pattern failed for pattern (sl : s')
 
 
 
@@ -1079,3 +1119,118 @@ xmlifyPresenceForPeer sock (Presence jid stat) = do
       [ EventBeginElement "{jabber:server}show" []
       , EventContent (ContentText stat)
       , EventEndElement "{jabber:server}show" ]
+
+xmlifyMessageForPeer sock msg = do
+    addr <- getSocketName sock
+    remote <- getPeerName sock
+    let n = name (msgFrom msg)
+        rsc = resource (msgFrom msg)
+        jidstr = toStrict . L.decodeUtf8 
+                  $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
+        tostr = toStrict . L.decodeUtf8 
+                  $ name (msgTo msg) <$++> "@" 
+                    <?++> showPeer (RemotePeer remote) <++?> "/" 
+                    <++$> resource (msgTo msg)
+    return $
+        [ EventBeginElement "{jabber:server}message" 
+            [ attr "from" jidstr
+            , attr "to"   tostr
+            ]
+        ]
+        ++ xmlifyMsgElements (msgLangMap msg) ++
+        [ EventEndElement "{jabber:server}message" ]
+
+xmlifyMsgElements langmap = concatMap (uncurry langElements) . Map.toList $ langmap
+
+langElements lang msg = 
+    ( maybeToList (msgSubject msg)
+         >>= wrap "{jabber:server}subject" )
+    ++ ( maybeToList (msgBody msg)
+         >>= wrap "{jabber:server}body" )
+    ++ ( Set.toList (msgElements msg)
+         >>= wrapTriple )
+ where
+    wrap name content = 
+        [ EventBeginElement name 
+            ( if lang/="" then [attr "xml:lang" lang] 
+                          else [] )
+        , EventContent (ContentText content)
+        , EventEndElement name
+        ]
+    wrapTriple (name,attrs,content) =
+        [ EventBeginElement name attrs -- Note: we assume lang specified in attrs
+        , EventContent (ContentText content)
+        , EventEndElement name
+        ]
+
+
+handleClientMessage session stanza = do
+    let log  = liftIO . debugL . ("(C) " <++>)
+    log $ "handleClientMessage "<++>bshow stanza
+    from <- liftIO $ getJID session
+    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
+    log $ "  to = "<++>bshow to_str
+    tojid <- liftIO $ parseHostNameJID (textToByteString to_str)
+    msg <- parseMessage ("{jabber:client}body"
+                        ,"{jabber:client}subject"
+                        ,"{jabber:client}thread"
+                        )
+                        log
+                        from
+                        tojid
+                        stanza
+    liftIO $ sendChat session msg
+
+{-
+unhandled-C: <message
+unhandled-C:   type="chat"
+unhandled-C:   id="purplea0a7fd24"
+unhandled-C:   to="user@vm2"
+unhandled-C:   xmlns="jabber:client">
+unhandled-C:     <active xmlns="http://jabber.org/protocol/chatstates"/>
+unhandled-C:     <body>
+unhandled-C:         hello dude
+unhandled-C:     </body>
+unhandled-C: </message>
+-}
+parseMessage (bodytag,subjecttag,threadtag) log from tojid stanza = do
+    let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing, msgElements=Set.empty }
+        parseChildren (th,cmap) = do
+            child <- nextElement
+            lvl <- nesting
+            xmllang <- xmlLang 
+            let lang = maybe "" id xmllang
+            let c = maybe emptyMsg id (Map.lookup lang cmap)
+            log $ " child: "<++> bshow child
+            case child of
+                Just tag | tagName tag==bodytag
+                                    -> do
+                                        txt <- lift content
+                                        awaitCloser lvl
+                                        parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
+                Just tag | tagName tag==subjecttag
+                                    -> do
+                                        txt <- lift content
+                                        awaitCloser lvl
+                                        parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
+                Just tag | tagName tag==threadtag
+                                    -> do
+                                        txt <- lift content
+                                        awaitCloser lvl
+                                        parseChildren (th {msgThreadContent=txt},cmap)
+                Just tag -> do
+                            let nm    = tagName tag
+                                attrs = tagAttrs tag
+                                elems = msgElements c
+                            txt <- lift content
+                            awaitCloser lvl
+                            parseChildren (th,Map.insert lang (c {msgElements=Set.insert (nm,attrs,txt) elems}) cmap)
+                Nothing -> return (th,cmap)
+    (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
+                                  , Map.empty )
+    return Message { 
+        msgTo = tojid,
+        msgFrom = from,
+        msgLangMap = langmap,
+        msgThread = if msgThreadContent th/="" then Just th else Nothing
+    }