module Wire.VerificationCodeGen
  ( VerificationCodeGen (genKey),
    mkVerificationCodeGen,
    mk6DigitVerificationCodeGen,
    mkKey,
    generateVerificationCode,
  )
where

import Crypto.Hash
import Data.ByteArray qualified as BA
import Data.ByteString qualified as BS
import Data.Code
import Data.Range
import Data.Text qualified as Text
import Data.Text.Ascii qualified as Ascii
import Data.Text.Encoding qualified as Text
import Data.UUID (UUID)
import Imports hiding (lookup)
import Polysemy
import Text.Printf
import Wire.API.User.Identity
import Wire.Arbitrary
import Wire.Sem.Random
import Wire.Sem.Random qualified as Random
import Wire.UserKeyStore
import Wire.VerificationCode

--------------------------------------------------------------------------------
-- VerificationCodeGeneration

data RandomValueType
  = Random6DigitNumber
  | Random15Bytes
  deriving (Int -> RandomValueType -> ShowS
[RandomValueType] -> ShowS
RandomValueType -> String
(Int -> RandomValueType -> ShowS)
-> (RandomValueType -> String)
-> ([RandomValueType] -> ShowS)
-> Show RandomValueType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RandomValueType -> ShowS
showsPrec :: Int -> RandomValueType -> ShowS
$cshow :: RandomValueType -> String
show :: RandomValueType -> String
$cshowList :: [RandomValueType] -> ShowS
showList :: [RandomValueType] -> ShowS
Show, RandomValueType -> RandomValueType -> Bool
(RandomValueType -> RandomValueType -> Bool)
-> (RandomValueType -> RandomValueType -> Bool)
-> Eq RandomValueType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RandomValueType -> RandomValueType -> Bool
== :: RandomValueType -> RandomValueType -> Bool
$c/= :: RandomValueType -> RandomValueType -> Bool
/= :: RandomValueType -> RandomValueType -> Bool
Eq, (forall x. RandomValueType -> Rep RandomValueType x)
-> (forall x. Rep RandomValueType x -> RandomValueType)
-> Generic RandomValueType
forall x. Rep RandomValueType x -> RandomValueType
forall x. RandomValueType -> Rep RandomValueType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RandomValueType -> Rep RandomValueType x
from :: forall x. RandomValueType -> Rep RandomValueType x
$cto :: forall x. Rep RandomValueType x -> RandomValueType
to :: forall x. Rep RandomValueType x -> RandomValueType
Generic)
  deriving (Gen RandomValueType
Gen RandomValueType
-> (RandomValueType -> [RandomValueType])
-> Arbitrary RandomValueType
RandomValueType -> [RandomValueType]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen RandomValueType
arbitrary :: Gen RandomValueType
$cshrink :: RandomValueType -> [RandomValueType]
shrink :: RandomValueType -> [RandomValueType]
Arbitrary) via GenericUniform RandomValueType

