{-# LANGUAGE ViewPatterns, OverloadedStrings, BangPatterns, ScopedTypeVariables #-}

-------------------------------------------------------------------------------
-- |
-- Module:      Crypto.G3P.BCrypt
-- Copyright:   (c) 2024 Auth Global
-- License:     Apache2
--
--    A very minimal binding to the core of the bcrypt algorithm, adapted from
--    OpenBSD's implementation. The Global Password Prehash Protocol version
--    G3Pb1 cannot be implemented in terms of standard bcrypt interfaces for
--    several reasons:
--
--    1.  Standard bcrypt hashes are truncated to 23 bytes.  The G3P depends
--        on all 24 output bytes.
--
--    2.  Standard bcrypt must specify a number of rounds that is a power of
--        two. The G3P allows any number of rounds between 1 and 2^32 inclusive.
--
--    3.  the G3P needs unimpeded access to the full 72 byte password input.
--        This is not doable with all bcrypt variants.
--
--    4.  Standard bcrypt limits salt length to 16 bytes. Version 1 of the G3P
--        depends on 72 byte salt parameters, and Version 2 depends on 4168 byte
--        salts.
--
--    5.  In addition to the standard salt parameter, Version 2 of the G3P
--        depends on two additional 4168 byte salt parameters which are
--        assumed to be filled with null bytes by standard bcrypt.
--
--    6.  G3Pb2 also implements a counter at the start of the excess salt
--
--    For this reason, this binding completely removes the code for handling
--    unix-style bcrypt hashes, which has repeatedly proven problematic. One
--    of the major design motifs of the G3P is to replace this cruft with PHKDF,
--    which is intended to be bulletproof.
--
--    Note that this binding doesn't (currently?) support the @2a@ and @2x@
--    variants.  On the other hand, at least the 2a variant depends on
--    overflow, which as undefined behavior in C is allowed to compile to
--    whatever it wants... so there might be multiple variants of the @2a@
--    "variant" of bcrypt floating around out there, depending on particular
--    C implementations and possibly even specific to architectures, compiler
--    flags, and versions
--
-------------------------------------------------------------------------------

module Crypto.G3P.BCrypt
  ( bcrypt
  , bcrypt_saltLength
  , bcrypt_maxPasswordLength
  , bcrypt_formatSaltString
  , bcrypt_parseSaltString
  , bcrypt_outputLength
  , bcryptRaw
  , bcryptRaw_maxInputLength
  , bcryptRaw_outputLength
  , bcryptXsFree
  ) where

import           Control.Exception(assert)

import           Data.Bits((.&.))
import           Data.ByteString(ByteString)
import qualified Data.ByteString as B
import           Data.ByteString.Internal(c2w, w2c)
import qualified Data.Char as Char
import           Data.Function((&))
import           Data.Int
import           Data.Word

import           Network.ByteOrder(word32, bytestring32)

import           Crypto.PHKDF.HMAC (HmacKeyPrefixed, hmacKeyPrefixed_feeds)
import           Crypto.PHKDF (PhkdfCtx, phkdfCtx_initPrefixed, phkdfCtx_feedArgsBy, phkdfCtx_feedArg, phkdfCtx_finalize, phkdfCtx_byteCount, phkdfCtx_endPaddingLength)
import           Crypto.PHKDF.Assert

import           Crypto.Encoding.PHKDF (chunkify, chunkifyCycle, takeBs, nullBuffer)
import           Crypto.G3P.BCrypt.Subtle

-- | OpenBSD-compatible bcrypt

bcrypt :: ByteString -- ^ password
       -> ByteString -- ^ unix-style salt string
       -> Maybe ByteString -- ^ unix-style password hash string
bcrypt :: ByteString -> ByteString -> Maybe ByteString
bcrypt ByteString
key ByteString
saltString =
  case  ByteString -> Maybe (Char, Word8, ByteString, ByteString)
bcrypt_parseSaltString ByteString
saltString of
    Just (Char
_, Word8
cost, ByteString
salt, ByteString
_) ->
      let hash :: ByteString
hash = ByteString -> ByteString -> Word32 -> ByteString
bcryptRaw ByteString
key' ByteString
salt (Word32
2 Word32 -> Word8 -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^ Word8
cost Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1)
       in ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ( Int -> ByteString -> ByteString
B.take Int
29 ByteString
saltString ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
base64Encode (Int -> ByteString -> ByteString
B.take Int
23 ByteString
hash))
    Maybe (Char, Word8, ByteString, ByteString)
Nothing -> Maybe ByteString
forall a. Maybe a
Nothing
  where
    key' :: ByteString
key' =
      case (Word8 -> ByteString -> Maybe Int
B.elemIndex Word8
0 (Int -> ByteString -> ByteString
B.take Int
bcrypt_maxPasswordLength ByteString
key)) of
        Maybe Int
Nothing -> ByteString
key
	Just Int
n -> Int -> ByteString -> ByteString
B.take Int
n ByteString
key

-- | produce a standard salt string for bcrypt, with or without a password
--   hash.

bcrypt_formatSaltString
   :: Char -- ^ Variant, must be @\'b\'@ for now
   -> Word8 -- ^ Cost factor, must be between 4 and 31 inclusive
   -> ByteString -- ^ Binary salt, must be 16 bytes long
   -> ByteString -- ^ Binary hash, must be 0 or 23 bytes long
   -> Maybe ByteString
bcrypt_formatSaltString :: Char -> Word8 -> ByteString -> ByteString -> Maybe ByteString
bcrypt_formatSaltString Char
variant Word8
cost ByteString
salt ByteString
hash
  | ByteString -> Int
B.length ByteString
salt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
16 = Maybe ByteString
forall a. Maybe a
Nothing
  | ByteString -> Int
B.length ByteString
hash Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int
0,Int
23] = Maybe ByteString
forall a. Maybe a
Nothing
  | Bool -> Bool
