implemented xml-enumerator-based elementToString functions, re-arranged the stanza types, rewrote parts of the Stream module

Network/XMPP.hs

@@ -61,7 +61,7 @@ module Network.XMPP ( -- Network.XMPP.JID
                     , StanzaID (SID)
                     , From
                     , To
-                    , XMLLang
+                    , LangTag
                     , MessageType (..)
                     , Message (..)
                     , PresenceType (..)
@@ -70,12 +70,7 @@ module Network.XMPP ( -- Network.XMPP.JID
                     , iqPayloadNamespace
                     , iqPayload
 
-                    , injectAction
+                    , injectAction ) where
-
-                    -- Network.XMPP.Utilities
-                    , elementToString
-                    , elementsToString
-                    , getID ) where
 
 import Network.XMPP.Address
 import Network.XMPP.SASL

Network/XMPP/Session.hs

@@ -586,7 +586,9 @@ processEvent e = get >>= \ state ->
             put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
             return Nothing
 
-  IEE (EnumeratorXML (XEPresence presenceEvent)) -> do
+  -- TODO: Known bug - does not work with PresenceError
+
+  IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do
     let stanzaID' = presenceID $ presenceEvent
     let newTimeouts = case stanzaID' of
                         Just stanzaID'' ->
@@ -603,7 +605,8 @@ processEvent e = get >>= \ state ->
     put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
     return Nothing
 
-  IEE (EnumeratorXML (XEMessage messageEvent)) -> do
+  -- TODO: Does not work with message errors
+  IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do
     let stanzaID' = messageID $ messageEvent
     let newTimeouts = case stanzaID' of
                         Just stanzaID'' ->
@@ -633,8 +636,8 @@ processEvent e = get >>= \ state ->
                 put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
         Nothing ->
             return ()
-    let xml = presenceToXML presence'
+    let xml = presenceToXML $ Right presence'
-    lift $ liftIO $ send xml handleOrTLSCtx
+    lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx
     return Nothing
 
   IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do
@@ -650,25 +653,19 @@ processEvent e = get >>= \ state ->
                 put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
         Nothing ->
             return ()
-    let xml = messageToXML message'
+    let xml = messageToXML $ Right message'
-    lift $ liftIO $ send xml handleOrTLSCtx
+    lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx
     return Nothing
 
+  -- TODO: Known bugs until Session rewritten - new ID everytime, callback not called
+
   IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do
-    iq' <- case iqID iq of
+    iq' <- do -- case iqID iq of
-      Nothing -> do
+      -- Nothing -> do
         id <- liftIO $ nextID $ stateIDGenerator state
-        return $ case iq of
+        return iq
-          IQReq r -> do
+    let callback' = fromJust stanzaCallback
-            IQReq (r { iqRequestID = Just (SID id) })
+    put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) }
-          IQRes r -> do
-            IQRes (r { iqResponseID = Just (SID id) })
-      _ -> return iq
-    case stanzaCallback of
-      Just callback' -> case iq of
-        IQReq {} -> put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) }
-        _ -> return ()
-      Nothing -> return ()
     case timeoutCallback of
         Just (t, timeoutCallback') ->
             let stanzaID' = (fromJust $ iqID iq') in do
@@ -678,7 +675,7 @@ processEvent e = get >>= \ state ->
             return ()
     -- TODO: Bind ID to callback
     let xml = iqToXML iq'
-    lift $ liftIO $ send xml handleOrTLSCtx
+    lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx
     return Nothing
 
   IEC (CEAction predicate callback) -> do

Network/XMPP/Stanza.hs

