Progress toward support for messaging.

4 files changed, 228 insertions, 12 deletions

diff --git a/Presence/SendMessage.hs b/Presence/SendMessage.hs
index d1db7a4f..8b4d00f7 100644
--- a/Presence/SendMessage.hs
+++ b/Presence/SendMessage.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
 module SendMessage
     ( sendMessage
     , CommandCache(..)
@@ -46,13 +47,15 @@ import Network.Socket
     , SocketType(..)
     )
 
-import XMPPTypes (Peer(..),discardPort,peerAddr,withPort,socketFamily)
+import XMPPTypes (Peer(..),discardPort,peerAddr,withPort,socketFamily,showPeer)
 import SocketLike
 import ServerC (packetSink)
 import ControlMaybe 
 import Data.Conduit (Sink,Source)
 import qualified Data.ByteString as S (ByteString)
 import XMLToByteStrings
+import Logging
+import ByteStringOperators
 
 type ByteStringSink = Sink S.ByteString IO ()
 
@@ -94,7 +97,7 @@ newOutgoingConnections interpretCommands = do
 
 
 sendMessage
-  :: (CommandCache a, ThreadChannelCommand (CacheableCommand a)) =>
+  :: (Show (CacheableCommand a), CommandCache a, ThreadChannelCommand (CacheableCommand a)) =>
      OutgoingConnections a -> CacheableCommand a -> Peer -> IO ()
 sendMessage (OutgoingConnections cons interpretCommands) msg peer0 = do
     let peer = discardPort peer0
@@ -192,7 +195,7 @@ type OutBoundXML sock cache msg =
          -> Source IO [XML.Event]
 
 handleOutgoingToPeer
-  :: SocketLike sock =>
+  :: (SocketLike sock, Show msg) =>
      OutBoundXML sock cache msg
      -> sock
      -> cache 
@@ -201,11 +204,11 @@ handleOutgoingToPeer
      -> IO (Maybe msg)
 handleOutgoingToPeer toPeer sock cache chan snk = do
     p <- getPeerName sock
-    -- L.putStrLn $ "(>P) connected " <++> showPeer (RemotePeer p)
+    debugL $ "(>P) connected " <++> showPeer (RemotePeer p)
     failed <- newIORef Nothing
     let failure cmd = do
             writeIORef failed cmd
-            -- putStrLn $ "Failed: " ++ show cmd
+            debugStr $ "Failed: " ++ show cmd
     finally (
         handleIO_ (return ()) $ toPeer sock cache chan failure `xmlToByteStrings` snk
         ) $ return () -- logging L.putStrLn $ "(>P) disconnected " <++> showPeer (RemotePeer p)
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
+    }
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index b654b320..7ee09189 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -33,20 +33,24 @@ import Data.ByteString.Lazy.Char8 as L
     , takeWhile
     , fromChunks
     )
-import Text.Show.ByteString as L
+import qualified Text.Show.ByteString as L
+import qualified Data.Text as S hiding (pack)
 import Data.Binary.Builder as B
 import Data.Binary.Put
+import Data.Set as Set (Set)
+import Data.Map as Map (Map)
 import Control.DeepSeq
 import ByteStringOperators
 import SocketLike
 import GetHostByAddr
 import Data.Maybe (listToMaybe)
-import Data.XML.Types as XML (Event)
+import Data.XML.Types as XML (Event,Name,Content)
 
 data ClientCommands = 
     Send [XML.Event] 
     | BoundToResource
     | InterestedInRoster
+    | Chat Message
     | QuitThread 
  deriving Prelude.Show
 
@@ -73,6 +77,7 @@ class JabberClientSession session where
     isBuddy      :: session -> ByteString -> IO Bool
     approveSubscriber :: session -> ByteString -> IO ()
     rejectSubscriber  :: session -> ByteString -> IO ()
+    sendChat :: session -> Message -> IO ()
 
 class JabberPeerSession session where
     data XMPPPeerClass session