not ( Word8
4 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
cost Bool -> Bool -> Bool
&& Word8
cost Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
31 ) = Maybe ByteString
forall a. Maybe a
Nothing
  | Char
variant Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'b'] = Maybe ByteString
forall a. Maybe a
Nothing
  | Bool
otherwise =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ([ByteString] -> ByteString
B.concat [ ByteString
"$2", Word8 -> ByteString
B.singleton (Char -> Word8
c2w Char
variant),
                        ByteString
"$", ByteString
x, ByteString
y, ByteString
"$",
                        ByteString -> ByteString
base64Encode ByteString
salt,
                        ByteString -> ByteString
base64Encode ByteString
hash ])
  where
    (Word8 -> ByteString
toDigit -> ByteString
x, Word8 -> ByteString
toDigit -> ByteString
y) = (Word8
cost Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`divMod` Word8
10)

toDigit :: Word8 -> ByteString
toDigit :: Word8 -> ByteString
toDigit Word8
a = Word8 -> ByteString
B.singleton (Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Char -> Word8
c2w Char
'0')

-- | Given a salt string (e.g. "@\$2b\$12\$...@") in the OpenBSD format,
--   returns (variant, work cost, binary salt, binary hash). The only supported
--   variant is currently @\'b\'@. The cost must be between 4 and 31, and the
--   input string must be either 29 or 60 bytes long, depending on whether the
--   salt string includes a password hash.

bcrypt_parseSaltString :: ByteString -> Maybe (Char, Word8, ByteString, ByteString)
bcrypt_parseSaltString :: ByteString -> Maybe (Char, Word8, ByteString, ByteString)
bcrypt_parseSaltString ByteString
salt
  | Bool -> Bool
not (ByteString -> Int
B.length ByteString
salt Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
29, Int
60]) = Maybe (Char, Word8, ByteString, ByteString)
forall a. Maybe a
Nothing
  | Bool -> Bool
