add sha1 and sha2-512 scram

src/Client/Authentication/Scram.hs

@@ -12,21 +12,39 @@ module Client.Authentication.Scram (
   initiateScram,
   addServerFirst,
   addServerFinal,
+  -- * Digests
+  ScramDigest(..),
+  mechanismName,
   ) where
 
-import Control.Monad ( guard )
-import Data.Bits ( xor )
+import Control.Monad (guard)
+import Data.Bits (xor)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
 import Data.ByteString.Base64 qualified as B64
 import Data.ByteString.Char8 qualified as B8
-import Data.List ( foldl1' )
-import OpenSSL.EVP.Digest ( Digest, digestBS, hmacBS )
+import Data.List (foldl1')
+import Data.Text (Text)
+import OpenSSL.EVP.Digest ( Digest, digestBS, hmacBS, getDigestByName)
 import Irc.Commands (AuthenticatePayload (AuthenticatePayload))
+import System.IO.Unsafe (unsafePerformIO)
+
+data ScramDigest
+  = ScramDigestSha1
+  | ScramDigestSha2_256
+  | ScramDigestSha2_512
+  deriving Show
+
+mechanismName :: ScramDigest -> Text
+mechanismName digest =
+  case digest of
+    ScramDigestSha1     -> "SCRAM-SHA-1"
+    ScramDigestSha2_256 -> "SCRAM-SHA-256"
+    ScramDigestSha2_512 -> "SCRAM-SHA-512"
 
 -- | SCRAM state waiting for server-first-message
 data Phase1 = Phase1
-  { phase1Digest          :: Digest     -- ^ underlying cryptographic hash function
+  { phase1Digest          :: ScramDigest -- ^ underlying cryptographic hash function
   , phase1Password        :: ByteString -- ^ password
   , phase1CbindInput      :: ByteString -- ^ cbind-input
   , phase1Nonce           :: ByteString -- ^ c-nonce
@@ -36,7 +54,7 @@ data Phase1 = Phase1
 -- | Construct client-first-message and extra parameters
 -- needed for 'addServerFirst'.
 initiateScram ::
-  Digest ->
+  ScramDigest ->
   ByteString {- ^ authentication ID -} ->
   ByteString {- ^ authorization ID  -} ->
   ByteString {- ^ password          -} ->
@@ -134,7 +152,7 @@ parseMessage msg =
 -- | Tranform all the SCRAM parameters into a @ClientProof@
 -- and @ServerSignature@.
 crypto ::
-  Digest      {- ^ digest       -} ->
+  ScramDigest {- ^ digest       -} ->
   ByteString  {- ^ password     -} ->
   ByteString  {- ^ salt         -} ->
   Int         {- ^ iterations   -} ->
@@ -143,13 +161,19 @@ crypto ::
 crypto digest password salt iterations authMessage =
   (clientProof, serverSignature)
   where
-    saltedPassword  = hi       digest password salt iterations
-    clientKey       = hmacBS   digest saltedPassword "Client Key"
-    storedKey       = digestBS digest clientKey
-    clientSignature = hmacBS   digest storedKey authMessage
+    saltedPassword  = hi       d password salt iterations
+    clientKey       = hmacBS   d saltedPassword "Client Key"
+    storedKey       = digestBS d clientKey
+    clientSignature = hmacBS   d storedKey authMessage
     clientProof     = xorBS clientKey clientSignature
-    serverKey       = hmacBS   digest saltedPassword "Server Key"
-    serverSignature = hmacBS   digest serverKey authMessage
+    serverKey       = hmacBS   d saltedPassword "Server Key"
+    serverSignature = hmacBS   d serverKey authMessage
+    digestName =
+      case digest of
+        ScramDigestSha1     -> "SHA1"
+        ScramDigestSha2_256 -> "SHA256"
+        ScramDigestSha2_512 -> "SHA512"
+    Just d = unsafePerformIO (getDigestByName digestName)
 
 -- | Encode usersnames so they fit in the comma/equals delimited
 -- SCRAM message format.

src/Client/Configuration/ServerSettings.hs

@@ -81,6 +81,7 @@ module Client.Configuration.ServerSettings
   , getRegex
   ) where
 
+import           Client.Authentication.Scram (ScramDigest(..))
 import           Client.Commands.Interpolation
 import           Client.Commands.WordCompletion
 import           Client.Configuration.Macros (macroCommandSpec)
@@ -157,7 +158,7 @@ data SaslMechanism
   = SaslPlain    (Maybe Text) Text Secret -- ^ SASL PLAIN RFC4616 - authzid authcid password
   | SaslEcdsa    (Maybe Text) Text FilePath -- ^ SASL NIST - https://github.com/kaniini/ecdsatool - authzid keypath
   | SaslExternal (Maybe Text)      -- ^ SASL EXTERNAL RFC4422 - authzid
-  | SaslScram    (Maybe Text) Text Secret -- ^ SASL SCRAM-SHA-256 RFC7677 - authzid authcid password
+  | SaslScram    ScramDigest (Maybe Text) Text Secret -- ^ SASL SCRAM-SHA-256 RFC7677 - authzid authcid password
   deriving Show
 
 -- | Regular expression matched with original source to help with debugging.
@@ -381,9 +382,19 @@ saslMechanismSpec = plain <!> external <!> ecdsa <!> scram
       authzid <*> username <*>
       reqSection' "private-key" filepathSpec "Private key file"
 
+    scramDigest =
+      fromMaybe ScramDigestSha2_256 <$>
+      optSection' "digest" scramDigests "Underlying digest function"
+
+    scramDigests =
+      ScramDigestSha1     <$ atomSpec "sha1" <!>
+      ScramDigestSha2_256 <$ atomSpec "sha2-256" <!>
+      ScramDigestSha2_512 <$ atomSpec "sha2-512"
+
     scram =
       sectionsSpec "sasl-scram" $
       SaslScram <$ mech "scram" <*>
+      scramDigest <*>
       authzid <*> username <*> reqSection "password" "Password"
 
 

src/Client/State/Network.hs

@@ -114,8 +114,6 @@ import           Irc.RawIrcMsg
 import           Irc.UserInfo
 import           LensUtils
 import qualified System.Random as Random
-import OpenSSL.EVP.Digest (getDigestByName)
-import System.IO.Unsafe ( unsafePerformIO )
 import qualified Data.ByteString.Base64 as B64
 
 -- | State tracked for each IRC connection
@@ -812,8 +810,7 @@ doAuthenticate param cs =
 
     AS_ScramStarted
       | "+" <- param
-      , Just digest <- unsafePerformIO (getDigestByName "SHA256")
-      , Just (SaslScram mbAuthz user (SecretText pass))
+      , Just (SaslScram digest mbAuthz user (SecretText pass))
           <- view ssSaslMechanism ss
       , let authz = fromMaybe "" mbAuthz
       , (nonce, cs') <- cs & csSeed %%~ scramNonce
@@ -897,8 +894,8 @@ doCap cmd cs =
           SaslExternal{} ->
             reply [ircAuthenticate "EXTERNAL"]
                   (set csAuthenticationState AS_ExternalStarted cs)
-          SaslScram{} ->
-            reply [ircAuthenticate "SCRAM-SHA-256"]
+          SaslScram digest _ _ _ ->
+            reply [ircAuthenticate (Scram.mechanismName digest)]
                   (set csAuthenticationState AS_ScramStarted cs)
 
     _ -> reply [ircCapEnd] cs