From 84610776d4f74942e8374378afe4fdab53ebd637 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 15 Apr 2012 14:50:58 +0200 Subject: [PATCH 1/7] removed makeshift replacements for sourceHandle and sinkHandle (fixed in upstream) --- src/Network/XMPP/Monad.hs | 30 ++---------------------------- 1 file changed, 2 insertions(+), 28 deletions(-) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index c080f53..0b61c6a 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -68,7 +68,7 @@ xmppFromHandle :: Handle -> IO (a, XMPPConState) xmppFromHandle handle hostname username res f = do liftIO $ hSetBuffering handle NoBuffering - let raw = sourceHandle' handle + let raw = sourceHandle handle let src = raw $= XP.parseBytes def let st = XMPPConState src @@ -82,32 +82,6 @@ xmppFromHandle handle hostname username res f = do res runStateT f st --- TODO: Once pullrequest has been merged, switch back to upstream -sourceHandle' :: MonadIO m => Handle -> Source m BS.ByteString -sourceHandle' h = - src - where - src = PipeM pull close - - pull = do - bs <- liftIO (BS.hGetSome h 4096) - if BS.null bs - then return $ Done Nothing () - else return $ HaveOutput src close bs - - close = return () - -sinkHandle' :: MonadIO m - => Handle - -> Sink BS.ByteString m () -sinkHandle' h = - NeedInput push close - where - push input = PipeM - (liftIO (BS.hPut h input) >> return (NeedInput push close)) - (return ()) - close = return () - zeroSource :: Source IO output zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000) @@ -131,7 +105,7 @@ xmppRawConnect host hostname = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering return con - let raw = sourceHandle' con + let raw = sourceHandle con let src = raw $= XP.parseBytes def let st = XMPPConState src From 522ec7a61fa935ad8b86d7ea8f649aa7d35842aa Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 16 Apr 2012 15:07:06 +0200 Subject: [PATCH 2/7] fixed cabal file --- pontarius.cabal | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/pontarius.cabal b/pontarius.cabal index ec387dd..cb80740 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -48,20 +48,19 @@ Library , xml-conduit -any , xml-types-pickle -any , data-default -any - Exposed-modules: Network.XMPP.Types - -- Network.XMPP - - -- , Network.XMPP.SASL - -- , Network.XMPP.Stream - -- , Network.XMPP.Pickle - -- , Network.XMPP.Marshal - -- , Network.XMPP.Monad - -- , Network.XMPP.Concurrent - -- , Network.XMPP.TLS - -- , Network.XMPP.Bind - -- , Network.XMPP.Session - -- , Text.XML.Stream.Elements - -- , Data.Conduit.TLS + Exposed-modules: Network.XMPP + , Network.XMPP.Types + , Network.XMPP.SASL + , Network.XMPP.Stream + , Network.XMPP.Pickle + , Network.XMPP.Marshal + , Network.XMPP.Monad + , Network.XMPP.Concurrent + , Network.XMPP.TLS + , Network.XMPP.Bind + , Network.XMPP.Session + , Text.XML.Stream.Elements + , Data.Conduit.TLS GHC-Options: -Wall From bbaa3c07180ebcc793f28611efe7845d74a81ebd Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 16 Apr 2012 15:10:06 +0200 Subject: [PATCH 3/7] added build script (requires cabal-dev) --- build.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 build.sh diff --git a/build.sh b/build.sh new file mode 100644 index 0000000..afccab5 --- /dev/null +++ b/build.sh @@ -0,0 +1,6 @@ +#!/bin/sh +git submodule init +git submodule update +cabal-dev install ./xml-types-pickle +cabal-dev install-deps +cabal-dev build From ef63f12952bd3369f5f1fb7df8d2a172b9ff426f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 16 Apr 2012 17:15:04 +0200 Subject: [PATCH 4/7] changed JID field names to conform to RFC 6120 --- src/Network/XMPP/Types.hs | 6 +++--- src/Tests.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index e948756..550c189 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -73,11 +73,11 @@ instance IsString StanzaId where -- @From@ is a readability type synonym for @Address@. -- | Jabber ID (JID) datatype -data JID = JID { node :: Maybe Text +data JID = JID { localpart :: Maybe Text -- ^ Account name - , domain :: Text + , domainpart :: Text -- ^ Server adress - , resource :: Maybe Text + , resourcepart :: Maybe Text -- ^ Resource name } diff --git a/src/Tests.hs b/src/Tests.hs index e3438f3..2e99ea2 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -89,11 +89,11 @@ runMain debug number = do withConnection $ do xmppConnect "localhost" "species64739.dyndns.org" xmppStartTLS exampleParams - saslResponse <- xmppSASL (fromJust $ node we) "pwd" + saslResponse <- xmppSASL (fromJust $ localpart we) "pwd" case saslResponse of Right _ -> return () Left e -> error e - xmppThreadedBind (resource we) + xmppThreadedBind (resourcepart we) withConnection $ xmppSession debug' "session standing" sendPresence presenceOnline @@ -101,7 +101,7 @@ runMain debug number = do forkXMPP iqResponder when active . void . forkXMPP $ do forM [1..10] $ \count -> do - let message = Text.pack . show $ node we + let message = Text.pack . show $ localpart we let payload = Payload count (even count) (Text.pack $ show count) let body = pickleElem payloadP payload Right answer <- sendIQ' (Just them) Get Nothing body From cca3a6d4d01be53a120161921d65ac5700561130 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 16 Apr 2012 18:59:04 +0200 Subject: [PATCH 5/7] added error handling to Stream, TLS switched to Strict State switched to mtl improved build script --- build.sh | 1 + pontarius.cabal | 2 + src/Network/XMPP.hs | 2 +- src/Network/XMPP/Bind.hs | 2 +- src/Network/XMPP/Concurrent/Monad.hs | 4 +- src/Network/XMPP/Concurrent/Threads.hs | 7 ++- src/Network/XMPP/Monad.hs | 4 +- src/Network/XMPP/Pickle.hs | 7 ++- src/Network/XMPP/SASL.hs | 2 +- src/Network/XMPP/Stream.hs | 59 +++++++++++++++++--------- src/Network/XMPP/TLS.hs | 56 ++++++++++++++++-------- src/Network/XMPP/Types.hs | 25 ++++++++--- src/Tests.hs | 4 +- 13 files changed, 115 insertions(+), 60 deletions(-) diff --git a/build.sh b/build.sh index afccab5..7e92cce 100644 --- a/build.sh +++ b/build.sh @@ -3,4 +3,5 @@ git submodule init git submodule update cabal-dev install ./xml-types-pickle cabal-dev install-deps +cabal-dev configure cabal-dev build diff --git a/pontarius.cabal b/pontarius.cabal index cb80740..947d444 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -26,6 +26,7 @@ Library Exposed: True Build-Depends: base >4 && <5 , conduit -any + , void -any , resourcet -any , containers -any , random -any @@ -48,6 +49,7 @@ Library , xml-conduit -any , xml-types-pickle -any , data-default -any +-- , stringprep -any Exposed-modules: Network.XMPP , Network.XMPP.Types , Network.XMPP.SASL diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 51c84d7..8c531e3 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -58,7 +58,7 @@ import Network.XMPP.Stream import Network.XMPP.TLS import Network.XMPP.Types -xmppConnect :: HostName -> Text -> XMPPConMonad () +xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 4ea7b3f..0cd307e 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -27,7 +27,7 @@ xmppThreadedBind :: Maybe Text -> XMPPThread Text xmppThreadedBind rsrc = do answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling - let (JID _n _d (Just r)) = unpickleElem jidP b + let Right (JID _n _d (Just r)) = unpickleElem jidP b return r diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index a7ccb62..a39ce1b 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -6,8 +6,8 @@ import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import Control.Monad.Reader +import Control.Monad.State.Strict import Data.IORef import qualified Data.Map as Map diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 40669e3..b40024b 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -10,10 +10,9 @@ import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource -import Control.Monad.Trans.State +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.State.Strict import qualified Data.ByteString as BS import Data.Conduit diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 0b61c6a..cf3b634 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -8,7 +8,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource import Control.Concurrent -import Control.Monad.Trans.State +import Control.Monad.State.Strict import Data.ByteString as BS import Data.Conduit @@ -55,7 +55,7 @@ pullE :: XMPPConMonad Element pullE = pulls elementFromEvents pullPickle :: PU [Node] a -> XMPPConMonad a -pullPickle p = unpickleElem p <$> pullE +pullPickle p = unpickleElem' p <$> pullE pull :: XMPPConMonad Stanza pull = pullPickle stanzaP diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index a999956..97d3989 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -52,11 +52,14 @@ right :: Either [Char] t -> t right (Left l) = error l right (Right r) = r -unpickleElem :: PU [Node] c -> Element -> c -unpickleElem p x = case unpickle (xpNodeElem p) x of +unpickleElem' :: PU [Node] c -> Element -> c +unpickleElem' p x = case unpickle (xpNodeElem p) x of Left l -> error $ l ++ "\n saw: " ++ ppElement x Right r -> r +unpickleElem :: PU [Node] a -> Element -> Either String a +unpickleElem p x = unpickle (xpNodeElem p) x + pickleElem :: PU [Node] a -> a -> Element pickleElem p = pickle $ xpNodeElem p diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 53b6c2e..72d823b 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -4,7 +4,7 @@ module Network.XMPP.SASL where import Control.Applicative import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.State +import Control.Monad.State.Strict import qualified Crypto.Classes as CC diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index b95706a..6f750e4 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -4,14 +4,17 @@ module Network.XMPP.Stream where import Control.Applicative((<$>)) +import Control.Exception(throwIO) import Control.Monad(unless) -import Control.Monad.Trans.State +import Control.Monad.Error +import Control.Monad.State.Strict import Data.Conduit import Data.Conduit.List as CL import Data.Text as T import Data.XML.Pickle import Data.XML.Types +import Data.Void(Void) import Network.XMPP.Monad import Network.XMPP.Pickle @@ -22,6 +25,16 @@ import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements +streamUnpickleElem :: PU [Node] a + -> Element + -> ErrorT StreamError (Pipe Event Void IO) a +streamUnpickleElem p x = do + case unpickleElem p x of + Left l -> throwError $ StreamUnpickleError l + Right r -> return r + +type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a + throwOutJunk :: Monad m => Sink Event m () throwOutJunk = do next <- CL.peek @@ -30,22 +43,26 @@ throwOutJunk = do Just (EventBeginElement _ _) -> return () _ -> CL.drop 1 >> throwOutJunk -openElementFromEvents :: Monad m => Sink Event m Element +openElementFromEvents :: StreamSink Element openElementFromEvents = do - throwOutJunk - Just (EventBeginElement name attrs) <- CL.head - return $ Element name attrs [] - - -xmppStartStream :: XMPPConMonad () -xmppStartStream = do - hostname <- gets sHostname - pushOpen $ pickleElem pickleStream ("1.0",Nothing, hostname) - features <- pulls xmppStream + lift throwOutJunk + hd <- lift CL.head + case hd of + Just (EventBeginElement name attrs) -> return $ Element name attrs [] + _ -> throwError $ StreamConnectionError + +xmppStartStream :: XMPPConMonad (Either StreamError ()) +xmppStartStream = runErrorT $ do + hostname' <- gets sHostname + case hostname' of + Nothing -> throwError StreamConnectionError + Just hostname -> lift . pushOpen $ + pickleElem pickleStream ("1.0",Nothing, Just hostname) + features <- ErrorT . pulls $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () -xmppRestartStream :: XMPPConMonad () +xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream = do raw <- gets sRawSrc let newsrc = raw $= XP.parseBytes def @@ -53,22 +70,22 @@ xmppRestartStream = do xmppStartStream -xmppStream :: Sink Event IO ServerFeatures +xmppStream :: StreamSink ServerFeatures xmppStream = do xmppStreamHeader xmppStreamFeatures -xmppStreamHeader :: Sink Event IO () +xmppStreamHeader :: StreamSink () xmppStreamHeader = do - throwOutJunk - (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents - unless (ver == "1.0") $ error "Not XMPP version 1.0 " + lift $ throwOutJunk + (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents + unless (ver == "1.0") . throwError $ StreamWrongVersion ver return() -xmppStreamFeatures :: Sink Event IO ServerFeatures -xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents - +xmppStreamFeatures :: StreamSink ServerFeatures +xmppStreamFeatures = streamUnpickleElem pickleStreamFeatures + =<< lift elementFromEvents -- Pickling diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 55884d5..7b9f159 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -1,15 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.XMPP.TLS where +import Control.Applicative((<$>)) +import Control.Arrow(left) +import qualified Control.Exception.Lifted as Ex import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.State +import Control.Monad.Error +import Control.Monad.State.Strict +import Control.Monad.Trans import Data.Conduit import Data.Conduit.List as CL import Data.Conduit.TLS as TLS import Data.Default +import Data.Typeable import Data.XML.Types import qualified Network.TLS as TLS @@ -39,21 +45,37 @@ exampleParams = TLS.defaultParams return TLS.CertificateUsageAccept } -xmppStartTLS :: TLS.TLSParams -> XMPPConMonad () -xmppStartTLS params = do - features <- gets sFeatures - unless (stls features == Nothing) $ do - pushN starttlsE - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE - Just handle <- gets sConHandle +data XMPPTLSError = TLSError TLSError + | TLSNoServerSupport + | TLSNoConnection + | TLSStreamError StreamError + deriving (Show, Eq, Typeable) + +instance Error XMPPTLSError where + noMsg = TLSNoConnection -- TODO: What should we choose here? +instance Ex.Exception XMPPTLSError + + +xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) +xmppStartTLS params = Ex.handle (return . Left . TLSError) + . runErrorT $ do + features <- lift $ gets sFeatures + handle' <- lift $ gets sConHandle + handle <- maybe (throwError TLSNoConnection) return handle' + when (stls features == Nothing) $ throwError TLSNoServerSupport + lift $ pushN starttlsE + answer <- lift $ pullE + case answer of + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () + _ -> throwError $ TLSStreamError StreamXMLError (raw, snk, psh) <- lift $ TLS.tlsinit params handle - modify (\x -> x - { sRawSrc = raw --- , sConSrc = -- Note: this momentarily leaves us in an - -- inconsistent state - , sConPushBS = psh - }) - xmppRestartStream + lift $ modify (\x -> x + { sRawSrc = raw +-- , sConSrc = -- Note: this momentarily leaves us in an + -- inconsistent state + , sConPushBS = psh + }) + ErrorT $ (left TLSStreamError) <$> xmppRestartStream modify (\s -> s{sHaveTLS = True}) - return () + return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 550c189..a3e827c 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} -- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the -- Pontarius distribution for more details. @@ -15,8 +16,11 @@ module Network.XMPP.Types where -- import Network.XMPP.Utilities (idGenerator) import Control.Applicative((<$>)) +import Control.Exception import Control.Monad.IO.Class -import Control.Monad.State +import Control.Monad.State.Strict +import Control.Monad.Error + import qualified Data.ByteString as BS import Data.Conduit @@ -24,6 +28,7 @@ import Data.List.Split as L import Data.String(IsString(..)) import Data.Text (Text) import qualified Data.Text as Text +import Data.Typeable(Typeable) import Data.XML.Types import qualified Network as N @@ -58,7 +63,7 @@ data SessionSettings = -- @IDGenerator@, is guaranteed to be unique for the XMPP session. -- Stanza identifiers are generated by Pontarius. -data StanzaId = SI Text deriving (Eq, Ord) +data StanzaId = SI !Text deriving (Eq, Ord) instance Show StanzaId where show (SI s) = Text.unpack s @@ -73,11 +78,11 @@ instance IsString StanzaId where -- @From@ is a readability type synonym for @Address@. -- | Jabber ID (JID) datatype -data JID = JID { localpart :: Maybe Text +data JID = JID { localpart :: !(Maybe Text) -- ^ Account name - , domainpart :: Text + , domainpart :: !Text -- ^ Server adress - , resourcepart :: Maybe Text + , resourcepart :: !(Maybe Text) -- ^ Resource name } @@ -533,8 +538,14 @@ data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) type Timeout = Int -data StreamError = StreamError - +data StreamError = StreamError String + | StreamWrongVersion Text + | StreamXMLError + | StreamUnpickleError String + | StreamConnectionError + deriving (Show, Eq, Typeable) +instance Exception StreamError +instance Error StreamError where strMsg = StreamError -- ============================================================================= -- XML TYPES diff --git a/src/Tests.hs b/src/Tests.hs index 2e99ea2..07b5602 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -54,7 +54,7 @@ iqResponder = do >> error "hanging up" forever $ do next@(iq,_) <- liftIO . atomically $ readTChan chan - let payload = unpickleElem payloadP $ iqRequestPayload iq + let Right payload = unpickleElem payloadP $ iqRequestPayload iq let answerPayload = invertPayload payload let answerBody = pickleElem payloadP answerPayload answerIQ next (Right $ Just answerBody) @@ -105,7 +105,7 @@ runMain debug number = do let payload = Payload count (even count) (Text.pack $ show count) let body = pickleElem payloadP payload Right answer <- sendIQ' (Just them) Get Nothing body - let answerPayload = unpickleElem payloadP + let Right answerPayload = unpickleElem payloadP (fromJust $ iqResultPayload answer) expect debug' (invertPayload payload) answerPayload liftIO $ threadDelay 100000 From 6de96f2679ff0ff8674aee6e9a07ca3edeb73b88 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Apr 2012 11:58:06 +0200 Subject: [PATCH 6/7] de-monadified createResponse --- src/Network/XMPP/SASL.hs | 75 +++++++++++++++++++++------------------- 1 file changed, 39 insertions(+), 36 deletions(-) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 72d823b..c325d89 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -68,7 +68,8 @@ xmppStartSASL realm username passwd = do pushN $ saslInitE "DIGEST-MD5" Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle let Right pairs = toPairs challenge - pushN . saslResponseE =<< createResponse realm username passwd pairs + g <- liftIO $ Random.newStdGen + pushN . saslResponseE $ createResponse g realm username passwd pairs challenge2 <- pullPickle (xpEither failurePickle challengePickle) case challenge2 of Left x -> error $ show x @@ -78,44 +79,46 @@ xmppStartSASL realm username passwd = do xmppRestartStream return () -createResponse :: Text +createResponse :: Random.RandomGen g + => g + -> Text -> Text -> Text -> [(BS8.ByteString, BS8.ByteString)] - -> XMPPConMonad Text -createResponse hostname username passwd' pairs = do - let Just qop = L.lookup "qop" pairs - let Just nonce = L.lookup "nonce" pairs - let uname = Text.encodeUtf8 username - let passwd = Text.encodeUtf8 passwd' - let realm = Text.encodeUtf8 hostname - g <- liftIO $ Random.newStdGen - let cnonce = BS.tail . BS.init . - B64.encode . BS.pack . take 8 $ Random.randoms g - let nc = "00000001" - let digestURI = ("xmpp/" `BS.append` realm) - let digest = md5Digest - uname - realm - passwd - digestURI - nc - qop - nonce - cnonce - let response = BS.intercalate"," . map (BS.intercalate "=") $ - [["username" , quote uname ] - ,["realm" , quote realm ] - ,["nonce" , quote nonce ] - ,["cnonce" , quote cnonce ] - ,["nc" , nc ] - ,["qop" , qop ] - ,["digest-uri", quote digestURI ] - ,["response" , digest ] - ,["charset" , "utf-8" ] - ] - return . Text.decodeUtf8 $ B64.encode response - where quote x = BS.concat ["\"",x,"\""] + -> Text +createResponse g hostname username passwd' pairs = let + Just qop = L.lookup "qop" pairs + Just nonce = L.lookup "nonce" pairs + uname = Text.encodeUtf8 username + passwd = Text.encodeUtf8 passwd' + realm = Text.encodeUtf8 hostname + cnonce = BS.tail . BS.init . + B64.encode . BS.pack . take 8 $ Random.randoms g + nc = "00000001" + digestURI = ("xmpp/" `BS.append` realm) + digest = md5Digest + uname + realm + passwd + digestURI + nc + qop + nonce + cnonce + response = BS.intercalate"," . map (BS.intercalate "=") $ + [["username" , quote uname ] + ,["realm" , quote realm ] + ,["nonce" , quote nonce ] + ,["cnonce" , quote cnonce ] + ,["nc" , nc ] + ,["qop" , qop ] + ,["digest-uri", quote digestURI ] + ,["response" , digest ] + ,["charset" , "utf-8" ] + ] + in Text.decodeUtf8 $ B64.encode response + where + quote x = BS.concat ["\"",x,"\""] toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do From 1a4fa214b4c146795809c20235a7b6e5f1bf3861 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Apr 2012 14:27:42 +0200 Subject: [PATCH 7/7] re-added stringprep --- .gitmodules | 3 +++ build.sh | 1 + pontarius.cabal | 2 +- stringprep-hs | 1 + 4 files changed, 6 insertions(+), 1 deletion(-) create mode 160000 stringprep-hs diff --git a/.gitmodules b/.gitmodules index a3c8b33..5f1db7e 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [submodule "xml-types-pickle"] path = xml-types-pickle url = git@github.com:Philonous/xml-types-pickle.git +[submodule "stringprep-hs"] + path = stringprep-hs + url = git@github.com:Philonous/stringprep-hs.git diff --git a/build.sh b/build.sh index 7e92cce..8029b43 100644 --- a/build.sh +++ b/build.sh @@ -2,6 +2,7 @@ git submodule init git submodule update cabal-dev install ./xml-types-pickle +cabal-dev install ./stringprep-hs cabal-dev install-deps cabal-dev configure cabal-dev build diff --git a/pontarius.cabal b/pontarius.cabal index 947d444..5240d2f 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -49,7 +49,7 @@ Library , xml-conduit -any , xml-types-pickle -any , data-default -any --- , stringprep -any + , stringprep >= 0.1.5 Exposed-modules: Network.XMPP , Network.XMPP.Types , Network.XMPP.SASL diff --git a/stringprep-hs b/stringprep-hs new file mode 160000 index 0000000..7a6ca46 --- /dev/null +++ b/stringprep-hs @@ -0,0 +1 @@ +Subproject commit 7a6ca463b5e6d6636abf266bc9a782ede4e76b06