miscellaneous sasl changes

stopped wrapping passwd in a SaslM computation for the time-being
SaslHandler now takes password and does not take hostname
minor formatting and documentation changes
runSasl where-local
SaslElement moved to Sasl/Types.hs

source/Network/Xmpp.hs

@@ -179,7 +179,7 @@ auth  :: Text.Text  -- ^ The username
                     -- assign one
       -> XmppConMonad (Either AuthError Text.Text)
 auth username passwd resource = runErrorT $ do
-        ErrorT $ xmppSasl username Nothing [scramSha1 $ return passwd]
+        ErrorT $ xmppSasl username Nothing passwd [scramSha1]
         res <- lift $ xmppBind resource
-        lift $ xmppStartSession
+        lift xmppStartSession
         return res

source/Network/Xmpp/Sasl.hs

@@ -34,38 +34,34 @@ import Network.Xmpp.Sasl.DigestMD5
 import Network.Xmpp.Sasl.Plain
 import Network.Xmpp.Sasl.Types
 
-
-runSasl :: (Text.Text -> Text.Text -> Maybe Text.Text -> SaslM a)
-        -> Text.Text
-        -> Maybe Text.Text
-        -> XmppConMonad (Either AuthError a)
-runSasl authAction authcid authzid = runErrorT $ do
-    hn <- gets sHostname
-    case hn of
-        Just hn' -> do
-            r <- authAction hn' authcid authzid
-            modify (\s -> s{ sUsername = Just authcid
-                           , sAuthzid = authzid
-                           })
-            _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
-            return r
-        Nothing -> throwError AuthConnectionError
-
 -- Uses the first supported mechanism to authenticate, if any. Updates the
 -- XmppConMonad state with non-password credentials and restarts the stream upon
 -- success. This computation wraps an ErrorT computation, which means that
 -- catchError can be used to catch any errors.
-xmppSasl :: Text.Text
+xmppSasl :: Text.Text -- ^ Authentication identity (user name)
-         -> Maybe Text.Text
+         -> Maybe Text.Text -- ^ Authorization identity
+         -> Text.Text -- ^ Password
          -> [SaslHandler] -- ^ Acceptable authentication
                                         -- mechanisms and their corresponding
                                         -- handlers
          -> XmppConMonad (Either AuthError ())
-xmppSasl authcid authzid handlers = do
+xmppSasl authcid authzid passwd handlers = do
     -- Chooses the first mechanism that is acceptable by both the client and the
     -- server.
     mechanisms <- gets $ saslMechanisms . sFeatures
     case (filter (\(name, _) -> name `elem` mechanisms)) handlers of
         [] -> return . Left $ AuthNoAcceptableMechanism mechanisms
-        (_name, handler):_ -> runSasl handler authcid authzid
+        (_name, handler):_ -> runSasl handler authcid authzid passwd
-
+  where
+    runSasl :: (Text.Text -> Maybe Text.Text -> Text.Text -> SaslM a)
+            -> Text.Text
+            -> Maybe Text.Text
+            -> Text.Text
+            -> XmppConMonad (Either AuthError a)
+    runSasl authAction authcid authzid passwd = runErrorT $ do
+        r <- authAction authcid authzid passwd
+        modify (\s -> s{ sUsername = Just authcid
+                       , sAuthzid = authzid
+                       })
+        _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
+        return r

source/Network/Xmpp/Sasl/Common.hs

@@ -26,9 +26,6 @@ import           Network.Xmpp.Sasl.Types
 
 import qualified System.Random as Random
 
-data SaslElement = SaslSuccess   (Maybe Text.Text)
-                 | SaslChallenge (Maybe Text.Text)
-
 --makeNonce :: SaslM BS.ByteString
 makeNonce :: IO BS.ByteString
 makeNonce = do
@@ -53,6 +50,7 @@ saslResponseE resp =
     []
     (maybeToList $ NodeContent . ContentText <$> resp)
 
+-- The <success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element.
 xpSuccess :: PU [Node] (Maybe Text.Text)
 xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success"
     (xpOption $ xpContent xpId)
@@ -91,7 +89,7 @@ xpChallenge :: PU [Node] (Maybe Text.Text)
 xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
                       (xpOption $ xpContent xpId)
 
