-- | Password encoding and validation using bcrypt.
--
-- Example usage:
--
-- >>> import Crypto.KDF.BCrypt (hashPassword, validatePassword)
-- >>> import qualified Data.ByteString.Char8 as B
-- >>>
-- >>> let bcryptHash = B.pack "$2a$10$MJJifxfaqQmbx1Mhsq3oq.YmMmfNhkyW4s/MS3K5rIMVfB7w0Q/OW"
-- >>> let password = B.pack "password"
-- >>> validatePassword password bcryptHash
-- >>> True
-- >>> let otherPassword = B.pack "otherpassword"
-- >>> otherHash <- hashPassword 12 otherPassword :: IO B.ByteString
-- >>> validatePassword otherPassword otherHash
-- >>> True
--
-- See <https://www.usenix.org/conference/1999-usenix-annual-technical-conference/future-adaptable-password-scheme>
-- for details of the original algorithm.
--
-- The functions @hashPassword@ and @validatePassword@ should be all that
-- most users need.
--
-- Hashes are strings of the form
-- @$2a$10$MJJifxfaqQmbx1Mhsq3oq.YmMmfNhkyW4s/MS3K5rIMVfB7w0Q/OW@ which
-- encode a version number, an integer cost parameter and the concatenated
-- salt and hash bytes (each separately Base64 encoded. Incrementing the
-- cost parameter approximately doubles the time taken to calculate the hash.
--
-- The different version numbers evolved to account for bugs in the standard
-- C implementations. They don't represent different versions of the algorithm
-- itself and in most cases should produce identical results.
-- The most up to date version is @2b@ and this implementation uses the
-- @2b@ version prefix, but will also attempt to validate
-- against hashes with versions @2a@ and @2y@. Version @2@ or @2x@ will be
-- rejected. No attempt is made to differentiate between the different versions
-- when validating a password, but in practice this shouldn't cause any problems
-- if passwords are UTF-8 encoded (which they should be) and less than 256
-- characters long.
--
-- Only the first 72 bytes of a password are used.  The rest is silently
-- ignored, so two passwords sharing a 72-byte prefix produce the same hash and
-- validate against each other.  That is what the original implementation does
-- and is kept for compatibility, but it means a longer
-- passphrase buys nothing past that point, and the limit is on /bytes/ rather
-- than characters -- a UTF-8 passphrase reaches it sooner than its length in
-- characters suggests.  Where passwords may be longer, hash them to a fixed
-- size first, or use "Crypto.KDF.Argon2" or "Crypto.KDF.Scrypt", which have no
-- such limit.
--
-- The cost parameter can be between 4 and 31 inclusive, but anything less than
-- 10 is probably not strong enough. High values may be prohibitively slow
-- depending on your hardware. Choose the highest value you can without having
-- an unacceptable impact on your users. The cost parameter can also be varied
-- depending on the account, since it is unique to an individual hash.
module Crypto.KDF.BCrypt (
    hashPassword,
    tryHashPassword,
    validatePassword,
    validatePasswordEither,
    bcrypt,
    tryBcrypt,
)
where

import Control.Monad (unless, when)
import Crypto.Cipher.Blowfish.Primitive (bcryptHash)
import Crypto.Error
import Crypto.Random (MonadRandom, getRandomBytes)
import Data.ByteArray (
    ByteArray,
    ByteArrayAccess,
    Bytes,
 )
import qualified Data.ByteArray as B
import Data.ByteArray.Encoding
import Data.Char

data BCryptHash = BCH Char Int Bytes Bytes

-- | Create a bcrypt hash for a password with a provided cost value.
-- Typically used to create a hash when a new user account is registered
-- or when a user changes their password.
--
-- Each increment of the cost approximately doubles the time taken.
-- The 16 bytes of random salt will be generated internally.
--
-- A cost outside 4 to 31 raises 'CryptoError_ParameterInvalid';
-- 'tryHashPassword' reports it instead.
hashPassword
    :: (MonadRandom m, ByteArray password, ByteArray hash)
    => Int
    -- ^ The cost parameter. Must be between 4 and 31 inclusive; anything
    -- else is refused.
    -> password
    -- ^ The password. Should be the UTF-8 encoded bytes of the password text.
    -- Only the first 72 bytes are used; see the module documentation.
    -> m hash
    -- ^ The bcrypt hash in standard format.
hashPassword :: forall (m :: * -> *) password hash.
(MonadRandom m, ByteArray password, ByteArray hash) =>
Int -> password -> m hash
hashPassword Int
cost password
password = CryptoFailable hash -> hash
forall a. CryptoFailable a -> a
throwCryptoError (CryptoFailable hash -> hash) -> m (CryptoFailable hash) -> m hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> password -> m (CryptoFailable hash)
forall (m :: * -> *) password hash.
(MonadRandom m, ByteArray password, ByteArray hash) =>
Int -> password -> m (CryptoFailable hash)
tryHashPassword Int
cost password
password

-- | Create a bcrypt hash for a password with a provided cost value,
-- reporting a cost the implementation refuses rather than raising.
--
-- The salt is generated internally and is always the right length, so the
-- cost is the only thing here that can be wrong.
tryHashPassword
    :: (MonadRandom m, ByteArray password, ByteArray hash)
    => Int
    -- ^ The cost parameter. Must be between 4 and 31 inclusive; anything
    -- else is reported.
    -> password
    -- ^ The password. Should be the UTF-8 encoded bytes of the password text.
    -- Only the first 72 bytes are used; see the module documentation.
    -> m (CryptoFailable hash)
    -- ^ The bcrypt hash in standard format.
tryHashPassword :: forall (m :: * -> *) password hash.
(MonadRandom m, ByteArray password, ByteArray hash) =>
Int -> password -> m (CryptoFailable hash)
tryHashPassword Int
cost password
password = do
    Bytes
salt <- Int -> m Bytes
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
16
    CryptoFailable hash -> m (CryptoFailable hash)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CryptoFailable hash -> m (CryptoFailable hash))
