module Network.Protocol.XMPP.Client.Features
( Feature (..)
, parseFeatures
, parseFeature
) where
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8
import Data.ByteString (ByteString)
import qualified Data.Text
import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.String (s)
data Feature =
FeatureStartTLS Bool
| FeatureSASL [ByteString]
| FeatureRegister
| FeatureBind
| FeatureSession
| FeatureUnknown X.Element
deriving (Show, Eq)
parseFeatures :: X.Element -> [Feature]
parseFeatures e =
parseFeature <$>
(X.isNamed nameFeatures e >>= X.elementChildren)
parseFeature :: X.Element -> Feature
parseFeature elemt = feature where
unpackName = (maybe "" Data.Text.unpack . X.nameNamespace) &&&
(Data.Text.unpack . X.nameLocalName)
feature = case unpackName (X.elementName elemt) of
("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS elemt
("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL elemt
("http://jabber.org/features/iq-register", "register") -> FeatureRegister
("urn:ietf:params:xml:ns:xmpp-bind", "bind") -> FeatureBind
("urn:ietf:params:xml:ns:xmpp-session", "session") -> FeatureSession
_ -> FeatureUnknown elemt
parseFeatureTLS :: X.Element -> Feature
parseFeatureTLS _ = FeatureStartTLS True
parseFeatureSASL :: X.Element -> Feature
parseFeatureSASL e = FeatureSASL $
fmap (Data.ByteString.Char8.pack . Data.Text.unpack . X.contentText) $
X.elementChildren e
>>= X.isNamed nameMechanism
>>= X.elementNodes
>>= X.isContent
nameMechanism :: X.Name
nameMechanism = s"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"
nameFeatures :: X.Name
nameFeatures = s"{http://etherx.jabber.org/streams}features"