Factored Stanza.{Types,Parse} out of XMPPServer.

2 files changed, 445 insertions, 0 deletions

diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
new file mode 100644
index 00000000..50e1e25b
--- /dev/null
+++ b/Presence/Stanza/Parse.hs
@@ -0,0 +1,261 @@
+module Stanza.Parse (grokStanza,errorTagLocalName) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Char
+import Data.Function
+import Data.Maybe
+import qualified Data.Text    as Text (pack, unpack, words)
+         ;import Data.Text    (Text)
+
+import Control.Monad.Catch             (MonadThrow)
+import Control.Monad.IO.Class          (MonadIO, liftIO)
+import qualified Data.Map              as Map
+import Data.XML.Types                  as XML
+import qualified Text.XML.Stream.Parse as XML
+
+import Control.Concurrent.STM.Util
+import ControlMaybe                (handleIO_, (<&>))
+import EventUtil
+import Nesting
+import Stanza.Type
+
+-- | Identify an XMPP stanza based on the open-tag.
+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
+
+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
+
+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
+
+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
+
+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
+
+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
+
+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
+                                   }
+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
+    }
+
+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
+
+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
+
+-- | Converts a CamelCase constructor to a hyphenated lower-case name for use
+-- as an xml tag.
+errorTagLocalName :: StanzaError -> 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
+
diff --git a/Presence/Stanza/Type.hs b/Presence/Stanza/Type.hs
new file mode 100644
index 00000000..1d8041a9
--- /dev/null
+++ b/Presence/Stanza/Type.hs
@@ -0,0 +1,184 @@
+{-# LANGUAGE FlexibleInstances #-}
+module Stanza.Type where
+
+import Control.Concurrent.STM
+import Data.Int
+import Data.Text
+import Data.XML.Types as XML
+
+import Connection (PeerAddress(..))
+import ConnectionKey (ClientAddress(..))
+import LockedChan
+import Nesting (Lang)
+
+type Stanza = StanzaWrap (LockedChan XML.Event)
+
+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
+    }
+
+data StanzaOrigin = LocalPeer
+                  | PeerOrigin PeerAddress (TChan Stanza)
+                  | ClientOrigin ClientAddress (TChan Stanza)
+
+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 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 LangSpecificMessage =
+    LangSpecificMessage { msgBody :: Maybe Text
+                        , msgSubject :: Maybe Text
+                        }
+  deriving (Show,Eq)
+
+data MessageThread = MessageThread {
+        msgThreadParent  :: Maybe Text,
+        msgThreadContent :: Text
+    }
+  deriving (Show,Eq)
+
+
+data JabberShow = Offline
+                | ExtendedAway
+                | Away
+                | DoNotDisturb
+                | Available
+                | Chatty
+ deriving (Show,Enum,Ord,Eq,Read)
+
+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"
+