-> CryptoFailable hash -> m (CryptoFailable hash)
forall a b. (a -> b) -> a -> b
$ Int -> Bytes -> password -> CryptoFailable hash
forall salt password output.
(ByteArray salt, ByteArray password, ByteArray output) =>
Int -> salt -> password -> CryptoFailable output
tryBcrypt Int
cost (Bytes
salt :: Bytes) password
password

-- | Create a bcrypt hash for a password with a provided cost value and salt.
--
-- A cost outside 4 to 31, or a salt that is not 16 bytes long, raises
-- 'CryptoError_ParameterInvalid'; 'tryBcrypt' reports the same conditions as
-- 'CryptoFailed'.
bcrypt
    :: (ByteArray salt, ByteArray password, ByteArray output)
    => Int
    -- ^ The cost parameter. Must be between 4 and 31 inclusive; anything
    -- else is refused.
    -> salt
    -- ^ The salt. Must be 16 bytes in length or an error will be raised.
    -> password
    -- ^ The password. Should be the UTF-8 encoded bytes of the password text.
    -- Only the first 72 bytes are used; see the module documentation.
    -> output
    -- ^ The bcrypt hash in standard format.
bcrypt :: forall salt password output.
(ByteArray salt, ByteArray password, ByteArray output) =>
Int -> salt -> password -> output
bcrypt Int
cost salt
salt password
password = CryptoFailable output -> output
forall a. CryptoFailable a -> a
throwCryptoError (Int -> salt -> password -> CryptoFailable output
forall salt password output.
(ByteArray salt, ByteArray password, ByteArray output) =>
Int -> salt -> password -> CryptoFailable output
tryBcrypt Int
cost salt
salt password
password)

-- | Create a bcrypt hash for a password with a provided cost value and salt,
-- reporting a parameter the implementation refuses rather than raising.
--
-- bcrypt is defined for a cost of 4 to 31, and a cost outside that is
-- reported rather than replaced by one inside it: a caller that asks for
-- something this does not do should hear so, not receive a hash at a cost it
-- did not choose.
tryBcrypt
    :: (ByteArray salt, ByteArray password, ByteArray output)
    => Int
    -- ^ The cost parameter. Must be between 4 and 31 inclusive; anything
    -- else is refused.
    -> salt
    -- ^ The salt. Must be 16 bytes in length.
    -> password
    -- ^ The password. Should be the UTF-8 encoded bytes of the password text.
    -- Only the first 72 bytes are used; see the module documentation.
    -> CryptoFailable output
    -- ^ The bcrypt hash in standard format.