@@ -15,7 +15,7 @@ module Network.XMPP.Stanza (
 iqID,
 iqFrom,
 iqTo,
-iqXMLLang,
+iqLangTag,
 iqPayload,
 iqPayloadNamespace,
 iqRequestPayloadNamespace,
@@ -37,8 +37,16 @@ import Data.Text (unpack)
 
 iqID :: IQ -> Maybe StanzaID
 
-iqID (IQReq i) = iqRequestID i
+iqID (Left req) = iqRequestID req
-iqID (IQRes i) = iqResponseID i
+iqID (Right res) = iqResponseID res
+
+
+-- TODO: Maybe?
+
+iqResponseID :: IQResponse -> Maybe StanzaID
+
+iqResponseID (Left err) = iqErrorID err
+iqResponseID (Right res) = iqResultID res
 
 
 -- |
@@ -46,8 +54,8 @@ iqID (IQRes i) = iqResponseID i
 
 iqFrom :: IQ -> Maybe From
 
-iqFrom (IQReq i) = iqRequestFrom i
+iqFrom (Left req) = iqRequestFrom req
-iqFrom (IQRes i) = iqResponseFrom i
+iqFrom (Right res) = iqResponseFrom res
 
 
 -- |
@@ -55,17 +63,36 @@ iqFrom (IQRes i) = iqResponseFrom i
 
 iqTo :: IQ -> Maybe To
 
-iqTo (IQReq i) = iqRequestTo i
+iqTo (Left req) = iqRequestTo req
-iqTo (IQRes i) = iqResponseTo i
+iqTo (Right res) = iqResponseTo res
 
 
 -- |
 -- Returns the @XMLLang@ value of the @IQ@, if any.
 
-iqXMLLang :: IQ -> Maybe XMLLang
+iqLangTag :: IQ -> Maybe LangTag
+
+iqLangTag (Left req) = iqRequestLangTag req
+iqLangTag (Right res) = iqResponseLangTag res
+
+
+iqResponseLangTag :: IQResponse -> Maybe LangTag
+
+iqResponseLangTag (Left err) = iqErrorLangTag err
+iqResponseLangTag (Right res) = iqResultLangTag res
+
+
+iqResponseFrom :: IQResponse -> Maybe From
+
+iqResponseFrom (Left err) = iqErrorFrom err
+iqResponseFrom (Right res) = iqResultFrom res
+
+
+iqResponseTo :: IQResponse -> Maybe To
+
+iqResponseTo (Left err) = iqErrorTo err
+iqResponseTo (Right res) = iqResultTo res
 
-iqXMLLang (IQReq i) = iqRequestXMLLang i
-iqXMLLang (IQRes i) = iqResponseXMLLang i
 
 
 -- |
@@ -74,8 +101,14 @@ iqXMLLang (IQRes i) = iqResponseXMLLang i
 
 iqPayload :: IQ -> Maybe Element
 
-iqPayload (IQReq i) = Just (iqRequestPayload i)
+iqPayload (Left req) = Just (iqRequestPayload req)
-iqPayload (IQRes i) = iqResponsePayload i
+iqPayload (Right res) = iqResponsePayload res
+
+
+iqResponsePayload :: IQResponse -> Maybe Element
+
+iqResponsePayload (Left err) = iqErrorPayload err
+iqResponsePayload (Right res) = iqResultPayload res
 
 
 -- |

Network/XMPP/Stream.hs

@@ -3,6 +3,8 @@
 
 {-# OPTIONS_HADDOCK hide #-}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Network.XMPP.Stream (
 isTLSSecured,
 xmlEnumerator,
@@ -54,9 +56,6 @@ import Text.Parsec.ByteString (GenParser)
 
 import qualified Data.ByteString.Char8 as DBC (pack)
 
-import Data.List (intersperse)
-import Data.Char (toLower)
-
 
 isTLSSecured :: TLSState -> Bool
 isTLSSecured (PostHandshake _) = True
@@ -151,7 +150,7 @@ processEventList e
   | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e
   | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e
   | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e
-  | otherwise = XEOther $ elementToString $ Just (eventsToElement e)
+  | otherwise = XEOther "TODO: Element instead of String" -- Just (eventsToElement e)
       where
         (EventBeginElement name attribs) = head e
         es = tail e
@@ -169,314 +168,105 @@ counter c (Just (EventBeginElement _ _)) = (c + 1)
 counter c (Just (EventEndElement _) )    = (c - 1)
 counter c _                       = c
 
-presenceToXML :: Presence -> String
-presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++
-                  (elementsToString $ presencePayload p) ++ "</presence>"
-  where
-    from :: String
-    from = case presenceFrom p of
-      -- TODO: Lower-case
-      Just s -> " from='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-    id' :: String
-    id' = case presenceID p of
-      Just (SID s) -> " id='" ++ s ++ "'"
-      Nothing -> ""
-
-    to :: String
-    to = case presenceTo p of
-      -- TODO: Lower-case
-      Just s -> " to='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-    type' :: String
-    type' = case presenceType p of
-      Available -> ""
-      t -> " type='" ++ (presenceTypeToString t) ++ "'"
-
-iqToXML :: IQ -> String
-iqToXML (IQReq (IQGet { iqRequestID = i, iqRequestPayload = p, iqRequestFrom = f, iqRequestTo = t })) =
-  let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
-  where
-    from :: String
-    from = case f of
-      -- TODO: Lower-case
-      Just s -> " from='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-    id' :: String
-    id' = case i of
-      Just (SID s) -> " id='" ++ s ++ "'"
-      Nothing -> ""
-
-    to :: String
-    to = case t of
-      -- TODO: Lower-case
-      Just s -> " to='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-iqToXML (IQReq (IQSet { iqRequestID = i, iqRequestPayload = p, iqRequestFrom = f, iqRequestTo = t })) =
-  let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
-  where
-    from :: String
-    from = case f of
-      -- TODO: Lower-case
-      Just s -> " from='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-    id' :: String
-    id' = case i of
-      Just (SID s) -> " id='" ++ s ++ "'"
-      Nothing -> ""
-
-    to :: String
-    to = case t of
-      -- TODO: Lower-case
-      Just s -> " to='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-iqToXML (IQRes (IQResult { iqResponseID = i, iqResponsePayload = p, iqResponseFrom = f, iqResponseTo = t })) =
-  let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"
-  where
-    from :: String
-    from = case f of
-      -- TODO: Lower-case
-      Just s -> " from='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-    id' :: String
-    id' = case i of
-      Just (SID s) -> " id='" ++ s ++ "'"
-      Nothing -> ""
-
-    to :: String
-    to = case t of
-      -- TODO: Lower-case
-      Just s -> " to='" ++ (show s) ++ "'"
-      Nothing -> ""
-
--- TODO: Turn message errors into XML.
-
-messageToXML :: Message -> String
-messageToXML Message { messageID = i, messageFrom = f, messageTo = t, messagePayload = p, messageType = ty } = "<message" ++ from ++ id' ++ to ++ type' ++ ">" ++
-                  (elementsToString $ p) ++ "</message>"
-  where
-    from :: String
-    from = case f of
-      -- TODO: Lower-case
-      Just s -> " from='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-    id' :: String
-    id' = case i of
-      Just (SID s) -> " id='" ++ s ++ "'"
-      Nothing -> ""
-
-    to :: String
-    to = case t of
-      -- TODO: Lower-case
-      Just s -> " to='" ++ (show s) ++ "'"
-      Nothing -> ""
-
-    type' :: String
-    type' = case ty of
-      Normal -> ""
-      t -> " type='" ++ (messageTypeToString t) ++ "'"
-
-
-parseIQ :: Element -> IQ
-parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload
-                                in IQReq (IQGet idAttr fromAttr toAttr Nothing
-                                   payloadMust)
-          | typeAttr == "set" = let (Just payloadMust) = payload
-                                in IQReq (IQSet idAttr fromAttr toAttr Nothing
-                                   payloadMust)
-          | typeAttr == "result" = IQRes (IQResult idAttr fromAttr toAttr
-                                   Nothing payload)
-
-  where
-    -- TODO: Many duplicate functions from parsePresence.
-
-    payload :: Maybe Element
-    payload = case null (elementChildren e) of
-      True -> Nothing
-      False -> Just $ head $ elementChildren e
-
-    typeAttr :: String
-    typeAttr = case attributeText typeName e of
-      -- Nothing -> Nothing
-      Just a -> DT.unpack a
-
-    fromAttr :: Maybe Address
-    fromAttr = case attributeText fromName e of
-      Nothing -> Nothing
-      Just a -> X.fromString $ DT.unpack a
-
-    toAttr :: Maybe Address
-    toAttr = case attributeText toName e of
-      Nothing -> Nothing
-      Just a -> X.fromString $ DT.unpack a
 
-    idAttr :: Maybe StanzaID
+presenceToXML :: InternalPresence -> Element
-    idAttr = case attributeText idName e of
-      Nothing -> Nothing
-      Just a -> Just (SID (DT.unpack a))
 
-    typeName :: Name
+presenceToXML (Right p) = Element "presence" attribs nodes
-    typeName = fromString "type"
+    where
-
-    fromName :: Name
-    fromName = fromString "from"
-
-    toName :: Name
-    toName = fromString "to"
-
-    idName :: Name
-    idName = fromString "id"
-
--- TODO: Parse xml:lang
-
-parsePresence :: Element -> Presence
-parsePresence e = Presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
-  where
-    -- TODO: Many duplicate functions from parseIQ.
-
-    typeAttr :: PresenceType
-    typeAttr = case attributeText typeName e of
-      Just t -> stringToPresenceType $ DT.unpack t
-      Nothing -> Available
 
-    fromAttr :: Maybe Address
+        attribs :: [(Name, [Content])]
-    fromAttr = case attributeText fromName e of
+        attribs = stanzaNodes (presenceID p) (presenceFrom p) (presenceTo p) (presenceLangTag p) ++
-      Nothing -> Nothing
+                  [("type", [ContentText $ DT.pack $ show $ presenceType p])]
-      Just a -> X.fromString $ DT.unpack a
 
-    toAttr :: Maybe Address
+        nodes :: [Node]
-    toAttr = case attributeText toName e of
+        nodes = map (\ x -> NodeElement x) (presencePayload p)
-      Nothing -> Nothing
-      Just a -> X.fromString $ DT.unpack a
 
-    idAttr :: Maybe StanzaID
+presenceToXML (Left p) = Element "presence" attribs nodes
-    idAttr = case attributeText idName e of
+    where
-      Nothing -> Nothing
-      Just a -> Just (SID (DT.unpack a))
 
-    fromName :: Name
+        attribs :: [(Name, [Content])]
-    fromName = fromString "from"
+        attribs = stanzaNodes (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) (presenceErrorLangTag p) ++
+                  [("type", [ContentText $ DT.pack "error"])]
 
-    typeName :: Name
+        nodes :: [Node]
-    typeName = fromString "type"
+        nodes = case presenceErrorPayload p of
+                    Just elem -> map (\ x -> NodeElement x) elem
+                    Nothing -> []
 
-    toName :: Name
-    toName = fromString "to"
 
-    idName :: Name
+iqToXML :: IQ -> Element
-    idName = fromString "id"
 
-parseMessage :: Element -> Message
+iqToXML = iqToXML
-parseMessage e = Message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
-  where
-    -- TODO: Many duplicate functions from parseIQ.
 
-    typeAttr :: MessageType
-    typeAttr = case attributeText typeName e of
-      Just t -> stringToMessageType $ DT.unpack t
-      Nothing -> Normal
 
-    fromAttr :: Maybe Address
+messageToXML :: InternalMessage -> Element
-    fromAttr = case attributeText fromName e of
-      Nothing -> Nothing
-      Just a -> X.fromString $ DT.unpack a
 
-    toAttr :: Maybe Address
+messageToXML = messageToXML
-    toAttr = case attributeText toName e of
-      Nothing -> Nothing
-      Just a -> X.fromString $ DT.unpack a
 
-    idAttr :: Maybe StanzaID
-    idAttr = case attributeText idName e of
-      Nothing -> Nothing
-      Just a -> Just (SID (DT.unpack a))
 
-    fromName :: Name
+stanzaNodes :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])]
-    fromName = fromString "from"
 
