M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +2 -1
@@ 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
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +12 -7
@@ 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
M Network/Protocol/XMPP/Internal/Authentication.hs => Network/Protocol/XMPP/Internal/Authentication.hs +38 -37
@@ 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
M Network/Protocol/XMPP/Internal/Features.hs => Network/Protocol/XMPP/Internal/Features.hs +8 -9
@@ 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"
M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +2 -2
@@ 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