From 36637654a5d18125370ba1323e9e96a6bc01441f Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 29 Jul 2013 23:50:14 -0400 Subject: Progress toward support for messaging. --- Presence/SendMessage.hs | 13 ++-- Presence/XMPP.hs | 161 +++++++++++++++++++++++++++++++++++++++++++++++- Presence/XMPPTypes.hs | 34 +++++++++- Presence/main.hs | 32 +++++++++- 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: +unhandled-C: +unhandled-C: +unhandled-C: hello dude +unhandled-C: +unhandled-C: +-} +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 -- cgit v1.2.3