-    typeName :: Name
+stanzaNodes i f t l = if isJust $ i then [("id", [ContentText $ DT.pack $ show $ fromJust i])] else [] ++
-    typeName = fromString "type"
+                      if isJust $ f then [("from", [ContentText $ DT.pack $ show $ fromJust f])] else [] ++
+                      if isJust $ t then [("to", [ContentText $ DT.pack $ show $ fromJust t])] else [] ++
+                      if isJust $ l then [("xml:lang", [ContentText $ DT.pack $ show l])] else []
 
-    toName :: Name
-    toName = fromString "to"
 
-    idName :: Name
+parseIQ :: Element -> IQ
-    idName = fromString "id"
 
--- stringToPresenceType "available" = Available
+parseIQ = parseIQ
--- stringToPresenceType "away" = Away
--- stringToPresenceType "chat" = Chat
--- stringToPresenceType "dnd" = DoNotDisturb
--- stringToPresenceType "xa" = ExtendedAway
 
-stringToPresenceType "available" = Available -- TODO: Some client sent this
 
-stringToPresenceType "probe" = Probe
+parsePresence :: Element -> InternalPresence
--- stringToPresenceType "error" = PresenceError -- TODO: Special case
 
-stringToPresenceType "unavailable" = Unavailable
+parsePresence = parsePresence
-stringToPresenceType "subscribe" = Subscribe
-stringToPresenceType "subscribed" = Subscribed
-stringToPresenceType "unsubscribe" = Unsubscribe
-stringToPresenceType "unsubscribed" = Unsubscribed
 
