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
hashPassword :: (MonadRandom m, ByteArray password, ByteArray hash)
=> Int
-> password
-> m hash
hashPassword :: forall (m :: * -> *) password hash.
(MonadRandom m, ByteArray password, ByteArray hash) =>
Int -> password -> m hash
hashPassword Int
cost password
password = do
Bytes
salt <- forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
16
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall salt password output.
(ByteArray salt, ByteArray password, ByteArray output) =>
Int -> salt -> password -> output
bcrypt Int
cost (Bytes
salt :: Bytes) password
password
bcrypt :: (ByteArray salt, ByteArray password, ByteArray output)
=> Int
-> salt
-> password
-> output
bcrypt :: forall salt password output.
(ByteArray salt, ByteArray password, ByteArray output) =>
Int -> salt -> password -> output
bcrypt Int
cost salt
salt password
password = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
[bin] -> bout
B.concat [salt
header, forall a. ByteArray a => a -> Word8 -> a
B.snoc salt
costBytes Word8
dollar, forall ba. ByteArray ba => ba -> ba
b64 salt
salt, forall ba. ByteArray ba => ba -> ba
b64 salt
hash]
where
hash :: salt
hash = 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 = forall a. ByteArray a => [Word8] -> a
B.pack [Word8
dollar, forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'2'), forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'b'), Word8
dollar]
dollar :: Word8
dollar = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'$')
zero :: Word8
zero = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'0')
costBytes :: salt
costBytes = forall a. ByteArray a => [Word8] -> a
B.pack [Word8
zero forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
realCost forall a. Integral a => a -> a -> a
`div` Int
10), Word8
zero forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
realCost forall a. Integral a => a -> a -> a
`mod` Int
10)]
realCost :: Int
realCost
| Int
cost forall a. Ord a => a -> a -> Bool
< Int
4 = Int
10
| Int
cost 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 = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64OpenBSD
validatePassword :: (ByteArray password, ByteArray hash) => password -> hash -> Bool
validatePassword :: forall password hash.
(ByteArray password, ByteArray hash) =>
password -> hash -> Bool
validatePassword password
password hash
bcHash = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) forall a. a -> a
id (forall password hash.
(ByteArray password, ByteArray hash) =>
password -> hash -> Either String Bool
validatePasswordEither password
password hash
bcHash)
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 <- forall ba. ByteArray ba => ba -> Either String BCryptHash
parseBCryptHash hash
bcHash
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (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) 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 = forall bs. ByteArray bs => Int -> bs -> bs
B.take Int
23 output
hash
where
hash :: output
hash = 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 forall a. Ord a => a -> a -> Bool
< t
64 = t -> t -> t
loop (t
iforall a. Num a => a -> a -> a
+t
1) (forall ba. ByteArray ba => Context -> ba -> ba
encrypt Context
ctx t
input)
| Bool
otherwise = t
input
key :: password
key = forall a. ByteArray a => a -> Word8 -> a
B.snoc (forall bs. ByteArray bs => Int -> bs -> bs
B.take Int
72 password
password) Word8
0
ctx :: Context
ctx = forall key salt.
(ByteArrayAccess key, ByteArrayAccess salt) =>
key -> salt -> Int -> Context
expensiveBlowfishContext password
key salt
salt Int
cost
orpheanBeholder :: output
orpheanBeholder = 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]
parseBCryptHash :: (ByteArray ba) => ba -> Either String BCryptHash
parseBCryptHash :: forall ba. ByteArray ba => ba -> Either String BCryptHash
parseBCryptHash ba
bc = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
bc forall a. Eq a => a -> a -> Bool
== Int
60 Bool -> Bool -> Bool
&&
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
0 forall a. Eq a => a -> a -> Bool
== Word8
dollar Bool -> Bool -> Bool
&&
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
1 forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'2') Bool -> Bool -> Bool
&&
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
3 forall a. Eq a => a -> a -> Bool
== Word8
dollar Bool -> Bool -> Bool
&&
forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
6 forall a. Eq a => a -> a -> Bool
== Word8
dollar) (forall a b. a -> Either a b
Left String
"Invalid hash format")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char
version forall a. Eq a => a -> a -> Bool
== Char
'b' Bool -> Bool -> Bool
|| Char
version forall a. Eq a => a -> a -> Bool
== Char
'a' Bool -> Bool -> Bool
|| Char
version forall a. Eq a => a -> a -> Bool
== Char
'y') (forall a b. a -> Either a b
Left (String
"Unsupported minor version: " forall a. [a] -> [a] -> [a]
++ [Char
version]))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
costTens forall a. Ord a => a -> a -> Bool
> Int
3 Bool -> Bool -> Bool
|| Int
cost forall a. Ord a => a -> a -> Bool
> Int
31 Bool -> Bool -> Bool
|| Int
cost forall a. Ord a => a -> a -> Bool
< Int
4) (forall a b. a -> Either a b
Left String
"Invalid bcrypt cost")
(Bytes
salt, Bytes
hash) <- forall {a} {b} {bin}.
(ByteArray a, ByteArray b, ByteArray bin) =>
bin -> Either String (a, b)
decodeSaltHash (forall bs. ByteArray bs => Int -> bs -> bs
B.drop Int
7 ba
bc)
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 = 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
4) forall a. Num a => a -> a -> a
- Int
zero
costUnits :: Int
costUnits = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
5) forall a. Num a => a -> a -> a
- Int
zero
version :: Char
version = Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. ByteArrayAccess a => a -> Int -> Word8
B.index ba
bc Int
2))
cost :: Int
cost = Int
costUnits forall a. Num a => a -> a -> a
+ Int
10forall a. Num a => a -> a -> a
*Int
costTens :: Int
decodeSaltHash :: bin -> Either String (a, b)
decodeSaltHash bin
saltHash = do
let (bin
s, bin
h) = forall bs. ByteArray bs => Int -> bs -> (bs, bs)
B.splitAt Int
22 bin
saltHash
a
salt <- forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64OpenBSD bin
s
b
hash <- forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64OpenBSD bin
h
forall (m :: * -> *) a. Monad m => a -> m a
return (a
salt, b
hash)
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
| forall ba. ByteArrayAccess ba => ba -> Int
B.length salt
saltBytes forall a. Eq a => a -> a -> Bool
/= Int
16 = forall a. HasCallStack => String -> a
error String
"bcrypt salt must be 16 bytes"
| Bool
otherwise = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ do
KeySchedule
ks <- IO KeySchedule
createKeySchedule
forall key salt.
(ByteArrayAccess key, ByteArrayAccess salt) =>
KeySchedule -> key -> salt -> IO ()
expandKeyWithSalt KeySchedule
ks key
keyBytes salt
saltBytes
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
2forall a b. (Num a, Integral b) => a -> b -> a
^Int
cost :: Int] forall a b. (a -> b) -> a -> b
$ \Int
_ -> do
forall key. ByteArrayAccess key => KeySchedule -> key -> IO ()
expandKey KeySchedule
ks key
keyBytes
forall key. ByteArrayAccess key => KeySchedule -> key -> IO ()
expandKey KeySchedule
ks salt
saltBytes
KeySchedule -> IO Context
freezeKeySchedule KeySchedule
ks