{-# LANGUAGE TemplateHaskell #-}

module Wire.UserKeyStore where

import Data.Id
import Data.Text qualified as Text
import Data.Text.Encoding (decodeUtf8)
import Imports hiding (local)
import Polysemy
import Test.QuickCheck
import Wire.API.User

-- | An 'EmailKey' is an 'Email' in a form that serves as a unique lookup key.
data EmailKey = EmailKey
  { EmailKey -> Text
emailKeyUniq :: !Text,
    EmailKey -> EmailAddress
emailKeyOrig :: !EmailAddress
  }
  deriving (Eq EmailKey
Eq EmailKey =>
(EmailKey -> EmailKey -> Ordering)
-> (EmailKey -> EmailKey -> Bool)
-> (EmailKey -> EmailKey -> Bool)
-> (EmailKey -> EmailKey -> Bool)
-> (EmailKey -> EmailKey -> Bool)
-> (EmailKey -> EmailKey -> EmailKey)
-> (EmailKey -> EmailKey -> EmailKey)
-> Ord EmailKey
EmailKey -> EmailKey -> Bool
EmailKey -> EmailKey -> Ordering
EmailKey -> EmailKey -> EmailKey
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 :: EmailKey -> EmailKey -> Ordering
compare :: EmailKey -> EmailKey -> Ordering
$c< :: EmailKey -> EmailKey -> Bool
< :: EmailKey -> EmailKey -> Bool
$c<= :: EmailKey -> EmailKey -> Bool
<= :: EmailKey -> EmailKey -> Bool
$c> :: EmailKey -> EmailKey -> Bool
> :: EmailKey -> EmailKey -> Bool
$c>= :: EmailKey -> EmailKey -> Bool
>= :: EmailKey -> EmailKey -> Bool
$cmax :: EmailKey -> EmailKey -> EmailKey
max :: EmailKey -> EmailKey -> EmailKey
$cmin :: EmailKey -> EmailKey -> EmailKey
min :: EmailKey -> EmailKey -> EmailKey
Ord)

instance Show EmailKey where
  showsPrec :: Int -> EmailKey -> ShowS
showsPrec Int
_ = Text -> ShowS
forall a. Show a => a -> ShowS
shows (Text -> ShowS) -> (EmailKey -> Text) -> EmailKey -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailKey -> Text
emailKeyUniq

instance Eq EmailKey where
  (EmailKey Text
k EmailAddress
_) == :: EmailKey -> EmailKey -> Bool
== (EmailKey Text
k' EmailAddress
_) = Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
k'

instance Arbitrary EmailKey where
  arbitrary :: Gen EmailKey
arbitrary = EmailAddress -> EmailKey
mkEmailKey (EmailAddress -> EmailKey) -> Gen EmailAddress -> Gen EmailKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen EmailAddress
forall a. Arbitrary a => Gen a
arbitrary

-- | Turn an 'Email' into an 'EmailKey'.
--
-- The following transformations are performed:
--
--   * Both local and domain parts are forced to lowercase to make
--     e-mail addresses fully case-insensitive.
--   * "+" suffixes on the local part are stripped unless the domain
--     part is contained in a trusted whitelist.
mkEmailKey :: EmailAddress -> EmailKey
mkEmailKey :: EmailAddress -> EmailKey
mkEmailKey EmailAddress
orig =
  let uniq :: Text
uniq = Text -> Text
Text.toLower Text
localPart' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.toLower Text
domain
   in Text -> EmailAddress -> EmailKey
EmailKey Text
uniq EmailAddress
orig
  where
    domain :: Text
domain = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (EmailAddress -> ByteString) -> EmailAddress -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> ByteString
domainPart (EmailAddress -> Text) -> EmailAddress -> Text
forall a b. (a -> b) -> a -> b
$ EmailAddress
orig
    local :: Text
local = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (EmailAddress -> ByteString) -> EmailAddress -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> ByteString
localPart (EmailAddress -> Text) -> EmailAddress -> Text
forall a b. (a -> b) -> a -> b
$ EmailAddress
orig
    localPart' :: Text
localPart'
      | (EmailAddress -> ByteString
domainPart EmailAddress
orig) ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ByteString]
trusted = (Char -> Bool) -> Text -> Text
Text.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'+') Text
local
      | Bool
otherwise = ByteString -> Text
decodeUtf8 (EmailAddress -> ByteString
localPart EmailAddress
orig)
    trusted :: [ByteString]
trusted = [ByteString
"wearezeta.com", ByteString
"wire.com", ByteString
"simulator.amazonses.com"]

data UserKeyStore m a where
  LookupKey :: EmailKey -> UserKeyStore m (Maybe UserId)
  InsertKey :: UserId -> EmailKey -> UserKeyStore m ()
  DeleteKey :: EmailKey -> UserKeyStore m ()
  DeleteKeyForUser :: UserId -> EmailKey -> UserKeyStore m ()
  KeyAvailable :: EmailKey -> Maybe UserId -> UserKeyStore m Bool
  ClaimKey :: EmailKey -> UserId -> UserKeyStore m Bool

makeSem ''UserKeyStore