diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs --- a/Network/Protocol/XMPP.hs +++ b/Network/Protocol/XMPP.hs @@ -1,27 +1,73 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . -module Network.Protocol.XMPP ( - module Network.Protocol.XMPP.JID - ,module Network.Protocol.XMPP.Client - ,module Network.Protocol.XMPP.Component - ,module Network.Protocol.XMPP.Stanzas - ) where -import Network.Protocol.XMPP.JID +module Network.Protocol.XMPP + ( + -- * JIDs + JID (..) + , Node + , Domain + , Resource + + , strNode + , strDomain + , strResource + + , parseJID + , formatJID + + -- * Stanzas + , Stanza + ( stanzaTo + , stanzaFrom + , stanzaID + , stanzaLang + , stanzaPayloads + ) + + , ReceivedStanza (..) + , Message (..) + , Presence (..) + , IQ (..) + , MessageType (..) + , PresenceType (..) + , IQType (..) + + , emptyMessage + , emptyPresence + , emptyIQ + + -- * The XMPP monad + , XMPP + , Server (..) + , Error (..) + , runClient + , runComponent + , putStanza + , getStanza + , bindJID + + -- ** Resuming sessions + , Session + , getSession + , runXMPP + ) where import Network.Protocol.XMPP.Client import Network.Protocol.XMPP.Component -import Network.Protocol.XMPP.Stanzas +import Network.Protocol.XMPP.Connections +import Network.Protocol.XMPP.JID +import Network.Protocol.XMPP.Monad +import Network.Protocol.XMPP.Stanza diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -1,109 +1,143 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . -module Network.Protocol.XMPP.Client ( - ConnectedClient - ,Client - ,clientConnect - ,clientAuthenticate - ,clientBind - ,clientJID - ,clientServerJID - ,putTree - ,getTree - ,putStanza +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.Client + ( runClient + , bindJID ) where - -import Network (HostName, PortID, connectTo) -import Text.XML.HXT.Arrow ((>>>)) -import qualified Text.XML.HXT.Arrow as A -import Text.XML.HXT.DOM.TypeDefs (XmlTree) -import qualified Text.XML.HXT.DOM.XmlNode as XN - -import Network.Protocol.XMPP.JID (JID, jidParse, jidResource) -import qualified Network.Protocol.XMPP.SASL as SASL -import qualified Network.Protocol.XMPP.Stream as S -import Network.Protocol.XMPP.Util (mkElement, mkQName) -import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree) -import Network.Protocol.XMPP.Connection +import Control.Monad ((>=>)) +import Control.Monad.Error (throwError) +import Control.Monad.Trans (liftIO) +import Data.ByteString (ByteString) +import qualified Data.Text.Lazy as T +import Network (connectTo) +import qualified System.IO as IO -data ConnectedClient = ConnectedClient JID S.Stream +import qualified Network.Protocol.XMPP.Client.Authentication as A +import qualified Network.Protocol.XMPP.Connections as C +import qualified Network.Protocol.XMPP.Client.Features as F +import qualified Network.Protocol.XMPP.Handle as H +import qualified Network.Protocol.XMPP.JID as J +import qualified Network.Protocol.XMPP.Monad as M +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.ErrorT +import Network.Protocol.XMPP.Stanza -data Client = Client { - clientJID :: JID - ,clientServerJID :: JID - ,clientStream :: S.Stream - } +runClient :: C.Server + -> J.JID -- ^ Client JID + -> T.Text -- ^ Username + -> T.Text -- ^ Password + -> M.XMPP a + -> IO (Either M.Error a) +runClient server jid username password xmpp = do + -- Open a TCP connection + let C.Server sjid host port = server + rawHandle <- connectTo host port + IO.hSetBuffering rawHandle IO.NoBuffering + let handle = H.PlainHandle rawHandle + + -- Open the initial stream and authenticate + M.startXMPP handle "jabber:client" $ do + features <- newStream sjid + tryTLS sjid features $ \tlsFeatures -> do + let mechanisms = authenticationMechanisms tlsFeatures + A.authenticate mechanisms jid sjid username password + M.restartXMPP Nothing (newStream sjid >> xmpp) -type Username = String -type Password = String +newStream :: J.JID -> M.XMPP [F.Feature] +newStream jid = do + M.putBytes $ C.xmlHeader "jabber:client" jid + M.readEvents C.startOfStream + F.parseFeatures `fmap` M.getElement -clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient -clientConnect jid host port = do - handle <- connectTo host port - stream <- S.beginStream jid "jabber:client" handle - return $ ConnectedClient jid stream +tryTLS :: J.JID -> [F.Feature] -> ([F.Feature] -> M.XMPP a) -> M.XMPP a +tryTLS sjid features m + | not (streamSupportsTLS features) = m features + | otherwise = do + M.putElement xmlStartTLS + M.getElement + h <- M.getHandle + eitherTLS <- liftIO $ runErrorT $ H.startTLS h + case eitherTLS of + Left err -> throwError $ M.TransportError err + Right tls -> M.restartXMPP (Just tls) $ newStream sjid >>= m -clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client -clientAuthenticate (ConnectedClient serverJID stream) jid username password = do - authed <- SASL.authenticate stream jid serverJID username password - case authed of - SASL.Failure -> error "Authentication failure" - _ -> do - newStream <- S.restartStream stream - return $ Client jid serverJID newStream +authenticationMechanisms :: [F.Feature] -> [ByteString] +authenticationMechanisms = step where + step [] = [] + step (f:fs) = case f of + (F.FeatureSASL ms) -> ms + _ -> step fs -clientBind :: Client -> IO JID -clientBind c = do +-- | Send a @\@ message for the given 'J.JID', returning the server's reply. In +-- most cases the reply will be the same as the input. However, if the input has no +-- 'J.Resource', the returned 'J.JID' will contain a generated 'J.Resource'. +-- +-- Clients must bind a 'J.JID' before sending any 'Stanza's. +bindJID :: J.JID -> M.XMPP J.JID +bindJID jid = do -- Bind - let resourceElements = case jidResource . clientJID $ c of - "" -> [] - resource -> - [mkElement ("", "resource") - [] - [XN.mkText resource]] + M.putStanza . bindStanza . J.jidResource $ jid + bindResult <- M.getStanza + let getJID = + X.elementChildren + >=> X.isNamed (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing) + >=> X.elementNodes + >=> X.isContent + >=> return . X.contentText - putTree c $ mkElement ("", "iq") - [("", "type", "set")] - [mkElement ("", "bind") - [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")] - resourceElements] + let maybeJID = do + iq <- case bindResult of + ReceivedIQ x -> Just x + _ -> Nothing + payload <- iqPayload iq + + case getJID payload of + [] -> Nothing + (str:_) -> J.parseJID str - bindResult <- getTree c - let [rawJID] = A.runLA ( - A.deep (A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-bind" "jid")) - >>> A.getChildren - >>> A.getText) bindResult - let jid = case jidParse rawJID of - Just x -> x - _ -> error "Couldn't parse server's returned JID" + returnedJID <- case maybeJID of + Just x -> return x + Nothing -> throwError $ M.InvalidBindResult bindResult -- Session - putTree c $ mkElement ("", "iq") - [("", "type", "set")] - [mkElement ("", "session") - [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")] - []] + M.putStanza sessionStanza + M.getStanza - getTree c + M.putStanza $ emptyPresence PresenceAvailable + M.getStanza - putTree c $ mkElement ("", "presence") [] [] - getTree c - return jid + return returnedJID -instance Connection Client where - getTree = S.getTree . clientStream - putTree = S.putTree . clientStream +bindStanza :: Maybe J.Resource -> IQ +bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where + payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested + requested = case fmap J.strResource resource of + Nothing -> [] + Just x -> [X.NodeElement $ X.element "resource" [] + [X.NodeContent $ X.ContentText x]] + +sessionStanza :: IQ +sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where + payload = X.nselement "urn:ietf:params:xml:ns:xmpp-session" "session" [] [] + +streamSupportsTLS :: [F.Feature] -> Bool +streamSupportsTLS = any isStartTLS where + isStartTLS (F.FeatureStartTLS _) = True + isStartTLS _ = False + +xmlStartTLS :: X.Element +xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] [] diff --git a/Network/Protocol/XMPP/Client/Authentication.hs b/Network/Protocol/XMPP/Client/Authentication.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/Client/Authentication.hs @@ -0,0 +1,133 @@ +-- Copyright (C) 2009-2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Network.Protocol.XMPP.Client.Authentication + ( Result (..) + , authenticate + ) where +import qualified Control.Exception as Exc +import Control.Monad (when, (>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Control.Monad.Error as E +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Data.Typeable (Typeable) +import qualified Network.Protocol.SASL.GNU as SASL + +import qualified Network.Protocol.XMPP.Monad as M +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID, formatJID, jidResource) + +data Result = Success | Failure + deriving (Show, Eq) + +data AuthException = XmppError M.Error | SaslError TL.Text + deriving (Typeable, Show) + +instance Exc.Exception AuthException + +authenticate :: [B.ByteString] -- ^ Mechanisms + -> JID -- ^ User JID + -> JID -- ^ Server JID + -> TL.Text -- ^ Username + -> TL.Text -- ^ Password + -> M.XMPP () +authenticate xmppMechanisms userJID serverJID username password = xmpp where + mechanisms = map SASL.Mechanism xmppMechanisms + authz = formatJID $ userJID { jidResource = Nothing } + hostname = formatJID serverJID + utf8 = TE.encodeUtf8 . T.concat . TL.toChunks + + xmpp = do + ctx <- M.getSession + res <- liftIO $ Exc.try $ SASL.runSASL $ do + suggested <- SASL.clientSuggestMechanism mechanisms + case suggested of + Nothing -> saslError "No supported authentication mechanism" + Just mechanism -> authSasl ctx mechanism + case res of + Right Success -> return () + Right Failure -> E.throwError M.AuthenticationFailure + Left (XmppError err) -> E.throwError err + Left (SaslError err) -> E.throwError $ M.AuthenticationError err + + authSasl ctx mechanism = do + let (SASL.Mechanism mechBytes) = mechanism + sessionResult <- SASL.runClient mechanism $ do + SASL.setProperty SASL.PropertyAuthzID $ utf8 authz + SASL.setProperty SASL.PropertyAuthID $ utf8 username + SASL.setProperty SASL.PropertyPassword $ utf8 password + SASL.setProperty SASL.PropertyService $ B.pack "xmpp" + SASL.setProperty SASL.PropertyHostname $ utf8 hostname + + (b64text, rc) <- SASL.step64 $ B.pack "" + putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth" + [("mechanism", TL.pack $ B.unpack mechBytes)] + [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text] + + case rc of + SASL.Complete -> saslFinish ctx + SASL.NeedsMore -> saslLoop ctx + + case sessionResult of + Right x -> return x + Left err -> saslError $ TL.pack $ show err + +saslLoop :: M.Session -> SASL.Session Result +saslLoop ctx = do + elemt <- getElement ctx + let name = X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing + let getChallengeText = + X.isNamed name + >=> X.elementNodes + >=> X.isContent + >=> return . X.contentText + let challengeText = getChallengeText elemt + when (null challengeText) $ saslError "Received empty challenge" + + (b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText + putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "response" + [] [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text] + case rc of + SASL.Complete -> saslFinish ctx + SASL.NeedsMore -> saslLoop ctx + +saslFinish :: M.Session -> SASL.Session Result +saslFinish ctx = do + elemt <- getElement ctx + let name = X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing + let success = X.isNamed name elemt + return $ if null success then Failure else Success + +putElement :: M.Session -> X.Element -> SASL.Session () +putElement ctx elemt = liftIO $ do + res <- M.runXMPP ctx $ M.putElement elemt + case res of + Left err -> Exc.throwIO $ XmppError err + Right x -> return x + +getElement :: M.Session -> SASL.Session X.Element +getElement ctx = liftIO $ do + res <- M.runXMPP ctx M.getElement + case res of + Left err -> Exc.throwIO $ XmppError err + Right x -> return x + +saslError :: MonadIO m => TL.Text -> m a +saslError = liftIO . Exc.throwIO . SaslError diff --git a/Network/Protocol/XMPP/Client/Features.hs b/Network/Protocol/XMPP/Client/Features.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/Client/Features.hs @@ -0,0 +1,68 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.Client.Features + ( Feature (..) + , parseFeatures + , parseFeature + ) where +import Control.Arrow ((&&&)) +import qualified Data.ByteString.Char8 as B +import qualified Data.Text.Lazy as TL +import qualified Network.Protocol.XMPP.XML as X + +data Feature = + FeatureStartTLS Bool + | FeatureSASL [B.ByteString] + | FeatureRegister + | FeatureBind + | FeatureSession + | FeatureUnknown X.Element + deriving (Show, Eq) + +parseFeatures :: X.Element -> [Feature] +parseFeatures e = + X.isNamed nameFeatures e + >>= X.elementChildren + >>= return . parseFeature + +parseFeature :: X.Element -> Feature +parseFeature elemt = feature where + unpackName = (maybe "" id . X.nameNamespace) &&& 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 -- TODO: detect whether or not required + +parseFeatureSASL :: X.Element -> Feature +parseFeatureSASL e = FeatureSASL $ + X.elementChildren e + >>= X.isNamed nameMechanism + >>= X.elementNodes + >>= X.isContent + >>= return . B.pack . TL.unpack . X.contentText + +nameMechanism :: X.Name +nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing + +nameFeatures :: X.Name +nameFeatures = X.Name "features" (Just "http://etherx.jabber.org/streams") Nothing diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs --- a/Network/Protocol/XMPP/Component.hs +++ b/Network/Protocol/XMPP/Component.hs @@ -1,77 +1,88 @@ -{- Copyright (C) 2010 Stephan Maka - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - +-- Copyright (C) 2010 Stephan Maka +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . -module Network.Protocol.XMPP.Component ( - ConnectedComponent - ,Component - ,componentConnect - ,componentAuthenticate - ,componentJID +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.Component + ( runComponent ) where - import Control.Monad (when) -import Network (HostName, PortID, connectTo) -import Text.XML.HXT.Arrow ((>>>)) -import qualified Text.XML.HXT.Arrow as A -import Text.XML.HXT.DOM.TypeDefs (XmlTree) -import qualified Text.XML.HXT.DOM.XmlNode as XN -import qualified Data.Digest.Pure.SHA as SHA - -import Network.Protocol.XMPP.JID (JID, jidParse, jidResource) -import qualified Network.Protocol.XMPP.SASL as SASL -import qualified Network.Protocol.XMPP.Stream as S -import Network.Protocol.XMPP.Util (mkElement, mkQName) -import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree) -import Network.Protocol.XMPP.Connection -import qualified Data.ByteString.Lazy.Char8 as B (pack) - -data ConnectedComponent = ConnectedComponent JID S.Stream - -data Component = Component { - componentJID :: JID - ,componentStream :: S.Stream - } - -type Password = String +import Control.Monad.Error (throwError) +import Data.Bits (shiftR, (.&.)) +import Data.Char (intToDigit) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as TE +import Network (connectTo) +import Network.Protocol.SASL.GNU (sha1) +import qualified System.IO as IO +import qualified Text.XML.LibXML.SAX as SAX -componentConnect :: JID -> HostName -> PortID -> IO ConnectedComponent -componentConnect jid host port = do - handle <- connectTo host port - stream <- S.beginStream jid "jabber:component:accept" handle - return $ ConnectedComponent jid stream +import qualified Network.Protocol.XMPP.Connections as C +import qualified Network.Protocol.XMPP.Handle as H +import qualified Network.Protocol.XMPP.Monad as M +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID) -componentAuthenticate :: ConnectedComponent -> Password -> IO Component -componentAuthenticate (ConnectedComponent jid stream) password - = do let c = Component jid stream +runComponent :: C.Server + -> T.Text -- ^ Server secret + -> M.XMPP a + -> IO (Either M.Error a) +runComponent server password xmpp = do + let C.Server jid host port = server + rawHandle <- connectTo host port + IO.hSetBuffering rawHandle IO.NoBuffering + let handle = H.PlainHandle rawHandle + M.startXMPP handle "jabber:component:accept" $ do + streamID <- beginStream jid + authenticate streamID password + xmpp - let S.XMPPStreamID sid = S.streamID stream - hash = SHA.showDigest . SHA.sha1 . B.pack $ sid ++ password - putTree c $ mkElement ("", "handshake") [] [XN.mkText hash] +beginStream :: JID -> M.XMPP T.Text +beginStream jid = do + M.putBytes $ C.xmlHeader "jabber:component:accept" jid + events <- M.readEvents C.startOfStream + case parseStreamID $ last events of + Nothing -> throwError M.NoComponentStreamID + Just x -> return x - result <- getTree c - when (A.runLA (A.getChildren - >>> A.hasQName (mkQName "jabber:component:accept" "handshake") - ) result == []) $ - error "Component handshake failed" +parseStreamID :: SAX.Event -> Maybe T.Text +parseStreamID (SAX.BeginElement _ attrs) = sid where + sid = case idAttrs of + (x:_) -> Just . X.attributeText $ x + _ -> Nothing + idAttrs = filter (matchingName . X.attributeName) attrs + matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing) +parseStreamID _ = Nothing - return c +authenticate :: T.Text -> T.Text -> M.XMPP () +authenticate streamID password = do + let bytes = buildSecret streamID password + let digest = showDigest $ sha1 bytes + M.putElement $ X.element "handshake" [] [X.NodeContent $ X.ContentText digest] + result <- M.getElement + let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing + when (null (X.isNamed nameHandshake result)) $ + throwError M.AuthenticationFailure -------------------------------------------------------------------------------- +buildSecret :: T.Text -> T.Text -> B.ByteString +buildSecret sid password = B.concat . BL.toChunks $ bytes where + bytes = TE.encodeUtf8 $ X.escape $ T.append sid password -instance Connection Component where - getTree = S.getTree . componentStream - putTree = S.putTree . componentStream +showDigest :: B.ByteString -> T.Text +showDigest = T.pack . concatMap wordToHex . B.unpack where + wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF] + hexDig = intToDigit . fromIntegral diff --git a/Network/Protocol/XMPP/Connection.hs b/Network/Protocol/XMPP/Connection.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Connection.hs +++ /dev/null @@ -1,38 +0,0 @@ -{- Copyright (C) 2010 John Millikin - Stephan Maka - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -module Network.Protocol.XMPP.Connection - ( Connection - , getTree - , putTree - , putStanza - ) where - -import Text.XML.HXT.DOM.TypeDefs (XmlTree) -import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree) - --- |Provides the basic operations for XMPP connections. -class Connection c where - -- |Receive XML - getTree :: c -> IO XmlTree - - -- |Send XML - putTree :: c -> XmlTree -> IO () - - -- |Send a stanza, uses putTree by default - putStanza :: c -> Stanza -> IO () - putStanza c = putTree c . stanzaToTree diff --git a/Network/Protocol/XMPP/Connections.hs b/Network/Protocol/XMPP/Connections.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/Connections.hs @@ -0,0 +1,58 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.Connections + ( Server (..) + , xmlHeader + , startOfStream + , qnameStream + ) where +import Network (HostName, PortID) +import qualified Data.ByteString.Lazy as B +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Text.XML.LibXML.SAX as SAX + +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID, formatJID) + +data Server = Server + { serverJID :: JID + , serverHostname :: HostName + , serverPort :: PortID + } + +-- Since only the opening tag should be written, normal XML +-- serialization cannot be used. Be careful to escape any embedded +-- attributes. +xmlHeader :: T.Text -> JID -> B.ByteString +xmlHeader ns jid = encodeUtf8 header where + attr x = T.concat ["\"", X.escape x, "\""] + header = T.concat + [ "\n" + , "" + ] + +startOfStream :: Integer -> SAX.Event -> Bool +startOfStream depth event = case (depth, event) of + (1, (SAX.BeginElement elemName _)) -> qnameStream == elemName + _ -> False + +qnameStream :: X.Name +qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing diff --git a/Network/Protocol/XMPP/ErrorT.hs b/Network/Protocol/XMPP/ErrorT.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/ErrorT.hs @@ -0,0 +1,72 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE TypeFamilies #-} +module Network.Protocol.XMPP.ErrorT + ( ErrorT (..) + , mapErrorT + ) where + +import Control.Monad (liftM) +import Control.Monad.Fix (MonadFix, mfix) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad.Trans.Class (MonadTrans, lift) +import qualified Control.Monad.Error as E +import qualified Control.Monad.Reader as R + +-- A custom version of ErrorT, without the 'Error' class restriction. + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +instance Functor m => Functor (ErrorT e m) where + fmap f = ErrorT . fmap (fmap f) . runErrorT + +instance Monad m => Monad (ErrorT e m) where + return = ErrorT . return . Right + (>>=) m k = ErrorT $ do + x <- runErrorT m + case x of + Left l -> return $ Left l + Right r -> runErrorT $ k r + +instance Monad m => E.MonadError (ErrorT e m) where + type E.ErrorType (ErrorT e m) = e + throwError = ErrorT . return . Left + catchError m h = ErrorT $ do + x <- runErrorT m + case x of + Left l -> runErrorT $ h l + Right r -> return $ Right r + +instance MonadTrans (ErrorT e) where + lift = ErrorT . liftM Right + +instance R.MonadReader m => R.MonadReader (ErrorT e m) where + type R.EnvType (ErrorT e m) = R.EnvType m + ask = lift R.ask + local = mapErrorT . R.local + +instance MonadIO m => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +instance MonadFix m => MonadFix (ErrorT e m) where + mfix f = ErrorT $ mfix $ \ex -> runErrorT $ f $ case ex of + Right x -> x + _ -> error "empty mfix parameter" + +mapErrorT :: (m (Either e a) -> n (Either e' b)) + -> ErrorT e m a + -> ErrorT e' n b +mapErrorT f m = ErrorT $ f (runErrorT m) diff --git a/Network/Protocol/XMPP/Handle.hs b/Network/Protocol/XMPP/Handle.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/Handle.hs @@ -0,0 +1,67 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.Handle + ( Handle (..) + , startTLS + , hPutBytes + , hGetBytes + ) where + +import Control.Monad (when) +import qualified Control.Monad.Error as E +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString.Lazy as B +import qualified Data.Text.Lazy as T +import qualified System.IO as IO +import qualified Network.Protocol.TLS.GNU as TLS +import Network.Protocol.XMPP.ErrorT + +data Handle = + PlainHandle IO.Handle + | SecureHandle IO.Handle TLS.Session + +liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT T.Text IO a +liftTLS s = liftTLS' . TLS.runTLS s + +liftTLS' :: IO (Either TLS.Error a) -> ErrorT T.Text IO a +liftTLS' io = do + eitherX <- liftIO io + case eitherX of + Left err -> E.throwError $ T.pack $ show err + Right x -> return x + +startTLS :: Handle -> ErrorT T.Text IO Handle +startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle" +startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do + TLS.setPriority [TLS.X509] + TLS.setCredentials =<< TLS.certificateCredentials + TLS.handshake + SecureHandle h `fmap` TLS.getSession + +hPutBytes :: Handle -> B.ByteString -> ErrorT T.Text IO () +hPutBytes (PlainHandle h) = liftIO . B.hPut h +hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes + +hGetBytes :: Handle -> Integer -> ErrorT T.Text IO B.ByteString +hGetBytes (PlainHandle h) n = liftIO $ B.hGet h $ fromInteger n +hGetBytes (SecureHandle h s) n = liftTLS s $ do + pending <- TLS.checkPending + when (pending == 0) $ do + liftIO $ IO.hWaitForInput h (- 1) + return () + + TLS.getBytes n diff --git a/Network/Protocol/XMPP/JID.hs b/Network/Protocol/XMPP/JID.hs --- a/Network/Protocol/XMPP/JID.hs +++ b/Network/Protocol/XMPP/JID.hs @@ -1,111 +1,106 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . -module Network.Protocol.XMPP.JID ( - JID(..) - ,JIDNode - ,JIDDomain - ,JIDResource - - ,jidNodeStr - ,jidDomainStr - ,jidResourceStr - - ,mkJIDNode - ,mkJIDDomain - ,mkJIDResource - ,mkJID - - ,jidNode - ,jidDomain - ,jidResource +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.JID + ( JID (..) + , Node (..) + , Domain (..) + , Resource (..) - ,jidParse - ,jidFormat + , parseJID + , parseJID_ + , formatJID ) where - -data JID = JID (Maybe JIDNode) JIDDomain (Maybe JIDResource) - deriving (Eq, Show) - -newtype JIDNode = JIDNode String - deriving (Eq, Show) - -newtype JIDDomain = JIDDomain String - deriving (Eq, Show) - -newtype JIDResource = JIDResource String - deriving (Eq, Show) +import qualified Data.Text.Lazy as T +import qualified Data.Text.IDN.StringPrep as SP +import Data.String (IsString, fromString) -jidNodeStr :: JIDNode -> String -jidNodeStr (JIDNode s) = s +newtype Node = Node { strNode :: T.Text } +newtype Domain = Domain { strDomain :: T.Text } +newtype Resource = Resource { strResource :: T.Text } -jidDomainStr :: JIDDomain -> String -jidDomainStr (JIDDomain s) = s +instance Show Node where + showsPrec d (Node x) = showParen (d > 10) $ + showString "Node " . shows x -jidResourceStr :: JIDResource -> String -jidResourceStr (JIDResource s) = s +instance Show Domain where + showsPrec d (Domain x) = showParen (d > 10) $ + showString "Domain " . shows x -mkJIDNode :: String -> Maybe JIDNode -mkJIDNode "" = Nothing -mkJIDNode s = Just (JIDNode s) -- TODO: stringprep, validation +instance Show Resource where + showsPrec d (Resource x) = showParen (d > 10) $ + showString "Resource " . shows x -mkJIDDomain :: String -> Maybe JIDDomain -mkJIDDomain "" = Nothing -mkJIDDomain s = Just (JIDDomain s) -- TODO: stringprep, validation +instance Eq Node where + (==) = equaling strNode -mkJIDResource :: String -> Maybe JIDResource -mkJIDResource "" = Nothing -mkJIDResource s = Just (JIDResource s) -- TODO: stringprep, validation +instance Eq Domain where + (==) = equaling strDomain -mkJID :: String -> String -> String -> Maybe JID -mkJID nodeStr domainStr resourceStr = let - node = mkJIDNode nodeStr - resource = mkJIDResource resourceStr - in do - domain <- mkJIDDomain domainStr - Just (JID node domain resource) +instance Eq Resource where + (==) = equaling strResource -jidNode :: JID -> String -jidNode (JID x _ _) = maybe "" jidNodeStr x +data JID = JID + { jidNode :: Maybe Node + , jidDomain :: Domain + , jidResource :: Maybe Resource + } + deriving (Eq) -jidDomain :: JID -> String -jidDomain (JID _ x _) = jidDomainStr x +instance Show JID where + showsPrec d jid = showParen (d > 10) $ + showString "JID " . shows (formatJID jid) -jidResource :: JID -> String -jidResource (JID _ _ x) = maybe "" jidResourceStr x +instance IsString JID where + fromString = parseJID_ . fromString --- TODO: validate input according to RFC 3920, section 3.1 -jidParse :: String -> Maybe JID -jidParse s = let - (nodeStr, postNode) = if '@' `elem` s then split s '@' else ("", s) - (domainStr, resourceStr) = if '/' `elem` postNode then split postNode '/' else (postNode, "") - in mkJID nodeStr domainStr resourceStr +parseJID :: T.Text -> Maybe JID +parseJID str = maybeJID where + (node, postNode) = case T.spanBy (/= '@') str of + (x, y) -> if T.null y + then ("", x) + else (x, T.drop 1 y) + (domain, resource) = case T.spanBy (/= '/') postNode of + (x, y) -> if T.null y + then (x, "") + else (x, T.drop 1 y) + nullable x f = if T.null x then Just Nothing else fmap Just $ f x + maybeJID = do + preppedNode <- nullable node $ stringprepM SP.profileNodeprep + preppedDomain <- stringprepM SP.profileNameprep domain + preppedResource <- nullable resource $ stringprepM SP.profileResourceprep + return $ JID + (fmap Node preppedNode) + (Domain preppedDomain) + (fmap Resource preppedResource) + stringprepM p x = case SP.stringprep p SP.defaultFlags x of + Left _ -> Nothing + Right y -> Just y -jidFormat :: JID -> String -jidFormat (JID node (JIDDomain domain) resource) = let - nodeStr = maybe "" (\(JIDNode s) -> s ++ "@") node - resourceStr = maybe "" (\(JIDResource s) -> "/" ++ s) resource - in concat [nodeStr, domain, resourceStr] +parseJID_ :: T.Text -> JID +parseJID_ text = case parseJID text of + Just jid -> jid + Nothing -> error "Malformed JID" -split :: (Eq a) => [a] -> a -> ([a], [a]) -split xs final = let - (before, rawAfter) = span (/= final) xs - after = safeTail rawAfter - in (before, after) +formatJID :: JID -> T.Text +formatJID (JID node (Domain domain) resource) = formatted where + formatted = T.concat [node', domain, resource'] + node' = maybe "" (\(Node x) -> T.append x "@") node + resource' = maybe "" (\(Resource x) -> T.append "/" x) resource -safeTail :: [a] -> [a] -safeTail [] = [] -safeTail (_:xs) = xs +-- Similar to 'comparing' +equaling :: Eq a => (b -> a) -> b -> b -> Bool +equaling f x y = f x == f y diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/Monad.hs @@ -0,0 +1,178 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.Monad + ( XMPP (..) + , Error (..) + , Session (..) + , runXMPP + , startXMPP + , restartXMPP + + , getHandle + , getSession + + , readEvents + , getElement + , getStanza + + , putBytes + , putElement + , putStanza + ) where +import qualified Control.Applicative as A +import Control.Monad (ap) +import Control.Monad.Fix (MonadFix, mfix) +import Control.Monad.Trans (MonadIO, liftIO) +import qualified Control.Monad.Error as E +import qualified Control.Monad.Reader as R +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.FailableList as FL +import qualified Text.XML.LibXML.SAX as SAX + +import Network.Protocol.XMPP.ErrorT +import qualified Network.Protocol.XMPP.Handle as H +import qualified Network.Protocol.XMPP.Stanza as S +import qualified Network.Protocol.XMPP.XML as X + +data Error + -- | The remote host refused the specified authentication credentials. + = AuthenticationFailure + + -- | There was an error while authenticating with the remote host. + | AuthenticationError Text + + -- | An unrecognized or malformed 'S.Stanza' was received from the remote + -- host. + | InvalidStanza X.Element + + -- | The remote host sent an invalid reply to a resource bind request. + | InvalidBindResult S.ReceivedStanza + + -- | There was an error with the underlying transport. + | TransportError Text + + -- | The remote host did not send a stream ID when accepting a component + -- connection. + | NoComponentStreamID + deriving (Show) + +data Session = Session H.Handle Text SAX.Parser + +newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Session IO) a } + +instance Functor XMPP where + fmap f = XMPP . fmap f . unXMPP + +instance Monad XMPP where + return = XMPP . return + m >>= f = XMPP $ unXMPP m >>= unXMPP . f + +instance MonadIO XMPP where + liftIO = XMPP . liftIO + +instance E.MonadError XMPP where + type E.ErrorType XMPP = Error + throwError = XMPP . E.throwError + catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h) + +instance A.Applicative XMPP where + pure = return + (<*>) = ap + +instance MonadFix XMPP where + mfix f = XMPP $ mfix $ unXMPP . f + +runXMPP :: Session -> XMPP a -> IO (Either Error a) +runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s + +startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a) +startXMPP h ns xmpp = do + sax <- SAX.newParser + runXMPP (Session h ns sax) xmpp + +restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a +restartXMPP newH xmpp = do + Session oldH ns _ <- getSession + sax <- liftIO SAX.newParser + let s = Session (maybe oldH id newH) ns sax + XMPP $ R.local (const s) (unXMPP xmpp) + +getSession :: XMPP Session +getSession = XMPP R.ask + +getHandle :: XMPP H.Handle +getHandle = do + Session h _ _ <- getSession + return h + +liftTLS :: ErrorT Text IO a -> XMPP a +liftTLS io = do + res <- liftIO $ runErrorT io + case res of + Left err -> E.throwError $ TransportError err + Right x -> return x + +putBytes :: B.ByteString -> XMPP () +putBytes bytes = do + h <- getHandle + liftTLS $ H.hPutBytes h bytes + +putElement :: X.Element -> XMPP () +putElement = putBytes . encodeUtf8 . X.serialiseElement + +putStanza :: S.Stanza a => a -> XMPP () +putStanza = putElement . S.stanzaToElement + +readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event] +readEvents done = xmpp where + xmpp = do + Session h _ p <- getSession + let nextEvents = do + -- TODO: read in larger increments + bytes <- liftTLS $ H.hGetBytes h 1 + failable <- liftIO $ SAX.parse p bytes False + failableToList failable + X.readEvents done nextEvents + + failableToList f = case f of + FL.Fail (SAX.Error e) -> E.throwError $ TransportError e + FL.Done -> return [] + FL.Next e es -> do + es' <- failableToList es + return $ e : es' + +getElement :: XMPP X.Element +getElement = xmpp where + xmpp = do + events <- readEvents endOfTree + case X.eventsToElement events of + Just x -> return x + Nothing -> E.throwError $ TransportError "getElement: invalid event list" + + endOfTree 0 (SAX.EndElement _) = True + endOfTree _ _ = False + +getStanza :: XMPP S.ReceivedStanza +getStanza = do + elemt <- getElement + Session _ ns _ <- getSession + case S.elementToStanza ns elemt of + Just x -> return x + Nothing -> E.throwError $ InvalidStanza elemt diff --git a/Network/Protocol/XMPP/SASL.hs b/Network/Protocol/XMPP/SASL.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/SASL.hs +++ /dev/null @@ -1,101 +0,0 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -module Network.Protocol.XMPP.SASL ( - Result(..) - ,authenticate - ) where - -import Text.XML.HXT.Arrow ((>>>)) -import qualified Text.XML.HXT.Arrow as A -import qualified Text.XML.HXT.DOM.XmlNode as XN -import qualified Network.Protocol.SASL.GSASL as G - -import Network.Protocol.XMPP.JID (JID, jidFormat) -import Network.Protocol.XMPP.Util (mkElement, mkQName) -import qualified Network.Protocol.XMPP.Stream as S - -type Username = String -type Password = String -type Mechanism = String - -data Result = Success | Failure - deriving (Show, Eq) - -authenticate :: S.Stream -> JID -> JID -> Username -> Password -> IO Result -authenticate stream userJID serverJID username password = do - let mechanisms = (advertisedMechanisms . S.streamFeatures) stream - let authz = jidFormat userJID - let hostname = jidFormat serverJID - - G.withContext $ \ctxt -> do - - suggested <- G.clientSuggestMechanism ctxt mechanisms - mechanism <- case suggested of - Just m -> return m - Nothing -> error "No supported SASL mechanisms advertised" - - G.withSession (G.clientStart ctxt mechanism) $ \s -> do - - G.propertySet s G.GSASL_AUTHZID authz - G.propertySet s G.GSASL_AUTHID username - G.propertySet s G.GSASL_PASSWORD password - G.propertySet s G.GSASL_SERVICE "xmpp" - G.propertySet s G.GSASL_HOSTNAME hostname - - (b64text, rc) <- G.step64 s "" - S.putTree stream $ mkElement ("", "auth") - [ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl") - ,("", "mechanism", mechanism)] - [XN.mkText b64text] - - case rc of - G.GSASL_OK -> saslFinish stream - G.GSASL_NEEDS_MORE -> saslLoop stream s - -saslLoop :: S.Stream -> G.Session -> IO Result -saslLoop stream session = do - challengeText <- A.runX ( - A.arrIO (\_ -> S.getTree stream) - >>> A.getChildren - >>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "challenge") - >>> A.getChildren >>> A.getText) - - if null challengeText then return Failure - else do - (b64text, rc) <- G.step64 session (concat challengeText) - S.putTree stream $ mkElement ("", "response") - [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")] - [XN.mkText b64text] - case rc of - G.GSASL_OK -> saslFinish stream - G.GSASL_NEEDS_MORE -> saslLoop stream session - -saslFinish :: S.Stream -> IO Result -saslFinish stream = do - successElem <- A.runX ( - A.arrIO (\_ -> S.getTree stream) - >>> A.getChildren - >>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "success")) - - return $ if null successElem then Failure else Success - -advertisedMechanisms :: [S.StreamFeature] -> [Mechanism] -advertisedMechanisms [] = [] -advertisedMechanisms (f:fs) = case f of - (S.FeatureSASL ms) -> ms - _ -> advertisedMechanisms fs - diff --git a/Network/Protocol/XMPP/Stanza.hs b/Network/Protocol/XMPP/Stanza.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/Stanza.hs @@ -0,0 +1,274 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.Stanza + ( Stanza (..) + + , ReceivedStanza (..) + , Message (..) + , Presence (..) + , IQ (..) + , MessageType (..) + , PresenceType (..) + , IQType (..) + + , emptyMessage + , emptyPresence + , emptyIQ + + , elementToStanza + ) where + +import Control.Monad (when) +import qualified Data.Text.Lazy as T +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID, parseJID, formatJID) + +class Stanza a where + stanzaTo :: a -> Maybe JID + stanzaFrom :: a -> Maybe JID + stanzaID :: a -> Maybe T.Text + stanzaLang :: a -> Maybe T.Text + stanzaPayloads :: a -> [X.Element] + stanzaToElement :: a -> X.Element + +data ReceivedStanza + = ReceivedMessage Message + | ReceivedPresence Presence + | ReceivedIQ IQ + deriving (Show) + +data Message = Message + { messageType :: MessageType + , messageTo :: Maybe JID + , messageFrom :: Maybe JID + , messageID :: Maybe T.Text + , messageLang :: Maybe T.Text + , messagePayloads :: [X.Element] + } + deriving (Show) + +instance Stanza Message where + stanzaTo = messageTo + stanzaFrom = messageFrom + stanzaID = messageID + stanzaLang = messageLang + stanzaPayloads = messagePayloads + stanzaToElement x = stanzaToElement' x "message" typeStr where + typeStr = case messageType x of + MessageNormal -> "normal" + MessageChat -> "chat" + MessageGroupChat -> "groupchat" + MessageHeadline -> "headline" + MessageError -> "error" + +data MessageType + = MessageNormal + | MessageChat + | MessageGroupChat + | MessageHeadline + | MessageError + deriving (Show, Eq) + +emptyMessage :: MessageType -> Message +emptyMessage t = Message + { messageType = t + , messageTo = Nothing + , messageFrom = Nothing + , messageID = Nothing + , messageLang = Nothing + , messagePayloads = [] + } + +data Presence = Presence + { presenceType :: PresenceType + , presenceTo :: Maybe JID + , presenceFrom :: Maybe JID + , presenceID :: Maybe T.Text + , presenceLang :: Maybe T.Text + , presencePayloads :: [X.Element] + } + deriving (Show) + +instance Stanza Presence where + stanzaTo = presenceTo + stanzaFrom = presenceFrom + stanzaID = presenceID + stanzaLang = presenceLang + stanzaPayloads = presencePayloads + stanzaToElement x = stanzaToElement' x "presence" typeStr where + typeStr = case presenceType x of + PresenceAvailable -> "" + PresenceUnavailable -> "unavailable" + PresenceSubscribe -> "subscribe" + PresenceSubscribed -> "subscribed" + PresenceUnsubscribe -> "unsubscribe" + PresenceUnsubscribed -> "unsubscribed" + PresenceProbe -> "probe" + PresenceError -> "error" + +data PresenceType + = PresenceAvailable + | PresenceUnavailable + | PresenceSubscribe + | PresenceSubscribed + | PresenceUnsubscribe + | PresenceUnsubscribed + | PresenceProbe + | PresenceError + deriving (Show, Eq) + +emptyPresence :: PresenceType -> Presence +emptyPresence t = Presence + { presenceType = t + , presenceTo = Nothing + , presenceFrom = Nothing + , presenceID = Nothing + , presenceLang = Nothing + , presencePayloads = [] + } + +data IQ = IQ + { iqType :: IQType + , iqTo :: Maybe JID + , iqFrom :: Maybe JID + , iqID :: Maybe T.Text + , iqLang :: Maybe T.Text + , iqPayload :: Maybe X.Element + } + deriving (Show) + +instance Stanza IQ where + stanzaTo = iqTo + stanzaFrom = iqFrom + stanzaID = iqID + stanzaLang = iqLang + stanzaPayloads iq = case iqPayload iq of + Just elemt -> [elemt] + Nothing -> [] + stanzaToElement x = stanzaToElement' x "iq" typeStr where + typeStr = case iqType x of + IQGet -> "get" + IQSet -> "set" + IQResult -> "result" + IQError -> "error" + +data IQType + = IQGet + | IQSet + | IQResult + | IQError + deriving (Show, Eq) + +emptyIQ :: IQType -> IQ +emptyIQ t = IQ + { iqType = t + , iqTo = Nothing + , iqFrom = Nothing + , iqID = Nothing + , iqLang = Nothing + , iqPayload = Nothing + } + +stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element +stanzaToElement' stanza name typeStr = X.element name attrs payloads where + payloads = map X.NodeElement $ stanzaPayloads stanza + attrs = concat + [ mattr "to" $ fmap formatJID . stanzaTo + , mattr "from" $ fmap formatJID . stanzaFrom + , mattr "id" stanzaID + , mattr "xml:lang" stanzaLang + , if T.null typeStr then [] else [("type", typeStr)] + ] + mattr label f = case f stanza of + Nothing -> [] + Just text -> [(label, text)] + +elementToStanza :: T.Text -> X.Element -> Maybe ReceivedStanza +elementToStanza ns elemt = do + let elemNS = X.nameNamespace . X.elementName $ elemt + when (elemNS /= Just ns) Nothing + + let elemName = X.nameLocalName . X.elementName $ elemt + case elemName of + "message" -> ReceivedMessage `fmap` parseMessage elemt + "presence" -> ReceivedPresence `fmap` parsePresence elemt + "iq" -> ReceivedIQ `fmap` parseIQ elemt + _ -> Nothing + +parseMessage :: X.Element -> Maybe Message +parseMessage elemt = do + typeStr <- X.getattr (X.name "type") elemt + msgType <- case typeStr of + "normal" -> Just MessageNormal + "chat" -> Just MessageChat + "groupchat" -> Just MessageGroupChat + "headline" -> Just MessageHeadline + "error" -> Just MessageError + _ -> Nothing + msgTo <- xmlJID "to" elemt + msgFrom <- xmlJID "from" elemt + let msgID = X.getattr (X.name "id") elemt + let msgLang = X.getattr (X.name "lang") elemt + let payloads = X.elementChildren elemt + return $ Message msgType msgTo msgFrom msgID msgLang payloads + +parsePresence :: X.Element -> Maybe Presence +parsePresence elemt = do + let typeStr = maybe "" id $ X.getattr (X.name "type") elemt + pType <- case typeStr of + "" -> Just PresenceAvailable + "unavailable" -> Just PresenceUnavailable + "subscribe" -> Just PresenceSubscribe + "subscribed" -> Just PresenceSubscribed + "unsubscribe" -> Just PresenceUnsubscribe + "unsubscribed" -> Just PresenceUnsubscribed + "probe" -> Just PresenceProbe + "error" -> Just PresenceError + _ -> Nothing + + msgTo <- xmlJID "to" elemt + msgFrom <- xmlJID "from" elemt + let msgID = X.getattr (X.name "id") elemt + let msgLang = X.getattr (X.name "lang") elemt + let payloads = X.elementChildren elemt + return $ Presence pType msgTo msgFrom msgID msgLang payloads + +parseIQ :: X.Element -> Maybe IQ +parseIQ elemt = do + typeStr <- X.getattr (X.name "type") elemt + iqType <- case typeStr of + "get" -> Just IQGet + "set" -> Just IQSet + "result" -> Just IQResult + "error" -> Just IQError + _ -> Nothing + + msgTo <- xmlJID "to" elemt + msgFrom <- xmlJID "from" elemt + let msgID = X.getattr (X.name "id") elemt + let msgLang = X.getattr (X.name "lang") elemt + let payload = case X.elementChildren elemt of + [] -> Nothing + child:_ -> Just child + return $ IQ iqType msgTo msgFrom msgID msgLang payload + +xmlJID :: T.Text -> X.Element -> Maybe (Maybe JID) +xmlJID name elemt = case X.getattr (X.name name) elemt of + Nothing -> Just Nothing + Just raw -> case parseJID raw of + Just jid -> Just (Just jid) + Nothing -> Nothing diff --git a/Network/Protocol/XMPP/Stanzas.hs b/Network/Protocol/XMPP/Stanzas.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Stanzas.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -module Network.Protocol.XMPP.Stanzas ( - StanzaType(..) - ,Stanza(..) - ,treeToStanza - ,stanzaToTree - ) where - -import Text.XML.HXT.DOM.Interface (XmlTree) -import Text.XML.HXT.Arrow ((>>>), (&&&)) -import qualified Text.XML.HXT.Arrow as A - -import Network.Protocol.XMPP.JID (JID, jidFormat, jidParse) -import Network.Protocol.XMPP.Util (mkElement, mkQName) -import qualified Text.XML.HXT.DOM.XmlNode as XN - -data StanzaType = - MessageNormal - | MessageChat - | MessageGroupChat - | MessageHeadline - | MessageError - - | PresenceUnavailable - | PresenceSubscribe - | PresenceSubscribed - | PresenceUnsubscribe - | PresenceUnsubscribed - | PresenceProbe - | PresenceError - - | IQGet - | IQSet - | IQResult - | IQError - deriving (Show, Eq) - -data Stanza = Stanza - { - stanzaType :: StanzaType - ,stanzaTo :: Maybe JID - ,stanzaFrom :: Maybe JID - ,stanzaID :: String - ,stanzaLang :: String - ,stanzaPayloads :: [XmlTree] - } - deriving (Show, Eq) - -stanzaTypeMap :: [((String, String, String), StanzaType)] -stanzaTypeMap = mkStanzaTypeMap $ [ - ("jabber:client", "message", [ - ("normal", MessageNormal) - ,("chat", MessageChat) - ,("groupchat", MessageGroupChat) - ,("headline", MessageHeadline) - ,("error", MessageError) - ]) - ,("jabber:client", "presence", [ - ("unavailable", PresenceUnavailable) - ,("subscribe", PresenceSubscribe) - ,("subscribed", PresenceSubscribed) - ,("unsubscribe", PresenceUnsubscribe) - ,("unsubscribed", PresenceUnsubscribed) - ,("probe", PresenceProbe) - ,("error", PresenceError) - ]) - ,("jabber:client", "iq", [ - ("get", IQGet) - ,("set", IQSet) - ,("result", IQResult) - ,("error", IQError) - ]) - ] - where mkStanzaTypeMap raw = do - (ns, elementName, typeStrings) <- raw - (typeString, type') <- typeStrings - return ((ns, elementName, typeString), type') - -stanzaTypeToStr :: StanzaType -> (String, String, String) -stanzaTypeToStr t = let - step [] = undefined - step ((ret, t'):tms) - | t == t' = ret - | otherwise = step tms - in step stanzaTypeMap - -stanzaTypeFromStr :: String -> String -> String -> Maybe StanzaType -stanzaTypeFromStr ns elementName typeString = let - key = (ns, elementName, typeString) - step [] = Nothing - step ((key', ret):tms) - | key == key' = Just ret - | otherwise = step tms - in step stanzaTypeMap - -treeToStanza :: XmlTree -> [Stanza] -treeToStanza t = do - to <- return . jidParse =<< A.runLA (A.getAttrValue "to") t - from <- return . jidParse =<< A.runLA (A.getAttrValue "from") t - id' <- A.runLA (A.getAttrValue "id") t - lang <- A.runLA (A.getAttrValue "lang") t - - ns <- A.runLA A.getNamespaceUri t - elementName <- A.runLA A.getLocalPart t - typeString <- A.runLA (A.getAttrValue "type") t - - let payloads = A.runLA (A.getChildren >>> A.isElem) t - - case stanzaTypeFromStr ns elementName typeString of - Nothing -> [] - Just type' -> [Stanza type' to from id' lang payloads] - -stanzaToTree :: Stanza -> XmlTree -stanzaToTree s = let - (ns, elementName, typeString) = stanzaTypeToStr (stanzaType s) - - attrs' = [ - autoAttr "to" (maybe "" jidFormat . stanzaTo) - ,autoAttr "from" (maybe "" jidFormat . stanzaFrom) - ,autoAttr "id" stanzaID - ,autoAttr "xml:lang" stanzaLang - ,\_ -> [("", "type", typeString)] - ] - attrs = concatMap ($ s) attrs' - in mkElement (ns, elementName) attrs (stanzaPayloads s) - -autoAttr :: String -> (Stanza -> String) -> Stanza -> [(String, String, String)] -autoAttr attr f stanza = case f stanza of - "" -> [] - text -> [("", attr, text)] diff --git a/Network/Protocol/XMPP/Stream.hs b/Network/Protocol/XMPP/Stream.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Stream.hs +++ /dev/null @@ -1,276 +0,0 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -module Network.Protocol.XMPP.Stream ( - Stream ( - streamLanguage - ,streamVersion - ,streamID - ,streamFeatures - ) - ,XMPPStreamID(XMPPStreamID) - ,StreamFeature ( - FeatureStartTLS - ,FeatureSASL - ,FeatureRegister - ,FeatureBind - ,FeatureSession - ) - ,beginStream - ,restartStream - ,getTree - ,putTree - ) where - -import qualified System.IO as IO -import Data.AssocList (lookupDef) -import Data.Char (toUpper) -import Control.Applicative - --- XML Parsing -import Text.XML.HXT.Arrow ((>>>)) -import qualified Text.XML.HXT.Arrow as A -import qualified Text.XML.HXT.DOM.Interface as DOM -import qualified Text.XML.HXT.DOM.XmlNode as XN -import qualified Text.XML.LibXML.SAX as SAX - --- TLS support -import qualified Network.GnuTLS as GnuTLS -import Foreign (allocaBytes) -import Foreign.C (peekCAStringLen) - -import Network.Protocol.XMPP.JID (JID, jidFormat) -import qualified Network.Protocol.XMPP.Util as Util - -maxXMPPVersion :: XMPPVersion -maxXMPPVersion = XMPPVersion 1 0 - -data Stream = Stream - { - streamHandle :: Handle - ,streamJID :: JID - ,streamNS :: String - ,streamParser :: SAX.Parser - ,streamLanguage :: XMLLanguage - ,streamVersion :: XMPPVersion - ,streamID :: XMPPStreamID - ,streamFeatures :: [StreamFeature] - } - -data StreamFeature = - FeatureStartTLS Bool - | FeatureSASL [String] - | FeatureRegister - | FeatureBind - | FeatureSession - | FeatureUnknown DOM.XmlTree - deriving (Show, Eq) - -newtype XMLLanguage = XMLLanguage String - deriving (Show, Eq) - -data XMPPVersion = XMPPVersion Int Int - deriving (Show, Eq) - -newtype XMPPStreamID = XMPPStreamID String - -data Handle = - PlainHandle IO.Handle - | SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client) - ------------------------------------------------------------------------------- - -restartStream :: Stream -> IO Stream -restartStream s = beginStream' (streamJID s) (streamNS s) (streamHandle s) - -beginStream :: JID -> String -> IO.Handle -> IO Stream -beginStream jid ns rawHandle = do - IO.hSetBuffering rawHandle IO.NoBuffering - - plainStream <- beginStream' jid ns (PlainHandle rawHandle) - - let startTLS = do - putTree plainStream $ Util.mkElement ("", "starttls") - [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] - [] - getTree plainStream - - session <- GnuTLS.tlsClient [ - GnuTLS.handle GnuTLS.:= rawHandle - ,GnuTLS.priorities GnuTLS.:= [GnuTLS.CrtX509] - ,GnuTLS.credentials GnuTLS.:= GnuTLS.certificateCredentials - ] - GnuTLS.handshake session - beginStream' jid ns (SecureHandle rawHandle session) - - case streamCanTLS plainStream of - True -> startTLS - False -> return plainStream - -beginStream' :: JID -> String -> Handle -> IO Stream -beginStream' jid ns h = do - -- Since only the opening tag should be written, normal XML - -- serialization cannot be used. Be careful to escape any embedded - -- attributes. - let xmlHeader = - "\n" ++ - "" - - parser <- SAX.mkParser - hPutStr h xmlHeader - initialEvents <- readEventsUntil startOfStream h parser - - let startStreamEvent = last initialEvents - let (language, version, streamID) = parseStartStream startStreamEvent - features <- (case ns of - "jabber:client" -> - parseFeatures <$> getTree' h parser - _ -> - return [] - ) - - return $ Stream h jid ns parser language version streamID features - - where - streamName = Util.mkQName "http://etherx.jabber.org/streams" "stream" - - startOfStream depth event = case (depth, event) of - (1, (SAX.BeginElement elemName _)) -> - streamName == Util.convertQName elemName - _ -> False - -parseStartStream :: SAX.Event -> (XMLLanguage, XMPPVersion, XMPPStreamID) -parseStartStream e = (XMLLanguage lang, XMPPVersion 1 0, XMPPStreamID id) - where SAX.BeginElement _ attrs = e - attr name = maybe "" SAX.attributeValue $ - m1 $ filter ((name ==) . SAX.qnameLocalName . SAX.attributeName) attrs - where m1 (x:_) = Just x - m1 _ = Nothing - lang = attr "lang" - id = attr "id" - -parseFeatures :: DOM.XmlTree -> [StreamFeature] -parseFeatures t = - A.runLA (A.getChildren - >>> A.hasQName featuresName - >>> A.getChildren - >>> A.arrL (\t' -> [parseFeature t'])) t - where - featuresName = Util.mkQName "http://etherx.jabber.org/streams" "features" - -parseFeature :: DOM.XmlTree -> StreamFeature -parseFeature t = lookupDef FeatureUnknown qname [ - (("urn:ietf:params:xml:ns:xmpp-tls", "starttls"), parseFeatureTLS) - ,(("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms"), parseFeatureSASL) - ,(("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)) - ] t - where - qname = maybe ("", "") (\n -> (DOM.namespaceUri n, DOM.localPart n)) (XN.getName t) - -parseFeatureTLS :: DOM.XmlTree -> StreamFeature -parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required - -parseFeatureSASL :: DOM.XmlTree -> StreamFeature -parseFeatureSASL t = let - mechName = Util.mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism" - mechanisms = A.runLA ( - A.getChildren - >>> A.hasQName mechName - >>> A.getChildren - >>> A.getText) t - - in FeatureSASL $ map (map toUpper) mechanisms - -streamCanTLS :: Stream -> Bool -streamCanTLS = (> 0) . length . - filter (\feature -> - case feature of - FeatureStartTLS _ -> True - _ -> False - ) . streamFeatures - -------------------------------------------------------------------------------- - -getTree :: Stream -> IO DOM.XmlTree -getTree s = getTree' (streamHandle s) (streamParser s) - -getTree' :: Handle -> SAX.Parser -> IO DOM.XmlTree -getTree' h p = do - events <- readEventsUntil finished h p - return $ Util.eventsToTree events - where - finished 0 (SAX.EndElement _) = True - finished _ _ = False - -putTree :: Stream -> DOM.XmlTree -> IO () -putTree s t = do - let root = XN.mkRoot [] [t] - let h = streamHandle s - [text] <- A.runX (A.constA root >>> A.writeDocumentToString [ - (A.a_no_xml_pi, "1") - ]) - hPutStr h text - -------------------------------------------------------------------------------- - -readEventsUntil :: (Int -> SAX.Event -> Bool) -> Handle -> SAX.Parser -> IO [SAX.Event] -readEventsUntil done h parser = readEventsUntil' done 0 [] $ do - char <- hGetChar h - SAX.parse parser [char] False - -readEventsUntil' :: (Int -> SAX.Event -> Bool) -> Int -> [SAX.Event] -> IO [SAX.Event] -> IO [SAX.Event] -readEventsUntil' done depth accum getEvents = do - events <- getEvents - let (done', depth', accum') = readEventsStep done events depth accum - if done' - then return accum' - else readEventsUntil' done depth' accum' getEvents - -readEventsStep :: (Int -> SAX.Event -> Bool) -> [SAX.Event] -> Int -> [SAX.Event] -> (Bool, Int, [SAX.Event]) -readEventsStep _ [] depth accum = (False, depth, accum) -readEventsStep done (e:es) depth accum = let - depth' = depth + case e of - (SAX.BeginElement _ _) -> 1 - (SAX.EndElement _) -> (- 1) - _ -> 0 - accum' = accum ++ [e] - in if done depth' e then (True, depth', accum') - else readEventsStep done es depth' accum' - -------------------------------------------------------------------------------- - -hPutStr :: Handle -> String -> IO () -hPutStr (PlainHandle h) = IO.hPutStr h -hPutStr (SecureHandle _ session) = GnuTLS.tlsSendString session - -hGetChar :: Handle -> IO Char -hGetChar (PlainHandle h) = IO.hGetChar h -hGetChar (SecureHandle h session) = allocaBytes 1 $ \ptr -> do - pending <- GnuTLS.tlsCheckPending session - if pending == 0 - then do - IO.hWaitForInput h (-1) - return () - else return () - - len <- GnuTLS.tlsRecv session ptr 1 - [char] <- peekCAStringLen (ptr, len) - return char diff --git a/Network/Protocol/XMPP/Util.hs b/Network/Protocol/XMPP/Util.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Util.hs +++ /dev/null @@ -1,97 +0,0 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -module Network.Protocol.XMPP.Util ( - eventsToTree - ,convertAttr - ,convertQName - ,mkElement - ,mkAttr - ,mkQName - ) where - -import qualified Text.XML.HXT.DOM.XmlNode as XN -import qualified Text.XML.HXT.DOM.Interface as DOM -import qualified Text.XML.LibXML.SAX as SAX - -------------------------------------------------------------------------------- --- For converting incremental XML event lists to HXT trees -------------------------------------------------------------------------------- - --- This function assumes the input list is valid. No validation is performed. -eventsToTree :: [SAX.Event] -> DOM.XmlTree -eventsToTree es = XN.mkRoot [] (eventsToTrees es) - -eventsToTrees :: [SAX.Event] -> [DOM.XmlTree] -eventsToTrees es = concatMap blockToTrees (splitBlocks es) - --- Split event list into a sequence of "blocks", which are the events including --- and between a pair of tags. and are both --- single blocks. -splitBlocks :: [SAX.Event] -> [[SAX.Event]] -splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es - -splitBlocks' :: (Int, [SAX.Event], [[SAX.Event]]) - -> SAX.Event - -> (Int, [SAX.Event], [[SAX.Event]]) -splitBlocks' (depth, accum, allAccum) e = - if depth' == 0 then - (depth', [], allAccum ++ [accum']) - else - (depth', accum', allAccum) - where - accum' = accum ++ [e] - depth' = depth + case e of - (SAX.BeginElement _ _) -> 1 - (SAX.EndElement _) -> (- 1) - _ -> 0 - -blockToTrees :: [SAX.Event] -> [DOM.XmlTree] -blockToTrees [] = [] -blockToTrees (begin:rest) = let end = (last rest) in case (begin, end) of - (SAX.BeginElement qname attrs, SAX.EndElement _) -> - [XN.mkElement (convertQName qname) - (map convertAttr attrs) - (eventsToTrees (init rest))] - (SAX.Characters s, _) -> [XN.mkText s] - (_, SAX.ParseError text) -> error text - _ -> [] - -convertAttr :: SAX.Attribute -> DOM.XmlTree -convertAttr (SAX.Attribute qname value) = XN.NTree - (XN.mkAttrNode (convertQName qname)) - [XN.mkText value] - -convertQName :: SAX.QName -> DOM.QName -convertQName (SAX.QName ns _ local) = mkQName ns local - -------------------------------------------------------------------------------- --- Utility function for building XML trees -------------------------------------------------------------------------------- - -mkElement :: (String, String) -> [(String, String, String)] -> [DOM.XmlTree] -> DOM.XmlTree -mkElement (ns, localpart) attrs children = let - qname = mkQName ns localpart - attrs' = [mkAttr ans alp text | (ans, alp, text) <- attrs] - in XN.mkElement qname attrs' children - -mkAttr :: String -> String -> String -> DOM.XmlTree -mkAttr ns localpart text = XN.mkAttr (mkQName ns localpart) [XN.mkText text] - -mkQName :: String -> String -> DOM.QName -mkQName ns localpart = case ns of - "" -> DOM.mkName localpart - _ -> DOM.mkNsName localpart ns diff --git a/Network/Protocol/XMPP/XML.hs b/Network/Protocol/XMPP/XML.hs new file mode 100644 --- /dev/null +++ b/Network/Protocol/XMPP/XML.hs @@ -0,0 +1,123 @@ +-- Copyright (C) 2010 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.XMPP.XML + ( module Data.XML.Types + + -- * Constructors + , name + , nsname + , element + , nselement + + -- * Misc + , getattr + , contentText + , attributeText + , escape + , serialiseElement + , readEvents + , SAX.eventsToElement + ) where +import qualified Data.Text.Lazy as T +import Data.XML.Types +import qualified Text.XML.LibXML.SAX as SAX + +getattr :: Name -> Element -> Maybe T.Text +getattr n e = case elementAttributes e >>= isNamed n of + [] -> Nothing + attr:_ -> Just $ attributeText attr + +contentText :: Content -> T.Text +contentText (ContentText t) = t +contentText (ContentEntity e) = T.concat ["&", e, ";"] + +attributeText :: Attribute -> T.Text +attributeText = T.concat . map contentText . attributeContent + +name :: T.Text -> Name +name t = Name t Nothing Nothing + +nsname :: T.Text -> T.Text -> Name +nsname ns n = Name n (Just ns) Nothing + +escape :: T.Text -> T.Text +escape = T.concatMap escapeChar where + escapeChar c = case c of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> T.singleton c + +escapeContent :: Content -> T.Text +escapeContent (ContentText t) = escape t +escapeContent (ContentEntity e) = T.concat ["&", escape e, ";"] + +element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element +element elemName attrs children = Element (name elemName) attrs' children where + attrs' = map (uncurry mkattr) attrs + +nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element +nselement ns ln attrs children = Element (nsname ns ln) attrs' children where + attrs' = map (uncurry mkattr) attrs + +mkattr :: T.Text -> T.Text -> Attribute +mkattr n val = Attribute (name n) [ContentText val] + +-- A somewhat primitive serialisation function +-- +-- TODO: better namespace / prefix handling +serialiseElement :: Element -> T.Text +serialiseElement e = text where + text = T.concat ["<", eName, " ", attrs, ">", contents, ""] + eName = formatName $ elementName e + formatName = escape . nameLocalName + attrs = T.intercalate " " $ map attr $ elementAttributes e ++ nsattr + attr (Attribute n c) = T.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""] + nsattr = case nameNamespace $ elementName e of + Nothing -> [] + Just ns -> [mkattr "xmlns" ns] + contents = T.concat $ map serialiseNode $ elementNodes e + + serialiseNode (NodeElement e') = serialiseElement e' + serialiseNode (NodeContent c) = escape (contentText c) + serialiseNode (NodeComment _) = "" + serialiseNode (NodeInstruction _) = "" + +readEvents :: Monad m + => (Integer -> SAX.Event -> Bool) + -> m [SAX.Event] + -> m [SAX.Event] +readEvents done nextEvents = readEvents' 0 [] where + readEvents' depth acc = do + events <- nextEvents + let (done', depth', acc') = step events depth acc + if done' + then return acc' + else readEvents' depth' acc' + + step [] depth acc = (False, depth, acc) + step (e:es) depth acc = let + depth' = depth + case e of + (SAX.BeginElement _ _) -> 1 + (SAX.EndElement _) -> (- 1) + _ -> 0 + acc' = e : acc + in if done depth' e + then (True, depth', reverse acc') + else step es depth' acc' diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -1,7 +1,7 @@ name: network-protocol-xmpp -version: 0.2.1 +version: 0.3 synopsis: Client <-> Server communication over XMPP -license: GPL +license: GPL-3 license-file: License.txt author: John Millikin Stephan Maka @@ -17,23 +17,34 @@ location: http://ianen.org/haskell/xmpp/ library + ghc-options: -Wall -fno-warn-unused-do-bind + build-depends: - base >=3 && < 5, - hxt >= 8.5 && < 8.6, - libxml-sax >= 0.3 && < 0.4, - hsgnutls >= 0.2 && < 0.3, - gsasl >= 0.2 && < 0.3, - network >= 2.2 && < 2.3, - bytestring >= 0.9 && < 1.0, - SHA >= 1.4 && < 1.5 + base >=3 && < 5 + , text >= 0.7 && < 0.8 + , gnuidn >= 0.1 && < 0.2 + , gnutls >= 0.1 && < 0.3 + , bytestring >= 0.9 && < 0.10 + , libxml-sax >= 0.4 && < 0.5 + , gsasl >= 0.3 && < 0.4 + , network >= 2.2 && < 2.3 + , transformers >= 0.2 && < 0.3 + , monads-tf >= 0.1 && < 0.2 + , xml-types >= 0.1 && < 0.2 + , failable-list >= 0.2 && < 0.3 exposed-modules: Network.Protocol.XMPP + + other-modules: Network.Protocol.XMPP.Client + Network.Protocol.XMPP.Client.Authentication + Network.Protocol.XMPP.Client.Features Network.Protocol.XMPP.Component - Network.Protocol.XMPP.Connection + Network.Protocol.XMPP.Connections + Network.Protocol.XMPP.ErrorT + Network.Protocol.XMPP.Handle Network.Protocol.XMPP.JID - Network.Protocol.XMPP.SASL - Network.Protocol.XMPP.Stanzas - Network.Protocol.XMPP.Stream - Network.Protocol.XMPP.Util + Network.Protocol.XMPP.Monad + Network.Protocol.XMPP.Stanza + Network.Protocol.XMPP.XML