not (ByteString
"$2" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
salt
         Bool -> Bool -> Bool
&& Word8 -> Char
w2c Word8
variant Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Char
'b' ]
         Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
salt Int
3 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'$' ) = Maybe (Char, Word8, ByteString, ByteString)
forall a. Maybe a
Nothing
  | Bool -> Bool
not (  Char -> Bool
Char.isDigit (Word8 -> Char
w2c (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
salt Int
4))
        Bool -> Bool -> Bool
&& Char -> Bool
Char.isDigit (Word8 -> Char
w2c (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
salt Int
5))
        Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
salt Int
6 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'$' ) = Maybe (Char, Word8, ByteString, ByteString)
forall a. Maybe a
Nothing
  | Bool -> Bool
not ( Word8
4 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
cost Bool -> Bool -> Bool
&& Word8
cost Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
31 ) = Maybe (Char, Word8, ByteString, ByteString)
forall a. Maybe a
Nothing
  | Just ByteString
binarySalt <- ByteString -> Maybe ByteString
base64Decode (Int -> ByteString -> ByteString
B.drop Int
7 (Int -> ByteString -> ByteString
B.take Int
29 ByteString
salt))
  , Just ByteString
binaryHash <- ByteString -> Maybe ByteString
base64Decode (Int -> ByteString -> ByteString
B.drop Int
29 ByteString
salt)
    = (Char, Word8, ByteString, ByteString)
-> Maybe (Char, Word8, ByteString, ByteString)
forall a. a -> Maybe a
Just (Word8 -> Char
w2c Word8
variant, Word8
cost, ByteString
binarySalt, ByteString
binaryHash)
  | Bool
otherwise = Maybe (Char, Word8, ByteString, ByteString)
forall a. Maybe a
Nothing
  where
    variant :: Word8
variant = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
salt Int
2
    cost :: Word8
cost = Word8
10 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
salt Int
4 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Char -> Word8
c2w Char
'0')
              Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
salt Int
5 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Char -> Word8
c2w Char
'0')

bcrypt_saltLength :: Int
bcrypt_saltLength :: Int
bcrypt_saltLength = Int
16

bcrypt_maxPasswordLength :: Int
bcrypt_maxPasswordLength :: Int
bcrypt_maxPasswordLength = Int
bcryptXs_maxKeyLength

bcrypt_outputLength :: Int
bcrypt_outputLength :: Int
bcrypt_outputLength = ByteString -> Int
B.length ByteString
bcrypt_outputSalt

-- | Any input longer than 72 bytes will be truncated.

bcryptRaw_maxInputLength :: Int
bcryptRaw_maxInputLength :: Int
bcryptRaw_maxInputLength = Int
bcryptXs_maxKeyLength

-- | Any output hash from 'bcryptRaw' will be exactly 24 bytes long.

bcryptRaw_outputLength :: Int
bcryptRaw_outputLength :: Int
bcryptRaw_outputLength = ByteString -> Int
B.length ByteString
bcryptRaw_outputSalt

-- | @bcryptRaw key salt rounds@ Be aware that keys and salts that are longer
--   than 72 bytes do get truncated to exactly 72 bytes. This binding will
--   return a hash that is exactly 24 bytes long.
--
--   Note the rounds parameter is one less than the number of rounds to be
--   computed. Thus if you want something equivalent to the traditional bcrypt
--   cost parameter of 12, you need to specify 4095 rounds.  This is because
--   @2^12 - 1 = 4095@.

bcryptRaw :: ByteString -> ByteString -> Word32 -> ByteString
bcryptRaw :: ByteString -> ByteString -> Word32 -> ByteString
bcryptRaw ByteString
key ByteString
salt Word32
rounds = BCryptXs -> ByteString
bcryptXs (ByteString -> ByteString -> Word32 -> BCryptXs
bcryptRaw_genInputs ByteString
key ByteString
salt Word32
rounds)