tryBcrypt :: forall salt password output.
(ByteArray salt, ByteArray password, ByteArray output) =>
Int -> salt -> password -> CryptoFailable output
tryBcrypt Int
cost salt
salt password
password
    | Int
cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 Bool -> Bool -> Bool
|| Int
cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
31 = CryptoError -> CryptoFailable output
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_ParameterInvalid
    | salt -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length salt
salt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
16 = CryptoError -> CryptoFailable output
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_ParameterInvalid
    | Bool
otherwise =
        output -> CryptoFailable output
forall a. a -> CryptoFailable a
CryptoPassed (output -> CryptoFailable output)
-> output -> CryptoFailable output
forall a b. (a -> b) -> a -> b
$
            [salt] -> output
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
[bin] -> bout
B.concat [salt
header, salt -> Word8 -> salt
forall a. ByteArray a => a -> Word8 -> a
B.snoc salt
costBytes Word8
dollar, salt -> salt
forall ba. ByteArray ba => ba -> ba
b64 salt
salt, salt -> salt
forall ba. ByteArray ba => ba -> ba
b64 salt
hash]
  where
    hash :: salt
hash = Char -> Int -> salt -> password -> salt
forall salt password output.
(ByteArrayAccess salt, ByteArray password, ByteArray output) =>
Char -> Int -> salt -> password -> output
rawHash Char
'b' Int
cost salt
salt password
password
    header :: salt
header = [Word8] -> salt
forall a. ByteArray a => [Word8] -> a
B.pack [Word8
dollar, Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'2'), Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'b'), Word8
dollar]
    dollar :: Word8
dollar = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'$')
    zero :: Word8
zero = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'0')
    costBytes :: salt
costBytes =
        [Word8] -> salt
forall a. ByteArray a => [Word8] -> a
B.pack
            [ Word8
zero Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
cost Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10)
            , Word8
zero Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
cost Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10)
            ]

    b64 :: ByteArray ba => ba -> ba
    b64 :: forall ba. ByteArray ba => ba -> ba
b64 = Base -> ba -> ba
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64OpenBSD

-- | Check a password against a stored bcrypt hash when authenticating a user.
--
-- Returns @False@ if the password doesn't match the hash, or if the hash is
-- invalid or an unsupported version.
--
-- Only the first 72 bytes of the password are compared; see the module
-- documentation.
validatePassword
    :: (ByteArray password, ByteArray hash) => password -> hash -> Bool
validatePassword :: forall password hash.
(ByteArray password, ByteArray hash) =>
password -> hash -> Bool
validatePassword password
password hash
bcHash = (String -> Bool) -> (Bool -> Bool) -> Either String Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False) Bool -> Bool
forall a. a -> a
id (password -> hash -> Either String Bool
forall password hash.
(ByteArray password, ByteArray hash) =>
password -> hash -> Either String Bool
validatePasswordEither password
password hash
bcHash)

-- | Check a password against a bcrypt hash
--
-- As for @validatePassword@ but will provide error information if the hash is invalid or
-- an unsupported version.  The same 72-byte limit applies.
validatePasswordEither
    :: (ByteArray password, ByteArray hash) => password -> hash -> Either String Bool
validatePasswordEither :: forall password hash.
(ByteArray password, ByteArray hash) =>
password -> hash -> Either String Bool
validatePasswordEither password
password hash
bcHash = do
    BCH Char
version Int
cost Bytes
salt Bytes
hash <- hash -> Either String BCryptHash
forall ba. ByteArray ba => ba -> Either String BCryptHash
parseBCryptHash hash
bcHash
    Bool -> Either String Bool
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either String Bool) -> Bool -> Either String Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Int -> Bytes -> password -> Bytes
forall salt password output.
(ByteArrayAccess salt, ByteArray password, ByteArray output) =>
Char -> Int -> salt -> password -> output
rawHash Char
version Int
cost Bytes
salt password
password :: Bytes) Bytes -> Bytes -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
`B.constEq` Bytes
hash