@@ -88,6 +93,7 @@ class JabberPeerSession session where
     processApproval  :: session -> ByteString -> JID -> IO ()
     processRejection :: session -> ByteString -> JID -> IO ()
     processRequest   :: session -> ByteString -> JID -> IO ()
+    sendChatToClient :: session -> Message -> IO ()
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
@@ -243,11 +249,35 @@ withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
 
 withoutPort = (`withPort` 0)
 
+
+data MessageThread = MessageThread { 
+        msgThreadParent  :: Maybe S.Text, 
+        msgThreadContent :: S.Text 
+    }
+  deriving (Show,Eq)
+
+data LangSpecificMessage = LangSpecificMessage {
+        msgBody :: Maybe S.Text,
+        msgSubject :: Maybe S.Text,
+        msgElements :: Set (XML.Name, [(Name, [Content])], S.Text )
+    }
+  deriving (Show,Eq)
+  
+
+data Message = Message { 
+                msgTo :: JID,
+                msgFrom :: JID,
+                msgThread :: Maybe MessageThread,
+                msgLangMap :: Map S.Text (LangSpecificMessage)
+               }
+  deriving (Show,Eq)
+
 data OutBoundMessage = OutBoundPresence Presence 
                         | PresenceProbe JID JID
                         | Solicitation  JID JID
                         | Approval JID JID
                         | Rejection JID JID
+                        | OutBoundMessage Message
                         | Disconnect
  deriving Prelude.Show
 
diff --git a/Presence/main.hs b/Presence/main.hs
index d7510f94..784faaca 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -56,7 +56,10 @@ import Network.Socket (Family(AF_INET,AF_INET6))
 import           Holumbus.Data.MultiMap as MM (MultiMap)
 import qualified Holumbus.Data.MultiMap as MM
 
-data Client = Client { clientShow :: JabberShow }
+data Client = Client { 
+    clientShow :: JabberShow,
+    clientChan :: TChan ClientCommands
+ }
 
 -- see Data.Map.Lazy.fromSet
 fromSet f = Map.fromList . map (\a -> (a,f a)) . Set.toList
@@ -195,7 +198,12 @@ instance JabberClientSession ClientSession where
             let au = activeUsers . presence_state $ s
             us <- readTVar au
             sequenceA $ Map.lookup (user,tty) us >>= \(ttypid,cs) -> do
-                let entry = (ttypid,Map.insert client_pid (Client {clientShow=stat}) cs)
+                let entry = (ttypid, Map.insert client_pid 
+                                                (Client {
+                                                     clientShow = stat,
+                                                     clientChan = Main.clientChannel s
+                                                 }) 
+                                                cs)
                 Just $ do
                     writeTVar au (Map.insert (user,tty) entry us)
                     subs <- readTVar $ subscriberMap (presence_state s)
@@ -394,6 +402,11 @@ instance JabberClientSession ClientSession where
                     (peer cjid)
         return ()
 
+    sendChat s msg = do
+        sendMessage (remotePeers . presence_state $ s) 
+                    (OutBoundMessage msg)
+                    (peer . msgTo $ msg)
+
 
 {- PeerSession 
  -
@@ -508,6 +521,21 @@ instance JabberPeerSession PeerSession where
         withJust mbuddy $ \buddy -> do
         rosterPush (PendingSubscriber user buddy) (peer_global session)
 
+    sendChatToClient session msg = do
+        let rsc = resource (msgTo msg)
+            g = peer_global session
+        (curtty,cmap) <- atomically $ liftM2 (,) (readTVar (currentTTY g))
+                                                 (readTVar (activeUsers g))
+                   
+        let rsc' = maybe curtty id rsc
+        withJust (name (msgTo msg)) $ \nto -> do
+        case Map.lookup (nto,rsc') cmap of
+            Just (ttypid,clients) -> 
+                forM_ (Map.toList clients) $ \(pid,client) -> do
+                    atomically $ writeTChan (clientChan client) (Chat msg)
+            Nothing            -> 
+                -- todo: fallback
+                return () 
 
 
 type RefCount = Int