formatFnName :: ByteString -> ByteString
formatFnName :: ByteString -> ByteString
formatFnName (Int -> ByteString -> ByteString
B.take Int
28 -> ByteString
name) = [ByteString] -> ByteString
B.concat [Word32 -> ByteString
bytestring32 Word32
0, ByteString
name, ByteString
nameExt]
  where
    nameExt :: ByteString
nameExt = Int -> ByteString -> ByteString
B.take (Int
28 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
name) ByteString
nullBuffer

bcryptXsFree_tagBytesPerRound :: Int
bcryptXsFree_tagBytesPerRound :: Int
bcryptXsFree_tagBytesPerRound = Int
bcryptXsCtr_outputLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32

concatTakeBs :: Int -> [ByteString] -> ByteString
concatTakeBs :: Int -> [ByteString] -> ByteString
concatTakeBs Int
n [ByteString]
bs = [ByteString] -> ByteString
B.concat (Int64 -> [ByteString] -> [ByteString]
takeBs (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) [ByteString]
bs)

bcryptXsFree :: forall f a. Foldable f => (a -> ByteString) -> ByteString
             -> f a -> ByteString -> f a -> ByteString -> Word32
             -> HmacKeyPrefixed -> (Int, HmacKeyPrefixed)
bcryptXsFree :: forall (f :: * -> *) a.
Foldable f =>
(a -> ByteString)
-> ByteString
-> f a
-> ByteString
-> f a
-> ByteString
-> Word32
-> HmacKeyPrefixed
-> (Int, HmacKeyPrefixed)
bcryptXsFree a -> ByteString
toString ByteString
fnName f a
creds ByteString
longTag f a
contextTags ByteString
domainTag Word32
ctr0 = HmacKeyPrefixed -> (Int, HmacKeyPrefixed)
initRound
  where
    Int64
rounds :: Int64 = Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ctr0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1
    -- Do 1-128 minirounds in the first superround, so that we end on an
    -- exact multiple of 128
    Int64
miniRoundBytes :: Int64 = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bcryptXsFree_tagBytesPerRound
    miniRounds0 :: Int64
miniRounds0 = let x :: Int64
x = Int64
rounds Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. Int64
127
                   in if Int64
x Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 then Int64
128 else Int64
x
    -- The number of superrounds after the first
    superRounds0 :: Int64
superRounds0 = (Int64
rounds Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
miniRounds0) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
128
    tagBytesFrom :: Int64 -> [ByteString]
tagBytesFrom = Int64 -> ByteString -> Int64 -> [ByteString]
chunkifyCycle Int64
32 ByteString
longTag

    -- minimum number of half blocks to complete a local commitment to the
    -- entirety of an excessively long extended salt for a single bcrypt round.

    -- The first and last rounds of the superround have their extended salts
    -- committed to as part of deriving the keys in use for that superround.

    -- This turns into cryptoacoustic repetition if the longTag is not
    -- excessively long.

    Int
halfBlocks :: Int = Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((Int64 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
miniRoundBytes :: Float) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
32)

    initRound :: HmacKeyPrefixed -> (Int, HmacKeyPrefixed)
    initRound :: HmacKeyPrefixed -> (Int, HmacKeyPrefixed)
