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

1 files changed, 4 insertions, 429 deletions

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     <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
 C->Unrecognized </iq>
 -}
-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