refactor digestMd5 to move common functionality to module Common

source/Network/Xmpp/Sasl/Common.hs

@@ -9,13 +9,20 @@ import           Control.Monad.Error
 
 import qualified Data.Attoparsec.ByteString.Char8 as AP
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
 import           Data.Maybe (fromMaybe)
 import           Data.Maybe (maybeToList)
 import           Data.Text
+import qualified Data.Text.Encoding as Text
 import           Data.XML.Pickle
 import           Data.XML.Types
 
+import           Network.Xmpp.Monad
 import           Network.Xmpp.Pickle
+import           Network.Xmpp.Sasl.Types
+
+data SaslElement = SaslSuccess
+                 | SaslChallenge (Maybe Text)
 
 -- The <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element, with an
 -- optional round-trip value.
@@ -26,22 +33,18 @@ saslInitE mechanism rt =
         (maybeToList $ NodeContent . ContentText <$> rt)
 
 -- SASL response with text payload.
-saslResponseE :: Text -> Element
+saslResponseE :: Maybe Text -> Element
 saslResponseE resp =
     Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
     []
-    [NodeContent $ ContentText resp]
+    (maybeToList $ NodeContent . ContentText <$> resp)
 
--- SASL response without payload.
-saslResponse2E :: Element
-saslResponse2E =
-    Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
-    []
-    []
+xpSuccess :: PU [Node] ()
+xpSuccess = xpElemBlank "{urn:ietf:params:xml:ns:xmpp-sasl}success"
 
 -- Parses the incoming SASL data to a mapped list of pairs.
-toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
-toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
+pairs :: BS.ByteString -> Either String Pairs
+pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
     AP.skipSpace
     name <- AP.takeWhile1 (/= '=')
     _ <- AP.char '='
@@ -51,8 +54,8 @@ toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
     return (name, content)
 
 -- Failure element pickler.
-failurePickle :: PU [Node] SaslFailure
-failurePickle = xpWrap
+xpFailure :: PU [Node] SaslFailure
+xpFailure = xpWrap
     (\(txt, (failure, _, _)) -> SaslFailure failure txt)
     (\(SaslFailure failure txt) -> (txt,(failure,(),())))
     (xpElemNodes
@@ -68,6 +71,54 @@ failurePickle = xpWrap
              (xpUnit)
              (xpUnit))))
 -- Challenge element pickler.
-challengePickle :: PU [Node] Text
-challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
-                      (xpIsolate $ xpContent xpId)
+xpChallenge :: PU [Node] (Maybe Text)
+xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
+                      (xpOption $ xpContent xpId)
+
+xpSaslElement = xpAlt saslSel
+                [ xpWrap (const SaslSuccess) (const ())          xpSuccess
+                , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge
+                ]
+  where
+    saslSel SaslSuccess       = 0
+    saslSel (SaslChallenge _) = 1
+
+quote :: BS.ByteString -> BS.ByteString
+quote x = BS.concat ["\"",x,"\""]
+
+saslInit :: Text -> Maybe Text -> SaslM Bool
+saslInit mechanism payload = lift . pushElement $ saslInitE mechanism payload
+
+pullSaslElement :: SaslM SaslElement
+pullSaslElement = do
+    el <- lift $ pullPickle (xpEither xpFailure xpSaslElement)
+    case el of
+        Left e ->throwError $ AuthSaslFailure e
+        Right r -> return r
+
+pullChallenge :: SaslM (Maybe Text)
+pullChallenge = do
+  e <- pullSaslElement
+  case e of
+      SaslChallenge sc -> return sc
+      _ -> throwError AuthChallengeError
+
+saslFromJust :: Maybe a -> SaslM a
+saslFromJust Nothing = throwError $ AuthChallengeError
+saslFromJust (Just d) = return d
+
+pullSuccess :: SaslM ()
+pullSuccess = do
+    e <- pullSaslElement
+    case e of
+        SaslSuccess -> return ()
+        _ -> throwError $ AuthXmlError
+
+toPairs :: Text -> SaslM Pairs
+toPairs ctext = case pairs <=< B64.decode . Text.encodeUtf8 $ ctext of
+    Left _e -> throwError AuthChallengeError
+    Right r -> return r
+
+respond :: Maybe Text -> SaslM Bool
+respond = lift . pushElement . saslResponseE
+