initRound !HmacKeyPrefixed
sha0 =
      let
        -- Locally ensure that the extended salt for the first and last
        -- rounds have been committed to before deriving the keys.

        -- (This turns into cryptoacoustic repetition if the extended salt
        -- isn't excessively long.)

        lastOffset :: Int64
lastOffset = (Int64
miniRounds0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
miniRoundBytes

        ltA :: [ByteString]
ltA = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take Int
halfBlocks ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Int64 -> [ByteString]
tagBytesFrom Int64
0
        ltZ :: [ByteString]
ltZ = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take (Int
halfBlocks Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Int64 -> [ByteString]
tagBytesFrom Int64
lastOffset

        -- Now actually perform the commitment:
        (ByteString
"", HmacKeyPrefixed
sha1) = [ByteString] -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
forall (f :: * -> *).
Foldable f =>
f ByteString -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
hmacKeyPrefixed_feeds ([ByteString]
ltA [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
ltZ) HmacKeyPrefixed
sha0

      in Word32
-> HmacKeyPrefixed
-> Maybe (f a)
-> Maybe BCryptState
-> Word32
-> Word32
-> Word32
-> (Int, HmacKeyPrefixed)
superRound Word32
0 HmacKeyPrefixed
sha1 (f a -> Maybe (f a)
forall a. a -> Maybe a
Just f a
creds) Maybe BCryptState
forall a. Maybe a
Nothing Word32
ctr0 (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
miniRounds0) (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
superRounds0)

    superRound :: Word32 -> HmacKeyPrefixed -> Maybe (f a) -> Maybe BCryptState -> Word32 -> Word32 -> Word32 -> (Int, HmacKeyPrefixed)
    superRound :: Word32
-> HmacKeyPrefixed
-> Maybe (f a)
-> Maybe BCryptState
-> Word32
-> Word32
-> Word32
-> (Int, HmacKeyPrefixed)
superRound Word32
tagPos !HmacKeyPrefixed
sha0 Maybe (f a)
mCreds Maybe BCryptState
mBcrypt0 Word32
ctr Word32
miniRounds Word32
superRounds =
      let
        -- The derivation of the keys for the superround will locally commit
        -- to the first 96 - 222 bytes of the extended salt of the
        -- penultimate miniround.
        penOffset :: Int64
penOffset = Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tagPos Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
miniRounds Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
2) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
miniRoundBytes
        penBytes :: [ByteString]
penBytes  = Int64 -> [ByteString]
tagBytesFrom Int64
penOffset
        endPad0 :: Int -> ByteString
endPad0 Int
n = Int -> [ByteString] -> ByteString
concatTakeBs Int
n (Int64 -> [ByteString]
tagBytesFrom (Int64
penOffset Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
96))
        endPad1 :: Int -> ByteString
endPad1 Int
n = Int -> [ByteString] -> ByteString
concatTakeBs Int
n (Int64 -> [ByteString]
tagBytesFrom (Int64
penOffset Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
96 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n))
        addCredentials :: f a -> PhkdfCtx -> PhkdfCtx
        addCredentials :: f a -> PhkdfCtx -> PhkdfCtx
addCredentials f a
cs PhkdfCtx
ctx0 = PhkdfCtx
ctx2
          where
            n0 :: Word64
n0 = PhkdfCtx -> Word64
phkdfCtx_byteCount PhkdfCtx
ctx0 Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
64
            n1 :: Word64
n1 = PhkdfCtx -> Word64
phkdfCtx_byteCount PhkdfCtx
ctx1 Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
64
            ctx1 :: PhkdfCtx
ctx1 = (a -> ByteString) -> f a -> PhkdfCtx -> PhkdfCtx
forall (f :: * -> *) a.
Foldable f =>
(a -> ByteString) -> f a -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArgsBy a -> ByteString
toString f a
cs PhkdfCtx
ctx0
            ctx2 :: PhkdfCtx
ctx2 = ByteString -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArg ByteString
credsPad PhkdfCtx
ctx1 PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
                   Word64 -> PhkdfCtx -> PhkdfCtx
phkdfCtx_assertBufferPosition Word64
n0
            -- Length of PHKDF end-of-args padding
            endPadLen :: Int
endPadLen = PhkdfCtx -> Int
phkdfCtx_endPaddingLength PhkdfCtx
ctx0
            -- Encoded length of credentials vector, mod 64
            credsLen :: Word64
credsLen = (Word64
n1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
n0) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
64
            -- We want to add 32 - 95 bytes as needed to bring the length
            -- of the encoded credentials vector + padding equivalent to
            -- 0 (mod 64).  Then use endPaddingLen to commit to more extended
            -- salt  (Note that this padding will require 3 bytes to
            -- encode it's length.)
            credsPadLen :: Int64
credsPadLen = Int64
32 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (Int64
29 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
credsLen) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Int64
64
            -- Now we'll commit to the next 32-95 bytes of the extended salt
            -- on the penultimate miniround:
            credsPadOffset :: Int64
credsPadOffset = Int64
penOffset Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
96 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
endPadLen
            credsPad :: ByteString
credsPad = [ByteString] -> ByteString
B.concat (Int64 -> [ByteString] -> [ByteString]
takeBs Int64
credsPadLen (Int64 -> [ByteString]
tagBytesFrom Int64
credsPadOffset))

        key0 :: ByteString
key0 = ByteString -> HmacKeyPrefixed -> PhkdfCtx
phkdfCtx_initPrefixed ([ByteString]
penBytes [ByteString] -> Int -> ByteString
forall a. HasCallStack => [a] -> Int -> a
!! Int
0) HmacKeyPrefixed
sha0 PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
               (a -> ByteString) -> f a -> PhkdfCtx -> PhkdfCtx
forall (f :: * -> *) a.
Foldable f =>
(a -> ByteString) -> f a -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArgsBy a -> ByteString
toString f a
contextTags PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
               (PhkdfCtx -> PhkdfCtx)
-> (f a -> PhkdfCtx -> PhkdfCtx)
-> Maybe (f a)
-> PhkdfCtx
-> PhkdfCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PhkdfCtx -> PhkdfCtx
forall a. a -> a
id f a -> PhkdfCtx -> PhkdfCtx
addCredentials Maybe (f a)
mCreds PhkdfCtx -> (PhkdfCtx -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
&
               (Int -> ByteString)
-> Word32 -> ByteString -> PhkdfCtx -> ByteString
phkdfCtx_finalize Int -> ByteString
endPad0 (ByteString -> Word32
word32 ByteString
"KEY0") ByteString
domainTag

        (ByteString
"",HmacKeyPrefixed
sha1) = [ByteString] -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
forall (f :: * -> *).
Foldable f =>
f ByteString -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
hmacKeyPrefixed_feeds [[ByteString]
penBytes [ByteString] -> Int -> ByteString
forall a. HasCallStack => [a] -> Int -> a
!! Int
1, ByteString
key0] HmacKeyPrefixed
sha0

        key1 :: ByteString
key1 = ByteString -> HmacKeyPrefixed -> PhkdfCtx
phkdfCtx_initPrefixed ([ByteString]
penBytes [ByteString] -> Int -> ByteString
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) HmacKeyPrefixed
sha1 PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
               (a -> ByteString) -> f a -> PhkdfCtx -> PhkdfCtx
forall (f :: * -> *) a.
Foldable f =>
(a -> ByteString) -> f a -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArgsBy a -> ByteString
toString f a
contextTags PhkdfCtx -> (PhkdfCtx -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
&
               (Int -> ByteString)
-> Word32 -> ByteString -> PhkdfCtx -> ByteString
phkdfCtx_finalize Int -> ByteString
endPad1 (ByteString -> Word32
word32 ByteString
"KEY1") ByteString
domainTag

        args :: BCryptXsCtr
args = BCryptXsCtr
          { bcryptXsCtr_key0 :: ByteString
bcryptXsCtr_key0 = ByteString
key0
          , bcryptXsCtr_key1 :: ByteString
bcryptXsCtr_key1 = ByteString
key1
          , bcryptXsCtr_tag :: ByteString
bcryptXsCtr_tag  = ByteString
longTag
          , bcryptXsCtr_name :: ByteString
bcryptXsCtr_name = ByteString -> ByteString
formatFnName ByteString
fnName
          }

        (Word32
tagPos', BCryptState
bcrypt1) = BCryptXsCtr
-> Word32
-> Word32
-> Word32
-> Maybe BCryptState
-> (Word32, BCryptState)
bcryptXsCtrSuperRound BCryptXsCtr
args
                                Word32
tagPos (Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
miniRounds) Word32
ctr Maybe BCryptState
mBcrypt0

        (ByteString
pBit, ByteString
pBox) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 (BCryptState -> ByteString
bcryptState_toByteString BCryptState
bcrypt1)

        chunksR :: [ByteString]
chunksR = ByteString
key1 ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
key0 ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
orpheanBeholderScryDoubt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pBit ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
                      Int -> ByteString -> [ByteString]
chunkify Int
32 ByteString
pBox

        list2 :: a -> a -> [a]
list2 a
x a
y = [a
x,a
y]
      in
        if Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tagPos' Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== (Int64
penOffset Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
*Int64
miniRoundBytes) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
longTag Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
             Word32
superRounds Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then let

            -- Now we need to do the local commitment for the *next* superround

            -- The next local commitment needs the offset into the tag used
            -- for the last miniround. There is always 128 minirounds in the
            -- next superround.

            lastOffset :: Int64
lastOffset = Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tagPos' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
127 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
miniRoundBytes

            ltA :: [ByteString]
ltA = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take Int
halfBlocks (Int64 -> [ByteString]
tagBytesFrom (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tagPos'))
            ltZ :: [ByteString]
ltZ = Int64 -> [ByteString]
tagBytesFrom Int64
lastOffset

            nextChunks :: [ByteString]
nextChunks = [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ByteString -> ByteString -> [ByteString])
-> [ByteString] -> [ByteString] -> [[ByteString]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ByteString -> ByteString -> [ByteString]
forall {a}. a -> a -> [a]
list2 [ByteString]
ltZ [ByteString]
chunksR) [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
ltA

            (ByteString
"",HmacKeyPrefixed
nextSha) = [ByteString] -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
forall (f :: * -> *).
Foldable f =>
f ByteString -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
hmacKeyPrefixed_feeds [ByteString]
nextChunks HmacKeyPrefixed
sha0
          in
            Word32
-> HmacKeyPrefixed
-> Maybe (f a)
-> Maybe BCryptState
-> Word32
-> Word32
-> Word32
-> (Int, HmacKeyPrefixed)
superRound Word32
tagPos' HmacKeyPrefixed
nextSha Maybe (f a)
forall a. Maybe a
Nothing (BCryptState -> Maybe BCryptState
forall a. a -> Maybe a
Just BCryptState
bcrypt1)
                       (Word32
ctr Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
miniRounds) Word32
128 (Word32
superRounds Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1)
        else let
            -- Now we need to do the end-of-key-stretching finalization.

            -- Repeat the most recent tag:

            endOffset :: Int64
endOffset = Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tagPos' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
32Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
*(Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
chunksR))

            endChunksL :: [ByteString]
endChunksL = Int64 -> [ByteString]
tagBytesFrom Int64
endOffset

            endChunks :: [ByteString]
endChunks = [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ByteString -> ByteString -> [ByteString])
-> [ByteString] -> [ByteString] -> [[ByteString]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ByteString -> ByteString -> [ByteString]
forall {a}. a -> a -> [a]
list2 [ByteString]
endChunksL [ByteString]
chunksR)

            (ByteString
"",HmacKeyPrefixed
endSha) = [ByteString] -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
forall (f :: * -> *).
Foldable f =>
f ByteString -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed)
hmacKeyPrefixed_feeds [ByteString]
endChunks HmacKeyPrefixed
sha0
          in
            ((,) (Int -> HmacKeyPrefixed -> (Int, HmacKeyPrefixed))
-> Int -> HmacKeyPrefixed -> (Int, HmacKeyPrefixed)
forall a b. (a -> b) -> a -> b
$! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tagPos') (HmacKeyPrefixed -> (Int, HmacKeyPrefixed))
-> HmacKeyPrefixed -> (Int, HmacKeyPrefixed)
forall a b. (a -> b) -> a -> b
$! HmacKeyPrefixed
endSha