--- presenceTypeToString Available = "available"
 
--- presenceTypeToString Away = "away"
+parseMessage :: Element -> InternalMessage
--- presenceTypeToString Chat = "chat"
--- presenceTypeToString DoNotDisturb = "dnd"
--- presenceTypeToString ExtendedAway = "xa"
 
-presenceTypeToString Unavailable = "unavailable"
+parseMessage = parseMessage
 
-presenceTypeToString Probe = "probe"
--- presenceTypeToString PresenceError = "error" -- TODO: Special case
 
-presenceTypeToString Subscribe = "subscribe"
+stringToPresenceType :: String -> Maybe (Maybe PresenceType)
-presenceTypeToString Subscribed = "subscribed"
-presenceTypeToString Unsubscribe = "unsubscribe"
-presenceTypeToString Unsubscribed = "unsubscribed"
 
-stringToMessageType "chat" = Chat
+stringToPresenceType "probe" = Just $ Just Probe
-stringToMessageType "error" = Error
+stringToPresenceType "unavailable" = Just $ Just Unavailable
-stringToMessageType "groupchat" = Groupchat
+stringToPresenceType "subscribe" = Just $ Just Subscribe
-stringToMessageType "headline" = Headline
+stringToPresenceType "subscribed" = Just $ Just Subscribed
-stringToMessageType "normal" = Normal
+stringToPresenceType "unsubscribe" = Just $ Just Unsubscribe
-stringToMessageType s = OtherMessageType s
+stringToPresenceType "unsubscribed" = Just $ Just Unsubscribed
+stringToPresenceType "error" = Just Nothing
+stringToPresenceType _ = Nothing
 
