{-# 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
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
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