{-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} module XMPPServer ( xmppServer , forkXmpp , quitXmpp , ClientAddress , PeerAddress , Local(..) , Remote(..) , ConnectionData(..) , ConnectionType(..) , MUC(..) , XMPPServerParameters(..) , XMPPServer , classifyConnection , addrToPeerKey , addrFromClientKey , xmppConnections , xmppEventChannel , StanzaWrap(..) , Stanza(..) , StanzaType(..) , StanzaOrigin(..) , cloneStanza , LangSpecificMessage(..) , peerKeyToText , addrToText , sendModifiedStanzaToPeer , sendModifiedStanzaToClient , presenceProbe , presenceSolicitation , makePresenceStanza , makeInformSubscription , makeRosterUpdate , makeMessage , JabberShow(..) , Server , flushPassThrough , greet' , (<&>) ) where import ConnectionKey import qualified Control.Concurrent.STM.UpdateStream as Slotted import Nesting import Connection.Tcp import EventUtil import ControlMaybe import LockedChan import Connection (PeerAddress(..)) import qualified Connection import Util import Network.Address (getBindAddress, sockAddrPort) import Debug.Trace import Control.Monad.Trans (lift) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Fix (fix) import Control.Monad import Control.Concurrent.ThreadUtil (forkIO,myThreadId,forkLabeled,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar,threadDelay) import Control.Concurrent.STM import Data.List hiding ((\\)) -- import Control.Concurrent.STM.TChan import Network.SocketLike import Text.Printf import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Strict8 -- import qualified Data.ByteString.Lazy.Char8 as Lazy8 import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB #if MIN_VERSION_conduit_extra(1,1,7) import Data.Conduit.ByteString.Builder (builderToByteStringFlush) #else import Data.Conduit.Blaze (builderToByteStringFlush) #endif import Control.Arrow import Control.Concurrent.STM.Util import DNSCache (withPort) import qualified Text.XML.Stream.Render as XML hiding (content) import qualified Text.XML.Stream.Parse as XML import Data.XML.Types as XML import Data.Maybe import Data.Monoid ( (<>) ) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Map as Map import Data.Set (Set, (\\) ) import qualified Data.Set as Set import Data.String ( IsString(..) ) import qualified System.Random import Data.Void (Void) import DPut import DebugTag import Stanza.Build import Stanza.Parse import Stanza.Types import MUC import Chat import Network.StreamServer (Local(..), Remote(..)) -- peerport :: PortNumber -- peerport = 5269 -- clientport :: PortNumber -- clientport = 5222 my_uuid :: Text my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574" data XMPPServerParameters = XMPPServerParameters { -- | Called when a client requests a resource id. The first Maybe indicates -- the name the client referred to this server by. The second Maybe is the -- client's preferred resource name. -- -- The returned domain will be discarded and replaced with the result of -- 'xmppTellMyNameToClient'. -- -- A Left result causes an error stanza to be sent instead. xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text) , -- | This should indicate the server's hostname that all client's see. xmppTellMyNameToClient :: ClientAddress -> IO Text , xmppTellMyNameToPeer :: Local SockAddr -> IO Text , xmppTellClientHisName :: ClientAddress -> IO Text , xmppTellPeerHisName :: PeerAddress -> IO Text , xmppNewConnection :: SockAddr -> ConnectionData -> TChan Stanza -> IO () , xmppEOF :: SockAddr -> ConnectionData -> IO () , xmppRosterBuddies :: ClientAddress -> IO [Text] , xmppRosterSubscribers :: ClientAddress -> IO [Text] , xmppRosterSolicited :: ClientAddress -> IO [Text] , xmppRosterOthers :: ClientAddress -> IO [Text] , -- | Called when after sending a roster to a client. Usually this means -- the client status should change from "available" to "interested". xmppSubscribeToRoster :: ClientAddress -> IO () -- , xmppLookupClientJID :: SockAddr -> IO Text , xmppDeliverMessage :: (IO ()) -> Stanza -> IO () -- | Called whenever a local client's presence changes. , xmppInformClientPresence :: ClientAddress -> Stanza -> IO () -- | Called whenever a remote peer's presence changes. , xmppInformPeerPresence :: PeerAddress -> Stanza -> IO () , -- | Called when a remote peer requests our status. xmppAnswerProbe :: PeerAddress -> Stanza -> TChan Stanza -> IO () , xmppClientSubscriptionRequest :: IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO () , -- | Called when a remote peer sends subscription request. xmppPeerSubscriptionRequest :: IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO () , xmppClientInformSubscription :: IO () -> ClientAddress -> Stanza -> IO () , -- | Called when a remote peer informs us of our subscription status. xmppPeerInformSubscription :: IO () -> PeerAddress -> Stanza -> IO () , xmppGroupChat :: Map.Map Text MUC -- Key should be lowercase identifier. , xmppVerbosity :: IO Int , xmppClientBind :: Maybe SockAddr , xmppPeerBind :: Maybe SockAddr } enableClientHacks :: forall t a. (Eq a, IsString a) => a -> t -> TChan Stanza -> IO () enableClientHacks "Pidgin" version replyto = do wlog "Enabling hack SimulatedChatErrors for client Pidgin" donevar <- atomically newEmptyTMVar sendReply donevar (InternalEnableHack SimulatedChatErrors) [] replyto enableClientHacks "irssi-xmpp" version replyto = do wlog "Enabling hack SimulatedChatErrors for client irssi-xmpp" donevar <- atomically newEmptyTMVar sendReply donevar (InternalEnableHack SimulatedChatErrors) [] replyto enableClientHacks _ _ _ = return () cacheMessageId :: Text -> TChan Stanza -> IO () cacheMessageId id' replyto = do wlog $ "Caching id " ++ Text.unpack id' donevar <- atomically newEmptyTMVar sendReply donevar (InternalCacheId id') [] replyto -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error -- client connection -- socat script to send stanza fragment -- copyToChannel can keep a stack of closers to append to finish-off a stanza -- the TMVar () from forkConnection can be passed and with a stanza to detect interruption addrToText :: SockAddr -> Text addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr) where stripColon s = pre where (pre,_) = break (==':') s addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr) where stripColon s = if null bracket then pre else pre ++ "]" where (pre,bracket) = break (==']') s -- Shows (as Text) the IP address associated with the given SockAddr. peerKeyToText :: PeerAddress -> Text peerKeyToText (PeerAddress addr) = addrToText addr wlog :: String -> IO () wlog = dput XJabber wlogb :: ByteString -> IO () wlogb = wlog . Strict8.unpack flushPassThrough :: Monad m => ConduitT a b m () -> ConduitT (Flush a) (Flush b) m () flushPassThrough c = getZipConduit $ ZipConduit (onlyChunks .| mapOutput Chunk c) <* ZipConduit onlyFlushes where onlyChunks :: Monad m => ConduitT (Flush a) a m () onlyFlushes :: Monad m => ConduitT (Flush a) (Flush b) m () onlyChunks = awaitForever yieldChunk onlyFlushes = awaitForever yieldFlush yieldFlush Flush = yield Flush yieldFlush _ = return () yieldChunk (Chunk x) = yield x yieldChunk _ = return () xmlStream :: ReadCommand -> WriteCommand -> ( ConduitT () XML.Event IO () , ConduitT (Flush XML.Event) Void IO () ) xmlStream conread conwrite = (xsrc,xsnk) where xsrc = src .| XML.parseBytes XML.def xsnk :: ConduitT (Flush Event) Void IO () xsnk = -- XML.renderBytes XML.def =$ snk flushPassThrough (XML.renderBuilder XML.def) .| builderToByteStringFlush .| discardFlush .| snk where discardFlush :: Monad m => ConduitM (Flush a) a m () discardFlush = awaitForever yieldChunk yieldChunk (Chunk x) = yield x yieldChunk _ = return () src = do v <- lift conread maybe (return ()) -- lift . wlog $ "conread: Nothing") (yield >=> const src) v snk = awaitForever $ liftIO . conwrite type FlagCommand = STM Bool type ReadCommand = IO (Maybe ByteString) type WriteCommand = ByteString -> IO Bool cloneStanza :: StanzaWrap (LockedChan a) -> IO (StanzaWrap (LockedChan a)) cloneStanza stanza = do dupped <- cloneLChan (stanzaChan stanza) return stanza { stanzaChan = dupped } copyToChannel :: MonadIO m => (Event -> a) -> LockedChan a -> TVar (Maybe [Event]) -> ConduitM Event Event m () copyToChannel f chan closer_stack = awaitForever copy where copy x = do liftIO . atomically $ writeLChan chan (f x) case x of EventBeginDocument {} -> do let clsr = closerFor x liftIO . atomically $ modifyTVar' closer_stack (fmap (clsr:)) EventEndDocument {} -> do liftIO . atomically $ modifyTVar' closer_stack (fmap (drop 1)) _ -> return () yield x prettyPrint :: ByteString -> ConduitM Event Void IO () prettyPrint prefix = XML.renderBytes (XML.def { XML.rsPretty=True }) .| CB.lines .| CL.mapM_ (wlogb . (prefix <>)) swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m () swapNamespace old new = awaitForever (yield . swapit old new) swapit :: Text -> Text -> Event -> Event swapit old new (EventBeginElement n as) | nameNamespace n==Just old = EventBeginElement (n { nameNamespace = Just new }) as swapit old new (EventEndElement n) | nameNamespace n==Just old = EventEndElement (n { nameNamespace = Just new }) swapit old new x = x -- | This is invoked by sendModifiedStanzaTo* before swapping the namespace. -- -- Optionally, when the namespace is jabber:server, this will set a "whitelist" -- attribute on a presence tag that indicates a list of users deliminated by -- spaces. This is so that a server can communicate to another server which -- users are believed to be subscribed. fixHeaders :: Monad m => Stanza -> ConduitM Event Event m () fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do x <- await maybe (return ()) f x where f (EventBeginElement n as) = do yield $ EventBeginElement n (update n as) awaitForever yield f x = yield x >> awaitForever yield update n as = as3 where as' = maybe as (setAttrib "to" as) mto as'' = maybe as' (setAttrib "from" as') mfrom as3 = case typ of PresenceStatus {} | nameNamespace n == Just "jabber:client" -> delAttrib "whitelist" as'' -- client-to-peer "whitelist" is filtered. PresenceStatus {} | otherwise -- peer-to-client, we may have set a list of subscribed users -- to be communicated to the remote end. -> case presenceWhiteList typ of [] -> delAttrib "whitelist" as'' ws -> setAttrib "whitelist" as'' (Text.intercalate " " ws) _ -> as'' setAttrib akey as aval = attr akey aval:filter ((/=akey) . fst) as delAttrib akey as = filter ((/=akey) . fst) as conduitToChan :: ConduitT () Event IO () -> IO (LockedChan Event, TVar (Maybe [Event]), TMVar a) conduitToChan c = do chan <- atomically newLockedChan clsrs <- atomically $ newTVar (Just []) quitvar <- atomically $ newEmptyTMVar forkLabeled "XMPP.conduitToChan" $ do runConduit $ c .| copyToChannel id chan clsrs .| awaitForever (const $ return ()) atomically $ writeTVar clsrs Nothing return (chan,clsrs,quitvar) conduitToStanza :: StanzaType -> Maybe Text -- ^ id -> Maybe Text -- ^ from -> Maybe Text -- ^ to -> ConduitT () Event IO () -> IO Stanza conduitToStanza stype mid from to c = do (chan,clsrs,quitvar) <- conduitToChan c return Stanza { stanzaType = stype , stanzaId = mid , stanzaTo = to , stanzaFrom = from , stanzaChan = chan , stanzaClosers = clsrs , stanzaInterrupt = quitvar , stanzaOrigin = LocalPeer } stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m () stanzaToConduit stanza = do let xchan = stanzaChan stanza xfin = stanzaClosers stanza rdone = stanzaInterrupt stanza loop = return () xchan <- liftIO $ unlockChan xchan fix $ \inner -> do what <- liftIO . atomically $ foldr1 orElse [readTChan xchan >>= \xml -> return $ do yield xml -- atomically $ Slotted.push slots Nothing xml inner ,do mb <- readTVar xfin cempty <- isEmptyTChan xchan if isNothing mb then if cempty then return loop else retry else do done <- tryReadTMVar rdone check (isJust done) trace "todo: send closers" retry ,do isEmptyTChan xchan >>= check readTMVar rdone return (return ())] what sendModifiedStanzaToPeer :: Stanza -> TChan Stanza -> IO () sendModifiedStanzaToPeer stanza chan = do (echan,clsrs,quitvar) <- conduitToChan c ioWriteChan chan stanza { stanzaChan = echan , stanzaClosers = clsrs , stanzaInterrupt = quitvar , stanzaType = processedType (stanzaType stanza) -- TODO id? origin? } where old = "jabber:client" new = "jabber:server" c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza processedType (Error cond tag) = Error cond (swapit old new tag) processedType x = x -- Modifies a server-to-server stanza to send it to a client. This changes the -- namespace and also filters some non-supported attributes. Any other -- modifications need to be made by the caller. sendModifiedStanzaToClient :: Stanza -> TChan Stanza -> IO () sendModifiedStanzaToClient stanza chan = do (echan,clsrs,quitvar) <- conduitToChan c -- wlog $ "send-to-client " ++ show (stanzaId stanza) ioWriteChan chan stanza { stanzaChan = echan , stanzaClosers = clsrs , stanzaInterrupt = quitvar , stanzaType = processedType (stanzaType stanza) -- TODO id? origin? } where old = "jabber:server" new = "jabber:client" c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza processedType (Error cond tag) = Error cond (swapit old new tag) processedType x = x -- id,to, and from are taken as-is from reply list -- todo: this should probably be restricted to IO monad sendReply :: (Functor m, MonadIO m) => TMVar () -> StanzaType -> [Event] -> TChan Stanza -> m () sendReply donevar stype reply replychan = do let stanzaTag = listToMaybe reply mid = stanzaTag >>= lookupAttrib "id" . tagAttrs mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs mto = stanzaTag >>= lookupAttrib "to" . tagAttrs isInternal (InternalEnableHack {}) = True isInternal (InternalCacheId {}) = True isInternal _ = False forM_ (fmap (const ()) stanzaTag `mplus` guard (isInternal stype)) . const $ do replyStanza <- liftIO . atomically $ do replyChan <- newLockedChan replyClsrs <- newTVar (Just []) return Stanza { stanzaType = stype , stanzaId = mid , stanzaTo = mto -- as-is from reply list , stanzaFrom = mfrom -- as-is from reply list , stanzaChan = replyChan , stanzaClosers = replyClsrs , stanzaInterrupt = donevar , stanzaOrigin = LocalPeer } ioWriteChan replychan replyStanza void . liftIO . forkLabeled "XMPPServer.sendReply" $ do mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing -- liftIO $ wlog "finished reply stanza" {- C->Unrecognized Unrecognized type="set" C->Unrecognized id="purpleae62d88f" C->Unrecognized xmlns="jabber:client"> C->Unrecognized C->Unrecognized -} -- Sends all stanzas to announce channel except ping, for which it sends a pong -- to the output channel. xmppInbound :: ConnectionData -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused) -> TChan Stanza -- ^ channel to announce incoming stanzas on -> TChan Stanza -- ^ channel used to send stanzas -> TMVar () -- ^ mvar that is filled when the connection quits -> ConduitM Event o IO () xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do withXML $ \begindoc -> do when (begindoc==EventBeginDocument) $ do whenJust nextElement $ \xml -> do withJust (elementAttrs "stream" xml) $ \stream_attrs -> do -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs let stream_name = lookupAttrib "to" stream_attrs stream_remote = lookupAttrib "from" stream_attrs -- xmpp_version = lookupAttrib "version" stream_attrs liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote fix $ \loop -> do -- liftIO . wlog $ "waiting for stanza." (chan,clsrs) <- liftIO . atomically $ liftM2 (,) newLockedChan (newTVar (Just [])) whenJust nextElement $ \stanzaTag -> do stanza_lvl <- nesting liftIO . atomically $ do writeLChan chan stanzaTag modifyTVar' clsrs (fmap (closerFor stanzaTag:)) copyToChannel id chan clsrs .| do let mid = lookupAttrib "id" $ tagAttrs stanzaTag mfrom = lookupAttrib "from" $ tagAttrs stanzaTag mto = lookupAttrib "to" $ tagAttrs stanzaTag dispatch <- grokStanza namespace stanzaTag let unrecog = do let stype = Unrecognized s <- liftIO . atomically $ do return Stanza { stanzaType = stype , stanzaId = mid , stanzaTo = mto , stanzaFrom = mfrom , stanzaChan = chan , stanzaClosers = clsrs , stanzaInterrupt = donevar , stanzaOrigin = mkorigin output } ioWriteChan stanzas s you <- liftIO tellyourname me <- liftIO tellmyname fromMaybe unrecog $ dispatch <&> \dispatch -> case dispatch of -- Checking that the to-address matches this server. -- Otherwise it could be a client-to-client ping or a -- client-to-server for some other server. -- For now, assuming its for the immediate connection. Ping | mto==Just me || mto==Nothing -> do let pongto = maybe you id mfrom pongfrom = maybe me id mto pong = makePong namespace mid pongto pongfrom sendReply donevar Pong pong output do -- TODO: Remove this, it is only to generate a debug print ioWriteChan stanzas Stanza { stanzaType = Ping , stanzaId = mid , stanzaTo = mto , stanzaFrom = mfrom , stanzaChan = chan , stanzaClosers = clsrs , stanzaInterrupt = donevar , stanzaOrigin = mkorigin output } stype -> ioWriteChan stanzas Stanza { stanzaType = case stype of RequestResource _ rsc -> RequestResource stream_name rsc _ -> stype , stanzaId = mid , stanzaTo = mto , stanzaFrom = mfrom , stanzaChan = chan , stanzaClosers = clsrs , stanzaInterrupt = donevar , stanzaOrigin = mkorigin output } awaitCloser stanza_lvl liftIO . atomically $ writeTVar clsrs Nothing loop while :: IO Bool -> IO a -> IO [a] while cond body = do b <- cond if b then do x <- body xs <- while cond body return (x:xs) else return [] {- readUntilNothing :: TChan (Maybe x) -> IO [x] readUntilNothing ch = do x <- atomically $ readTChan ch maybe (return []) (\x -> do xs <- readUntilNothing ch return (x:xs)) x -} streamFeatures :: Text -> [XML.Event] streamFeatures "jabber:client" = [ 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") ] streamFeatures "jabber:server" = [] greet' :: Text -> Text -> [XML.Event] greet' namespace host = EventBeginDocument : greet'' namespace host greet'' :: Text -> Text -> [Event] greet'' namespace host = [ EventBeginElement (streamP "stream") [("from",[ContentText host]) ,("id",[ContentText "someid"]) ,("xmlns",[ContentText namespace]) ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"]) ,("version",[ContentText "1.0"]) ] ] ++ streamFeatures namespace consid :: Maybe Text -> [(Name, [Content])] -> [(Name, [Content])] consid Nothing = id consid (Just sid) = (("id",[ContentText sid]):) data XMPPState = PingSlot deriving (Eq,Ord) makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event] makePing namespace mid to from = [ EventBeginElement (mkname namespace "iq") $ (case mid of Just c -> (("id",[ContentText c]):) _ -> id ) [ ("type",[ContentText "get"]) , attr "to" to , attr "from" from ] , EventBeginElement "{urn:xmpp:ping}ping" [] , EventEndElement "{urn:xmpp:ping}ping" , EventEndElement $ mkname namespace "iq"] makeInfo :: Maybe Text -> Text -> Maybe Text -> [Event] makeInfo mid from mto = concat [ [ EventBeginElement "{jabber:client}iq" $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto [("from", [ContentText from]) ,("type", [ContentText "result"])] , EventBeginElement "{http://jabber.org/protocol/disco#info}query" [] , EventBeginElement "{http://jabber.org/protocol/disco#info}identity" [("category",[ContentText "server"]) ,("type",[ContentText "im"])] , EventEndElement "{http://jabber.org/protocol/disco#info}identity" , EventBeginElement "{http://jabber.org/protocol/disco#info}feature" [("var",[ContentText "http://jabber.org/protocol/disco#info"])] , EventEndElement "{http://jabber.org/protocol/disco#info}feature" , EventBeginElement "{http://jabber.org/protocol/disco#info}feature" [("var",[ContentText "http://jabber.org/protocol/disco#items"])] , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ] , [] -- todo , [ EventEndElement "{http://jabber.org/protocol/disco#info}query" , EventEndElement "{jabber:client}iq" ] ] makeNodeInfo :: Maybe Text -> Text -> Text -> Maybe Text -> Maybe Text-> [XML.Event] makeNodeInfo mid node from mto mname = concat [ [ EventBeginElement "{jabber:client}iq" $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto [("from", [ContentText from]) ,("type", [ContentText "result"])] , EventBeginElement "{http://jabber.org/protocol/disco#info}query" [("node",[ContentText node])] ] , case mname of Nothing -> [] Just name -> [ EventBeginElement "{http://jabber.org/protocol/disco#info}identity" [("category",[ContentText "conference"]) ,("type",[ContentText "text"]) ,("name",[ContentText name])] , EventEndElement "{http://jabber.org/protocol/disco#info}identity" ] , [ EventEndElement "{http://jabber.org/protocol/disco#info}query" , EventEndElement "{jabber:client}iq" ] ] features :: [Text] -> [XML.Event] features fs = do t <- fs [ EventBeginElement "{http://jabber.org/protocol/disco#info}feature" [("var",[ContentText t])], EventEndElement "{http://jabber.org/protocol/disco#info}feature" ] makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [XML.Event] -> [XML.Event] makeMUCInfo mid from mto fs = concat [ [ EventBeginElement "{jabber:client}iq" $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto [("from", [ContentText from]) ,("type", [ContentText "result"])] , EventBeginElement "{http://jabber.org/protocol/disco#info}query" [] , EventBeginElement "{http://jabber.org/protocol/disco#info}identity" [("category",[ContentText "conference"]) ,("type",[ContentText "text"])] , EventEndElement "{http://jabber.org/protocol/disco#info}identity" {- , EventBeginElement "{http://jabber.org/protocol/disco#info}feature" [("var",[ContentText "http://jabber.org/protocol/disco#info"])] , EventEndElement "{http://jabber.org/protocol/disco#info}feature" , EventBeginElement "{http://jabber.org/protocol/disco#info}feature" [("var",[ContentText "http://jabber.org/protocol/disco#items"])] , EventEndElement "{http://jabber.org/protocol/disco#info}feature" -} , EventBeginElement "{http://jabber.org/protocol/disco#info}feature" [("var",[ContentText "http://jabber.org/protocol/muc"])] , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ] , fs , [ EventEndElement "{http://jabber.org/protocol/disco#info}query" , EventEndElement "{jabber:client}iq" ] ] makeItemList :: Maybe Text -> [(Text,Maybe Text)] -> Text -> Maybe Text -> [Event] makeItemList mid items from mto = concat [ [ EventBeginElement "{jabber:client}iq" $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto [("from", [ContentText from]) ,("type", [ContentText "result"])] , EventBeginElement "{http://jabber.org/protocol/disco#items}query" []] , do (jid,name) <- items [ EventBeginElement "{http://jabber.org/protocol/disco#items}item" $ maybe id (\n -> (("name", [ContentText n]) :)) name [ ("jid", [ContentText jid]) ], EventEndElement "{http://jabber.org/protocol/disco#items}item" ] , [ EventEndElement "{http://jabber.org/protocol/disco#items}query" , EventEndElement "{jabber:client}iq" ] ] iq_bind_reply :: Maybe Text -> Text -> [XML.Event] iq_bind_reply mid jid = [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])]) , 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" {- -- query for client version , EventBeginElement "{jabber:client}iq" [ attr "to" jid , attr "from" hostname , attr "type" "get" , attr "id" "version"] , EventBeginElement "{jabber:iq:version}query" [] , EventEndElement "{jabber:iq:version}query" , EventEndElement "{jabber:client}iq" -} ] iq_session_reply :: Maybe Text -> Text -> [XML.Event] iq_session_reply mid host = -- Note: similar to Pong [ EventBeginElement "{jabber:client}iq" (consid mid [("from",[ContentText host]) ,("type",[ContentText "result"]) ]) , EventEndElement "{jabber:client}iq" ] iq_service_unavailable :: Maybe Text -> Text -> XML.Name -> [XML.Event] iq_service_unavailable mid host {- mjid -} req = [ EventBeginElement "{jabber:client}iq" (consid mid [attr "type" "error" ,attr "from" host]) , EventBeginElement req [] , EventEndElement req , EventBeginElement "{jabber:client}error" [ attr "type" "cancel" , attr "code" "503" ] , 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" ] wrapStanzaList :: [XML.Event] -> STM [Either (StanzaWrap XML.Event) XML.Event] wrapStanzaList xs = do wrap <- do clsrs <- newTVar Nothing donev <- newTMVar () return $ \ x -> Stanza { stanzaType = Unrecognized , stanzaId = mid , stanzaTo = mto , stanzaFrom = mfrom , stanzaClosers = clsrs , stanzaInterrupt = donev , stanzaOrigin = LocalPeer , stanzaChan = x } return $ map (Left . wrap) (take 1 xs) ++ map Right (drop 1 xs) where m = listToMaybe xs mto = m >>= lookupAttrib "to" . tagAttrs mfrom = m >>= lookupAttrib "from" . tagAttrs mid = m >>= lookupAttrib "id" . tagAttrs wrapStanzaConduit :: Monad m => StanzaWrap a -> ConduitM Event (Either (StanzaWrap Event) Event) m () wrapStanzaConduit stanza = do mfirst <- await forM_ mfirst $ \first -> do yield . Left $ stanza { stanzaChan = first } awaitForever $ yield . Right {- greet namespace = [ EventBeginDocument , EventBeginElement (streamP "stream") [ attr "xmlns" namespace , attr "version" "1.0" ] ] -} {- goodbye :: [XML.Event] goodbye = [ EventEndElement (streamP "stream") , EventEndDocument ] -} simulateChatError :: StanzaError -> Maybe Text -> [Event] simulateChatError err mfrom = [ EventBeginElement "{jabber:client}message" ((maybe id (\t->(attr "from" t:)) mfrom) [attr "type" "normal" ]) , EventBeginElement "{jabber:client}body" [] , EventContent $ ContentText ("/me " <> errorText err) , EventEndElement "{jabber:client}body" , EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" [] , EventBeginElement "{http://www.w3.org/1999/xhtml}body" [] , EventBeginElement "{http://www.w3.org/1999/xhtml}p" [ attr "style" "font-weight:bold; color:red" ] , EventContent $ ContentText ("/me " <> errorText err) , EventEndElement "{http://www.w3.org/1999/xhtml}p" , EventEndElement "{http://www.w3.org/1999/xhtml}body" , EventEndElement "{http://jabber.org/protocol/xhtml-im}html" , EventEndElement "{jabber:client}message" ] -- | Create a friend-request stanza. presenceSolicitation :: Text -- ^ JID of sender making request. -> Text -- ^ JID of recipient who needs to approve it. -> IO Stanza presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe" presenceProbe :: Text -> Text -> IO Stanza presenceProbe = presenceStanza PresenceRequestStatus "probe" presenceStanza :: StanzaType -> Text -> Text -> Text -> IO Stanza presenceStanza stanza_type type_attr me jid = stanzaFromList stanza_type [ EventBeginElement "{jabber:server}presence" [ attr "to" jid , attr "from" me , attr "type" type_attr ] , EventEndElement "{jabber:server}presence" ] slotsToSource :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event) -> TVar Int -> TVar (Maybe (StanzaWrap XML.Event)) -> TVar Bool -> TMVar () -> ConduitT () (Flush XML.Event) IO () slotsToSource slots nesting lastStanza needsFlush rdone = fix $ \slot_src -> join . lift . atomically $ foldr1 orElse [Slotted.pull slots >>= \x -> do x <- case x of Left wrapped -> do writeTVar nesting 1 writeTVar lastStanza (Just wrapped) return $ stanzaChan wrapped Right x -> do when (isEventBeginElement x) $ modifyTVar' nesting (+1) when (isEventEndElement x) $ do n <- readTVar nesting when (n==1) $ writeTVar lastStanza Nothing modifyTVar' nesting (subtract 1) return x writeTVar needsFlush True return $ do -- liftIO $ wlog $ "yielding Chunk: " ++ show x yield (Chunk x) slot_src ,do Slotted.isEmpty slots >>= check readTVar needsFlush >>= check writeTVar needsFlush False return $ do -- liftIO $ wlog "yielding Flush" yield Flush slot_src ,readTMVar rdone >> return (return ()) ] forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event -> XMPPServerParameters -> PeerAddress -- SockAddr (XXX(what?): remote for peer, local for client) -> ConnectionData -> FlagCommand -> ConduitT () XML.Event IO () -> ConduitT (Flush XML.Event) Void IO () -> TChan Stanza -> MVar () -> IO (TChan Stanza) forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do let auxAddr = cdAddr cdta clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of Right _ -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr) , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr) , ClientOrigin (ClientAddress $ peerAddress saddr)) Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr , xmppTellPeerHisName xmpp saddr , PeerOrigin saddr) me <- tellmyname rdone <- atomically newEmptyTMVar let isStarter (Left _) = True isStarter (Right e) | isEventBeginElement e = True isStarter _ = False isStopper (Left _) = False isStopper (Right e) | isEventEndElement e = True isStopper _ = False slots <- atomically $ Slotted.new isStarter isStopper needsFlush <- atomically $ newTVar False lastStanza <- atomically $ newTVar Nothing nesting <- atomically $ newTVar 0 let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event) let greet_src = do CL.sourceList (greet' namespace me) .| CL.map Chunk yield Flush slot_src = slotsToSource slots nesting lastStanza needsFlush rdone -- client.PeerAddress {peerAddress = [::1]:5222} let lbl n = concat [ n , Text.unpack (Text.drop 7 namespace) -- "client" or "server" , "." , case cdProfile cdta of _ | Right _ <- cdAddr cdta -> show saddr "." -> show saddr mytoxname -> show saddr {- TODO: remote tox peer name? -} ] forkLabeled (lbl "xmpp-post.") $ do -- This thread handles messages after they are pulled out of -- the slots-queue. Hence, xmpp-post, for post- slots-queue. -- Read all slots-queued XML events or stanzas and yield them -- upstream. This should continue until the connection is -- closed. runConduit $ (greet_src >> slot_src) .| snk -- Connection is now closed. Here we handle any unsent stanzas. last <- atomically $ readTVar lastStanza es <- while (atomically . fmap not $ Slotted.isEmpty slots) (atomically . Slotted.pull $ slots) let es' = mapMaybe metadata es -- We only care about full stanzas. metadata (Left s) = Just s metadata _ = Nothing -- TODO: Issuing RecipientUnavailable for all errors is a presence leak -- and protocol violation -- TODO: IDMangler can be used for better targetted error delivery. let fail stanza = do wlog $ "failed delivery: " ++ show (stanzaId stanza) quitVar <- atomically newEmptyTMVar reply <- makeErrorStanza stanza tag <- stanzaFirstTag stanza -- sendReply quitVar (Error RecipientUnavailable tag) reply replyto replystanza <- stanzaFromList (Error RecipientUnavailable tag) reply xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza notError s = case stanzaType s of Error {} -> False _ -> True -- TODO: Probably some stanzas should be queued or saved for re-connect. mapM_ fail $ filter notError (maybeToList last ++ es') wlog $ "end xmpp-post fork: " ++ (lbl "") output <- atomically newTChan hacks <- atomically $ newTVar Map.empty msgids <- atomically $ newTVar [] forkLabeled (lbl "xmpp-pre.") $ do -- Here is the pre- slots-queue thread which handles messages as they -- arrive and assigns slots to them if that is appropriate. -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer verbosity <- xmppVerbosity xmpp fix $ \loop -> do what <- atomically $ foldr1 orElse [readTChan output >>= \stanza -> return $ do wantStanzas <- getVerbose XJabber let notping f | not wantStanzas = return () | (verbosity==1) = case stanzaType stanza of Pong -> return () _ -> f | (verbosity>=2) = f | otherwise = return () -- isempty <- atomically $ isEmptyTChan (stanzaChan stanza) -- kwlog $ "queuing: "++show (isempty, stanzaId stanza) notping $ do dup <- cloneStanza stanza let typ = Strict8.pack $ c ++ "<-" ++ stanzaTypeString dup ++ " " c = case auxAddr of Right _ -> "C" Left _ -> "P" wlog "" liftIO $ takeMVar pp_mvar runConduit $ stanzaToConduit dup .| prettyPrint typ liftIO $ putMVar pp_mvar () -- wlog $ "hacks: "++show (stanzaId stanza) case stanzaType stanza of InternalEnableHack hack -> do -- wlog $ "enable hack: " ++ show hack atomically $ modifyTVar' hacks (Map.insert hack ()) InternalCacheId x -> do -- wlog $ "cache id thread: " ++ show x atomically $ modifyTVar' msgids (take 3 . (x:)) _ -> return () runConduit $ stanzaToConduit stanza .| wrapStanzaConduit stanza .| awaitForever -- TODO: PresenceStatus stanzas should be pushed to appropriate slots (liftIO . atomically . Slotted.push slots Nothing) case stanzaType stanza of Error err tag | tagName tag=="{jabber:client}message" -> do wlog $ "handling Error hacks" b <- atomically $ do m <- readTVar hacks cached <- readTVar msgids fromMaybe (return False) $ stanzaId stanza <&> \id' -> do return $ Map.member SimulatedChatErrors m && elem id' cached ids <- atomically $ readTVar msgids wlog $ "ids = " ++ show (b,stanzaId stanza, ids) when b $ do let sim = simulateChatError err (stanzaFrom stanza) wlog $ "sending simulated chat for error message." runConduit $ CL.sourceList sim .| wrapStanzaConduit stanza -- not quite right, but whatever .| awaitForever (liftIO . atomically . Slotted.push slots Nothing) Error e _ -> do wlog $ "no hacks for error: " ++ show e _ -> return () loop ,do pingflag >>= check return $ do to <- telltheirname let from = me -- Look it up from Server object -- or pass it with Connection event. mid = Just "ping" ping0 = makePing namespace mid to from ping <- atomically $ wrapStanzaList ping0 mapM_ (atomically . Slotted.push slots (Just $ PingSlot)) ping wlog "" runConduit $ CL.sourceList ping0 .| prettyPrint (case auxAddr of Right _ -> "C<-Ping" Left _ -> "P<-Ping ") loop ,readTMVar rdone >> return (return ()) ] what wlog $ "end xmpp-pre fork: " ++ show (lbl "") forkLabeled (lbl "xmpp-reader.") $ do -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show) runConduit $ src .| xmppInbound cdta clientOrServer pingflag stanzas output rdone atomically $ putTMVar rdone () wlog $ "end reader fork: " ++ lbl "" return output {- data Peer = Peer { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis , peerState :: TVar PeerState } data PeerState = PeerPendingConnect UTCTime | PeerPendingAccept UTCTime | PeerConnected (TChan Stanza) -} peerKey :: SocketLike sock => Maybe SockAddr -> (sock, (Local SockAddr, Remote SockAddr)) -> IO (PeerAddress,ConnectionData) peerKey bind_addr (sock,(laddr,Remote raddr)) = do {- laddr <- getSocketName sock raddr <- isValidSocket sock >>= \(sock,c) -> if c then getPeerName sock -- addr is normally socketName else return laddr -- Weird hack: addr is would-be peer name -} -- Assume remote peers are listening on the same port that we do. let peerport = fromIntegral $ fromMaybe 5269 $ do p <- bind_addr >>= sockAddrPort guard (p /= 0) -- Make sure we never use port 0 because it is used -- to distinguish fake address connection keys. return p rname <- atomically $ newTVar Nothing -- dput XMan $ "peerKey " ++ show (PeerAddress $ raddr `withPort` peerport,laddr) return $ ( PeerAddress $ raddr `withPort` peerport , ConnectionData { cdAddr = Left laddr , cdType = XMPP , cdProfile = "." , cdRemoteName = rname } ) clientKey :: SocketLike sock => (sock, (Local SockAddr,Remote SockAddr)) -> IO (PeerAddress,ConnectionData) clientKey (sock,(laddr,Remote raddr)) = do -- laddr <- getSocketName sock -- [::1]:5222 bind address, same for all clients -- raddr <- getPeerName sock -- [::1]:????? unique key when (Just 0 == sockAddrPort raddr) $ do dput XMan $ unwords [ "BUG: XMPP Client" , show (laddr,raddr) , "is using port zero. This could interfere" , "with Tox peer sessions." ] rname <- atomically $ newTVar Nothing -- dput XMan $ "clientKey " ++ show (PeerAddress laddr,raddr) return $ ( PeerAddress raddr -- Actually a ClientAddress, but _xmpp_sv conkey type is PeerAddress. , ConnectionData { cdAddr = Right (Remote raddr) -- FIXME: This is a bad way to detect client/peer. , cdType = XMPP , cdProfile = "." , cdRemoteName = rname } ) xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m () xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) where item jid = do yield $ EventBeginElement "{jabber:iq:roster}item" ([ attr "jid" jid , attr "subscription" stype ]++if Set.member jid solicited then [attr "ask" "subscribe"] else [] ) yield $ EventEndElement "{jabber:iq:roster}item" sendRoster :: StanzaWrap a -> XMPPServerParameters -> ClientAddress -> TChan Stanza -> IO () sendRoster query xmpp clientKey replyto = do let maddr = case stanzaOrigin query of ClientOrigin addr _ -> Just addr PeerOrigin {} -> Nothing -- remote peer requested roster? LocalPeer -> Nothing -- local peer requested roster? forM_ maddr $ \k -> do hostname <- xmppTellMyNameToClient xmpp clientKey let getlist f = do bs <- f xmpp k return (Set.fromList bs) -- js) buddies <- getlist xmppRosterBuddies subscribers <- getlist xmppRosterSubscribers solicited <- getlist xmppRosterSolicited subnone0 <- getlist xmppRosterOthers jid <- xmppTellClientHisName xmpp k -- LookupClientJID xmpp k let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers let subto = buddies \\ subscribers let subfrom = subscribers \\ buddies let subboth = Set.intersection buddies subscribers let roster = do yield $ EventBeginElement "{jabber:client}iq" (consid (stanzaId query) [ attr "to" jid , attr "type" "result" ]) yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver? xmlifyRosterItems solicited "to" subto xmlifyRosterItems solicited "from" subfrom xmlifyRosterItems solicited "both" subboth xmlifyRosterItems solicited "none" subnone yield $ EventEndElement "{jabber:iq:roster}query" yield $ EventEndElement "{jabber:client}iq" conduitToStanza Roster (stanzaId query) Nothing (Just jid) roster >>= ioWriteChan replyto {- let debugpresence = [ EventBeginElement "{jabber:client}presence" [ attr "from" "guest@oxio4inifatsetlx.onion" , attr "to" jid] , EventEndElement "{jabber:client}presence" ] quitvar <- atomically newEmptyTMVar sendReply quitvar Unrecognized debugpresence replyto -} socketFromKey :: Server PeerAddress ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr) socketFromKey sv (ClientAddress addr) = do map <- atomically $ readTVar (conmap sv) let mcd = Map.lookup (PeerAddress addr) map oops = Remote addr -- No connection data, so using incorrect address. case mcd of Nothing -> return oops Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd eventContent :: Maybe [Content] -> Text eventContent cs = maybe "" (foldr1 (<>) . map content1) cs where content1 (ContentText t) = t content1 (ContentEntity t) = t makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event] makeErrorStanza stanza = makeErrorStanza' stanza RecipientUnavailable [] makeErrorStanza' :: StanzaFirstTag a => StanzaWrap a -> StanzaError -> [(Name, [Content])] -> IO [Event] makeErrorStanza' stanza err attrs = do startTag <- stanzaFirstTag stanza let n = tagName startTag endTag = EventEndElement n amap0 = Map.fromList (tagAttrs startTag) mto = Map.lookup "to" amap0 mfrom = Map.lookup "from" amap0 mtype = Map.lookup "type" amap0 -- mid = Map.lookup "id" amap0 amap1 = Map.alter (const mto) "from" amap0 -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1 amap2 = Map.alter (const mfrom) "to" amap1 amap3 = Map.insert "type" [XML.ContentText "error"] amap2 startTag' = EventBeginElement (tagName startTag) (Map.toList amap3) -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable errname = n { nameLocalName = "error" } -- errattrs = [attr "type" "wait"] -- "modify"] errorAttribs e xs = ys ++ xs -- todo replace instead of append where (typ,code) = xep0086 e ys = [attr "type" typ, attr "code" (Text.pack . show $ code)] errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas" , nameLocalName = errorTagLocalName err , namePrefix = Nothing } errattrs = errorAttribs err attrs {- let wlogd v s = do wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s wlogd "amap0" amap0 wlogd "mto" mto wlogd "mfrom" mfrom wlogd "amap3" amap3 -} if eventContent mtype=="error" then return [] else do return [ startTag' , EventBeginElement errname errattrs , EventBeginElement errorTagName [] , EventEndElement errorTagName , EventEndElement errname {- , EventBeginElement "{jabber:client}body" [] , EventContent (ContentText "what?") , EventEndElement "{jabber:client}body" -} {- , EventBeginElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy" [] , EventEndElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy" -} , endTag ] monitor :: Server PeerAddress ConnectionData releaseKey XML.Event -> ConnectionParameters PeerAddress ConnectionData -> XMPPServerParameters -> IO b monitor sv params xmpp = do chan <- return $ serverEvent sv stanzas <- atomically newTChan quitVar <- atomically newEmptyTMVar pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log. joined_rooms <- atomically $ newTVar (Map.empty :: Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress))) fix $ \loop -> do action <- atomically $ foldr1 orElse [ readTChan chan >>= \((addr,u),e) -> return $ do case e of Connection pingflag xsrc xsnk -> do wlog $ tomsg addr "Connection" outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar -- /addr/ may be a peer or a client. So we'll strip off -- the PeerAddress constructor before exposing it. xmppNewConnection xmpp (peerAddress addr) u outs ConnectFailure addr -> do return () -- wlog $ tomsg k "ConnectFailure" EOF -> do wlog $ tomsg addr "EOF" -- /addr/ may be a peer or a client. So we'll strip off -- the PeerAddress constructor before exposing it. xmppEOF xmpp (peerAddress addr) u HalfConnection In -> do wlog $ tomsg addr "ReadOnly" case cdAddr u of Left (Local _) -> control sv (Connect (peerAddress addr) params) _ -> return () -- Don't call-back client connections. HalfConnection Out -> do wlog $ tomsg addr "WriteOnly" RequiresPing -> do return () -- wlog $ tomsg k "RequiresPing" , readTChan stanzas >>= \stanza -> return $ do {- dup <- case stanzaType stanza of -- Must dup anything that is going to be delivered... Message {} -> do dup <- cloneStanza stanza -- dupped so we can make debug print return dup Error {} -> do dup <- cloneStanza stanza -- dupped so we can make debug print return dup _ -> return stanza -} dup <- cloneStanza stanza forkLabeled ("process." ++ stanzaTypeString stanza) $ do applyStanza sv joined_rooms quitVar xmpp stanza forwardStanza quitVar xmpp stanza -- We need to clone in the case the stanza is passed on as for Message. wantStanzas <- getVerbose XJabber verbosity <- xmppVerbosity xmpp let notping f | not wantStanzas = return () | (verbosity==1) = case stanzaType stanza of Pong -> return () _ -> f | (verbosity>=2) = f | otherwise = return () notping $ do let typ = Strict8.pack $ c ++ "->" ++ stanzaTypeString stanza ++ " " c = case stanzaOrigin stanza of LocalPeer -> "*" ClientOrigin {} -> "C" PeerOrigin {} -> "P" wlog "" liftIO $ takeMVar pp_mvar runConduit $ stanzaToConduit dup .| prettyPrint typ liftIO $ putMVar pp_mvar () , do m <- readTVar joined_rooms foldr orElse retry $ (`map` (do (k,rs) <- Map.toList m i <- Map.toList rs return (k,i))) $ \(k,((rkey,muckey),(replyto,r))) -> do (mine,ChatTransaction no cjid cnick es) <- readRoom k r return $ do me <- xmppTellMyNameToClient xmpp k dput XJabber $ "CHAT " ++ Text.unpack rkey ++ ": <" ++ Text.unpack cnick ++ "> " ++ show es forM_ es $ \case Join | mine -> sendRoomOccupants muckey me cnick rkey r replyto Join -> do stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Available [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] , EventEndElement "{http://jabber.org/protocol/muc#user}x" ] ioWriteChan replyto stanza Part -> do stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Offline $ [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] ] ++ (do guard mine [ EventBeginElement "{http://jabber.org/protocol/muc#user}status" [ ("code",[ContentText "110"]) -- self-presence code. ] , EventEndElement "{http://jabber.org/protocol/muc#user}status" ]) ++ [ EventEndElement "{http://jabber.org/protocol/muc#user}x" ] ioWriteChan replyto stanza when mine $ atomically $ do jrs <- readTVar joined_rooms let m = Map.findWithDefault Map.empty k jrs m' = Map.delete (rkey,muckey) m jrs' = if Map.null m' then Map.delete k jrs else Map.insert k m' jrs writeTVar joined_rooms jrs' Talk talk -> do them <- xmppTellClientHisName xmpp k stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk ioWriteChan replyto stanza return () _ -> return () ] action loop where tomsg k str = printf "%12s %s" str (show k) where _ = str :: String roomjid :: Text {- ^ service -} -> Text {- ^ hostname -} -> Text {- ^ room -} -> Text {- ^ nick -} -> Text roomjid a me room n = room <> "@" <> a <> "." <> me <> "/" <> n sendRoomOccupants :: Text -> Text -> Text -> Text -> JoinedRoom k -> TChan Stanza -> IO () sendRoomOccupants a me them room r replyto = do xs <- map (\(n,m) -> (roomjid a me room n, m)) <$> atomically (roomOccupants $ joinedRoom r) let (ys,xs') = partition (\(jid,_) -> jid == roomjid a me room them) xs forM_ xs $ \(jid,_) -> do stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] , EventEndElement "{http://jabber.org/protocol/muc#user}x" ] ioWriteChan replyto stanza forM_ ys $ \(jid,_) -> do stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] , EventBeginElement "{http://jabber.org/protocol/muc#user}status" [ ("code",[ContentText "110"]) -- self-presence code. ] , EventEndElement "{http://jabber.org/protocol/muc#user}status" , EventEndElement "{http://jabber.org/protocol/muc#user}x" ] ioWriteChan replyto stanza stanzaTypeString :: StanzaWrap a -> String stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza) data ServiceMatch a = NotMe -- ^ Hostname of another server. | UnknownService Text -- ^ Unknown subdomain of this host. | Service (Maybe Text) Text a -- ^ A known subdomain of this host. Optionally, a specific room name. | TopLevelService -- ^ This server's exact hostname. lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a) lookupService me mucs to = case Text.toLower to of nm | nm == Text.toLower me -> TopLevelService nm | let (a,hostname) = second (Text.drop 1) $ Text.break (=='@') nm (service,b) = Text.break (=='.') $ if Text.null hostname then a else hostname , Text.drop 1 b == Text.toLower me -> case Map.lookup service mucs of Just muc -> Service (if Text.null hostname then Nothing else Just a) service muc Nothing -> UnknownService service _ -> NotMe requestVersion :: Text -> Text -> ConduitT i XML.Event IO () requestVersion rsc hostname = do yield $ EventBeginElement "{jabber:client}iq" [ attr "to" rsc , attr "from" hostname , attr "type" "get" , attr "id" "version"] yield $ EventBeginElement "{jabber:iq:version}query" [] yield $ EventEndElement "{jabber:iq:version}query" yield $ EventEndElement "{jabber:client}iq" applyStanza :: Server PeerAddress ConnectionData releaseKey Event -> TVar (Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress))) -> TMVar () -> XMPPServerParameters -> StanzaWrap (LockedChan Event) -> IO () applyStanza sv joined_rooms quitVar xmpp stanza = do dput XJabber $ "applyStanza: " ++ show (stanzaType stanza) case stanzaOrigin stanza of ClientOrigin k replyto -> case stanzaType stanza of RequestResource clientsNameForMe wanted -> do sockaddr <- socketFromKey sv k xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted >>= \case Right rsc0 -> do hostname <- xmppTellMyNameToClient xmpp k let rsc = unsplitJID (n,hostname,r) where (n,_,r) = splitJID rsc0 let reply = iq_bind_reply (stanzaId stanza) rsc sendReply quitVar SetResource reply replyto conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query") Nothing -- id (Just hostname) -- from (Just rsc) -- to (requestVersion rsc hostname) >>= ioWriteChan replyto Left err -> do hostname <- xmppTellMyNameToClient xmpp k reply <- makeErrorStanza' stanza NotAllowed [] sendReply quitVar (Error NotAuthorized (head reply)) reply replyto SessionRequest -> do me <- xmppTellMyNameToClient xmpp k let reply = iq_session_reply (stanzaId stanza) me sendReply quitVar Pong reply replyto RequestRoster -> do sendRoster stanza xmpp k replyto xmppSubscribeToRoster xmpp k PresenceStatus {} -> do let mucs = xmppGroupChat xmpp me <- xmppTellMyNameToClient xmpp k if | Just to <- stanzaTo stanza , (Just room,h,mnick) <- splitJID to , let roomjid = unsplitJID ((Just room,h,Nothing)) , Service (Just _) mucname muc <- lookupService me mucs roomjid -> case mnick of Nothing -> do -- Missing nick. reply <- makeErrorStanza' stanza JidMalformed [ ("by", [ContentText roomjid]) ] sendReply quitVar (Error JidMalformed (head reply)) reply replyto Just nick -> case presenceShow (stanzaType stanza) of Offline -> do jid <- xmppTellClientHisName xmpp k atomically $ do jrs <- readTVar joined_rooms let m = Map.findWithDefault Map.empty k jrs case Map.lookup (room,mucname) m of Just (_,r) -> do partRoom r (Just jid) -- joinedNick r == nick {- let m' = Map.delete (room,mucname) m jrs' = if Map.null m' then Map.delete k jrs else Map.insert k m' jrs writeTVar joined_rooms jrs' -} _ -> return () -- Anything other than type="unavailable" is treated as a join. _ -> do jid <- xmppTellClientHisName xmpp k join $ atomically $ do jrs <- readTVar joined_rooms let m = Map.findWithDefault Map.empty k jrs case Map.lookup (room,mucname) m of Nothing -> do r <- mucJoinRoom muc jid nick room k -- stanza jrs <- readTVar joined_rooms let m = Map.findWithDefault Map.empty k jrs writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs return $ return () Just r -> return $ dput XJabber "MUC: already joined." | otherwise -> do -- Handle presence stanza that is not a chatroom join. xmppInformClientPresence xmpp k stanza PresenceRequestSubscription {} -> do let fail = return () -- todo xmppClientSubscriptionRequest xmpp fail k stanza replyto PresenceInformSubscription {} -> do let fail = return () -- todo xmppClientInformSubscription xmpp fail k stanza NotifyClientVersion name version -> do enableClientHacks name version replyto RequestInfo mnode -> do me <- xmppTellMyNameToClient xmpp k let unavail = let query = "{http://jabber.org/protocol/disco#info}info" reply = iq_service_unavailable (stanzaId stanza) me query in return (Error ServiceUnavailable (head reply), reply) sto = fromMaybe me (stanzaTo stanza) (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of NotMe -> unavail (UnknownService a) -> unavail -- TODO ItemNotFound instead? (Service Nothing a muc) -> case mnode of Just _ -> unavail Nothing -> let reply = makeMUCInfo (stanzaId stanza) (a <> "." <> me) (stanzaFrom stanza) [] in return (Info, reply) (Service (Just room) a muc) | Nothing <- mnode -> let reply = makeMUCInfo (stanzaId stanza) (room <> "@" <> a <> "." <> me) (stanzaFrom stanza) $ features [ "http://jabber.org/protocol/muc#stable_id" ] in return (Info, reply) (Service (Just room) a muc) | Just "x-roomuser-item" <- mnode -> do mgetnick <- mucReservedNick muc room case mgetnick of Nothing -> do reply <- makeErrorStanza' stanza FeatureNotImplemented [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ] return (Error FeatureNotImplemented (head reply), reply) Just getnick -> do who <- xmppTellClientHisName xmpp k n <- getnick who let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me) (stanzaFrom stanza) n return (Info, reply) (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#traffic" <- mnode -> do dput XJabber $ "TODO: 18.1.1 Allowable Traffic" reply <- makeErrorStanza' stanza FeatureNotImplemented [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ] return (Error FeatureNotImplemented (head reply), reply) (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#rooms" <- mnode -> do dput XJabber $ "TODO: 6.7 Discovering Client Support for MUC" reply <- makeErrorStanza' stanza FeatureNotImplemented [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ] return (Error FeatureNotImplemented (head reply), reply) (Service (Just room) a muc) | Just nodename <- mnode -> do dput XJabber $ "Uknown info node: " ++ Text.unpack nodename reply <- makeErrorStanza' stanza FeatureNotImplemented [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ] return (Error FeatureNotImplemented (head reply), reply) TopLevelService -> case mnode of Just _ -> unavail Nothing -> let reply = makeInfo (stanzaId stanza) me (stanzaFrom stanza) in return (Info, reply) sendReply quitVar rtyp reply replyto RequestItems mnode -> do -- let query = "{http://jabber.org/protocol/disco#items}query" me <- xmppTellMyNameToClient xmpp k let unavail = let query = "{http://jabber.org/protocol/disco#info}info" reply = iq_service_unavailable (stanzaId stanza) me query in return (Error ServiceUnavailable (head reply), reply) sto = fromMaybe me (stanzaTo stanza) (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of NotMe -> unavail (UnknownService a) -> unavail -- TODO ItemNotFound instead? (Service Nothing a muc) -> do items <- map (\(n,m) -> (n <> "@" <> a <> "." <> me, m)) <$> mucRoomList muc let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza) return (Items, reply) (Service (Just room) a muc) -> do items <- map (\(n,m) -> (room <> "@" <> a <> "." <> me <> "/" <> n, m)) <$> mucRoomOccupants muc room -- Note: I'm assuming 'mucRoomOccupants' returns an empty list for -- private rooms. let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza) return (Items, reply) TopLevelService -> do let items = do (name,MUC {}) <- Map.toList $ xmppGroupChat xmpp return (name <> "." <> me, Nothing) reply = makeItemList (stanzaId stanza) items me (stanzaFrom stanza) return (Items, reply) sendReply quitVar rtyp reply replyto UnrecognizedQuery query -> do me <- xmppTellMyNameToClient xmpp k let reply = iq_service_unavailable (stanzaId stanza) me query sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto Message { msgType = GroupChatMsg } -> do let mucs = xmppGroupChat xmpp me <- xmppTellMyNameToClient xmpp k if | Just to <- stanzaTo stanza , (Just room,h,mnick) <- splitJID to , let roomjid = unsplitJID ((Just room,h,Nothing)) , Service (Just _) mucname muc <- lookupService me mucs roomjid -> case mnick of Nothing -> do -- Send message. jid <- xmppTellClientHisName xmpp k -- This should match stanzaFrom join $ atomically $ do jrs <- readTVar joined_rooms let m = Map.findWithDefault Map.empty k jrs case Map.lookup (room,mucname) m of Just (_,r) -> do let RH v = roomHandle r oldt <- readTVar v expected <- readTVar (roomFutureSeqNo $ joinedRoom r) b <- sendChat r (Just jid) $ do (_,msg) <- msgLangMap (stanzaType stanza) talk <- maybeToList $ msgBody msg [ Talk talk ] return $ dput XJabber $ "sendChat: " ++ show (b,expected,oldt,msgLangMap (stanzaType stanza)) _ -> return $ dput XJabber $ "uknown room" ++ show (room,mucname) Just nick -> do -- Private message. TODO dput XJabber $ "TODO: Private messasge. " ++ show nick | otherwise -> dput XJabber $ "Failed groupchat parse. to=" ++ show (stanzaTo stanza) Message {} -> do -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza)) maybe (return ()) (flip cacheMessageId replyto) $ do guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza) stanzaId stanza _ -> return () PeerOrigin k replyto -> case stanzaType stanza of PresenceRequestStatus {} -> do xmppAnswerProbe xmpp k stanza replyto PresenceStatus {} -> do xmppInformPeerPresence xmpp k stanza PresenceRequestSubscription {} -> do let fail = return () -- todo xmppPeerSubscriptionRequest xmpp fail k stanza replyto PresenceInformSubscription {} -> do let fail = return () -- todo xmppPeerInformSubscription xmpp fail k stanza _ -> return () _ -> return () forwardStanza :: TMVar () -> XMPPServerParameters -> StanzaWrap (LockedChan Event) -> IO () forwardStanza quitVar xmpp stanza = do let deliver replyto = do -- TODO: Issuing RecipientUnavailable for all errors is a presence leak -- and protocol violation let fail = do wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO reply <- makeErrorStanza stanza tag <- stanzaFirstTag stanza sendReply quitVar (Error RecipientUnavailable tag) reply replyto xmppDeliverMessage xmpp fail stanza -- -- bad idea: -- let newStream = greet'' "jabber:client" "blackbird" -- sendReply quitVar Error newStream replyto case stanzaType stanza of Message { msgType = GroupChatMsg } -> return () -- Group chat handled elsewhere. Message {} -> do case stanzaOrigin stanza of LocalPeer {} -> return () ClientOrigin _ replyto -> deliver replyto PeerOrigin _ replyto -> deliver replyto Error {} -> do case stanzaOrigin stanza of LocalPeer {} -> return () ClientOrigin _ replyto -> deliver replyto PeerOrigin _ replyto -> deliver replyto _ -> return () data ConnectionType = XMPP | Tox deriving (Eq,Ord,Enum,Show,Read) data ConnectionData = ConnectionData { cdAddr :: Either (Local SockAddr) -- Peer connection local address (Remote SockAddr) -- unused, todo:remove. (was client connection remote address). , cdType :: ConnectionType , cdProfile :: Text -- Currently ignored for clients. Instead, see -- 'clientProfile' field of 'ClientState'. -- -- For peers: "." for XMPP, otherwise the ".tox" hostname -- of this local node. -- Initially Nothing, when the remote end identifies itself by a given name, -- the result will be stored here. , cdRemoteName :: TVar (Maybe Text) } addrToPeerKey :: Remote SockAddr -> PeerAddress addrToPeerKey (Remote raddr) = PeerAddress raddr addrFromClientKey :: ClientAddress -> Local SockAddr addrFromClientKey (ClientAddress laddr) = Local laddr classifyConnection :: SockAddr -> ConnectionData -> Either (PeerAddress, Local SockAddr) (ClientAddress, Remote SockAddr) classifyConnection saddr dta = case cdAddr dta of Left laddr -> Left (PeerAddress saddr, laddr) Right raddr -> Right (ClientAddress saddr, raddr) data XMPPServer = forall releaseKey. XMPPServer { _xmpp_sv :: Server PeerAddress ConnectionData releaseKey XML.Event -- ^ Internally, we're using PeerAddress for both clients -- and peers. For the external interface, we mark client -- addresses as 'ClientAddress' and not 'PeerAddress'. , _xmpp_man :: Connection.Manager TCPStatus Text , _xmpp_peer_params :: ConnectionParameters PeerAddress ConnectionData , _xmpp_peer_bind :: SockAddr } xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text) xmppConnections xsv@XMPPServer{_xmpp_man = m} = return m xmppEventChannel :: XMPPServer -> TChan ((PeerAddress, ConnectionData), ConnectionEvent Event) xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv quitXmpp :: XMPPServer -> IO () quitXmpp XMPPServer{_xmpp_sv=sv} = control sv Quit xmppServer :: MonadIO m => Allocate releaseKey m -> Maybe SockAddr -- ^ Listen address for server-to-server protocol. -> m XMPPServer xmppServer allocate bind_addr = do sv <- server allocate xmlStream liftIO $ do gen <- System.Random.getStdGen peer_bind <- maybe (getBindAddress "5269" True) return bind_addr let (r, _) = System.Random.next gen fuzz = r `mod` 2000 -- maximum 2 seconds of ping fuzz peer_params :: ConnectionParameters PeerAddress ConnectionData peer_params = (connectionDefaults $ peerKey $ Just peer_bind) { pingInterval = 15000 + fuzz , timeout = 2000 , duplex = False } tcp <- tcpManager (\(PeerAddress addr) -> (addr, peer_params, 10000)) sv -- TODO: unused return XMPPServer { _xmpp_sv = sv , _xmpp_man = tcp -- TODO: unused , _xmpp_peer_params = peer_params , _xmpp_peer_bind = peer_bind } forkXmpp :: MonadIO m => XMPPServer -> XMPPServerParameters -> m ThreadId forkXmpp XMPPServer { _xmpp_sv = sv , _xmpp_peer_params = peer_params , _xmpp_peer_bind = peer_bind } xmpp = liftIO $ do let client_params :: ConnectionParameters PeerAddress ConnectionData client_params = (connectionDefaults clientKey) { pingInterval = 0 , timeout = 0 } mt <- forkLabeled "XMPP.monitor" $ do monitor sv peer_params xmpp dput XMisc $ "Starting peer listen" control sv (Listen peer_bind peer_params) dput XMisc $ "Starting client listen" client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp control sv (Listen client_bind client_params) return mt