--- | pickler for SaslElement
+-- | Pickler for SaslElement.
 xpSaslElement :: PU [Node] SaslElement
 xpSaslElement = xpAlt saslSel
                 [ xpWrap SaslSuccess   (\(SaslSuccess x)   -> x) xpSuccess
@@ -101,7 +99,7 @@ xpSaslElement = xpAlt saslSel
     saslSel (SaslSuccess   _) = 0
     saslSel (SaslChallenge _) = 1
 
--- | Add quotationmarks around a byte string
+-- | Add quotationmarks around a byte string.
 quote :: BS.ByteString -> BS.ByteString
 quote x = BS.concat ["\"",x,"\""]
 
@@ -109,7 +107,7 @@ saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool
 saslInit mechanism payload = lift . pushElement . saslInitE mechanism $
                                Text.decodeUtf8 . B64.encode <$> payload
 
--- | Pull the next element
+-- | Pull the next element.
 pullSaslElement :: SaslM SaslElement
 pullSaslElement = do
     el <- lift $ pullPickle (xpEither xpFailure xpSaslElement)
@@ -117,7 +115,7 @@ pullSaslElement = do
         Left e ->throwError $ AuthSaslFailure e
         Right r -> return r
 
--- | Pull the next element, checking that it is a challenge
+-- | Pull the next element, checking that it is a challenge.
 pullChallenge :: SaslM (Maybe BS.ByteString)
 pullChallenge = do
   e <- pullSaslElement
@@ -128,12 +126,12 @@ pullChallenge = do
              -> return $ Just sc
       _ -> throwError AuthChallengeError
 
--- | Extract value from Just, failing with AuthChallengeError on Nothing
+-- | Extract value from Just, failing with AuthChallengeError on Nothing.
 saslFromJust :: Maybe a -> SaslM a
 saslFromJust Nothing = throwError $ AuthChallengeError
 saslFromJust (Just d) = return d
 
--- | Pull the next element and check that it is success
+-- | Pull the next element and check that it is success.
 pullSuccess :: SaslM (Maybe Text.Text)
 pullSuccess = do
     e <- pullSaslElement
@@ -142,7 +140,7 @@ pullSuccess = do
         _ -> throwError $ AuthXmlError
 
 -- | Pull the next element. When it's success, return it's payload.
--- If it's a challenge, send an empty response and pull success
+-- If it's a challenge, send an empty response and pull success.
 pullFinalMessage :: SaslM (Maybe BS.ByteString)
 pullFinalMessage = do
     challenge2 <- pullSaslElement
@@ -158,14 +156,13 @@ pullFinalMessage = do
         Left _e -> throwError $ AuthChallengeError
         Right x -> return $ Just x
 
--- | Extract p=q pairs from a challenge
+-- | Extract p=q pairs from a challenge.
 toPairs :: BS.ByteString -> SaslM Pairs
 toPairs ctext = case pairs ctext of
     Left _e -> throwError AuthChallengeError
     Right r -> return r
 
--- | Send a SASL response element. The content will be base64-encoded  for you
+-- | Send a SASL response element. The content will be base64-encoded.
 respond :: Maybe BS.ByteString -> SaslM Bool
 respond = lift . pushElement . saslResponseE .
     fmap (Text.decodeUtf8 . B64.encode)
-

source/Network/Xmpp/Sasl/Plain.hs

@@ -46,32 +46,27 @@ import Network.Xmpp.Sasl.Common
 import Network.Xmpp.Sasl.Types
 
 -- TODO: stringprep
-xmppPlain :: SaslM Text.Text
+xmppPlain :: Text.Text -- ^ Password
-          -> a
+          -> Maybe Text.Text -- ^ Authorization identity (authzid)
-          -> Text.Text
+          -> Text.Text -- ^ Authentication identity (authcid)
-          -> Maybe Text.Text
           -> SaslM ()
-xmppPlain pw _hostname authcid authzid  = do
+xmppPlain passwd authzid authcid = do
-    passwd <- pw
+    _ <- saslInit "PLAIN" (Just $ plainMessage passwd)
-    _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd)
     _ <- pullSuccess
     return ()
   where
     -- Converts an optional authorization identity, an authentication identity,
     -- and a password to a \NUL-separated PLAIN message.
-    plainMessage :: Maybe Text.Text -- Authorization identity (authzid)
+    plainMessage :: Text.Text -> BS.ByteString
-                 -> Text.Text -- Authentication identity (authcid)
+    plainMessage passwd = BS.concat
-                 -> Text.Text -- Password
-                 -> BS.ByteString -- The PLAIN message
-    plainMessage authzid authcid passwd = BS.concat $
         [ authzid'
         , "\NUL"
-                                            , Text.encodeUtf8 $ authcid
+        , Text.encodeUtf8 authcid
         , "\NUL"
-                                            , Text.encodeUtf8 $ passwd
+        , Text.encodeUtf8 passwd
         ]
       where
         authzid' = maybe "" Text.encodeUtf8 authzid
 
-plain :: SaslM Text.Text -> SaslHandler
+plain :: SaslHandler
-plain passwd = ("PLAIN", xmppPlain passwd)
+plain = ("PLAIN", xmppPlain)

source/Network/Xmpp/Sasl/Scram.hs

@@ -170,9 +170,5 @@ hashToken :: (Crypto.Hash ctx hash) => hash
 hashToken = undefined
 
 -- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler.
-scramSha1 :: SaslM Text.Text -> SaslHandler
+scramSha1 :: SaslHandler
-scramSha1 passwd = ("SCRAM-SHA-1"
+scramSha1 = ("SCRAM-SHA-1", scram (hashToken :: Crypto.SHA1))
-                   , \_hostname authcid authzid -> do
-                         pw <- passwd
-                         scram (hashToken :: Crypto.SHA1) authcid authzid pw
-                   )

source/Network/Xmpp/Sasl/Types.hs

@@ -11,21 +11,29 @@ data AuthError = AuthXmlError
                                                        -- offered
                | AuthChallengeError
                | AuthServerAuthError -- ^ The server failed to authenticate
-                                     -- himself
+                                     -- itself
                | AuthStreamError StreamError -- ^ Stream error on stream restart
+               -- TODO: Rename AuthConnectionError?
                | AuthConnectionError -- ^ No host name set in state
                | AuthError -- General instance used for the Error instance
-               | AuthSaslFailure SaslFailure -- ^ defined SASL error condition
+               | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition
                  deriving Show
 
 instance Error AuthError where
     noMsg = AuthError
 
+data SaslElement = SaslSuccess   (Maybe Text.Text)
+                 | SaslChallenge (Maybe Text.Text)
+
+-- | SASL mechanism XmppConnection computation, with the possibility of throwing
+-- an authentication error.
 type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a
 
 type Pairs = [(ByteString, ByteString)]
 
-type SaslHandler = (Text.Text, Text.Text
+-- | Tuple defining the SASL Handler's name, and a SASL mechanism computation
-                               -> Text.Text
+-- taking an authentication identity, an optional authorization identity, and a
-                               -> Maybe Text.Text
+-- password.
-                               -> SaslM ())
+type SaslHandler = ( Text.Text,
+                     Text.Text -> Maybe Text.Text -> Text.Text -> SaslM ()
+                   )