From f393f02c50d1c6927ae58369f2fa8295c19d71b6 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Thu, 1 Apr 2010 03:53:27 +0000 Subject: [PATCH] Quick-n-dirty conversion to version 0.3 of the GNU SASL bindings. --- Network/Protocol/XMPP/Client.hs | 3 +- Network/Protocol/XMPP/Component.hs | 19 +++-- .../Protocol/XMPP/Internal/Authentication.hs | 75 ++++++++++--------- Network/Protocol/XMPP/Internal/Features.hs | 17 ++--- network-protocol-xmpp.cabal | 4 +- 5 files changed, 62 insertions(+), 56 deletions(-) diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs index f3efe73..5e1e1dc 100644 --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -26,6 +26,7 @@ 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 System.IO as IO +import Data.ByteString (ByteString) import qualified Data.Text as T import qualified Text.XML.LibXML.SAX as SAX @@ -90,7 +91,7 @@ authenticate stream jid sjid username password = do A.Failure -> error "Authentication failure" _ -> restartStream stream -authenticationMechanisms :: ClientStream -> [T.Text] +authenticationMechanisms :: ClientStream -> [ByteString] authenticationMechanisms = step . streamFeatures where step [] = [] step (f:fs) = case f of diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs index 6e3cf52..9e47287 100644 --- a/Network/Protocol/XMPP/Component.hs +++ b/Network/Protocol/XMPP/Component.hs @@ -21,18 +21,18 @@ module Network.Protocol.XMPP.Component , componentStreamID , connectComponent ) where - +import Data.Bits (shiftR, (.&.)) +import Data.Char (intToDigit) +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Network (connectTo) 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 Data.Digest.Pure.SHA as SHA +import Network.Protocol.SASL.GNU (sha1) import qualified System.IO as IO -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL import qualified Text.XML.LibXML.SAX as SAX import qualified Network.Protocol.XMPP.Internal.Connections as C @@ -95,7 +95,7 @@ parseStreamID _ = Nothing authenticate :: Component -> T.Text -> IO () authenticate stream password = do let bytes = buildSecret (componentStreamID stream) password - let digest = SHA.showDigest $ SHA.sha1 $ BL.fromChunks [bytes] + let digest = showDigest $ sha1 bytes S.putTree stream $ element ("", "handshake") [] [XN.mkText digest] result <- S.getTree stream let accepted = A.runLA $ @@ -111,3 +111,8 @@ buildSecret sid password = bytes where escaped = DOM.attrEscapeXml $ sid' ++ password' sid' = T.unpack sid password' = T.unpack password + +showDigest :: B.ByteString -> String +showDigest = concatMap wordToHex . B.unpack where + wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF] + hexDig = intToDigit . fromIntegral diff --git a/Network/Protocol/XMPP/Internal/Authentication.hs b/Network/Protocol/XMPP/Internal/Authentication.hs index 01e1f8d..e1edd81 100644 --- a/Network/Protocol/XMPP/Internal/Authentication.hs +++ b/Network/Protocol/XMPP/Internal/Authentication.hs @@ -17,12 +17,15 @@ module Network.Protocol.XMPP.Internal.Authentication ( Result(..) , authenticate ) where +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Char8 as B import qualified Data.Text as T +import qualified Data.Text.Encoding as TE 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 qualified Network.Protocol.SASL.GNU as SASL import Network.Protocol.XMPP.JID (JID, formatJID) import Network.Protocol.XMPP.Internal.XML (element, qname) @@ -32,7 +35,7 @@ data Result = Success | Failure deriving (Show, Eq) authenticate :: S.Stream stream => stream - -> [T.Text] -- ^ Mechanisms + -> [B.ByteString] -- ^ Mechanisms -> JID -- ^ User JID -> JID -- ^ Server JID -> T.Text -- ^ Username @@ -41,51 +44,49 @@ authenticate :: S.Stream stream => stream authenticate stream mechanisms userJID serverJID username password = do let authz = formatJID userJID let hostname = formatJID serverJID + let utf8 = TE.encodeUtf8 - G.withContext $ \ctxt -> do - - suggested <- G.clientSuggestMechanism ctxt (map T.unpack 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 $ T.unpack authz - G.propertySet s G.GSASL_AUTHID $ T.unpack username - G.propertySet s G.GSASL_PASSWORD $ T.unpack password - G.propertySet s G.GSASL_SERVICE "xmpp" - G.propertySet s G.GSASL_HOSTNAME $ T.unpack hostname - - (b64text, rc) <- G.step64 s "" - S.putTree stream $ element ("", "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 - _ -> error "Unknown GNU SASL response" + SASL.runSASL $ do + suggested <- SASL.clientSuggestMechanism $ map SASL.Mechanism mechanisms + mechanism <- case suggested of + Just m -> return m + Nothing -> error "No supported SASL mechanisms advertised" + let (SASL.Mechanism mechBytes) = mechanism + 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 "" + liftIO $ S.putTree stream $ element ("", "auth") + [ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl") + , ("", "mechanism", B.unpack mechBytes)] + [XN.mkText $ B.unpack b64text] + + case rc of + SASL.Complete -> liftIO $ saslFinish stream + SASL.NeedsMore -> saslLoop stream -saslLoop :: S.Stream s => s -> G.Session -> IO Result -saslLoop stream session = do - challengeText <- A.runX ( +saslLoop :: S.Stream s => s -> SASL.Session Result +saslLoop stream = do + challengeText <- liftIO $ A.runX ( A.arrIO (\_ -> S.getTree stream) >>> A.getChildren >>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge") >>> A.getChildren >>> A.getText) - if null challengeText then return Failure + if null challengeText + then return Failure else do - (b64text, rc) <- G.step64 session (concat challengeText) - S.putTree stream $ element ("", "response") + (b64text, rc) <- SASL.step64 $ B.pack $ concat challengeText + liftIO $ S.putTree stream $ element ("", "response") [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")] - [XN.mkText b64text] + [XN.mkText $ B.unpack b64text] case rc of - G.GSASL_OK -> saslFinish stream - G.GSASL_NEEDS_MORE -> saslLoop stream session - _ -> error "Unknown GNU SASL response" + SASL.Complete -> liftIO $ saslFinish stream + SASL.NeedsMore -> saslLoop stream saslFinish :: S.Stream s => s -> IO Result saslFinish stream = do diff --git a/Network/Protocol/XMPP/Internal/Features.hs b/Network/Protocol/XMPP/Internal/Features.hs index 8fa3f63..eb03670 100644 --- a/Network/Protocol/XMPP/Internal/Features.hs +++ b/Network/Protocol/XMPP/Internal/Features.hs @@ -18,7 +18,7 @@ module Network.Protocol.XMPP.Internal.Features , parseFeatures , parseFeature ) where -import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B import Text.XML.HXT.Arrow ((>>>)) import qualified Text.XML.HXT.Arrow as A import qualified Text.XML.HXT.DOM.Interface as DOM @@ -27,7 +27,7 @@ import Network.Protocol.XMPP.Internal.XML (qname) data Feature = FeatureStartTLS Bool - | FeatureSASL [T.Text] + | FeatureSASL [B.ByteString] | FeatureRegister | FeatureBind | FeatureSession @@ -56,13 +56,12 @@ parseFeatureTLS :: DOM.XmlTree -> Feature parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required parseFeatureSASL :: DOM.XmlTree -> Feature -parseFeatureSASL t = FeatureSASL $ map T.toUpper mechanisms where - mechanisms = A.runLA ( - A.getChildren - >>> A.hasQName qnameMechanism - >>> A.getChildren - >>> A.getText - >>> A.arr T.pack) t +parseFeatureSASL t = FeatureSASL $ A.runLA ( + A.getChildren + >>> A.hasQName qnameMechanism + >>> A.getChildren + >>> A.getText + >>> A.arr B.pack) t qnameMechanism :: DOM.QName qnameMechanism = qname "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism" diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal index dc078fb..be28eb2 100644 --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -28,9 +28,9 @@ library , hsgnutls >= 0.2 && < 0.3 , bytestring >= 0.9 && < 1.0 , libxml-sax >= 0.3 && < 0.4 - , gsasl >= 0.2 && < 0.3 + , gsasl >= 0.3 && < 0.4 , network >= 2.2 && < 2.3 - , SHA >= 1.4 && < 1.5 + , transformers >= 0.2 && < 0.3 exposed-modules: Network.Protocol.XMPP -- 2.38.5