-messageTypeToString Chat = "chat"
-messageTypeToString Error = "error"
-messageTypeToString Groupchat = "groupchat"
-messageTypeToString Headline = "headline"
-messageTypeToString Normal = "normal"
-messageTypeToString (OtherMessageType s) = s
 
+presenceTypeToString :: Maybe PresenceType -> String
 
-data Version = Version { majorVersion :: Integer
+presenceTypeToString (Just Unavailable) = "unavailable"
-                       , minorVersion :: Integer } deriving (Eq)
+presenceTypeToString (Just Probe) = "probe"
+presenceTypeToString Nothing = "error"
+presenceTypeToString (Just Subscribe) = "subscribe"
+presenceTypeToString (Just Subscribed) = "subscribed"
+presenceTypeToString (Just Unsubscribe) = "unsubscribe"
+presenceTypeToString (Just Unsubscribed) = "unsubscribed"
 
 
--- Version numbers are displayed as "<major>.<minor>".
+stringToMessageType :: String -> Maybe (Maybe MessageType)
 
-instance Show Version where
+stringToMessageType "chat" = Just $ Just Chat
-    show (Version major minor) = (show major) ++ "." ++ (show minor)
+stringToMessageType "error" = Just $ Nothing
+stringToMessageType "groupchat" = Just $ Just Groupchat
+stringToMessageType "headline" = Just $ Just Headline
+stringToMessageType "normal" = Just $ Just Normal
+stringToMessageType _ = Nothing
 
 
--- If the major version numbers are not equal, compare them. Otherwise, compare
+messageTypeToString :: Maybe MessageType -> String
--- the minor version numbers.
 
-instance Ord Version where
+messageTypeToString (Just Chat) = "chat"
-    compare (Version amajor aminor) (Version bmajor bminor)
+messageTypeToString Nothing = "error"
-        | amajor /= bmajor = compare amajor bmajor
+messageTypeToString (Just Groupchat) = "groupchat"
-        | otherwise = compare aminor bminor
+messageTypeToString (Just Headline) = "headline"
+messageTypeToString (Just Normal) = "normal"
 
 
 -- Converts a "<major>.<minor>" numeric version number to a "Version" object.
@@ -507,25 +297,6 @@ version = do
     return $ Version (read major) (read minor)
 
 
-data LangTag = LangTag { primaryTag :: String
-                       , subtags :: [String] }
-
-
--- Displays the language tag in the form of "en-US".
-
-instance Show LangTag where
-    show (LangTag p []) = p
-    show (LangTag p s) = p ++ "-" ++ (concat $ intersperse "-" s)
-
-
--- Two language tags are considered equal of they contain the same tags (case-insensitive).
-
-instance Eq LangTag where
-    (LangTag ap as) == (LangTag bp bs)
-        | length as == length bs && map toLower ap == map toLower bp = all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs
-        | otherwise = False
-
-
 -- |
 -- Parses, validates, and possibly constructs a "LangTag" object.
 

Network/XMPP/Types.hs

@@ -9,7 +9,7 @@ module Network.XMPP.Types (
 StanzaID (..),
 From,
 To,
-IQ (..),
+IQ,
 IQRequest (..),
 IQResponse (..),
 Message (..),
@@ -32,7 +32,7 @@ Address (..),
 Localpart,
 Domainpart,
 Resourcepart,
-XMLLang,
+LangTag (..),
 InternalEvent (..),
 XMLEvent (..),
 ConnectionState (..),
@@ -48,7 +48,14 @@ XMPPError (..),
 Timeout,
 TimeoutEvent (..),
 StreamError (..),
-IDGenerator (..)
+IDGenerator (..),
+Version (..),
+IQError (..),
+IQResult (..),
+IQRequestType (..),
+PresenceError (..),
+InternalPresence (..),
+InternalMessage (..)
 ) where
 
 import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
@@ -61,7 +68,7 @@ import Control.Monad.State hiding (State)
 
 import Data.XML.Types
 
-import Network.TLS
+import Network.TLS hiding (Version)
 import Network.TLS.Cipher
 
 import qualified Control.Monad.Error as CME
@@ -70,6 +77,9 @@ import Data.IORef
 
 import Data.Certificate.X509 (X509)
 
