-- |
-- Module      : Crypto.KDF.BCryptPBKDF
-- License     : BSD-style
-- Stability   : experimental
-- Portability : Good
--
-- Port of the bcrypt_pbkdf key derivation function from OpenBSD
-- as described at <http://man.openbsd.org/bcrypt_pbkdf.3>.
module Crypto.KDF.BCryptPBKDF
    ( Parameters (..)
    , generate
    , hashInternal
    )
where

import           Basement.Block                   (MutableBlock)
import qualified Basement.Block                   as Block
import qualified Basement.Block.Mutable           as Block
import           Basement.Monad                   (PrimState)
import           Basement.Types.OffsetSize        (CountOf (..), Offset (..))
import           Control.Exception                (finally)
import           Control.Monad                    (when)
import qualified Crypto.Cipher.Blowfish.Box       as Blowfish
import qualified Crypto.Cipher.Blowfish.Primitive as Blowfish
import           Crypto.Hash.Algorithms           (SHA512 (..))
import           Crypto.Hash.Types                (Context,
                                                   hashDigestSize,
                                                   hashInternalContextSize,
                                                   hashInternalFinalize,
                                                   hashInternalInit,
                                                   hashInternalUpdate)
import           Crypto.Internal.Compat           (unsafeDoIO)
import           Data.Bits
import qualified Data.ByteArray                   as B
import           Data.Foldable                    (forM_)
import           Data.Memory.PtrMethods           (memCopy, memSet, memXor)
import           Data.Word
import           Foreign.Ptr                      (Ptr, castPtr)
import           Foreign.Storable                 (peekByteOff, pokeByteOff)

data Parameters = Parameters
  { Parameters -> Int
iterCounts   :: Int -- ^ The number of user-defined iterations for the algorithm
                        --   (must be > 0)
  , Parameters -> Int
outputLength :: Int -- ^ The number of bytes to generate out of BCryptPBKDF
                        --   (must be in 1..1024)
  } deriving (Parameters -> Parameters -> Bool
(Parameters -> Parameters -> Bool)
-> (Parameters -> Parameters -> Bool) -> Eq Parameters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Parameters -> Parameters -> Bool
== :: Parameters -> Parameters -> Bool
$c/= :: Parameters -> Parameters -> Bool
/= :: Parameters -> Parameters -> Bool
Eq, Eq Parameters
Eq Parameters =>
(Parameters -> Parameters -> Ordering)
-> (Parameters -> Parameters -> Bool)
-> (Parameters -> Parameters -> Bool)
-> (Parameters -> Parameters -> Bool)
-> (Parameters -> Parameters -> Bool)
-> (Parameters -> Parameters -> Parameters)
-> (Parameters -> Parameters -> Parameters)
-> Ord Parameters
Parameters -> Parameters -> Bool
Parameters -> Parameters -> Ordering
Parameters -> Parameters -> Parameters
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Parameters -> Parameters -> Ordering
compare :: Parameters -> Parameters -> Ordering
$c< :: Parameters -> Parameters -> Bool
< :: Parameters -> Parameters -> Bool
$c<= :: Parameters -> Parameters -> Bool
<= :: Parameters -> Parameters -> Bool
$c> :: Parameters -> Parameters -> Bool
> :: Parameters -> Parameters -> Bool
$c>= :: Parameters -> Parameters -> Bool
>= :: Parameters -> Parameters -> Bool
$cmax :: Parameters -> Parameters -> Parameters
max :: Parameters -> Parameters -> Parameters
$cmin :: Parameters -> Parameters -> Parameters
min :: Parameters -> Parameters -> Parameters
Ord, Int -> Parameters -> ShowS
[Parameters] -> ShowS
Parameters -> String
(Int -> Parameters -> ShowS)
-> (Parameters -> String)
-> ([Parameters] -> ShowS)
-> Show Parameters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Parameters -> ShowS
showsPrec :: Int -> Parameters -> ShowS
$cshow :: Parameters -> String
show :: Parameters -> String
$cshowList :: [Parameters] -> ShowS
showList :: [Parameters] -> ShowS
Show)

-- | Derive a key of specified length using the bcrypt_pbkdf algorithm.
generate :: (B.ByteArray pass, B.ByteArray salt, B.ByteArray output)
       => Parameters
       -> pass
       -> salt
       -> output
