{-# LANGUAGE OverloadedStrings #-}

-------------------------------------------------------------------------------
-- |
-- Module:      Crypto.G3P.V2.Foxtrot
-- Copyright:   (c) 2024 Auth Global
-- License:     Apache2
--
-------------------------------------------------------------------------------

{- |

Stripped-down version of G3Pb2 charlie, primarily intended for server-side
application. This uses HMAC-SHA256 both to generate inputs to bcrypt and to
summarize the resulting bcrypt state.

Assuming your deployment is basically a traditional give-me-your-password
authentication protocol but with prehashing, I recommend a two-step approach
to counteracting prehash precomputation attacks. First, I recommend that the
server apply at least as much key-stretching as the client. Second, I recommend
this server-side key-stretching be protected by a secret HMAC key.

In such a deployment, a cracker could front-load half of the computation
needed to guess a password at significant storage expense. This is far less
appealing to the cracker than being able to front-load nearly all of
the computation needed while incurring the same expense to store the
intermediate guesses.

The test suite's MyCorpExample.hs contains an example of how one might use
these functions in a deployment. By using reduced-round calls to 'g3pFoxtrot'
in conjuction with argon2, one can make precomputation an even less appealing
strategy, as the key-stretching occurs server-side is significantly more
expensive than the prehash itself.

-}
module Crypto.G3P.V2.Foxtrot where

import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.Function((&))
import           Data.Word
import           Data.Vector(Vector)
import qualified Data.Vector as V

import           Crypto.G3P.BCrypt (bcryptXsFree)
import           Crypto.PHKDF
import           Crypto.Encoding.PHKDF (takeBs, nullBuffer)

import           Network.ByteOrder(bytestring64)

data G3PFoxtrotSalt = G3PFoxtrotSalt
  { G3PFoxtrotSalt -> HmacKey
g3pFoxtrotSalt_key :: !HmacKey
  , G3PFoxtrotSalt -> ByteString
g3pFoxtrotSalt_longTag :: !ByteString
  , G3PFoxtrotSalt -> Vector ByteString
g3pFoxtrotSalt_contextTags :: !(Vector ByteString)
  , G3PFoxtrotSalt -> ByteString
g3pFoxtrotSalt_domainTag :: !ByteString
  , G3PFoxtrotSalt -> Word32
g3pFoxtrotSalt_bcryptRounds :: !Word32
  }


-- | G3Pb2 foxtrot is a function that incorporates a bcrypt-like key-stretching
--   phase. Stripped down version of G3Pb2 charlie, without a built-in continuation
--   control key. @test/MyCorpExample.hs@ uses this as a server-side cryptoacoustic
--   component that sandwiches the comparatively silent argon2.

g3pFoxtrot
  :: (Foldable f, Foldable g)
  => G3PFoxtrotSalt
  -> f ByteString
  -> g ByteString
  -> Word32
  -> ByteString
g3pFoxtrot :: forall (f :: * -> *) (g :: * -> *).
(Foldable f, Foldable g) =>
G3PFoxtrotSalt
-> f ByteString -> g ByteString -> Word32 -> ByteString
g3pFoxtrot G3PFoxtrotSalt
salt f ByteString
inputs = g ByteString -> Word32 -> ByteString
forall {f :: * -> *}.
Foldable f =>
f ByteString -> Word32 -> ByteString
doTweak
  where
    foxtrot :: ByteString
foxtrot = ByteString
"G3Pb2 foxtrot"
    key :: HmacKey
key = G3PFoxtrotSalt -> HmacKey
g3pFoxtrotSalt_key G3PFoxtrotSalt
salt
    longTag :: ByteString
longTag = G3PFoxtrotSalt -> ByteString
g3pFoxtrotSalt_longTag G3PFoxtrotSalt
salt
    contextTags :: Vector ByteString
contextTags = G3PFoxtrotSalt -> Vector ByteString
g3pFoxtrotSalt_contextTags G3PFoxtrotSalt
salt
    domainTag :: ByteString
domainTag = G3PFoxtrotSalt -> ByteString
g3pFoxtrotSalt_domainTag G3PFoxtrotSalt
salt
    rounds :: Word32
rounds = G3PFoxtrotSalt -> Word32
g3pFoxtrotSalt_bcryptRounds G3PFoxtrotSalt
salt

    spark :: HmacKeyPrefixed
spark =
      HmacKey -> PhkdfCtx
phkdfCtx_init HmacKey
key PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
      ByteString -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArg ByteString
foxtrot PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
      f ByteString -> PhkdfCtx -> PhkdfCtx
forall (f :: * -> *).
Foldable f =>
f ByteString -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArgs f ByteString
inputs PhkdfCtx -> (PhkdfCtx -> HmacKeyPrefixed) -> HmacKeyPrefixed
forall a b. a -> (a -> b) -> b
&
      (Int -> ByteString) -> PhkdfCtx -> HmacKeyPrefixed
phkdfCtx_toHmacKeyPrefixed ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (Int -> [ByteString]) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> [ByteString] -> [ByteString])
-> [ByteString] -> Int64 -> [ByteString]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int64 -> [ByteString] -> [ByteString]
takeBs [ByteString
domainTag, ByteString
"\x00", ByteString
longTag, ByteString
nullBuffer] (Int64 -> [ByteString]) -> (Int -> Int64) -> Int -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

    -- G3Pb2 foxtrot doesn't ever explicitly encode the length of the syntax
    -- generated by bcryptXsFree in the plaintext of the HMAC message itself.

    -- This length of this syntax is determined by the number of superrounds,
    -- which in turn is determined by the number of bcrypt rounds.

    -- This doesn't create any homophones, a.k.a. "canonicalization attacks",
    -- which is terminology that the algebraist in me isn't fond of.

    -- It can't cause homophones because the number of rounds, and thus this
    -- syntax length, is encoded in the bcrypt key-stretching phase well before
    -- the very first bcrypt output byte is generated. As these bytes are
    -- then consumed by HMAC, their overall length is implicitly encoded into
    -- the HMAC message.

    -- Not to mention that there are heurstic methods to parse the generated
    -- HMAC syntax without knowing the number of bcrypt rounds up front
    -- that will perform with perfect accuracy on most or all actual
    -- deployments. Every superround results in a fixed-length, multi-kilobyte
    -- syntax string appended to the message, which is much much longer than
    -- the expected length of the remaining parameters. Futhermore each
    -- multi-kilobyte superround syntax string always contains the literal
    -- sequence of bytes "OrpheanBeholderScryDoubt" in a fixed location,
    -- which in practice won't appear in other parameters.

    bcryptName :: ByteString