-- | A contextual string that is hashed into the key to yield distinct keys in
-- different contexts for the same email address.
-- TODO: newtype KeyContext = KeyContext ByteString
data VerificationCodeGen = VerificationCodeGen
  { VerificationCodeGen -> EmailAddress
genFor :: !EmailAddress,
    VerificationCodeGen -> Key
genKey :: !Key, -- Note [Unique keys]
    VerificationCodeGen -> RandomValueType
genValueType :: !RandomValueType
  }
  deriving (Int -> VerificationCodeGen -> ShowS
[VerificationCodeGen] -> ShowS
VerificationCodeGen -> String
(Int -> VerificationCodeGen -> ShowS)
-> (VerificationCodeGen -> String)
-> ([VerificationCodeGen] -> ShowS)
-> Show VerificationCodeGen
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerificationCodeGen -> ShowS
showsPrec :: Int -> VerificationCodeGen -> ShowS
$cshow :: VerificationCodeGen -> String
show :: VerificationCodeGen -> String
$cshowList :: [VerificationCodeGen] -> ShowS
showList :: [VerificationCodeGen] -> ShowS
Show, VerificationCodeGen -> VerificationCodeGen -> Bool
(VerificationCodeGen -> VerificationCodeGen -> Bool)
-> (VerificationCodeGen -> VerificationCodeGen -> Bool)
-> Eq VerificationCodeGen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerificationCodeGen -> VerificationCodeGen -> Bool
== :: VerificationCodeGen -> VerificationCodeGen -> Bool
$c/= :: VerificationCodeGen -> VerificationCodeGen -> Bool
/= :: VerificationCodeGen -> VerificationCodeGen -> Bool
Eq, (forall x. VerificationCodeGen -> Rep VerificationCodeGen x)
-> (forall x. Rep VerificationCodeGen x -> VerificationCodeGen)
-> Generic VerificationCodeGen
forall x. Rep VerificationCodeGen x -> VerificationCodeGen
forall x. VerificationCodeGen -> Rep VerificationCodeGen x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. VerificationCodeGen -> Rep VerificationCodeGen x
from :: forall x. VerificationCodeGen -> Rep VerificationCodeGen x
$cto :: forall x. Rep VerificationCodeGen x -> VerificationCodeGen
to :: forall x. Rep VerificationCodeGen x -> VerificationCodeGen
Generic)
  deriving (Gen VerificationCodeGen
Gen VerificationCodeGen
-> (VerificationCodeGen -> [VerificationCodeGen])
-> Arbitrary VerificationCodeGen
VerificationCodeGen -> [VerificationCodeGen]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen VerificationCodeGen
arbitrary :: Gen VerificationCodeGen
$cshrink :: VerificationCodeGen -> [VerificationCodeGen]
shrink :: VerificationCodeGen -> [VerificationCodeGen]
Arbitrary) via GenericUniform VerificationCodeGen

-- | Initialise a 'Code' 'VerificationCodeGen'erator for a given natural key.
-- This generates a link for emails and a 6-digit code for phone. See also:
-- `mk6DigitVerificationCodeGen`.
mkVerificationCodeGen :: EmailAddress -> VerificationCodeGen
mkVerificationCodeGen :: EmailAddress -> VerificationCodeGen
mkVerificationCodeGen EmailAddress
email =
  EmailAddress -> Key -> RandomValueType -> VerificationCodeGen
VerificationCodeGen EmailAddress
email (EmailAddress -> Key
mkKey EmailAddress
email) RandomValueType
Random15Bytes

-- | Initialise a 'Code' 'VerificationCodeGen'erator for a given natural key.
-- This generates a 6-digit code, matter whether it is sent to a phone or to an
-- email address. See also: `mkVerificationCodeGen`.
mk6DigitVerificationCodeGen :: EmailAddress -> VerificationCodeGen
mk6DigitVerificationCodeGen :: EmailAddress -> VerificationCodeGen
mk6DigitVerificationCodeGen EmailAddress
email = EmailAddress -> Key -> RandomValueType -> VerificationCodeGen
VerificationCodeGen EmailAddress
email (EmailAddress -> Key
mkKey EmailAddress
email) RandomValueType
Random6DigitNumber

mkKey :: EmailAddress -> Key
mkKey :: EmailAddress -> Key
mkKey EmailAddress
email =
  Range 20 20 AsciiBase64Url -> Key
Key
    (Range 20 20 AsciiBase64Url -> Key)
-> (EmailKey -> Range 20 20 AsciiBase64Url) -> EmailKey -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsciiBase64Url -> Range 20 20 AsciiBase64Url
forall a (n :: Nat) (m :: Nat).
(Show a, KnownNat n, KnownNat m, Within a n m) =>
a -> Range n m a
unsafeRange
    (AsciiBase64Url -> Range 20 20 AsciiBase64Url)
-> (EmailKey -> AsciiBase64Url)
-> EmailKey
-> Range 20 20 AsciiBase64Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> AsciiBase64Url
Ascii.encodeBase64Url
    (ByteString -> AsciiBase64Url)
-> (EmailKey -> ByteString) -> EmailKey -> AsciiBase64Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.take Int
15
    (ByteString -> ByteString)
-> (EmailKey -> ByteString) -> EmailKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
    (Digest SHA256 -> ByteString)
-> (EmailKey -> Digest SHA256) -> EmailKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash @_ @SHA256
    (ByteString -> Digest SHA256)
-> (EmailKey -> ByteString) -> EmailKey -> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
    (Text -> ByteString)
-> (EmailKey -> Text) -> EmailKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailKey -> Text
emailKeyUniq
    (EmailKey -> Key) -> EmailKey -> Key