+import Data.List (intersperse)
+import Data.Char (toLower)
+
 
 -- =============================================================================
 --  STANZA TYPES
@@ -110,42 +120,43 @@ type To = Address
 -- An Info/Query (IQ) stanza is either of the type "request" ("get" or "set") or
 -- "response" ("result" or "error"). The @IQ@ type wraps these two sub-types.
 
-data IQ = IQReq IQRequest | IQRes IQResponse deriving (Eq, Show)
+type IQ = Either IQRequest IQResponse
 
 
 -- |
 -- A "request" Info/Query (IQ) stanza is one with either "get" or "set" as type.
 -- They are guaranteed to always contain a payload.
 
-data IQRequest = IQGet { iqRequestID :: Maybe StanzaID
+data IQRequest = IQRequest { iqRequestID :: Maybe StanzaID
-                       , iqRequestFrom :: Maybe From
+                           , iqRequestFrom :: Maybe From
-                       , iqRequestTo :: Maybe To
+                           , iqRequestTo :: Maybe To
-                       , iqRequestXMLLang :: Maybe XMLLang
+                           , iqRequestLangTag :: Maybe LangTag
-                       , iqRequestPayload :: Element } |
+                           , iqRequestType :: IQRequestType
-                 IQSet { iqRequestID :: Maybe StanzaID
+                           , iqRequestPayload :: Element }
-                       , iqRequestFrom :: Maybe From
+                 deriving (Show)
-                       , iqRequestTo :: Maybe To
-                       , iqRequestXMLLang :: Maybe XMLLang
-                       , iqRequestPayload :: Element }
-                 deriving (Eq, Show)
 
 
--- |
+data IQRequestType = Get | Set deriving (Show)
--- A "response" Info/Query (IQ) stanza is one with either "result" or "error" as
+
--- type.
+
-
+type IQResponse = Either IQError IQResult
-data IQResponse = IQResult { iqResponseID :: Maybe StanzaID
+
-                           , iqResponseFrom :: Maybe From
+
-                           , iqResponseTo :: Maybe To
+data IQResult = IQResult { iqResultID :: Maybe StanzaID
-                           , iqResponseXMLLang :: Maybe XMLLang
+                         , iqResultFrom :: Maybe From
-                           , iqResponsePayload :: Maybe Element } |
+                         , iqResultTo :: Maybe To
-                  IQError { iqResponseID :: Maybe StanzaID
+                         , iqResultLangTag :: Maybe LangTag
-                          , iqResponseFrom :: Maybe From
+                         , iqResultPayload :: Maybe Element }
-                          , iqResponseTo :: Maybe To
+                deriving (Show)
-                          , iqResponseXMLLang :: Maybe XMLLang
+
-                          , iqResponsePayload :: Maybe Element
+
-                          , iqResponseStanzaError :: StanzaError }
+data IQError = IQError { iqErrorID :: Maybe StanzaID
-                  deriving (Eq, Show)
+                       , iqErrorFrom :: Maybe From
+                       , iqErrorTo :: Maybe To
+                       , iqErrorLangTag :: Maybe LangTag
+                       , iqErrorPayload :: Maybe Element
+                       , iqErrorStanzaError :: Maybe StanzaError }
+               deriving (Show)
 
 
 -- |
@@ -154,51 +165,70 @@ data IQResponse = IQResult { iqResponseID :: Maybe StanzaID
 data Message = Message { messageID :: Maybe StanzaID
                        , messageFrom :: Maybe From
                        , messageTo :: Maybe To
-                       , messageXMLLang :: Maybe XMLLang
+                       , messageXMLLang :: Maybe LangTag
                        , messageType :: MessageType
-                       , messagePayload :: [Element] } |
+                       , messagePayload :: [Element] }
-               MessageError { messageID :: Maybe StanzaID
+               deriving (Show)
-                            , messageFrom :: Maybe From
+
-                            , messageTo :: Maybe To
+
-                            , messageXMLLang  :: Maybe XMLLang
+data MessageError = MessageError { messageErrorID :: StanzaID
-                            , messageErrorPayload :: Maybe [Element]
+                                 , messageErrorFrom :: Maybe From
-                            , messageErrorStanzaError :: StanzaError }
+                                 , messageErrorTo :: Maybe To
-               deriving (Eq, Show)
+                                 , messageErrorXMLLang  :: Maybe LangTag
+                                 , messageErrorPayload :: Maybe [Element]
+                                 , messageErrorStanzaError :: StanzaError }
+                    deriving (Show)
+
+
+type InternalMessage = Either MessageError Message
 
 
 -- |
 -- @MessageType@ holds XMPP message types as defined in XMPP-IM. @Normal@ is the