bcryptName = [ByteString] -> ByteString
B.concat
      [ ByteString
"G3Pb2 bcrypt-xs-free"
      , Word64 -> ByteString
bytestring64 (Word64
8 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
longTag))
      ]

    (Int
_tagPos, HmacKeyPrefixed
seed) =
      (ByteString -> ByteString)
-> ByteString
-> Vector ByteString
-> ByteString
-> Vector ByteString
-> ByteString
-> Word32
-> HmacKeyPrefixed
-> (Int, HmacKeyPrefixed)
forall (f :: * -> *) a.
Foldable f =>
(a -> ByteString)
-> ByteString
-> f a
-> ByteString
-> f a
-> ByteString
-> Word32
-> HmacKeyPrefixed
-> (Int, HmacKeyPrefixed)
bcryptXsFree ByteString -> ByteString
forall a. a -> a
id ByteString
bcryptName Vector ByteString
forall a. Vector a
V.empty ByteString
longTag Vector ByteString
contextTags ByteString
domainTag
                   Word32
rounds HmacKeyPrefixed
spark

    sprout :: PhkdfCtx
sprout =
      ByteString -> HmacKeyPrefixed -> PhkdfCtx
phkdfCtx_initPrefixed ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> [ByteString] -> [ByteString]
takeBs Int64
32 [ByteString
domainTag, ByteString
"\x00", ByteString
foxtrot, ByteString
nullBuffer]) HmacKeyPrefixed
seed PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
      Vector ByteString -> PhkdfCtx -> PhkdfCtx
forall (f :: * -> *).
Foldable f =>
f ByteString -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArgs Vector ByteString
contextTags

    doTweak :: f ByteString -> Word32 -> ByteString
doTweak f ByteString
tweak Word32
counter =
      f ByteString -> PhkdfCtx -> PhkdfCtx
forall (f :: * -> *).
Foldable f =>
f ByteString -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArgs f ByteString
tweak PhkdfCtx
sprout PhkdfCtx -> (PhkdfCtx -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
&
      (Int -> ByteString)
-> Word32 -> ByteString -> PhkdfCtx -> ByteString
phkdfCtx_finalize ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (Int -> [ByteString]) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> [ByteString] -> [ByteString])
-> [ByteString] -> Int64 -> [ByteString]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int64 -> [ByteString] -> [ByteString]
takeBs ([ByteString] -> [ByteString]
forall a. HasCallStack => [a] -> [a]
cycle [ByteString
domainTag, ByteString
"\x00"]) (Int64 -> [ByteString]) -> (Int -> Int64) -> Int -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Word32
counter ByteString
domainTag


-- | G3Pb2 tango: a simple application of PHKDF used to derive secret server-side
--   salts in @test/MyCorpExample.hs@.

-- TODO: rewrite this in a more point-free style, in order to better support partial application
g3pTango
  :: (Foldable f)
  => HmacKey
  -> f ByteString -- ^ inputs
  -> Word32       -- ^ counter
  -> ByteString   -- ^ domain tag
  -> ByteString   -- ^ 32-byte output hash
g3pTango :: forall (f :: * -> *).
Foldable f =>
HmacKey -> f ByteString -> Word32 -> ByteString -> ByteString
g3pTango HmacKey
key f ByteString
inputs Word32
counter ByteString
domainTag = ByteString
out
  where
    tango :: ByteString
tango = ByteString
"G3Pb2 tango"
    out :: ByteString
out =
      HmacKey -> PhkdfCtx
phkdfCtx_init HmacKey
key PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
      ByteString -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArg ByteString
tango PhkdfCtx -> (PhkdfCtx -> PhkdfCtx) -> PhkdfCtx
forall a b. a -> (a -> b) -> b
&
      f ByteString -> PhkdfCtx -> PhkdfCtx
forall (f :: * -> *).
Foldable f =>
f ByteString -> PhkdfCtx -> PhkdfCtx
phkdfCtx_feedArgs f ByteString
inputs PhkdfCtx -> (PhkdfCtx -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
&
      (Int -> ByteString)
-> Word32 -> ByteString -> PhkdfCtx -> ByteString
phkdfCtx_finalize ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (Int -> [ByteString]) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> [ByteString] -> [ByteString])
-> [ByteString] -> Int64 -> [ByteString]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int64 -> [ByteString] -> [ByteString]
takeBs ([ByteString] -> [ByteString]
forall a. HasCallStack => [a] -> [a]
cycle [ByteString
domainTag, ByteString
"\x00"]) (Int64 -> [ByteString]) -> (Int -> Int64) -> Int -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Word32
counter ByteString
domainTag