{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} module XMPP ( module XMPPTypes , listenForXmppClients , listenForRemotePeers , newServerConnections , seekRemotePeers , quitListening , OutBoundMessage(..) , OutgoingConnections , CachedMessages , toPeer , newOutgoingConnections , sendMessage ) where import ServerC import XMPPTypes import ByteStringOperators 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 Control.Concurrent.STM.Delay import Data.Conduit import Data.Maybe import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as L ( fromChunks ) import Control.Concurrent.Async import Control.Exception as E ( finally ) import System.IO.Error (isDoesNotExistError) import Control.Monad.IO.Class 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 (Text,takeWhile) import Data.Text.Encoding as S (decodeUtf8,encodeUtf8) import Data.Text.Lazy.Encoding as L (decodeUtf8) import Data.Text.Lazy (toStrict) import qualified Data.Sequence as Seq import Data.Foldable (toList) import Data.List (find) import qualified Text.Show.ByteString as L import NestingXML import Data.Set as Set (Set,(\\)) import qualified Data.Set as Set import qualified Data.Map as Map import Data.Map as Map (Map) textToByteString x = L.fromChunks [S.encodeUtf8 x] xmlifyPresenceForClient :: Presence -> IO [XML.Event] xmlifyPresenceForClient (Presence jid stat) = do let n = name jid rsc = resource jid names <- getNamesForPeer (peer jid) let tostr p = L.decodeUtf8 $ n <$++> "@" L.fromChunks [p] <++?> "/" <++$> rsc jidstrs = fmap (toStrict . tostr) names return (concatMap presenceEvents jidstrs) where presenceEvents jidstr = [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat) ] ++ ( shw stat >>= jabberShow ) ++ [ EventEndElement "{jabber:client}presence" ] typ Offline = [("type",[ContentText "unavailable"])] typ _ = [] shw ExtendedAway = ["xa"] shw Chatty = ["chat"] shw Away = ["away"] shw DoNotDisturb = ["dnd"] shw _ = [] jabberShow stat = [ EventBeginElement "{jabber:client}show" [] , EventContent (ContentText stat) , EventEndElement "{jabber:client}show" ] prefix ## name = Name name Nothing (Just prefix) streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream") greet host = [ EventBeginDocument , EventBeginElement (streamP "stream") [("from",[ContentText host]) ,("id",[ContentText "someid"]) ,("xmlns",[ContentText "jabber:client"]) ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"]) ,("version",[ContentText "1.0"]) ] , EventBeginElement (streamP "features") [] , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" {- -- , " " , " " -- , " DIGEST-MD5" , " PLAIN" , " " -} , EventEndElement (streamP "features") ] -- type Consumer i m r = forall o. ConduitM i o m r mawait :: Monad m => MaybeT (ConduitM i o m) i mawait = MaybeT await -- Note: This function ignores name space qualification elementAttrs expected (EventBeginElement name attrs) | nameLocalName name==expected = return attrs elementAttrs _ _ = mzero eventIsBeginElement (EventBeginElement _ _) = True eventIsBeginElement _ = False eventIsEndElement (EventEndElement _) = True eventIsEndElement _ = False filterMapElement:: (Monad m, MonadPlus mp) => (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a) filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1 where loop ts 0 = return ts loop ts cnt = do tag <- mawait let ts' = mplus ts (ret tag) case () of _ | eventIsEndElement tag -> loop ts' (cnt-1) _ | eventIsBeginElement tag -> loop ts' (cnt+1) _ -> loop ts' cnt gatherElement :: (Monad m, MonadPlus mp) => Event -> mp Event -> NestingXML o m (mp Event) gatherElement opentag empty = loop (empty `mplus` return opentag) 1 where loop ts 0 = return ts loop ts cnt = do maybeXML (return ts) $ \tag -> do let ts' = mplus ts (return tag) case () of _ | eventIsEndElement tag -> loop ts' (cnt-1) _ | eventIsBeginElement tag -> loop ts' (cnt+1) _ -> loop ts' cnt voidMaybeT body = (>> return ()) . runMaybeT $ body fixMaybeT f = (>> return ()) . runMaybeT . fix $ f iq_bind_reply id jid = [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])] , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])] , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" [] , EventContent (ContentText jid) , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" , EventEndElement "{jabber:client}iq" ] uncontent cs = head $ map getText cs where getText (ContentText x) = x getText (ContentEntity x ) = x tagAttrs (EventBeginElement _ xs) = xs tagAttrs _ = [] tagName (EventBeginElement n _) = n tagName _ = "" handleIQSetBind session cmdChan stanza_id = do mchild <- nextElement rsc <- case mchild of Just child -> do let unhandledBind = do liftIO $ debugStr $ "unhandled-bind: "++show child return "" case tagName child of "{urn:ietf:params:xml:ns:xmpp-bind}resource" -> do rsc <- lift content return . textToByteString $ rsc _ -> unhandledBind Nothing -> do liftIO $ debugStr $ "empty bind request!" return "" liftIO $ do debugL $ "iq-set-bind-resource " <++> rsc setResource session rsc jid <- getJID session atomically $ do writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) ) writeTChan cmdChan BoundToResource forCachedPresence session $ \presence -> do xs <- xmlifyPresenceForClient presence atomically . writeTChan cmdChan . Send $ xs iq_session_reply host stanza_id = [ EventBeginElement "{jabber:client}iq" [("id",[ContentText stanza_id]) ,("from",[ContentText host]) ,("type",[ContentText "result"]) ] , EventEndElement "{jabber:client}iq" ] handleIQSetSession session cmdChan stanza_id = do host <- liftIO $ do jid <- getJID session names <- getNamesForPeer (peer jid) return (S.decodeUtf8 . head $ names) liftIO . atomically . writeTChan cmdChan . Send $ iq_session_reply host stanza_id handleIQSet session cmdChan tag = do withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do whenJust nextElement $ \child -> do let unhandledSet = liftIO $ debugStr ("iq-set: "++show (stanza_id,child)) case tagName child of "{urn:ietf:params:xml:ns:xmpp-bind}bind" -> handleIQSetBind session cmdChan stanza_id "{urn:ietf:params:xml:ns:xmpp-session}session" -> handleIQSetSession session cmdChan stanza_id _ -> unhandledSet matchAttrib name value attrs = case find ( (==name) . fst) attrs of Just (_,[ContentText x]) | x==value -> True Just (_,[ContentEntity x]) | x==value -> True _ -> False lookupAttrib name attrs = case find ( (==name) . fst) attrs of Just (_,[ContentText x]) -> Just x Just (_,[ContentEntity x]) -> Just x _ -> Nothing iqTypeSet = "set" iqTypeGet = "get" iqTypeResult = "result" iqTypeError = "error" isIQOf (EventBeginElement name attrs) testType | name=="{jabber:client}iq" && matchAttrib "type" testType attrs = True isIQOf _ _ = False isServerIQOf (EventBeginElement name attrs) testType | name=="{jabber:server}iq" && matchAttrib "type" testType attrs = True isServerIQOf _ _ = False iq_service_unavailable host iq_id mjid req = [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "error"]) ,("id",[ContentText iq_id]) -- , TODO: set "from" if isJust mjid ] , EventBeginElement req [] , EventEndElement req , EventBeginElement "{jabber:client}error" [("type",[ContentText "cancel"])] , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" [] , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" , EventEndElement "{jabber:client}error" , EventEndElement "{jabber:client}iq" ] attr name value = (name,[ContentText value]) attrbs name value = (name,[ContentText (toStrict . L.decodeUtf8 $ value)]) getRoster session iqid = do let getlist f = do bs <- f session -- js <- mapM parseHostNameJID bs return (Set.fromList bs) -- js) buddies <- getlist getMyBuddies subscribers <- getlist getMySubscribers solicited <- getlist getMySolicited subnone0 <- getlist getMyOthers let subnone = subnone0 \\ (Set.union buddies subscribers) let subto = buddies \\ subscribers let subfrom = subscribers \\ buddies let subboth = Set.intersection buddies subscribers -- solicited -> ask='subscribe' jid <- getJID session let dest = toStrict . L.decodeUtf8 . bshow $ jid let items= (xmlify solicited "to" subto) ++(xmlify solicited "from" subfrom) ++(xmlify solicited "both" subboth) ++(xmlify solicited "none" subnone) openiq = [EventBeginElement "{jabber:client}iq" [ attr "id" iqid , attr "to" dest , attr "type" "result" ] ,EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver? ] closeiq = [EventEndElement "{jabber:iq:roster}query" ,EventEndElement "{jabber:client}iq"] return $ openiq ++ items ++ closeiq where xmlify solicited stype set = flip concatMap (Set.toList set) $ \jid -> [ EventBeginElement "item" ([ attr "jid" (toStrict . L.decodeUtf8 $ jid) , attr "subscription" stype ]++if Set.member jid solicited then [attr "ask" "subscribe"] else [] ) , EventEndElement "item" ] handleIQGet session cmdChan tag = do withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do whenJust nextElement $ \child -> do host <- liftIO $ do jid <- getJID session names <- getNamesForPeer (peer jid) return (S.decodeUtf8 . head $ names) let unhandledGet req = do liftIO $ debugStr ("iq-get: "++show (stanza_id,child)) liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req case tagName child of -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items" "{urn:xmpp:ping}ping" -> liftIO $ do let mjid = lookupAttrib "from" (tagAttrs tag) let pong = [ EventBeginElement "{jabber:client}iq" $ (case mjid of Just jid -> (attr "to" jid :) _ -> id ) [ attr "type" "result" , attr "id" stanza_id , attr "from" host ] , EventEndElement "{jabber:client}iq" ] atomically . writeTChan cmdChan . Send $ pong "{jabber:iq:roster}query" -> liftIO $ do debugStr $ "REQUESTED ROSTER " ++ show tag roster <- getRoster session stanza_id atomically $ do writeTChan cmdChan InterestedInRoster writeTChan cmdChan . Send $ roster sendPending session req -> unhandledGet req handleClientPresence session stanza = do -- online (Available or Away) let log = liftIO . debugL . ("(C) " <++>) log $ "handleClientPresence "<++>bshow stanza jid <- liftIO $ getJID session -- cjid <- liftIO $ parseAddressJID (textToByteString jid) let parseChildren stat = do child <- nextElement log $ " child: "<++> bshow child case child of Just tag | tagName tag=="{jabber:client}show" -> fmap toStat (lift content) Just tag | otherwise -> parseChildren stat Nothing -> return stat toStat "away" = Away toStat "xa" = ExtendedAway toStat "dnd" = DoNotDisturb toStat "chat" = Chatty stat' <- parseChildren Available liftIO $ setPresence session stat' 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 let log = liftIO . debugL . ("(C) " <++>) send = liftIO . atomically . writeTChan cmdChan . Send withXML $ \begindoc -> do when (begindoc==EventBeginDocument) $ do log "begin-doc" withXML $ \xml -> do withJust (elementAttrs "stream" xml) $ \stream_attrs -> do log $ "stream atributes: " <++> bshow stream_attrs host <- liftIO $ do jid <- getJID session names <- getNamesForPeer (peer jid) return (S.decodeUtf8 . head $ names) send $ greet host fix $ \loop -> do log "waiting for stanza." whenJust nextElement $ \stanza -> do stanza_lvl <- nesting liftIO . debugStr $ "stanza: "++show stanza let unhandledStanza = do xs <- gatherElement stanza Seq.empty prettyPrint "unhandled-C: " (toList xs) case () of _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza _ | stanza `isClientPresenceOf` presenceTypeSubscribe -> clientRequestsSubscription session cmdChan stanza _ | stanza `isClientPresenceOf` presenceTypeSubscribed -> clientApprovesSubscription session stanza _ | stanza `isClientPresenceOf` presenceTypeUnsubscribed -> clientRejectsSubscription session stanza _ | stanza `isClientPresenceOf` presenceTypeOnline -> handleClientPresence session stanza _ | isMessageStanza stanza -> handleClientMessage session stanza _ | otherwise -> unhandledStanza awaitCloser stanza_lvl loop log $ "end of stream" withXML $ \xml -> do log $ "end-of-document: " <++> bshow xml rosterPush to contact attrs = do let n = name to rsc = resource to names <- getNamesForPeer (peer to) let tostr p = L.decodeUtf8 $ n <$++> "@" L.fromChunks [p] <++?> "/" <++$> rsc jidstrs = fmap (toStrict . tostr) names tojid = head jidstrs return [ EventBeginElement "{jabber:client}iq" [ attr "to" tojid , attr "id" "someid" , attr "type" "set" ] , EventBeginElement "{jabber:iq:roster}query" [] , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs) , EventEndElement "{jabber:iq:roster}item" , EventEndElement "{jabber:iq:roster}query" , EventEndElement "{jabber:client}iq" ] data EventsForClient = CmdChan ClientCommands | PChan Presence | RChan RosterEvent toClient :: (MonadIO m, JabberClientSession session ) => session -> TChan Presence -> TChan ClientCommands -> TChan RosterEvent -> Source m [XML.Event] toClient session pchan cmdChan rchan = toClient' False False where toClient' isBound isInterested = do let loop = toClient' isBound isInterested send xs = yield xs >> prettyPrint ">C: " xs event <- liftIO . atomically $ foldr1 orElse [fmap CmdChan $ readTChan cmdChan ,fmap RChan $ readTChan rchan ,fmap PChan $ readTChan pchan ] case event of CmdChan QuitThread -> return () CmdChan (Send xs) -> send xs >> loop CmdChan BoundToResource -> toClient' True isInterested CmdChan InterestedInRoster -> do liftIO . debugStr $ "Roster: interested" toClient' isBound True CmdChan (Chat msg) -> do xs <- liftIO $ xmlifyMessageForClient msg send xs loop -- CmdChan cmd -> liftIO (debugStr $ "unhandled event: "++show cmd) >> loop RChan (RequestedSubscription who contact) -> do jid <- liftIO $ getJID session when (isInterested && Just who==name jid) $ do r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"] send r loop RChan (NewBuddy who contact) -> do liftIO . debugStr $ "Roster push: NewBuddy "++show (isInterested,who,contact) (jid,me) <- liftIO $ do jid <- getJID session me <- asHostNameJID jid return (jid,me) withJust me $ \me -> do when (isInterested && Just who==name jid) $ do send [ EventBeginElement "{jabber:client}presence" [ attrbs "from" contact , attrbs "to" me , attr "type" "subscribed" ] , EventEndElement "{jabber:client}presence" ] let f True = "both" f False = "to" subscription <- fmap f (liftIO $ isSubscribed session contact) r <- liftIO . handleIO (\e -> debugStr ("Roster NewBuddy error: "++show e) >> return []) $ do rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "subscription" subscription] send r loop RChan (RemovedBuddy who contact) -> do liftIO . debugStr $ "Roster push: RemovedBuddy "++show (isInterested,who,contact) (jid,me) <- liftIO $ do jid <- getJID session me <- asHostNameJID jid return (jid,me) withJust me $ \me -> do when (isInterested && Just who==name jid) $ do send [ EventBeginElement "{jabber:client}presence" [ attrbs "from" contact , attrbs "to" me , attr "type" "unsubscribed" ] , EventEndElement "{jabber:client}presence" ] let f True = "from" f False = "none" subscription <- fmap f (liftIO $ isSubscribed session contact) r <- liftIO . handleIO (\e -> debugStr ("Roster RemovedBuddy error: "++show e) >> return []) $ do rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "subscription" subscription] send r loop RChan (NewSubscriber who contact) -> do liftIO . debugStr $ "Roster push: NewSubscriber "++show (isInterested,who,contact) (jid,me) <- liftIO $ do jid <- getJID session me <- asHostNameJID jid return (jid,me) withJust me $ \me -> do when (isInterested && Just who==name jid) $ do let f True = "both" f False = "from" subscription <- fmap f (liftIO $ isBuddy session contact) r <- liftIO . handleIO (\e -> debugStr ("Roster NewSubscriber error: "++show e) >> return []) $ do rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "subscription" subscription] send r loop RChan (RejectSubscriber who contact) -> do liftIO . debugStr $ "Roster push: RejectSubscriber "++show (isInterested,who,contact) (jid,me) <- liftIO $ do jid <- getJID session me <- asHostNameJID jid return (jid,me) withJust me $ \me -> do when (isInterested && Just who==name jid) $ do let f True = "to" f False = "none" subscription <- fmap f (liftIO $ isBuddy session contact) r <- liftIO . handleIO (\e -> debugStr ("Roster RejectSubscriber error: "++show e) >> return []) $ do rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "subscription" subscription] send r loop RChan (PendingSubscriber who contact) -> do liftIO . debugStr $ "Roster: Pending buddy "++show (isInterested,who,contact) (jid,me) <- liftIO $ do jid <- getJID session me <- asHostNameJID jid return (jid,me) withJust me $ \me -> do when (isInterested && Just who==name jid) $ do send [ EventBeginElement "{jabber:client}presence" [ attrbs "from" contact , attrbs "to" me , attr "type" "subscribe" ] , EventEndElement "{jabber:client}presence" ] loop PChan presence -> do when isBound $ do xs <- liftIO $ xmlifyPresenceForClient presence send xs loop handleClient :: (SocketLike sock, HHead l (XMPPClass session), JabberClientSession session) => HCons sock (HCons t l) -> Source IO ByteString -> Sink ByteString IO () -> IO () handleClient st src snk = do let HCons sock (HCons _ st') = st session_factory = hHead st' pname <- getPeerName sock session <- newSession session_factory sock debugStr $ "PEER NAME: "++Prelude.show pname pchan <- subscribe session Nothing rchan <- subscribeToRoster session let cmdChan = clientChannel session writer <- async ( toClient session pchan cmdChan rchan `xmlToByteStrings` snk ) finally ( src $= parseBytes def $$ fromClient session cmdChan ) $ do atomically $ writeTChan cmdChan QuitThread wait writer closeSession session listenForXmppClients :: (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1, HExtend e l1 (HCons PortNumber l), JabberClientSession session) => Family -> e1 -> e -> l2 -> IO ServerHandle listenForXmppClients addr_family session_factory port st = do doServer (addr_family .*. port .*. session_factory .*. st) handleClient listenForRemotePeers :: (HList l, HHead l (XMPPPeerClass session), HExtend e l1 (HCons PortNumber l), HExtend e1 l2 l1, JabberPeerSession session) => Family -> e1 -> e -> l2 -> IO ServerHandle listenForRemotePeers addrfamily session_factory port st = do doServer (addrfamily .*. port .*. session_factory .*. st) handlePeer handlePeer :: (HHead l (XMPPPeerClass session), JabberPeerSession session) => HCons RestrictedSocket (HCons t1 l) -> Source IO ByteString -> t -> IO () handlePeer st src snk = do let HCons sock (HCons _ st') = st session_factory = hHead st' name <- fmap bshow $ getPeerName sock debugL $ "(P) connected " <++> name session <- newPeerSession session_factory sock didClose <- newTVarIO False finally ( src $= parseBytes def $$ fromPeer sock session didClose ) $ do debugL $ "(P) disconnected " <++> name didc <- readTVarIO didClose when (not didc) $ closePeerSession session handlePeerPresence session stanza False = do -- Offline liftIO . debugStr $ "PEER-OFFLINE: "++show stanza withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do peer_jid <- liftIO $ parseAddressJID (textToByteString jid) liftIO . debugStr $ "PEER-OFFLINE-JID: "++show peer_jid liftIO $ announcePresence session (Presence peer_jid Offline) handlePeerPresence session stanza True = do -- online (Available or Away) let log = liftIO . debugL . ("(P) " <++>) withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do pjid <- liftIO $ parseAddressJID (textToByteString jid) -- stat <- show element content let parseChildren stat = do child <- nextElement case child of Just tag | tagName tag=="{jabber:server}show" -> fmap toStat (lift content) Just tag | otherwise -> parseChildren stat Nothing -> return stat toStat "away" = Away toStat "xa" = ExtendedAway toStat "dnd" = DoNotDisturb toStat "chat" = Chatty stat' <- parseChildren Available liftIO . debugStr $ "announcing peer online: "++show (pjid,stat') 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 Just (_,[ContentEntity x]) | x==value -> True _ -> False matchAttribMaybe name Nothing attrs | find ( (==name) . fst) attrs==Nothing = True matchAttribMaybe name Nothing attrs | otherwise = False presenceTypeOffline = Just "unavailable" presenceTypeOnline = Nothing presenceTypeProbe = Just "probe" presenceTypeSubscribe = Just "subscribe" presenceTypeSubscribed = Just "subscribed" presenceTypeUnsubscribed = Just "unsubscribed" isPresenceOf (EventBeginElement name attrs) testType | name=="{jabber:server}presence" && matchAttribMaybe "type" testType attrs = 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 = True isClientPresenceOf _ _ = False handlePresenceProbe session stanza = do withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do jid <- liftIO $ parseAddressJID $ textToByteString to withJust (name jid) $ \user -> do liftIO $ debugL $ "RECEIVED PROBE "<++>bshow (peerAddress session,to) liftIO $ do subs <- getSubscribers (peerSessionFactory session) user liftIO $ debugL $ "subscribers for "<++>bshow user<++>": " <++>bshow subs forM_ subs $ \jidstr -> do handleIO_ (return ()) $ do debugL $ "parsing " <++>jidstr sub <- parseHostNameJID jidstr debugStr $ "comparing " ++show (peer sub , peerAddress session) when (peer sub == discardPort (peerAddress session)) $ do ps <- userStatus session user -- todo: Consider making this a directed presence forM_ ps $ \p -> do debugStr ("PROBE-REPLY: "++show p) mapM_ (sendPeerMessage session . OutBoundPresence) ps return () subscribeToPresence subscribers peer_jid user = do pjid <- parseAddressJID peer_jid if Set.member pjid subscribers then return () else return () bare (JID n host _) = JID n host Nothing presenceErrorRemoteNotFound iqid from to = return [ EventBeginElement "{stream:client}presence" ( case iqid of { Nothing -> id; Just iqid -> ( attr "id" iqid :) } $ [ attr "from" to , attr "type" "error" ] ) , EventBeginElement "{stream:client}error" [ attr "type" "modify"] , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found" [] , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found" , EventEndElement "{stream:client}error" , EventEndElement "{stream:client}presence" ] presenceSubscribed from = return [ EventBeginElement "{stream:client}presence" [ attr "from" from , attr "type" "subscribed" ] , EventEndElement "{stream:client}presence" ] clientRequestsSubscription session cmdChan stanza = do liftIO $ do debugStr $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str0 -> do let to_str = S.takeWhile (/='/') to_str0 from = lookupAttrib "from" (tagAttrs stanza) iqid = lookupAttrib "id" (tagAttrs stanza) let handleError e | isDoesNotExistError e = do debugStr $ "remote-server-not-found" r <- presenceErrorRemoteNotFound iqid from to_str atomically $ writeTChan cmdChan (Send r) handleError e = do debugStr $ "ERROR: "++ show e handleIO handleError $ do let to_str' = textToByteString to_str to_jid <- fmap bare $ parseHostNameJID to_str' if (is_remote . peer) to_jid then do addSolicited session to_str' to_jid debugStr $ "added to solicited: " ++ show to_jid else do -- addLocalSubscriber session to_str -- self <- getJID session r <- presenceSubscribed to_str -- self atomically $ writeTChan cmdChan (Send r) return () stanzaFromTo :: JabberPeerSession session => session -> Event -> IO (Maybe (JID, JID)) stanzaFromTo session stanza = let lookup key = fmap textToByteString (lookupAttrib key (tagAttrs stanza)) parse jidstr = handleIO_ (return Nothing) (fmap Just $ parseAddressJID jidstr) in case liftM2 (,) (lookup "from") (lookup "to") of Nothing -> return Nothing Just (from,to) -> do mfrom <- parse from mto <- parse to case liftM2 (,) mfrom mto of Nothing -> return Nothing Just (from,to) -> do let fromjid = JID (name from) (peerAddress session) Nothing return $ Just (fromjid,to) peerRequestsSubsription session stanza = do liftIO $ debugStr $ "PEER PRESENCE SUBSCRIBE " ++ show stanza whenJust (liftIO . handleIO (\e -> debugStr ("peerRequestsSubsription: "++show e) >> return Nothing) $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do withJust (name tojid) $ \user -> do subs <- liftIO $ do subs <- getSubscribers (peerSessionFactory session) user msubs <- flip mapM subs $ \str -> do handleIO_ (return Nothing) (fmap Just $ parseHostNameJID str) return (catMaybes msubs) if elem fromjid subs then do liftIO . debugL $ bshow fromjid <++> " already subscribed to " <++> user -- if already subscribed, reply liftIO $ do sendPeerMessage session (Approval tojid fromjid) ps <- userStatus session user -- todo: consider making this a directed presence mapM_ (sendPeerMessage session . OutBoundPresence) ps else liftIO $ processRequest session user fromjid clientApprovesSubscription session stanza = do liftIO $ debugStr $ "CLIENT APPROVES SUBSCRIPTION" withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do liftIO $ approveSubscriber session (textToByteString to_str) clientRejectsSubscription session stanza = do liftIO $ debugStr $ "CLIENT REJECTS SUBSCRIPTION" withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do liftIO $ rejectSubscriber session (textToByteString to_str) peerApprovesSubscription session stanza = do liftIO $ debugStr $ "PEER APPROVES SUBSCRIPTION" whenJust (liftIO . handleIO (\e -> debugStr ("peerApprovesSubscription: "++show e) >> return Nothing) $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do withJust (name tojid) $ \user -> do liftIO $ processApproval session user fromjid peerRejectsSubscription session stanza = do liftIO $ debugStr $ "PEER REJECTS SUBSCRIPTION" whenJust (liftIO . handleIO (\e -> debugStr ("peerRejectsSubscription: "++show e) >> return Nothing) $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do withJust (name tojid) $ \user -> do liftIO $ processRejection session user fromjid handlePeerIQGet :: (JabberPeerSession session, MonadIO m) => session -> XML.Event -> NestingXML o m () handlePeerIQGet session tag = do -- TODO: Pings should not require an id field. withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do whenJust nextElement $ \child -> do let unhandledGet req = do liftIO $ debugStr ("iq-peer-get: "++show (stanza_id,child)) liftIO $ sendPeerMessage session (Unsupported (JID Nothing LocalHost Nothing) (JID Nothing (peerAddress session) Nothing) (Just (ContentText stanza_id)) req) -- Client equiv: liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req case tagName child of -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items" "{urn:xmpp:ping}ping" -> liftIO $ do sendPeerMessage session (Pong (JID Nothing LocalHost Nothing) (JID Nothing (peerAddress session) Nothing) (Just (ContentText stanza_id))) -- Client equiv: atomically . writeTChan cmdChan . Send $ pong return () req -> unhandledGet req fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => RestrictedSocket -> session -> TVar Bool -> Sink XML.Event m () fromPeer sock session didClose = doNestingXML $ do let log = liftIO . debugL . ("(P) " <++>) withXML $ \begindoc -> do when (begindoc==EventBeginDocument) $ do log "begin-doc" withXML $ \xml -> do withJust (elementAttrs "stream" xml) $ \stream_attrs -> do log $ "stream atributes: " <++> bshow stream_attrs let doTimeout = Thunk $ do atomically $ writeTVar didClose True closePeerSession session fix $ \loop -> do log "waiting for stanza." whenJust nextElement $ \stanza -> do stanza_lvl <- nesting liftIO $ sendPeerMessage session (ActivityBump doTimeout) -- reset ping timer let unhandledStanza = do xs <- gatherElement stanza Seq.empty prettyPrint "P: " (toList xs) case () of _ | stanza `isServerIQOf` iqTypeGet -> handlePeerIQGet session stanza _ | stanza `isPresenceOf` presenceTypeOnline -> handlePeerPresence session stanza True _ | stanza `isPresenceOf` presenceTypeOffline -> handlePeerPresence session stanza False _ | stanza `isPresenceOf` presenceTypeProbe -> handlePresenceProbe session stanza _ | stanza `isPresenceOf` presenceTypeSubscribe -> peerRequestsSubsription session stanza _ | stanza `isPresenceOf` presenceTypeSubscribed -> peerApprovesSubscription session stanza _ | stanza `isPresenceOf` presenceTypeUnsubscribed -> peerRejectsSubscription session stanza _ | isMessageStanza stanza -> handlePeerMessage session stanza _ -> unhandledStanza awaitCloser stanza_lvl loop log $ "end of stream" withXML $ \xml -> do log $ "end-of-document: " <++> bshow xml newServerConnections = newTVar Map.empty data CachedMessages = CachedMessages { presences :: Map JID JabberShow , probes :: Map JID (Set (Bool,JID)) -- False means solicitation rather than probe , approvals :: Map JID (Set (Bool,JID) ) -- False means rejection rather than approval } instance CommandCache CachedMessages where type CacheableCommand CachedMessages = OutBoundMessage emptyCache = CachedMessages Map.empty Map.empty Map.empty updateCache (OutBoundPresence (Presence jid Offline)) cache = cache { presences=Map.delete jid . presences $ cache } updateCache (OutBoundPresence p@(Presence jid st)) cache = cache { presences=Map.insert jid st . presences $ cache } updateCache (PresenceProbe from to) cache = cache { probes = mmInsert (True,from) to $ probes cache } updateCache (Solicitation from to) cache = cache { probes= mmInsert (False,from) to $ probes cache } updateCache (Approval from to) cache = 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: cache chat? updateCache (Pong _ _ _) cache = trace "(DISCARDING Pong)" cache -- pings are not cached updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached updateCache (ActivityBump sock) cache = cache instance ThreadChannelCommand OutBoundMessage where isQuitCommand Disconnect = True isQuitCommand _ = False mmInsert val key mm = Map.alter f key mm where f Nothing = Just $ Set.singleton val f (Just set) = Just $ Set.insert val set greetPeer = [ EventBeginDocument , EventBeginElement (streamP "stream") [ attr "xmlns" "jabber:server" , attr "version" "1.0" ] ] goodbyePeer = [ EventEndElement (streamP "stream") , EventEndDocument ] peerJidTextLocal sock jid = do addr <- getSocketName sock return . toStrict . L.decodeUtf8 $ name jid <$++> "@" showPeer (RemotePeer addr) <++?> "/" <++$> resource jid peerJidTextRemote sock jid = do addr <- getPeerName sock return . toStrict . L.decodeUtf8 $ name jid <$++> "@" showPeer (RemotePeer addr) <++?> "/" <++$> resource jid presenceStanza sock fromjid tojid typ = do from <- peerJidTextLocal sock fromjid let to = toStrict . L.decodeUtf8 $ name tojid <$++> "@" showPeer (peer tojid) return [ EventBeginElement "{jabber:server}presence" [ attr "from" from , attr "to" to , attr "type" typ ] , EventEndElement "{jabber:server}presence" ] toPeer :: SocketLike sock => sock -> CachedMessages -> TChan OutBoundMessage -> (Maybe OutBoundMessage -> IO ()) -> ConduitM i [Event] IO () toPeer sock cache chan fail = do let -- log = liftIO . debugL . ("(>P) " <++>) send xs = yield xs >> prettyPrint ">P: " xs -- >> return (3::Int) checkConnection cmd = do liftIO $ catchIO (getPeerName sock >> return ()) (\_ -> fail . Just $ cmd) sendOrFail getXML cmd = do checkConnection cmd r <- liftIO $ getXML -- handleIO (\e -> debugStr ("ERROR: "++show e) >> return []) getXML yieldOr r (fail . Just $ cmd) prettyPrint ">P: " r sendPresence presence = sendOrFail (xmlifyPresenceForPeer sock presence) (OutBoundPresence presence) sendProbe from to = sendOrFail (presenceStanza sock from to "probe") (PresenceProbe from to) sendSolicitation from to = sendOrFail (presenceStanza sock from to "subscribe") (Solicitation from to) sendApproval approve from to = sendOrFail (presenceStanza sock from to (if approve then "subscribed" else "unsubscribed")) (if approve then Approval from to else Rejection from to) sendMessage msg = sendOrFail (xmlifyMessageForPeer sock msg) (OutBoundMessage msg) sendPong from to mid = do liftIO . debugL $ "SEND PONG" sendOrFail (xmlifyPong sock from to mid) (Pong from to mid) where xmlifyPong sock from to mid = do fromjid <- peerJidTextLocal sock to tojid <- peerJidTextRemote sock to return $ [ EventBeginElement "{jabber:server}iq" $ (case mid of Just c -> (("id",[c]):) _ -> id ) [ attr "type" "result" , attr "to" tojid , attr "from" fromjid ] , EventEndElement "{jabber:server}iq" ] sendUnsupported from to mid tag = sendOrFail (xmlifyUnsupported sock from to mid tag) (Unsupported from to mid tag) where xmlifyUnsupported sock from to mid req = do fromjid <- peerJidTextLocal sock to tojid <- peerJidTextRemote sock to return $ [ EventBeginElement "{jabber:server}iq" $ (case mid of Just c -> (("id",[c]):) _ -> id ) [("type",[ContentText "error"]) , attr "to" tojid , attr "from" fromjid ] , EventBeginElement req [] , EventEndElement req , EventBeginElement "{jabber:server}error" [("type",[ContentText "cancel"])] , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" [] , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" , EventEndElement "{jabber:server}error" , EventEndElement "{jabber:server}iq" ] send greetPeer forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do forM_ (Set.toList froms) $ \(approve,from) -> do liftIO $ debugL "sending cached approval/rejection..." sendApproval approve from to forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do sendPresence (Presence jid st) forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do forM_ (Set.toList froms) $ \(got,from) -> do if got then do liftIO $ debugL "sending cached probe..." sendProbe from to else do liftIO $ debugL "sending cached solicitation..." sendSolicitation from to let five_sec = 5 * 1000000 :: Int pingref <- liftIO $ do ping_timer <- liftIO $ newDelay five_sec newTVarIO (ping_timer,0::Int) sockref <- liftIO $ atomically newEmptyTMVar let bump fromsock = do remote <- liftIO $ catchIO (fmap Just $ getPeerName sock) (\_ -> return Nothing) debugL $ "PING BUMP" <++?> fmap (showPeer . RemotePeer) remote timer <- atomically $ do tryTakeTMVar sockref putTMVar sockref fromsock (timer,v) <- readTVar pingref writeTVar pingref (timer,0) return timer updateDelay timer five_sec waitPing = do (timer,v) <- readTVar pingref waitDelay timer return v fix $ \loop -> do liftIO . debugStr $ "LOOP waiting..." event <- lift . atomically $ orElse (Left `fmap` readTChan chan) (Right `fmap` waitPing) liftIO . debugStr $ "LOOP event = " ++ show event let sendPing n = do case n of 0 -> do ping <- liftIO makePing yield ping liftIO . debugL $ "SEND PING" prettyPrint ">P: " ping ping_timer <- liftIO $ newDelay five_sec liftIO . atomically $ writeTVar pingref (ping_timer,1) loop 1 -> do remote <- liftIO $ getPeerName sock liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote) fromsock <- liftIO $ atomically $ readTMVar sockref -- liftIO $ sClose fromsock liftIO $ runThunk fromsock return () -- PING TIMEOUT (loop quits) x -> error ("What? "++show x) where makePing = do addr <- getSocketName sock remote <- getPeerName sock let from = toStrict . L.decodeUtf8 . showPeer $ RemotePeer addr to = toStrict . L.decodeUtf8 . showPeer $ RemotePeer remote mid = Just (ContentText "iduno") return $ [ EventBeginElement "{jabber:server}iq" $ (case mid of Just c -> (("id",[c]):) _ -> id ) [ ("type",[ContentText "get"]) , attr "to" to , attr "from" from ] , EventBeginElement "{urn:xmpp:ping}ping" [] , EventEndElement "{urn:xmpp:ping}ping" , EventEndElement "{jabber:server}iq" ] chanEvent event = do case event of OutBoundPresence p -> sendPresence p PresenceProbe from to -> do liftIO $ debugL "sending live probe..." sendProbe from to Solicitation from to -> do liftIO $ debugL "sending live solicitation..." sendSolicitation from to Approval from to -> do liftIO . debugL $ "sending approval "<++>bshow (from,to) sendApproval True from to Rejection from to -> do liftIO . debugL $ "sending rejection "<++>bshow (from,to) sendApproval False from to OutBoundMessage msg -> sendMessage msg Pong from to mid -> do liftIO . debugL $ "sending pong "<++>bshow (from,to) sendPong from to mid Unsupported from to mid tag -> sendUnsupported from to mid tag Disconnect -> return () ActivityBump fromsock -> liftIO (bump fromsock) when (not . isQuitCommand $ event) loop either chanEvent sendPing event 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') seekRemotePeers :: JabberPeerSession config => XMPPPeerClass config -> TChan Presence -> OutgoingConnections CachedMessages -> IO b0 seekRemotePeers config chan server_connections = do fix $ \loop -> do event <- atomically $ readTChan chan case event of p@(Presence jid stat) | not (is_remote (peer jid)) -> do -- debugL $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat runMaybeT $ do u <- MaybeT . return $ name jid subscribers <- liftIO $ do subs <- getSubscribers config u mapM parseHostNameJID subs -- liftIO . debugL $ "subscribers: " <++> bshow subscribers let peers = Set.map peer (Set.fromList subscribers) forM_ (Set.toList peers) $ \peer -> do when (is_remote peer) $ liftIO $ sendMessage server_connections (OutBoundPresence p) peer _ -> return (Just ()) loop xmlifyPresenceForPeer sock (Presence jid stat) = do addr <- getSocketName sock let n = name jid rsc = resource jid jidstr = toStrict . L.decodeUtf8 $ n <$++> "@" showPeer (RemotePeer addr) <++?> "/" <++$> rsc return $ [ EventBeginElement "{jabber:server}presence" (attr "from" jidstr:typ stat) ] ++ ( shw stat >>= jabberShow ) ++ [ EventEndElement "{jabber:server}presence" ] where typ Offline = [attr "type" "unavailable"] typ _ = [] shw ExtendedAway = ["xa"] shw Chatty = ["chat"] shw Away = ["away"] shw DoNotDisturb = ["dnd"] shw _ = [] jabberShow stat = [ EventBeginElement "{jabber:server}show" [] , EventContent (ContentText stat) , EventEndElement "{jabber:server}show" ] xmlifyMessageForClient msg = do let tojid = msgTo msg fromjid = msgFrom msg tonames <- getNamesForPeer (peer tojid) fromnames <- getNamesForPeer (peer fromjid) let mk_str ns jid = toStrict . L.decodeUtf8 $ name jid <$++> "@" L.fromChunks [head ns] <++?> "/" <++$> resource jid to_str = mk_str tonames tojid from_str = mk_str fromnames fromjid tags = ( "{jabber:client}subject" , "{jabber:client}body" ) return $ [ EventBeginElement "{jabber:client}message" [ attr "from" from_str , attr "to" to_str ] ] ++ xmlifyMsgElements tags (msgLangMap msg) ++ [ EventEndElement "{jabber:client}message" ] 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) tags = ( "{jabber:server}subject" , "{jabber:server}body" ) return $ [ EventBeginElement "{jabber:server}message" [ attr "from" jidstr , attr "to" tostr ] ] ++ xmlifyMsgElements tags (msgLangMap msg) ++ [ EventEndElement "{jabber:server}message" ] xmlifyMsgElements tags langmap = concatMap (uncurry (langElements tags)) . Map.toList $ langmap langElements (subjecttag,bodytag) lang msg = ( maybeToList (msgSubject msg) >>= wrap subjecttag ) ++ ( maybeToList (msgBody msg) >>= wrap bodytag ) ++ ( 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 }