generate :: forall pass salt output.
(ByteArray pass, ByteArray salt, ByteArray output) =>
Parameters -> pass -> salt -> output
generate Parameters
params pass
pass salt
salt
    | Parameters -> Int
iterCounts Parameters
params Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1       = String -> output
forall a. HasCallStack => String -> a
error String
"BCryptPBKDF: iterCounts must be > 0"
    | Int
keyLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
keyLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1024 = String -> output
forall a. HasCallStack => String -> a
error String
"BCryptPBKDF: outputLength must be in 1..1024"
    | Bool
otherwise                   = Int -> (Ptr Word8 -> IO ()) -> output
forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
B.unsafeCreate Int
keyLen Ptr Word8 -> IO ()
deriveKey
  where
    outLen, tmpLen, blkLen, keyLen, passLen, saltLen, ctxLen, hashLen, blocks :: Int
    outLen :: Int
outLen  = Int
32
    tmpLen :: Int
tmpLen  = Int
32
    blkLen :: Int
blkLen  = Int
4
    passLen :: Int
passLen = pass -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length pass
pass
    saltLen :: Int
saltLen = salt -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length salt
salt
    keyLen :: Int
keyLen  = Parameters -> Int
outputLength Parameters
params
    ctxLen :: Int
ctxLen  = SHA512 -> Int
forall a. HashAlgorithm a => a -> Int
hashInternalContextSize SHA512
SHA512
    hashLen :: Int
hashLen = SHA512 -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize SHA512
SHA512 -- 64
    blocks :: Int