source/Network/Xmpp/Sasl/DigestMD5.hs

@@ -36,9 +36,11 @@ import           Network.Xmpp.Pickle
 
 import qualified System.Random as Random
 
-import Network.Xmpp.Sasl.Sasl
+import Network.Xmpp.Sasl.Common
 import Network.Xmpp.Sasl.Types
 
+
+
 xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid)
                -> Text -- Authentication identity (authzid)
                -> Text -- Password (authzid)
@@ -47,38 +49,26 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do
     realm <- gets sHostname
     case realm of
         Just realm' -> do
-            ErrorT $ xmppDigestMD5' realm'
+            xmppDigestMD5' realm'
             -- TODO: Save authzid
             modify (\s -> s{sUsername = Just authcid})
         Nothing -> throwError AuthConnectionError
   where
     xmppDigestMD5' :: Text -- ^ SASL realm
-                    -> XmppConMonad (Either AuthError ())
-    xmppDigestMD5' realm = runErrorT $ do
-        -- Push element and receive the challenge (in XmppConMonad).
-        _ <- lift . pushElement $ saslInitE "DIGEST-MD5" Nothing -- TODO: Check boolean?
-        challenge' <- lift $ B64.decode . Text.encodeUtf8 <$>
-            pullPickle challengePickle
-        challenge <- case challenge' of
-            Left _e -> throwError AuthChallengeError
-            Right r -> return r
-        pairs <- case toPairs challenge of
-            Left _ -> throwError AuthChallengeError
-            Right p -> return p
+                    -> SaslM ()
+    xmppDigestMD5' realm = do
+        -- Push element and receive the challenge (in SaslM).
+        _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?
+        pairs <- toPairs =<< saslFromJust =<< pullChallenge
         g <- liftIO Random.newStdGen
-        _ <- lift . pushElement . -- TODO: Check boolean?
-            saslResponseE $ createResponse g realm pairs
-        challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle)
+        _b <- respond . Just $ createResponse g realm pairs
+        challenge2 <- pullSaslElement
         case challenge2 of
-            Left _x -> throwError AuthXmlError
-            Right _ -> return ()
-        lift $ pushElement saslResponse2E
-        e <- lift pullElement
-        case e of
-            Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] ->
-                return ()
-            _ -> throwError AuthXmlError -- TODO: investigate
-        -- The SASL authentication has succeeded; the stream is restarted.
+            SaslSuccess -> return ()
+            SaslChallenge Nothing -> do
+                _b <- respond Nothing
+                pullSuccess
+            _ -> throwError AuthChallengeError
         _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
         return ()
     -- Produce the response to the challenge.
@@ -121,8 +111,6 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do
                         , ["charset"   ,       "utf-8"  ]
                         ]
         in Text.decodeUtf8 $ B64.encode response
-    quote :: BS8.ByteString -> BS8.ByteString
-    quote x = BS.concat ["\"",x,"\""]
     toWord8 :: Int -> Word8
     toWord8 x = fromIntegral x :: Word8
     hash :: [BS8.ByteString] -> BS8.ByteString

source/Network/Xmpp/Sasl/Types.hs

@@ -1,8 +1,10 @@
 module Network.Xmpp.Sasl.Types where
 
-import           Control.Monad.Error
-import           Data.Text
-import           Network.Xmpp.Types
+import Control.Monad.Error
+import Control.Monad.State.Strict
+import Data.Text
+import Network.Xmpp.Types
+import Data.ByteString(ByteString)
 
 data AuthError = AuthXmlError
                | AuthMechanismError [Text] -- ^ Wraps mechanisms offered
@@ -10,7 +12,12 @@ data AuthError = AuthXmlError
                | AuthStreamError StreamError -- ^ Stream error on stream restart
                | AuthConnectionError -- ^ No host name set in state
                | AuthError -- General instance used for the Error instance
+               | AuthSaslFailure SaslFailure -- ^ defined SASL error condition
                  deriving Show
 
 instance Error AuthError where
     noMsg = AuthError
+
+type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a
+
+type Pairs = [(ByteString, ByteString)]