rawHash
    :: (ByteArrayAccess salt, ByteArray password, ByteArray output)
    => Char -> Int -> salt -> password -> output
rawHash :: forall salt password output.
(ByteArrayAccess salt, ByteArray password, ByteArray output) =>
Char -> Int -> salt -> password -> output
rawHash Char
_ Int
cost salt
salt password
password = case Int -> salt -> Bytes -> Maybe output
forall salt key output.
(ByteArrayAccess salt, ByteArrayAccess key, ByteArray output) =>
Int -> salt -> key -> Maybe output
bcryptHash Int
cost salt
salt Bytes
key of
    Just output
hash -> Int -> output -> output
forall bs. ByteArray bs => Int -> bs -> bs
B.take Int
23 output
hash -- Another compatibility bug. Ignore last byte of hash
    Maybe output
Nothing -> String -> output
forall a. HasCallStack => String -> a
error String
"bcrypt: the cost or the salt is not one bcrypt takes"
  where
    -- Truncate the password if necessary and append a null byte for C compatibility
    key :: Bytes
key = Bytes -> Word8 -> Bytes
forall a. ByteArray a => a -> Word8 -> a
B.snoc (Int -> Bytes -> Bytes
forall bs. ByteArray bs => Int -> bs -> bs
B.take Int
72 (password -> Bytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
B.convert password
password :: Bytes)) Word8
0

-- "$2a$10$XajjQvNhvvRt5GSeFk1xFeyqRrsxkhBkUiQeg0dt.wU1qD4aFDcga"
parseBCryptHash :: ByteArray ba => ba -> Either String BCryptHash
parseBCryptHash :: forall ba. ByteArray ba => ba -> Either String BCryptHash
parseBCryptHash ba
bc = do
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        ( ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
bc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
60
            Bool -> Bool -> Bool
&& ba -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
dollar
            Bool -> Bool -> Bool
&& ba -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'2')
            Bool -> Bool -> Bool
&& ba -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
3 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
dollar
            Bool -> Bool -> Bool
&& ba -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
6 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
dollar
        )
        (String -> Either String ()
forall a b. a -> Either a b
Left String
"Invalid hash format")
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (Char
version Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'b' Bool -> Bool -> Bool
|| Char
version Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'a' Bool -> Bool -> Bool
|| Char
version Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'y')
        (String -> Either String ()
forall a b. a -> Either a b
Left (String
"Unsupported minor version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
version]))
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
costTens Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3 Bool -> Bool -> Bool
|| Int
cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
31 Bool -> Bool -> Bool
|| Int
cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4) (String -> Either String ()
forall a b. a -> Either a b
Left String
"Invalid bcrypt cost")
    (Bytes
salt, Bytes
hash) <- ba -> Either String (Bytes, Bytes)
forall {a} {b} {bin}.
(ByteArray a, ByteArray b, ByteArray bin) =>
bin -> Either String (a, b)
decodeSaltHash (Int -> ba -> ba
forall bs. ByteArray bs => Int -> bs -> bs
B.drop Int
7 ba
bc)
    BCryptHash -> Either String BCryptHash
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Int -> Bytes -> Bytes -> BCryptHash
BCH Char
version Int
cost Bytes
salt Bytes
hash)
  where
    dollar :: Word8
dollar = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'$')
    zero :: Int
zero = Char -> Int
ord Char
'0'
    costTens :: Int
costTens = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ba -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
4) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
zero
    costUnits :: Int
costUnits = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ba -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
5) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
zero
    version :: Char
version = Int -> Char
chr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ba -> Int -> Word8
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
2))
    cost :: Int
cost = Int
costUnits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
costTens :: Int

    decodeSaltHash :: bin -> Either String (a, b)
decodeSaltHash bin
saltHash = do
        let (bin
s, bin
h) = Int -> bin -> (bin, bin)
forall bs. ByteArray bs => Int -> bs -> (bs, bs)
B.splitAt Int
22 bin
saltHash
        a
salt <- Base -> bin -> Either String a
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64OpenBSD bin
s
        b
hash <- Base -> bin -> Either String b
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64OpenBSD bin
h
        (a, b) -> Either String (a, b)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
salt, b
hash)