|
|
|
@ -39,29 +39,29 @@ import Network.Xmpp.Sasl.Types |
|
|
|
-- XmppConMonad state with non-password credentials and restarts the stream upon |
|
|
|
-- XmppConMonad state with non-password credentials and restarts the stream upon |
|
|
|
-- success. This computation wraps an ErrorT computation, which means that |
|
|
|
-- success. This computation wraps an ErrorT computation, which means that |
|
|
|
-- catchError can be used to catch any errors. |
|
|
|
-- catchError can be used to catch any errors. |
|
|
|
xmppSASL :: [SASLCredentials] -- ^ Acceptable authentication mechanisms and |
|
|
|
xmppSasl :: [SaslCredentials] -- ^ Acceptable authentication mechanisms and |
|
|
|
-- their corresponding credentials |
|
|
|
-- their corresponding credentials |
|
|
|
-> XmppConMonad (Either AuthError ()) |
|
|
|
-> XmppConMonad (Either AuthError ()) |
|
|
|
xmppSASL creds = runErrorT $ do |
|
|
|
xmppSasl creds = runErrorT $ do |
|
|
|
-- Chooses the first mechanism that is acceptable by both the client and the |
|
|
|
-- Chooses the first mechanism that is acceptable by both the client and the |
|
|
|
-- server. |
|
|
|
-- server. |
|
|
|
mechanisms <- gets $ saslMechanisms . sFeatures |
|
|
|
mechanisms <- gets $ saslMechanisms . sFeatures |
|
|
|
let cred = L.find (\cred -> credsToName cred `elem` mechanisms) creds |
|
|
|
let cred = L.find (\cred -> credsToName cred `elem` mechanisms) creds |
|
|
|
unless (isJust cred) (throwError $ AuthMechanismError mechanisms) |
|
|
|
unless (isJust cred) (throwError $ AuthMechanismError mechanisms) |
|
|
|
case fromJust cred of |
|
|
|
case fromJust cred of |
|
|
|
DIGEST_MD5Credentials authzid authcid passwd -> ErrorT $ xmppDigestMD5 |
|
|
|
DigestMD5Credentials authzid authcid passwd -> ErrorT $ xmppDigestMD5 |
|
|
|
authzid |
|
|
|
authzid |
|
|
|
authcid |
|
|
|
authcid |
|
|
|
passwd |
|
|
|
passwd |
|
|
|
PLAINCredentials authzid authcid passwd -> ErrorT $ xmppPLAIN |
|
|
|
PlainCredentials authzid authcid passwd -> ErrorT $ xmppPLAIN |
|
|
|
authzid |
|
|
|
authzid |
|
|
|
authcid |
|
|
|
authcid |
|
|
|
passwd |
|
|
|
passwd |
|
|
|
_ -> error "xmppSASL: Mechanism not caught" |
|
|
|
_ -> error "xmppSasl: Mechanism not caught" |
|
|
|
where |
|
|
|
where |
|
|
|
-- Converts the credentials to the appropriate mechanism name, corresponding to |
|
|
|
-- Converts the credentials to the appropriate mechanism name, corresponding to |
|
|
|
-- the XMPP mechanism attribute. |
|
|
|
-- the XMPP mechanism attribute. |
|
|
|
credsToName :: SASLCredentials -> Text |
|
|
|
credsToName :: SaslCredentials -> Text |
|
|
|
credsToName (DIGEST_MD5Credentials _ _ _) = "DIGEST-MD5" |
|
|
|
credsToName (DigestMD5Credentials _ _ _) = "DIGEST-MD5" |
|
|
|
credsToName (PLAINCredentials _ _ _) = "PLAIN" |
|
|
|
credsToName (PlainCredentials _ _ _) = "PLAIN" |
|
|
|
credsToName c = error $ "credsToName failed for " ++ (show c) |
|
|
|
credsToName c = error $ "credsToName failed for " ++ (show c) |