forall a b. (a -> b) -> a -> b
$ EmailAddress -> EmailKey
mkEmailKey EmailAddress
email

-- | VerificationCodeGenerate a new 'Code'.
generateVerificationCode ::
  (Member Random r) =>
  -- | The 'VerificationCodeGen'erator to use.
  VerificationCodeGen ->
  -- | The scope of the generated code.
  Scope ->
  -- | Maximum verification attempts.
  Retries ->
  -- | Time-to-live in seconds.
  Timeout ->
  -- | Associated account ID.
  Maybe UUID ->
  Sem r Code
generateVerificationCode :: forall (r :: EffectRow).
Member Random r =>
VerificationCodeGen
-> Scope -> Retries -> Timeout -> Maybe UUID -> Sem r Code
generateVerificationCode VerificationCodeGen
gen Scope
scope Retries
retries Timeout
ttl Maybe UUID
account = do
  let key :: Key
key = VerificationCodeGen -> Key
genKey VerificationCodeGen
gen
  Value
val <- RandomValueType -> Sem r Value
forall (r :: EffectRow).
Member Random r =>
RandomValueType -> Sem r Value
genValue VerificationCodeGen
gen.genValueType
  Code -> Sem r Code
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code -> Sem r Code) -> Code -> Sem r Code
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Code
mkCode Key
key Value
val
  where
    mkCode :: Key -> Value -> Code
mkCode Key
key Value
val =
      Code
        { $sel:codeKey:Code :: Key
codeKey = Key
key,
          $sel:codeValue:Code :: Value
codeValue = Value
val,
          $sel:codeScope:Code :: Scope
codeScope = Scope
scope,
          $sel:codeRetries:Code :: Retries
codeRetries = Retries
retries,
          $sel:codeTTL:Code :: Timeout
codeTTL = Timeout
ttl,
          $sel:codeFor:Code :: EmailAddress
codeFor = VerificationCodeGen -> EmailAddress
genFor VerificationCodeGen
gen,
          $sel:codeAccount:Code :: Maybe UUID
codeAccount = Maybe UUID
account
        }

genValue :: (Member Random r) => RandomValueType -> Sem r Value
genValue :: forall (r :: EffectRow).
Member Random r =>
RandomValueType -> Sem r Value
genValue RandomValueType
Random15Bytes =
  Range 6 20 AsciiBase64Url -> Value
Value (Range 6 20 AsciiBase64Url -> Value)
-> (ByteString -> Range 6 20 AsciiBase64Url) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsciiBase64Url -> Range 6 20 AsciiBase64Url
forall a (n :: Nat) (m :: Nat).
(Show a, KnownNat n, KnownNat m, Within a n m) =>
a -> Range n m a
unsafeRange (AsciiBase64Url -> Range 6 20 AsciiBase64Url)
-> (ByteString -> AsciiBase64Url)
-> ByteString
-> Range 6 20 AsciiBase64Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> AsciiBase64Url
Ascii.encodeBase64Url
    (ByteString -> Value) -> Sem r ByteString -> Sem r Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Sem r ByteString
forall (r :: EffectRow). Member Random r => Int -> Sem r ByteString
Random.bytes Int
15
genValue RandomValueType
Random6DigitNumber =
  Range 6 20 AsciiBase64Url -> Value
Value (Range 6 20 AsciiBase64Url -> Value)
-> (Integer -> Range 6 20 AsciiBase64Url) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsciiBase64Url -> Range 6 20 AsciiBase64Url
forall a (n :: Nat) (m :: Nat).
(Show a, KnownNat n, KnownNat m, Within a n m) =>
a -> Range n m a
unsafeRange (AsciiBase64Url -> Range 6 20 AsciiBase64Url)
-> (Integer -> AsciiBase64Url)
-> Integer
-> Range 6 20 AsciiBase64Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> AsciiBase64Url
forall c. AsciiChars c => Text -> AsciiText c
Ascii.unsafeFromText (Text -> AsciiBase64Url)
-> (Integer -> Text) -> Integer -> AsciiBase64Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%06d"
    (Integer -> Value) -> Sem r Integer -> Sem r Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Sem r Integer
forall (r :: EffectRow). Member Random r => Int -> Sem r Integer
Random.nDigitNumber Int
6