--- default message type.
+-- default message type. The "error" message type is left out as errors are
+-- using @MessageError@.
 
 data MessageType = Chat |
-                   Error |
                    Groupchat |
                    Headline |
-                   Normal |
+                   Normal deriving (Eq)
-                   OtherMessageType String deriving (Eq, Show)
+
+
+instance Show MessageType where
+    show Chat = "chat"
+    show Groupchat = "groupchat"
+    show Headline = "headline"
+    show Normal = "normal"
 
 
 -- |
--- The presence stanza - either a presence or a presence error.
+-- The presence stanza. It is used for both originating messages and replies.
+-- For presence errors, see "PresenceError".
 
 data Presence = Presence { presenceID :: Maybe StanzaID
                          , presenceFrom :: Maybe From
                          , presenceTo :: Maybe To
-                         , presenceXMLLang  :: Maybe XMLLang
+                         , presenceLangTag :: Maybe LangTag
-                         , presenceType :: PresenceType
+                         , presenceType :: Maybe PresenceType
-                         , presencePayload :: [Element] } |
+                         , presencePayload :: [Element] }
-                PresenceError { presenceID :: Maybe StanzaID
+                deriving (Show)
-                              , presenceFrom :: Maybe From
+
-                              , presenceTo :: Maybe To
+
-                              , presenceXMLLang  :: Maybe XMLLang
+data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaID
-                              , presenceErrorPayload :: Maybe [Element]
+                                   , presenceErrorFrom :: Maybe From
-                              , presenceErrorStanzaError :: StanzaError }
+                                   , presenceErrorTo :: Maybe To
-                deriving (Eq, Show)
+                                   , presenceErrorLangTag :: Maybe LangTag
+                                   , presenceErrorPayload :: Maybe [Element]
+                                   , presenceErrorStanzaError :: StanzaError }
+                     deriving (Show)
+
+
+type InternalPresence = Either PresenceError Presence
 
 
 -- |
--- @PresenceType@ holds XMPP presence types. When a presence type is not
+-- @PresenceType@ holds XMPP presence types. The "error" message type is left
--- provided, we assign the @PresenceType@ value @Available@.
+-- out as errors are using @PresenceError@.
 
 data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence
                     Subscribed   | -- ^ Sender has approved the subscription
@@ -207,8 +237,16 @@ data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence
                                    --   subscription
                     Probe        | -- ^ Sender requests current presence;
                                    --   should only be used by servers
-                    Available    | -- ^ Sender did not specify a type attribute
+                    Unavailable deriving (Eq)
-                    Unavailable deriving (Eq, Show)
+
+
+instance Show PresenceType where
+    show Subscribe    = "subscribe"
+    show Subscribed   = "subscribed"
+    show Unsubscribe  = "unsubscribe"
+    show Unsubscribed = "unsubscribed"
+    show Probe        = "probe"
+    show Unavailable  = "unavailable"
 
 
 -- |
@@ -360,8 +398,8 @@ type Resource = String
 
 data XMLEvent = XEBeginStream String | XEFeatures String |
                 XEChallenge Challenge | XESuccess Success |
-                XEEndStream | XEIQ IQ | XEPresence Presence |
+                XEEndStream | XEIQ IQ | XEPresence InternalPresence |
-                XEMessage Message | XEProceed |
+                XEMessage InternalMessage | XEProceed |
                 XEOther String deriving (Show)
 
 data EnumeratorEvent = EnumeratorDone |
@@ -472,12 +510,47 @@ data StreamError = StreamError
 --  XML TYPES
 -- =============================================================================
 
-type XMLLang = String
--- Validate, protect. See:
--- http://tools.ietf.org/html/rfc6120#section-8.1.5
--- http://www.w3.org/TR/2008/REC-xml-20081126/
--- http://www.rfc-editor.org/rfc/bcp/bcp47.txt
--- http://www.ietf.org/rfc/rfc1766.txt
-
 
 newtype IDGenerator = IDGenerator (IORef [String])
+
+
+
+
+--- other stuff
+
+data Version = Version { majorVersion :: Integer
+                       , minorVersion :: Integer } deriving (Eq)
+
+
+-- Version numbers are displayed as "<major>.<minor>".
+
+instance Show Version where
+    show (Version major minor) = (show major) ++ "." ++ (show minor)
+
+
+-- If the major version numbers are not equal, compare them. Otherwise, compare
+-- the minor version numbers.
+
+instance Ord Version where
+    compare (Version amajor aminor) (Version bmajor bminor)
+        | amajor /= bmajor = compare amajor bmajor
+        | otherwise = compare aminor bminor
+
+
+data LangTag = LangTag { primaryTag :: String
+                       , subtags :: [String] }
+
+
+-- Displays the language tag in the form of "en-US".
+
+instance Show LangTag where
+    show (LangTag p []) = p
+    show (LangTag p s) = p ++ "-" ++ (concat $ intersperse "-" s)
+
+
+-- Two language tags are considered equal of they contain the same tags (case-insensitive).
+
+instance Eq LangTag where
+    (LangTag ap as) == (LangTag bp bs)
+        | length as == length bs && map toLower ap == map toLower bp = all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs
+        | otherwise = False

