From e8d00e729f1d6737180210d018f78e4b2efd8a35 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 4 Nov 2018 23:32:38 -0500 Subject: Factored Stanza.{Types,Parse} out of XMPPServer. --- Presence/XMPPServer.hs | 433 +------------------------------------------------ 1 file changed, 4 insertions(+), 429 deletions(-) (limited to 'Presence/XMPPServer.hs') diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 3327b523..11a27660 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -75,7 +75,6 @@ import Text.Printf import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Strict8 -- import qualified Data.ByteString.Lazy.Char8 as Lazy8 -import Data.Int (Int8) import Data.Conduit import qualified Data.Conduit.List as CL @@ -85,8 +84,8 @@ import Data.Conduit.ByteString.Builder (builderToByteStringFlush) #else import Data.Conduit.Blaze (builderToByteStringFlush) #endif -import Control.Monad.Catch (MonadThrow) +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 @@ -94,8 +93,7 @@ import Data.XML.Types as XML import Data.Maybe import Data.Monoid ( (<>) ) import Data.Text (Text) -import qualified Data.Text as Text (pack,unpack,words,intercalate,drop) -import Data.Char (chr,ord) +import qualified Data.Text as Text (pack,unpack,intercalate,drop) import qualified Data.Map as Map import Data.Set (Set, (\\) ) import qualified Data.Set as Set @@ -104,6 +102,8 @@ import qualified System.Random import Data.Void (Void) import DPut import DebugTag +import Stanza.Type +import Stanza.Parse -- peerport :: PortNumber -- peerport = 5269 @@ -113,87 +113,6 @@ import DebugTag my_uuid :: Text my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574" -data JabberShow = Offline - | ExtendedAway - | Away - | DoNotDisturb - | Available - | Chatty - deriving (Show,Enum,Ord,Eq,Read) - -data MessageThread = MessageThread { - msgThreadParent :: Maybe Text, - msgThreadContent :: Text - } - deriving (Show,Eq) - -data LangSpecificMessage = - LangSpecificMessage { msgBody :: Maybe Text - , msgSubject :: Maybe Text - } - deriving (Show,Eq) - -data RosterEventType - = RequestedSubscription - | NewBuddy -- preceded by PresenceInformSubscription True - | RemovedBuddy -- preceded by PresenceInformSubscription False - | PendingSubscriber -- same as PresenceRequestSubscription - | NewSubscriber - | RejectSubscriber - deriving (Show,Read,Ord,Eq,Enum) - -data ClientHack = SimulatedChatErrors - deriving (Show,Read,Ord,Eq,Enum) - -data StanzaType - = Unrecognized - | Ping - | Pong - | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id. - | SetResource - | SessionRequest - | UnrecognizedQuery Name - | RequestRoster - | Roster - | RosterEvent { rosterEventType :: RosterEventType - , rosterUser :: Text - , rosterContact :: Text } - | Error StanzaError XML.Event - | PresenceStatus { presenceShow :: JabberShow - , presencePriority :: Maybe Int8 - , presenceStatus :: [(Lang,Text)] - , presenceWhiteList :: [Text] - } - | PresenceInformError - | PresenceInformSubscription Bool - | PresenceRequestStatus - | PresenceRequestSubscription Bool - | Message { msgThread :: Maybe MessageThread - , msgLangMap :: [(Lang,LangSpecificMessage)] - } - | NotifyClientVersion { versionName :: Text - , versionVersion :: Text } - | InternalEnableHack ClientHack - | InternalCacheId Text - deriving (Show,Eq) - -data StanzaOrigin = LocalPeer - | PeerOrigin PeerAddress (TChan Stanza) - | ClientOrigin ClientAddress (TChan Stanza) - - -data StanzaWrap a = Stanza - { stanzaType :: StanzaType - , stanzaId :: Maybe Text - , stanzaTo :: Maybe Text - , stanzaFrom :: Maybe Text - , stanzaChan :: a - , stanzaClosers :: TVar (Maybe [XML.Event]) - , stanzaInterrupt :: TMVar () - , stanzaOrigin :: StanzaOrigin - } - -type Stanza = StanzaWrap (LockedChan XML.Event) newtype Local a = Local a deriving (Eq,Ord,Show) newtype Remote a = Remote a deriving (Eq,Ord,Show) @@ -434,9 +353,6 @@ conduitToStanza stype mid from to c = do } -ioWriteChan :: MonadIO m => TChan a -> a -> m () -ioWriteChan c v = liftIO . atomically $ writeTChan c v - stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m () stanzaToConduit stanza = do let xchan = stanzaChan stanza @@ -564,60 +480,6 @@ stanzaFromList stype reply = do , stanzaOrigin = LocalPeer } -grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType) -grokStanzaIQGet stanza = do - mtag <- nextElement - forM mtag $ \tag -> do - case tagName tag of - "{urn:xmpp:ping}ping" -> return Ping - "{jabber:iq:roster}query" -> return RequestRoster - name -> return $ UnrecognizedQuery name - -parseClientVersion :: NestingXML o IO (Maybe StanzaType) -parseClientVersion = parseit Nothing Nothing - where - reportit mname mver = return $ do - name <- mname - ver <- mver - return NotifyClientVersion { versionName=name, versionVersion=ver } - parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType) - parseit mname mver = do - mtag <- nextElement - fromMaybe (reportit mname mver) $ mtag <&> \tag -> do - case tagName tag of - "{jabber:iq:version}name" -> do - x <- XML.content - parseit (Just x) mver - "{jabber:iq:version}version" -> do - x <- XML.content - parseit mname (Just x) - _ -> parseit mname mver - - -grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType) -grokStanzaIQResult stanza = do - mtag <- nextElement - fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do - case tagName tag of - "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client" - -> parseClientVersion - _ -> return Nothing - -grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType) -grokStanzaIQSet stanza = do - mtag <- nextElement - case tagName <$> mtag of - Just "{urn:ietf:params:xml:ns:xmpp-bind}bind" - -> do mchild <- nextElement - case tagName <$> mchild of - Just "{urn:ietf:params:xml:ns:xmpp-bind}resource" - -> do rsc <- XML.content -- TODO: MonadThrow??? - return . Just $ RequestResource Nothing (Just rsc) - Just _ -> return Nothing - Nothing -> return . Just $ RequestResource Nothing Nothing - Just "{urn:ietf:params:xml:ns:xmpp-session}session" - -> return $ Just SessionRequest - _ -> return Nothing {- @@ -628,197 +490,7 @@ C->Unrecognized xmlns="jabber:client"> C->Unrecognized C->Unrecognized -} -chanContents :: TChan x -> IO [x] -chanContents ch = do - x <- atomically $ do - bempty <- isEmptyTChan ch - if bempty - then return Nothing - else fmap Just $ readTChan ch - maybe (return []) - (\x -> do - xs <- chanContents ch - return (x:xs)) - x - - -parsePresenceStatus - :: ( MonadThrow m - , MonadIO m - ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType) -parsePresenceStatus ns stanzaTag = do - let toStat "away" = Away - toStat "xa" = ExtendedAway - toStat "dnd" = DoNotDisturb - toStat "chat" = Chatty - - showv <- liftIO . atomically $ newTVar Available - priov <- liftIO . atomically $ newTVar Nothing - statusv <- liftIO . atomically $ newTChan - fix $ \loop -> do - mtag <- nextElement - forM_ mtag $ \tag -> do - when (nameNamespace (tagName tag) == Just ns) $ do - case nameLocalName (tagName tag) of - "show" -> do t <- XML.content - liftIO . atomically $ writeTVar showv (toStat t) - "priority" -> do t <- XML.content - liftIO . handleIO_ (return ()) $ do - prio <- readIO (Text.unpack t) - atomically $ writeTVar priov (Just prio) - "status" -> do t <- XML.content - lang <- xmlLang - ioWriteChan statusv (maybe "" id lang,t) - _ -> return () - loop - show <- liftIO . atomically $ readTVar showv - prio <- liftIO . atomically $ readTVar priov - status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to - -- avoid multiple passes, but whatever. - let wlist = do - w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag) - Text.words w - return . Just $ PresenceStatus { presenceShow = show - , presencePriority = prio - , presenceStatus = status - , presenceWhiteList = wlist - } -grokPresence - :: ( MonadThrow m - , MonadIO m - ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType) -grokPresence ns stanzaTag = do - let typ = lookupAttrib "type" (tagAttrs stanzaTag) - case typ of - Nothing -> parsePresenceStatus ns stanzaTag - Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline})) - $ parsePresenceStatus ns stanzaTag - Just "error" -> return . Just $ PresenceInformError - Just "unsubscribed" -> return . Just $ PresenceInformSubscription False - Just "subscribed" -> return . Just $ PresenceInformSubscription True - Just "probe" -> return . Just $ PresenceRequestStatus - Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False - Just "subscribe" -> return . Just $ PresenceRequestSubscription True - _ -> return Nothing - -parseMessage - :: ( MonadThrow m - , MonadIO m - ) => Text -> XML.Event -> NestingXML o m StanzaType -parseMessage ns stanza = do - let bodytag = Name { nameNamespace = Just ns - , nameLocalName = "body" - , namePrefix = Nothing } - subjecttag = Name { nameNamespace = Just ns - , nameLocalName = "subject" - , namePrefix = Nothing } - threadtag = Name { nameNamespace = Just ns - , nameLocalName = "thread" - , namePrefix = Nothing } - let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing } - 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 <- XML.content - awaitCloser lvl - parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap) - Just tag | tagName tag==subjecttag - -> do - txt <- XML.content - awaitCloser lvl - parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap) - Just tag | tagName tag==threadtag - -> do - txt <- XML.content - awaitCloser lvl - parseChildren (th {msgThreadContent=txt},cmap) - Just tag -> do - -- let nm = tagName tag - -- attrs = tagAttrs tag - -- -- elems = msgElements c - -- txt <- XML.content - awaitCloser lvl - parseChildren (th,Map.insert lang c cmap) - Nothing -> return (th,cmap) - (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""} - , Map.empty ) - return Message { - msgLangMap = Map.toList langmap, - msgThread = if msgThreadContent th/="" then Just th else Nothing - } - -findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event) -findConditionTag = do - mx <- nextElement - fmap join $ forM mx $ \x -> do - case nameNamespace (tagName x) of - Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x) - _ -> findConditionTag - -conditionFromText :: Text -> Maybe StanzaError -conditionFromText t = fmap fst $ listToMaybe ss - where - es = [BadRequest .. UnexpectedRequest] - ts = map (\e->(e,errorTagLocalName e)) es - ss = dropWhile ((/=t) . snd) ts - -findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError) -findErrorTag ns = do - x <- nextElement - fmap join $ forM x $ \x -> - case tagName x of - n | nameNamespace n==Just ns && nameLocalName n=="error" - -> do - mtag <- findConditionTag - return $ do - tag <- {- trace ("mtag = "++show mtag) -} mtag - let t = nameLocalName (tagName tag) - conditionFromText t - _ -> findErrorTag ns - -grokMessage - :: ( MonadThrow m - , MonadIO m - ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType) -grokMessage ns stanzaTag = do - let typ = lookupAttrib "type" (tagAttrs stanzaTag) - case typ of - Just "error" -> do - mb <- findErrorTag ns - return $ do - e <- mb - return $ Error e stanzaTag - _ -> do t <- parseMessage ns stanzaTag - return $ Just t - - - -grokStanza - :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType) -grokStanza "jabber:server" stanzaTag = - case () of - _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag - _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag - _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag - _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag - _ -> return $ Just Unrecognized - -grokStanza "jabber:client" stanzaTag = - case () of - _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag - _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag - _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag - _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag - _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag - _ -> return $ Just Unrecognized mkname :: Text -> Text -> XML.Name mkname namespace name = (Name name (Just namespace) Nothing) @@ -1547,108 +1219,11 @@ socketFromKey sv (ClientAddress addr) = do Nothing -> return oops Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd -class StanzaFirstTag a where - stanzaFirstTag :: StanzaWrap a -> IO XML.Event -instance StanzaFirstTag (TChan XML.Event) where - stanzaFirstTag stanza = do - e <-atomically $ peekTChan (stanzaChan stanza) - return e -instance StanzaFirstTag (LockedChan XML.Event) where - stanzaFirstTag stanza = do - e <-atomically $ peekLChan (stanzaChan stanza) - return e -instance StanzaFirstTag XML.Event where - stanzaFirstTag stanza = return (stanzaChan stanza) - -data StanzaError - = BadRequest - | Conflict - | FeatureNotImplemented - | Forbidden - | Gone - | InternalServerError - | ItemNotFound - | JidMalformed - | NotAcceptable - | NotAllowed - | NotAuthorized - | PaymentRequired - | RecipientUnavailable - | Redirect - | RegistrationRequired - | RemoteServerNotFound - | RemoteServerTimeout - | ResourceConstraint - | ServiceUnavailable - | SubscriptionRequired - | UndefinedCondition - | UnexpectedRequest - deriving (Show,Enum,Ord,Eq) - -xep0086 :: StanzaError -> (Text, Int) -xep0086 e = - case e of - BadRequest -> ("modify", 400) - Conflict -> ("cancel", 409) - FeatureNotImplemented -> ("cancel", 501) - Forbidden -> ("auth", 403) - Gone -> ("modify", 302) - InternalServerError -> ("wait", 500) - ItemNotFound -> ("cancel", 404) - JidMalformed -> ("modify", 400) - NotAcceptable -> ("modify", 406) - NotAllowed -> ("cancel", 405) - NotAuthorized -> ("auth", 401) - PaymentRequired -> ("auth", 402) - RecipientUnavailable -> ("wait", 404) - Redirect -> ("modify", 302) - RegistrationRequired -> ("auth", 407) - RemoteServerNotFound -> ("cancel", 404) - RemoteServerTimeout -> ("wait", 504) - ResourceConstraint -> ("wait", 500) - ServiceUnavailable -> ("cancel", 503) - SubscriptionRequired -> ("auth", 407) - UndefinedCondition -> ("", 500) - UnexpectedRequest -> ("wait", 400) - -errorText :: StanzaError -> Text -errorText e = - case e of - BadRequest -> "Bad request" - Conflict -> "Conflict" - FeatureNotImplemented -> "This feature is not implemented" - Forbidden -> "Forbidden" - Gone -> "Recipient can no longer be contacted" - InternalServerError -> "Internal server error" - ItemNotFound -> "Item not found" - JidMalformed -> "JID Malformed" - NotAcceptable -> "Message was rejected" - NotAllowed -> "Not allowed" - NotAuthorized -> "Not authorized" - PaymentRequired -> "Payment is required" - RecipientUnavailable -> "Recipient is unavailable" - Redirect -> "Redirect" - RegistrationRequired -> "Registration required" - RemoteServerNotFound -> "Recipient's server not found" - RemoteServerTimeout -> "Remote server timeout" - ResourceConstraint -> "The server is low on resources" - ServiceUnavailable -> "The service is unavailable" - SubscriptionRequired -> "A subscription is required" - UndefinedCondition -> "Undefined condition" - UnexpectedRequest -> "Unexpected request" - eventContent :: Maybe [Content] -> Text eventContent cs = maybe "" (foldr1 (<>) . map content1) cs where content1 (ContentText t) = t content1 (ContentEntity t) = t -errorTagLocalName :: forall a. Show a => a -> Text -errorTagLocalName e = Text.pack . drop 1 $ do - c <- show e - if 'A' <= c && c <= 'Z' - then [ '-', chr( ord c - ord 'A' + ord 'a') ] - else return c - makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event] makeErrorStanza stanza = do startTag <- stanzaFirstTag stanza -- cgit v1.2.3