-- | 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.
--
-- 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
    , validatePassword
    , validatePasswordEither
    , bcrypt
    )
where

import           Control.Monad                    (forM_, unless, when)
import           Crypto.Cipher.Blowfish.Primitive (Context, createKeySchedule,
                                                   encrypt, expandKey,
                                                   expandKeyWithSalt,
                                                   freezeKeySchedule)
import           Crypto.Internal.Compat
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.
hashPassword :: (MonadRandom m, ByteArray password, ByteArray hash)
             => Int
             -- ^ The cost parameter. Should be between 4 and 31 (inclusive).
             -- Values which lie outside this range will be adjusted accordingly.
             -> password
             -- ^ The password. Should be the UTF-8 encoded bytes of the password text.
             -> 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 = 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
    hash -> m hash
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (hash -> m hash) -> hash -> m hash
forall a b. (a -> b) -> a -> b
$ Int -> Bytes -> password -> hash
forall salt password output.
(ByteArray salt, ByteArray password, ByteArray output) =>
Int -> salt -> password -> output
bcrypt Int
cost (Bytes
salt :: Bytes) password
password

-- | Create a bcrypt hash for a password with a provided cost value and salt.
--
-- Cost value under 4 will be automatically adjusted back to 10 for safety reason.
bcrypt :: (ByteArray salt, ByteArray password, ByteArray output)
       => Int
       -- ^ The cost parameter. Should be between 4 and 31 (inclusive).
       -- Values which lie outside this range will be adjusted accordingly.
       -> 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.
       -> 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 = [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
realCost 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
realCost 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
realCost Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10)]
    realCost :: Int
realCost
        | Int
cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4  = Int
10 -- 4 is virtually pointless so go for 10
        | Int
cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
31 = Int
31
        | Bool
otherwise = Int
cost

    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.
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.
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 = Int -> output -> output
forall bs. ByteArray bs => Int -> bs -> bs
B.take Int
23 output
hash -- Another compatibility bug. Ignore last byte of hash
  where
    hash :: output
hash = Int -> output -> output
forall {t} {t}. (Num t, ByteArray t, Ord t) => t -> t -> t
loop (Int
0 :: Int) output
orpheanBeholder

    loop :: t -> t -> t
loop t
i t
input
        | t
i t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
64    = t -> t -> t
loop (t
it -> t -> t
forall a. Num a => a -> a -> a
+t
1) (Context -> t -> t
forall ba. ByteArray ba => Context -> ba -> ba
encrypt Context
ctx t
input)
        | Bool
otherwise = t
input

    -- Truncate the password if necessary and append a null byte for C compatibility
    key :: password
key = password -> Word8 -> password
forall a. ByteArray a => a -> Word8 -> a
B.snoc (Int -> password -> password
forall bs. ByteArray bs => Int -> bs -> bs
B.take Int
72 password
password) Word8
0

    ctx :: Context
ctx = password -> salt -> Int -> Context
forall key salt.
(ByteArrayAccess key, ByteArrayAccess salt) =>
key -> salt -> Int -> Context
expensiveBlowfishContext password
key salt
salt Int
cost

    -- The BCrypt plaintext: "OrpheanBeholderScryDoubt"
    orpheanBeholder :: output
orpheanBeholder = [Word8] -> output
forall a. ByteArray a => [Word8] -> a
B.pack [Word8
79,Word8
114,Word8
112,Word8
104,Word8
101,Word8
97,Word8
110,Word8
66,Word8
101,Word8
104,Word8
111,Word8
108,Word8
100,Word8
101,Word8
114,Word8
83,Word8
99,Word8
114,Word8
121,Word8
68,Word8
111,Word8
117,Word8
98,Word8
116]

-- "$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
10Int -> 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)

-- | Create a key schedule for the BCrypt "EKS" version.
--
-- Salt must be a 128-bit byte array.
-- Cost must be between 4 and 31 inclusive
-- See <https://www.usenix.org/conference/1999-usenix-annual-technical-conference/future-adaptable-password-scheme>
expensiveBlowfishContext :: (ByteArrayAccess key, ByteArrayAccess salt) => key-> salt -> Int -> Context
expensiveBlowfishContext :: forall key salt.
(ByteArrayAccess key, ByteArrayAccess salt) =>
key -> salt -> Int -> Context
expensiveBlowfishContext key
keyBytes salt
saltBytes Int
cost
  | salt -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length salt
saltBytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
16 = String -> Context
forall a. HasCallStack => String -> a
error String
"bcrypt salt must be 16 bytes"
  | Bool
otherwise = IO Context -> Context
forall a. IO a -> a
unsafeDoIO (IO Context -> Context) -> IO Context -> Context
forall a b. (a -> b) -> a -> b
$ do
        KeySchedule
ks <- IO KeySchedule
createKeySchedule
        KeySchedule -> key -> salt -> IO ()
forall key salt.
(ByteArrayAccess key, ByteArrayAccess salt) =>
KeySchedule -> key -> salt -> IO ()
expandKeyWithSalt KeySchedule
ks key
keyBytes salt
saltBytes
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
cost :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do
            KeySchedule -> key -> IO ()
forall key. ByteArrayAccess key => KeySchedule -> key -> IO ()
expandKey KeySchedule
ks key
keyBytes
            KeySchedule -> salt -> IO ()
forall key. ByteArrayAccess key => KeySchedule -> key -> IO ()
expandKey KeySchedule
ks salt
saltBytes
        KeySchedule -> IO Context
freezeKeySchedule KeySchedule
ks