Network/XMPP/Utilities.hs

@@ -3,13 +3,19 @@
 
 {-# OPTIONS_HADDOCK hide #-}
 
+{-# LANGUAGE OverloadedStrings #-}
+
+-- TODO: Use -fno-cse? http://cvs.haskell.org/Hugs/pages/libraries/base/System-IO-Unsafe.html
+
+
 -- TODO: Document this module
 -- TODO: Make is possible to customize characters
 -- TODO: Make it possible to customize length
 
 module Network.XMPP.Utilities ( elementToString
-                              , elementsToString ) where
+                              , elementsToString, testElement ) where
 
+import Prelude hiding (concat)
 import Data.Word
 import Data.XML.Types
 import System.Crypto.Random
@@ -17,48 +23,55 @@ import System.Random
 import qualified Data.ByteString as DB
 import qualified Data.Map as DM
 import qualified Data.Text as DT
+import qualified Data.ByteString.Char8 as DBC
+
+import Data.Enumerator (($$), Stream (Chunks), Enumerator, Iteratee, Step (Continue), continue, joinI,
+                        run, run_, yield, returnI)
+import Data.Enumerator.List (consume)
+import Text.XML.Enumerator.Document (toEvents)
+import Text.XML.Enumerator.Render (renderBytes)
+import Data.Maybe (fromJust)
+import Data.ByteString (concat, unpack)
+import Data.List (tail)
+import System.IO.Unsafe (unsafePerformIO)
 
 
+{-# NOINLINE elementToString #-}
+
 
 -- =============================================================================
 --  XML Utilities
 -- =============================================================================
 
 
+-- TODO: Remove?
+
 elementsToString :: [Element] -> String
+
 elementsToString [] = ""
-elementsToString (e:es) = (elementToString $ Just e) ++ elementsToString es
+elementsToString (e:es) = (elementToString (Just e)) ++ (elementsToString es)
+
+
+-- Converts the Element object to a document, converts it into Events, strips
+-- the DocumentBegin event, generates a ByteString, and converts it into a
+-- String.
 
 elementToString :: Maybe Element -> String
+
 elementToString Nothing = ""
-elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns ++
+elementToString (Just elem) = DBC.unpack $ concat $ unsafePerformIO $ do
-                           attributes (elementAttributes e) ++
+    r <- run_ $ events $$ (joinI $ renderBytes $$ consume)
-                           ">" ++ (nodesToString $ elementNodes e) ++ "</" ++
+    return r
-                           nameToString (elementName e) ++ ">"
+    where
-  where
+
-    xmlns :: String
+        -- Enumerator that "produces" the events to convert to the document
-    xmlns = case nameNamespace $ elementName e of
+        events :: Enumerator Event IO [DB.ByteString]
-      Nothing -> ""
+        events (Continue more) = more $ Chunks (tail $ toEvents $ dummyDoc elem)
-      Just t -> " xmlns='" ++ (DT.unpack t) ++ "'"
+        events step = returnI step
-
+
-    nameToString :: Name -> String
+        dummyDoc :: Element -> Document
-    nameToString Name { nameLocalName = n, namePrefix = Nothing } = DT.unpack n
+        dummyDoc e = Document (Prologue [] Nothing []) elem []
-    nameToString Name { nameLocalName = n, namePrefix = Just p } =
+
-      (DT.unpack p) ++ ":" ++ (DT.unpack n)
+
-
+testElement :: Element
-    contentToString :: Content -> String
+testElement = Element ("{http://example.com/ns/my-namespace}my-name" :: Name) [] []
-    contentToString (ContentText t) = DT.unpack t
-    contentToString (ContentEntity t) = DT.unpack t
-
-    attributes :: [(Name, [Content])] -> String
-    attributes [] = ""
-    attributes ((n, c):t) = (" " ++ (nameToString n) ++ "='" ++
-                             concat (map contentToString c) ++ "'") ++
-                            attributes t
-
-    nodesToString :: [Node] -> String
-    nodesToString [] = ""
-    nodesToString ((NodeElement e):ns) = (elementToString $ Just e) ++
-                                         (nodesToString ns)
-    nodesToString ((NodeContent c):ns) = (contentToString c) ++
-                                         (nodesToString ns)