From 27bee8c435a42fbe5228e4d188665399429d9d16 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Mon, 15 Jun 2009 03:30:52 +0000 Subject: [PATCH] Started work on authentication support. --- Network/Protocol/XMPP/Client.hs | 51 ++++++++++++++++++---- Network/Protocol/XMPP/SASL.hs | 43 +++++++++++++++++++ Network/Protocol/XMPP/Stream.hs | 76 ++++++++++++++++++++++++--------- 3 files changed, 141 insertions(+), 29 deletions(-) create mode 100644 Network/Protocol/XMPP/SASL.hs diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs index c7e4f43..656d7ad 100644 --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -24,13 +24,19 @@ module Network.Protocol.XMPP.Client ( import System.IO (Handle) import Network (HostName, PortID, connectTo) +import Text.XML.HXT.Arrow ((>>>)) +import qualified Text.XML.HXT.Arrow as A +import qualified Text.XML.HXT.DOM.XmlNode as XN +import qualified Text.XML.HXT.DOM.QualifiedName as QN + import Network.Protocol.XMPP.JID (JID) -import Network.Protocol.XMPP.Stream (beginStream, streamFeatures) +import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism) +import qualified Network.Protocol.XMPP.Stream as S import Network.Protocol.XMPP.Stanzas (Stanza) -data ConnectedClient = ConnectedClient JID Handle +data ConnectedClient = ConnectedClient JID S.Stream -data AuthenticatedClient = AuthenticatedClient Handle HostName PortID +data AuthenticatedClient = AuthenticatedClient JID S.Stream type Username = String type Password = String @@ -38,13 +44,42 @@ type Password = String clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient clientConnect jid host port = do handle <- connectTo host port - stream <- beginStream jid host handle - putStrLn $ "streamFeatures = " ++ (show (streamFeatures stream)) - return $ ConnectedClient jid handle + stream <- S.beginStream jid host handle + + -- TODO: TLS support + + return $ ConnectedClient jid stream -clientAuthenticate :: ConnectedClient -> Username -> Password -> AuthenticatedClient -clientAuthenticate = undefined +clientAuthenticate :: ConnectedClient -> Username -> Password -> IO AuthenticatedClient +clientAuthenticate (ConnectedClient jid stream) username password = let + mechanisms = (advertisedMechanisms . S.streamFeatures) stream + saslMechanism = case bestMechanism mechanisms of + Nothing -> error "No supported SASL mechanism" + Just m -> m + in do + putStrLn $ "mechanism = " ++ (show saslMechanism) + + -- TODO: use detected mechanism + S.putTree stream $ XN.mkElement + (QN.mkName "auth") + [ + XN.mkAttr (QN.mkName "xmlns") [XN.mkText "urn:ietf:params:xml:ns:xmpp-sasl"] + ,XN.mkAttr (QN.mkName "mechanism") [XN.mkText "PLAIN"] + ] + [XN.mkText "="] + + response <- S.getTree stream + putStrLn $ "response:" + A.runX (A.constA response >>> A.putXmlTree "-") + + return $ AuthenticatedClient jid stream clientSend :: (Stanza s) => AuthenticatedClient -> s -> IO () clientSend = undefined +advertisedMechanisms :: [S.StreamFeature] -> [Mechanism] +advertisedMechanisms [] = [] +advertisedMechanisms (f:fs) = case f of + (S.FeatureSASL ms) -> ms + otherwise -> advertisedMechanisms fs + diff --git a/Network/Protocol/XMPP/SASL.hs b/Network/Protocol/XMPP/SASL.hs new file mode 100644 index 0000000..1dbe6ab --- /dev/null +++ b/Network/Protocol/XMPP/SASL.hs @@ -0,0 +1,43 @@ +{- 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 ( + Mechanism + ,supportedMechanisms + ,bestMechanism + ,findMechanism + ) where + +import Data.List (intersect) +import Data.AssocList (lookupDef) + +type Username = String +type Password = String + +type Mechanism = String + +-- TODO: validation +supportedMechanisms :: [Mechanism] +supportedMechanisms = ["PLAIN"] -- TODO: Digest-MD5 + +bestMechanism :: [Mechanism] -> Maybe Mechanism +bestMechanism ms = let + in case intersect supportedMechanisms ms of + [] -> Nothing + (m:_) -> Just m + +findMechanism :: String -> Mechanism +findMechanism s = s -- TODO: validate diff --git a/Network/Protocol/XMPP/Stream.hs b/Network/Protocol/XMPP/Stream.hs index 0ad04bb..6344715 100644 --- a/Network/Protocol/XMPP/Stream.hs +++ b/Network/Protocol/XMPP/Stream.hs @@ -21,8 +21,14 @@ module Network.Protocol.XMPP.Stream ( ,streamVersion ,streamFeatures ) + ,StreamFeature ( + FeatureStartTLS + ,FeatureSASL + ,FeatureRegister + ) ,beginStream - ,send + ,getTree + ,putTree ) where import qualified System.IO as IO @@ -37,7 +43,9 @@ import Text.XML.HXT.DOM.Util (attrEscapeXml) import Text.XML.HXT.Arrow ((>>>), (>>.)) import Data.Tree.NTree.TypeDefs (NTree(NTree)) import qualified Text.XML.HXT.Arrow as A + import Network.Protocol.XMPP.JID (JID) +import Network.Protocol.XMPP.SASL (Mechanism, findMechanism) import Network.Protocol.XMPP.Stanzas (Stanza) import Network.Protocol.XMPP.XMLBuilder (eventsToTree) @@ -55,7 +63,7 @@ data Stream = Stream data StreamFeature = FeatureStartTLS Bool - | FeatureSASL [SASLMechanism] + | FeatureSASL [Mechanism] | FeatureRegister | FeatureUnknown XmlTree | FeatureDebug String @@ -64,9 +72,6 @@ data StreamFeature = newtype XMLLanguage = XMLLanguage String deriving (Show, Eq) -newtype SASLMechanism = SASLMechanism String - deriving (Show, Eq) - data XMPPVersion = XMPPVersion Int Int deriving (Show, Eq) @@ -87,12 +92,15 @@ beginStream jid host handle = do " to='" ++ (attrEscapeXml . show) jid ++ "'" ++ " version='1.0'" ++ " xmlns:stream='http://etherx.jabber.org/streams'>" - IO.hFlush handle - xmlChars <- hGetChars handle 100 - events <- (XML.incrementalParse parser xmlChars) + events <- readEventsUntil endOfFeatures handle parser 1000 return $ beginStream' handle parser events + where + featuresName = QN.mkNsName "features" "http://etherx.jabber.org/streams" + endOfFeatures depth event = case (depth, event) of + (1, (XML.EndElement featuresName)) -> True + otherwise -> False beginStream' handle parser (streamStart:events) = let -- TODO: parse from streamStart @@ -135,22 +143,48 @@ parseFeatureSASL t = let -- TODO: validate mechanism names according to SASL rules -- <20 chars, uppercase, alphanum, etc - in FeatureSASL [SASLMechanism n | n <- rawMechanisms] + in FeatureSASL (map findMechanism rawMechanisms) ------------------------------------------------------------------------------- -send :: (Stanza s) => Stream -> s -> IO () -send = undefined +getTree :: Stream -> IO XmlTree +getTree s = do + events <- readEventsUntil finished (streamHandle s) (streamParser s) 1000 + return $ eventsToTree events + where + finished 0 (XML.EndElement _) = True + finished _ _ = False + +putTree :: Stream -> 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") + ]) + IO.hPutStr h text + IO.hFlush h ------------------------------------------------------------------------------- -hGetChars :: IO.Handle -> Int -> IO String -hGetChars h timeout = do - have_input <- IO.hWaitForInput h timeout - case have_input of - False -> return [] - True -> do - chr <- IO.hGetChar h - next <- hGetChars h timeout - return $ chr : next - +readEventsUntil :: (Int -> XML.Event -> Bool) -> IO.Handle -> XML.Parser -> Int -> IO [XML.Event] +readEventsUntil done h parser timeout = readEventsUntil' done 0 [] $ do + char <- IO.hGetChar h + XML.incrementalParse parser [char] + +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 _ [] depth accum = (False, depth, accum) +readEventsStep done (e:es) depth accum = let + depth' = depth + case e of + (XML.BeginElement _ _) -> 1 + (XML.EndElement _) -> (- 1) + otherwise -> 0 + accum' = accum ++ [e] + in if done depth' e then (True, depth', accum') + else readEventsStep done es depth' accum' -- 2.38.5