blocks  = (Int
keyLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
outLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
outLen

    deriveKey :: Ptr Word8 -> IO ()
    deriveKey :: Ptr Word8 -> IO ()
deriveKey Ptr Word8
keyPtr = do
        -- Allocate all necessary memory. The algorihm shall not allocate
        -- any more dynamic memory after this point. Blocks need to be pinned
        -- as pointers to them are passed to the SHA512 implementation.
        KeySchedule
ksClean        <- IO KeySchedule
Blowfish.createKeySchedule
        KeySchedule
ksDirty        <- IO KeySchedule
Blowfish.createKeySchedule
        MutableBlock Word8 RealWorld
ctxMBlock      <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
Block.newPinned (Int -> CountOf Word8
forall ty. Int -> CountOf ty
CountOf Int
ctxLen  :: CountOf Word8)
        MutableBlock Word8 RealWorld
outMBlock      <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
Block.newPinned (Int -> CountOf Word8
forall ty. Int -> CountOf ty
CountOf Int
outLen  :: CountOf Word8)
        MutableBlock Word8 RealWorld
tmpMBlock      <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
Block.newPinned (Int -> CountOf Word8
forall ty. Int -> CountOf ty
CountOf Int
tmpLen  :: CountOf Word8)
        MutableBlock Word8 RealWorld
blkMBlock      <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
Block.newPinned (Int -> CountOf Word8
forall ty. Int -> CountOf ty
CountOf Int
blkLen  :: CountOf Word8)
        MutableBlock Word8 RealWorld
passHashMBlock <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
Block.newPinned (Int -> CountOf Word8
forall ty. Int -> CountOf ty
CountOf Int
hashLen :: CountOf Word8)
        MutableBlock Word8 RealWorld
saltHashMBlock <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
Block.newPinned (Int -> CountOf Word8
forall ty. Int -> CountOf ty
CountOf Int
hashLen :: CountOf Word8)
        -- Finally erase all memory areas that contain information from
        -- which the derived key could be reconstructed.
        -- As all MutableBlocks are pinned it shall be guaranteed that
        -- no temporary trampoline buffers are allocated.
        MutableBlock Word8 (PrimState IO) -> IO () -> IO ()
finallyErase MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
outMBlock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MutableBlock Word8 (PrimState IO) -> IO () -> IO ()
finallyErase MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
passHashMBlock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            pass -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. pass -> (Ptr p -> IO a) -> IO a
B.withByteArray pass
pass                ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
passPtr->
            salt -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. salt -> (Ptr p -> IO a) -> IO a
B.withByteArray salt
salt                ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
saltPtr->
            MutableBlock Word8 (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (prim :: * -> *) ty a.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a
Block.withMutablePtr MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
ctxMBlock      ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ctxPtr->
            MutableBlock Word8 (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (prim :: * -> *) ty a.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a
Block.withMutablePtr MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
outMBlock      ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
outPtr->
            MutableBlock Word8 (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (prim :: * -> *) ty a.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a
Block.withMutablePtr MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
tmpMBlock      ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
tmpPtr->
            MutableBlock Word8 (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (prim :: * -> *) ty a.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a
Block.withMutablePtr MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
blkMBlock      ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
blkPtr->
            MutableBlock Word8 (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (prim :: * -> *) ty a.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a
Block.withMutablePtr MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
passHashMBlock ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
passHashPtr->
            MutableBlock Word8 (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (prim :: * -> *) ty a.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a
Block.withMutablePtr MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
saltHashMBlock ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
saltHashPtr-> do
                -- Hash the password.
                let shaPtr :: Ptr (Context SHA512)
shaPtr = Ptr Word8 -> Ptr (Context SHA512)
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ctxPtr :: Ptr (Context SHA512)
                Ptr (Context SHA512) -> IO ()
forall a. HashAlgorithm a => Ptr (Context a) -> IO ()
hashInternalInit     Ptr (Context SHA512)
shaPtr
                Ptr (Context SHA512) -> Ptr Word8 -> Word32 -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate   Ptr (Context SHA512)
shaPtr Ptr Word8
passPtr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
passLen)
                Ptr (Context SHA512) -> Ptr (Digest SHA512) -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr (Digest a) -> IO ()
hashInternalFinalize Ptr (Context SHA512)
shaPtr (Ptr Word8 -> Ptr (Digest SHA512)
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
passHashPtr)
                Block Word8
passHashBlock <- MutableBlock Word8 (PrimState IO) -> IO (Block Word8)
forall (prim :: * -> *) ty.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> prim (Block ty)
Block.unsafeFreeze MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
passHashMBlock
                [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
blocks] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
block-> do
                    -- Poke the increased block counter.
                    MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
blkMBlock Offset Word8
0 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
block Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
                    MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
blkMBlock Offset Word8
1 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
block Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
                    MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
blkMBlock Offset Word8
2 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
block Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR`  Int
8)
                    MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
blkMBlock Offset Word8
3 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
block Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR`  Int
0)
                    -- First round (slightly different).
                    Ptr (Context SHA512) -> IO ()
forall a. HashAlgorithm a => Ptr (Context a) -> IO ()
hashInternalInit     Ptr (Context SHA512)
shaPtr
                    Ptr (Context SHA512) -> Ptr Word8 -> Word32 -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate   Ptr (Context SHA512)
shaPtr Ptr Word8
saltPtr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
saltLen)
                    Ptr (Context SHA512) -> Ptr Word8 -> Word32 -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate   Ptr (Context SHA512)
shaPtr Ptr Word8
blkPtr  (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
blkLen)
                    Ptr (Context SHA512) -> Ptr (Digest SHA512) -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr (Digest a) -> IO ()
hashInternalFinalize Ptr (Context SHA512)
shaPtr (Ptr Word8 -> Ptr (Digest SHA512)
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
saltHashPtr)
                    MutableBlock Word8 (PrimState IO) -> IO (Block Word8)
forall (prim :: * -> *) ty.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> prim (Block ty)
Block.unsafeFreeze MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
saltHashMBlock IO (Block Word8) -> (Block Word8 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Block Word8
x-> do
                        KeySchedule -> KeySchedule -> IO ()
Blowfish.copyKeySchedule KeySchedule
ksDirty KeySchedule
ksClean
                        KeySchedule
-> Block Word8
-> Block Word8
-> MutableBlock Word8 (PrimState IO)
-> IO ()
forall pass salt.
(ByteArrayAccess pass, ByteArrayAccess salt) =>
KeySchedule
-> pass -> salt -> MutableBlock Word8 (PrimState IO) -> IO ()
hashInternalMutable KeySchedule
ksDirty Block Word8
passHashBlock Block Word8
x MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
tmpMBlock
                    Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memCopy Ptr Word8
outPtr Ptr Word8
tmpPtr Int
outLen
                    -- Remaining rounds.
                    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
2..Parameters -> Int
iterCounts Parameters
params] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> Int -> IO ()
forall a b. a -> b -> a
const (IO () -> Int -> IO ()) -> IO () -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        Ptr (Context SHA512) -> IO ()
forall a. HashAlgorithm a => Ptr (Context a) -> IO ()
hashInternalInit     Ptr (Context SHA512)
shaPtr
                        Ptr (Context SHA512) -> Ptr Word8 -> Word32 -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate   Ptr (Context SHA512)
shaPtr Ptr Word8
tmpPtr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tmpLen)
                        Ptr (Context SHA512) -> Ptr (Digest SHA512) -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr (Digest a) -> IO ()
hashInternalFinalize Ptr (Context SHA512)
shaPtr (Ptr Word8 -> Ptr (Digest SHA512)
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
saltHashPtr)
                        MutableBlock Word8 (PrimState IO) -> IO (Block Word8)
forall (prim :: * -> *) ty.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> prim (Block ty)
Block.unsafeFreeze MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
saltHashMBlock IO (Block Word8) -> (Block Word8 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Block Word8
x-> do
                            KeySchedule -> KeySchedule -> IO ()
Blowfish.copyKeySchedule KeySchedule
ksDirty KeySchedule
ksClean
                            KeySchedule
-> Block Word8
-> Block Word8
-> MutableBlock Word8 (PrimState IO)
-> IO ()
forall pass salt.
(ByteArrayAccess pass, ByteArrayAccess salt) =>
KeySchedule
-> pass -> salt -> MutableBlock Word8 (PrimState IO) -> IO ()
hashInternalMutable KeySchedule
ksDirty Block Word8
passHashBlock Block Word8
x MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
tmpMBlock
                        Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memXor Ptr Word8
outPtr Ptr Word8
outPtr Ptr Word8
tmpPtr Int
outLen
                    -- Spread the current out buffer evenly over the key buffer.
                    -- After both loops have run every byte of the key buffer
                    -- will have been written to exactly once and every byte
                    -- of the output will have been used.
                    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
outLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
outIdx-> do
                        let keyIdx :: Int
keyIdx = Int
outIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
block Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
keyIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
keyLen) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            Word8
w8 <- Ptr Word8 -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
outPtr Int
outIdx :: IO Word8
                            Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
keyPtr Int
keyIdx Word8
w8

-- | Internal hash function used by `generate`.
--
-- Normal users should not need this.
hashInternal :: (B.ByteArrayAccess pass, B.ByteArrayAccess salt, B.ByteArray output)
    => pass
    -> salt
    -> output
hashInternal :: forall pass salt output.
(ByteArrayAccess pass, ByteArrayAccess salt, ByteArray output) =>
pass -> salt -> output
hashInternal pass
passHash salt
saltHash
    | pass -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length pass
passHash Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
64 = String -> output
forall a. HasCallStack => String -> a
error String
"passHash must be 512 bits"
    | salt -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length salt
saltHash Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
64 = String -> output
forall a. HasCallStack => String -> a
error String
"saltHash must be 512 bits"
    | Bool
otherwise = IO output -> output
forall a. IO a -> a
unsafeDoIO (IO output -> output) -> IO output -> output
forall a b. (a -> b) -> a -> b
$ do
        KeySchedule
ks0 <- IO KeySchedule
Blowfish.createKeySchedule
        MutableBlock Word8 RealWorld
outMBlock <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
Block.newPinned CountOf Word8
32
        KeySchedule
-> pass -> salt -> MutableBlock Word8 (PrimState IO) -> IO ()
forall pass salt.
(ByteArrayAccess pass, ByteArrayAccess salt) =>
KeySchedule
-> pass -> salt -> MutableBlock Word8 (PrimState IO) -> IO ()
hashInternalMutable KeySchedule
ks0 pass
passHash salt
saltHash MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
outMBlock
        Block Word8 -> output
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
B.convert (Block Word8 -> output) -> IO (Block Word8) -> IO output
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` MutableBlock Word8 (PrimState IO) -> IO (Block Word8)
forall ty (prim :: * -> *).
(PrimType ty, PrimMonad prim) =>
MutableBlock ty (PrimState prim) -> prim (Block ty)
Block.freeze MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
outMBlock

hashInternalMutable :: (B.ByteArrayAccess pass, B.ByteArrayAccess salt)
    => Blowfish.KeySchedule
    -> pass
    -> salt
    -> MutableBlock Word8 (PrimState IO)
    -> IO ()
hashInternalMutable :: forall pass salt.
(ByteArrayAccess pass, ByteArrayAccess salt) =>
KeySchedule
-> pass -> salt -> MutableBlock Word8 (PrimState IO) -> IO ()
hashInternalMutable KeySchedule
bfks pass
passHash salt
saltHash MutableBlock Word8 (PrimState IO)
outMBlock = do
    KeySchedule -> pass -> salt -> IO ()
forall key salt.
(ByteArrayAccess key, ByteArrayAccess salt) =>
KeySchedule -> key -> salt -> IO ()
Blowfish.expandKeyWithSalt KeySchedule
bfks pass
passHash salt
saltHash
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
63 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> Int -> IO ()
forall a b. a -> b -> a
const (IO () -> Int -> IO ()) -> IO () -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        KeySchedule -> salt -> IO ()
forall key. ByteArrayAccess key => KeySchedule -> key -> IO ()
Blowfish.expandKey KeySchedule
bfks salt
saltHash
        KeySchedule -> pass -> IO ()
forall key. ByteArrayAccess key => KeySchedule -> key -> IO ()
Blowfish.expandKey KeySchedule
bfks pass
passHash
    -- "OxychromaticBlowfishSwatDynamite" represented as 4 Word64 in big-endian.
    Offset Word8 -> Word64 -> IO ()
store  Offset Word8
0 (Word64 -> IO ()) -> IO Word64 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Word64 -> IO Word64
cipher Int
64 Word64
0x4f78796368726f6d
    Offset Word8 -> Word64 -> IO ()
store  Offset Word8
8 (Word64 -> IO ()) -> IO Word64 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Word64 -> IO Word64
cipher Int
64 Word64
0x61746963426c6f77
    Offset Word8 -> Word64 -> IO ()
store Offset Word8
16 (Word64 -> IO ()) -> IO Word64 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Word64 -> IO Word64
cipher Int
64 Word64
0x6669736853776174
    Offset Word8 -> Word64 -> IO ()
store Offset Word8
24 (Word64 -> IO ()) -> IO Word64 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Word64 -> IO Word64
cipher Int
64 Word64
0x44796e616d697465
    where
        store :: Offset Word8 -> Word64 -> IO ()
        store :: Offset Word8 -> Word64 -> IO ()
store Offset Word8
o Word64
w64 = do
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
0) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
1) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
40)
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
2) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48)
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
3) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
56)
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
4) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR`  Int
0)
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
5) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR`  Int
8)
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
6) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
            MutableBlock Word8 (PrimState IO) -> Offset Word8 -> Word8 -> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
Block.unsafeWrite MutableBlock Word8 (PrimState IO)
outMBlock (Offset Word8
o Offset Word8 -> Offset Word8 -> Offset Word8
forall a. Num a => a -> a -> a
+ Offset Word8
7) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
        cipher :: Int -> Word64 -> IO Word64
        cipher :: Int -> Word64 -> IO Word64
cipher Int
0 Word64
block = Word64 -> IO Word64
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
block
        cipher Int
i Word64
block = KeySchedule -> Word64 -> IO Word64
Blowfish.cipherBlockMutable KeySchedule
bfks Word64
block IO Word64 -> (Word64 -> IO Word64) -> IO Word64
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word64 -> IO Word64
cipher (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

finallyErase :: MutableBlock Word8 (PrimState IO) -> IO () -> IO ()
finallyErase :: MutableBlock Word8 (PrimState IO) -> IO () -> IO ()
finallyErase MutableBlock Word8 (PrimState IO)
mblock IO ()
action =
    IO ()
action IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` MutableBlock Word8 (PrimState IO) -> (Ptr Word8 -> IO ()) -> IO ()
forall (prim :: * -> *) ty a.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a
Block.withMutablePtr MutableBlock Word8 (PrimState IO)
mblock (\Ptr Word8
ptr-> Ptr Word8 -> Word8 -> Int -> IO ()
memSet Ptr Word8
ptr Word8
0 Int
len)
    where
        CountOf Int
len = MutableBlock Word8 RealWorld -> CountOf Word8
forall ty st. MutableBlock ty st -> CountOf Word8
Block.mutableLengthBytes MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
mblock