diff --git a/Network/XMPP.hs b/Network/XMPP.hs index 34eee9b..d7707bb 100644 --- a/Network/XMPP.hs +++ b/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 - - -- Network.XMPP.Utilities - , elementToString - , elementsToString - , getID ) where + , injectAction ) where import Network.XMPP.Address import Network.XMPP.SASL diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index e6374cd..2105b03 100644 --- a/Network/XMPP/Session.hs +++ b/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' - lift $ liftIO $ send xml handleOrTLSCtx + let xml = presenceToXML $ Right presence' + 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' - lift $ liftIO $ send xml handleOrTLSCtx + let xml = messageToXML $ Right message' + 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 - Nothing -> do + iq' <- do -- case iqID iq of + -- Nothing -> do id <- liftIO $ nextID $ stateIDGenerator state - return $ case iq of - IQReq r -> do - IQReq (r { iqRequestID = Just (SID id) }) - 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 () + return iq + let callback' = fromJust stanzaCallback + put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) } 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 diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs index cdca7f4..0e66961 100644 --- a/Network/XMPP/Stanza.hs +++ b/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 (IQRes i) = iqResponseID i +iqID (Left req) = iqRequestID req +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 (IQRes i) = iqResponseFrom i +iqFrom (Left req) = iqRequestFrom req +iqFrom (Right res) = iqResponseFrom res -- | @@ -55,17 +63,36 @@ iqFrom (IQRes i) = iqResponseFrom i iqTo :: IQ -> Maybe To -iqTo (IQReq i) = iqRequestTo i -iqTo (IQRes i) = iqResponseTo i +iqTo (Left req) = iqRequestTo req +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 (IQRes i) = iqResponsePayload i +iqPayload (Left req) = Just (iqRequestPayload req) +iqPayload (Right res) = iqResponsePayload res + + +iqResponsePayload :: IQResponse -> Maybe Element + +iqResponsePayload (Left err) = iqErrorPayload err +iqResponsePayload (Right res) = iqResultPayload res -- | diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs index 3324df0..8f0cefa 100644 --- a/Network/XMPP/Stream.hs +++ b/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 = "" ++ - (elementsToString $ presencePayload p) ++ "" - 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 "" ++ (elementToString (Just p)) ++ "" - 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 "" ++ (elementToString (Just p)) ++ "" - 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 "" ++ (elementToString p) ++ "" - 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 } = "" ++ - (elementsToString $ p) ++ "" - 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 - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) +presenceToXML :: InternalPresence -> Element - typeName :: Name - typeName = fromString "type" - - 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 +presenceToXML (Right p) = Element "presence" attribs nodes + where - fromAttr :: Maybe Address - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> X.fromString $ DT.unpack a + attribs :: [(Name, [Content])] + attribs = stanzaNodes (presenceID p) (presenceFrom p) (presenceTo p) (presenceLangTag p) ++ + [("type", [ContentText $ DT.pack $ show $ presenceType p])] - toAttr :: Maybe Address - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> X.fromString $ DT.unpack a + nodes :: [Node] + nodes = map (\ x -> NodeElement x) (presencePayload p) - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) +presenceToXML (Left p) = Element "presence" attribs nodes + where - fromName :: Name - fromName = fromString "from" + attribs :: [(Name, [Content])] + attribs = stanzaNodes (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) (presenceErrorLangTag p) ++ + [("type", [ContentText $ DT.pack "error"])] - typeName :: Name - typeName = fromString "type" + nodes :: [Node] + nodes = case presenceErrorPayload p of + Just elem -> map (\ x -> NodeElement x) elem + Nothing -> [] - toName :: Name - toName = fromString "to" - idName :: Name - idName = fromString "id" +iqToXML :: IQ -> Element -parseMessage :: Element -> Message -parseMessage e = Message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) - where - -- TODO: Many duplicate functions from parseIQ. +iqToXML = iqToXML - typeAttr :: MessageType - typeAttr = case attributeText typeName e of - Just t -> stringToMessageType $ DT.unpack t - Nothing -> Normal - fromAttr :: Maybe Address - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> X.fromString $ DT.unpack a +messageToXML :: InternalMessage -> Element - toAttr :: Maybe Address - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> X.fromString $ DT.unpack a +messageToXML = messageToXML - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) - fromName :: Name - fromName = fromString "from" +stanzaNodes :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])] - typeName :: Name - typeName = fromString "type" +stanzaNodes i f t l = if isJust $ i then [("id", [ContentText $ DT.pack $ show $ fromJust i])] else [] ++ + 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 - idName = fromString "id" +parseIQ :: Element -> IQ --- stringToPresenceType "available" = Available --- stringToPresenceType "away" = Away --- stringToPresenceType "chat" = Chat --- stringToPresenceType "dnd" = DoNotDisturb --- stringToPresenceType "xa" = ExtendedAway +parseIQ = parseIQ -stringToPresenceType "available" = Available -- TODO: Some client sent this -stringToPresenceType "probe" = Probe --- stringToPresenceType "error" = PresenceError -- TODO: Special case +parsePresence :: Element -> InternalPresence -stringToPresenceType "unavailable" = Unavailable -stringToPresenceType "subscribe" = Subscribe -stringToPresenceType "subscribed" = Subscribed -stringToPresenceType "unsubscribe" = Unsubscribe -stringToPresenceType "unsubscribed" = Unsubscribed +parsePresence = parsePresence --- presenceTypeToString Available = "available" --- presenceTypeToString Away = "away" --- presenceTypeToString Chat = "chat" --- presenceTypeToString DoNotDisturb = "dnd" --- presenceTypeToString ExtendedAway = "xa" +parseMessage :: Element -> InternalMessage -presenceTypeToString Unavailable = "unavailable" +parseMessage = parseMessage -presenceTypeToString Probe = "probe" --- presenceTypeToString PresenceError = "error" -- TODO: Special case -presenceTypeToString Subscribe = "subscribe" -presenceTypeToString Subscribed = "subscribed" -presenceTypeToString Unsubscribe = "unsubscribe" -presenceTypeToString Unsubscribed = "unsubscribed" +stringToPresenceType :: String -> Maybe (Maybe PresenceType) -stringToMessageType "chat" = Chat -stringToMessageType "error" = Error -stringToMessageType "groupchat" = Groupchat -stringToMessageType "headline" = Headline -stringToMessageType "normal" = Normal -stringToMessageType s = OtherMessageType s +stringToPresenceType "probe" = Just $ Just Probe +stringToPresenceType "unavailable" = Just $ Just Unavailable +stringToPresenceType "subscribe" = Just $ Just Subscribe +stringToPresenceType "subscribed" = Just $ Just Subscribed +stringToPresenceType "unsubscribe" = Just $ Just Unsubscribe +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 - , minorVersion :: Integer } deriving (Eq) +presenceTypeToString (Just Unavailable) = "unavailable" +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 ".". +stringToMessageType :: String -> Maybe (Maybe MessageType) -instance Show Version where - show (Version major minor) = (show major) ++ "." ++ (show minor) +stringToMessageType "chat" = Just $ Just Chat +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 --- the minor version numbers. +messageTypeToString :: Maybe MessageType -> String -instance Ord Version where - compare (Version amajor aminor) (Version bmajor bminor) - | amajor /= bmajor = compare amajor bmajor - | otherwise = compare aminor bminor +messageTypeToString (Just Chat) = "chat" +messageTypeToString Nothing = "error" +messageTypeToString (Just Groupchat) = "groupchat" +messageTypeToString (Just Headline) = "headline" +messageTypeToString (Just Normal) = "normal" -- Converts a "." 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. diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index 5a397e9..8f69e43 100644 --- a/Network/XMPP/Types.hs +++ b/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 - , iqRequestFrom :: Maybe From - , iqRequestTo :: Maybe To - , iqRequestXMLLang :: Maybe XMLLang - , iqRequestPayload :: Element } | - IQSet { iqRequestID :: Maybe StanzaID - , iqRequestFrom :: Maybe From - , iqRequestTo :: Maybe To - , iqRequestXMLLang :: Maybe XMLLang - , iqRequestPayload :: Element } - deriving (Eq, Show) +data IQRequest = IQRequest { iqRequestID :: Maybe StanzaID + , iqRequestFrom :: Maybe From + , iqRequestTo :: Maybe To + , iqRequestLangTag :: Maybe LangTag + , iqRequestType :: IQRequestType + , iqRequestPayload :: Element } + deriving (Show) --- | --- A "response" Info/Query (IQ) stanza is one with either "result" or "error" as --- type. - -data IQResponse = IQResult { iqResponseID :: Maybe StanzaID - , iqResponseFrom :: Maybe From - , iqResponseTo :: Maybe To - , iqResponseXMLLang :: Maybe XMLLang - , iqResponsePayload :: Maybe Element } | - IQError { iqResponseID :: Maybe StanzaID - , iqResponseFrom :: Maybe From - , iqResponseTo :: Maybe To - , iqResponseXMLLang :: Maybe XMLLang - , iqResponsePayload :: Maybe Element - , iqResponseStanzaError :: StanzaError } - deriving (Eq, Show) +data IQRequestType = Get | Set deriving (Show) + + +type IQResponse = Either IQError IQResult + + +data IQResult = IQResult { iqResultID :: Maybe StanzaID + , iqResultFrom :: Maybe From + , iqResultTo :: Maybe To + , iqResultLangTag :: Maybe LangTag + , iqResultPayload :: Maybe Element } + deriving (Show) + + +data IQError = IQError { iqErrorID :: Maybe StanzaID + , 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] } | - MessageError { messageID :: Maybe StanzaID - , messageFrom :: Maybe From - , messageTo :: Maybe To - , messageXMLLang :: Maybe XMLLang - , messageErrorPayload :: Maybe [Element] - , messageErrorStanzaError :: StanzaError } - deriving (Eq, Show) + , messagePayload :: [Element] } + deriving (Show) + + +data MessageError = MessageError { messageErrorID :: StanzaID + , messageErrorFrom :: Maybe From + , messageErrorTo :: Maybe To + , 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 | - OtherMessageType String deriving (Eq, Show) + Normal deriving (Eq) + + +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 - , presenceType :: PresenceType - , presencePayload :: [Element] } | - PresenceError { presenceID :: Maybe StanzaID - , presenceFrom :: Maybe From - , presenceTo :: Maybe To - , presenceXMLLang :: Maybe XMLLang - , presenceErrorPayload :: Maybe [Element] - , presenceErrorStanzaError :: StanzaError } - deriving (Eq, Show) + , presenceLangTag :: Maybe LangTag + , presenceType :: Maybe PresenceType + , presencePayload :: [Element] } + deriving (Show) + + +data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaID + , presenceErrorFrom :: Maybe From + , presenceErrorTo :: Maybe To + , 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 --- provided, we assign the @PresenceType@ value @Available@. +-- @PresenceType@ holds XMPP presence types. The "error" message type is left +-- 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, Show) + Unavailable deriving (Eq) + + +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 | - XEMessage Message | XEProceed | + XEEndStream | XEIQ IQ | XEPresence InternalPresence | + 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 ".". + +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 diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs index 8e3abaa..dc3eeb0 100644 --- a/Network/XMPP/Utilities.hs +++ b/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 ++ - attributes (elementAttributes e) ++ - ">" ++ (nodesToString $ elementNodes e) ++ "" - where - xmlns :: String - xmlns = case nameNamespace $ elementName e of - Nothing -> "" - Just t -> " xmlns='" ++ (DT.unpack t) ++ "'" - - nameToString :: Name -> String - nameToString Name { nameLocalName = n, namePrefix = Nothing } = DT.unpack n - nameToString Name { nameLocalName = n, namePrefix = Just p } = - (DT.unpack p) ++ ":" ++ (DT.unpack n) - - contentToString :: Content -> String - 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) +elementToString (Just elem) = DBC.unpack $ concat $ unsafePerformIO $ do + r <- run_ $ events $$ (joinI $ renderBytes $$ consume) + return r + where + + -- Enumerator that "produces" the events to convert to the document + events :: Enumerator Event IO [DB.ByteString] + events (Continue more) = more $ Chunks (tail $ toEvents $ dummyDoc elem) + events step = returnI step + + dummyDoc :: Element -> Document + dummyDoc e = Document (Prologue [] Nothing []) elem [] + + +testElement :: Element +testElement = Element ("{http://example.com/ns/my-namespace}my-name" :: Name) [] []