{-# OPTIONS_GHC -Wno-orphans #-}
module Wire.API.User.EmailAddress
( fromEmail,
emailAddress,
emailAddressText,
module Text.Email.Parser,
emailToSAMLNameID,
emailFromSAML,
)
where
import Cassandra.CQL qualified as C
import Data.ByteString.Conversion hiding (toByteString)
import Data.Data (Proxy (..))
import Data.OpenApi hiding (Schema, ToSchema)
import Data.Schema
import Data.Text hiding (null)
import Data.Text.Encoding
import Data.Text.Encoding.Error
import Deriving.Aeson
import Imports
import SAML2.WebSSO.Types qualified as SAML
import SAML2.WebSSO.Types.Email qualified as SAMLEmail
import Servant.API qualified as S
import Test.QuickCheck
import Text.Email.Parser
import Text.Email.Validate
instance ToByteString EmailAddress where
builder :: EmailAddress -> Builder
builder = Text -> Builder
forall a. ToByteString a => a -> Builder
builder (Text -> Builder)
-> (EmailAddress -> Text) -> EmailAddress -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> Text
fromEmail
instance FromByteString EmailAddress where
parser :: Parser EmailAddress
parser = Parser ByteString
forall a. FromByteString a => Parser a
parser Parser ByteString
-> (ByteString -> Parser EmailAddress) -> Parser EmailAddress
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser EmailAddress
-> (EmailAddress -> Parser EmailAddress)
-> Maybe EmailAddress
-> Parser EmailAddress
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser EmailAddress
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid email") EmailAddress -> Parser EmailAddress
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EmailAddress -> Parser EmailAddress)
-> (ByteString -> Maybe EmailAddress)
-> ByteString
-> Parser EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe EmailAddress
emailAddress
deriving via (Schema EmailAddress) instance ToJSON EmailAddress
deriving via (Schema EmailAddress) instance FromJSON EmailAddress
instance ToParamSchema EmailAddress where
toParamSchema :: Proxy EmailAddress -> Schema
toParamSchema Proxy EmailAddress
_ = Proxy Text -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
toParamSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Text)
instance ToSchema EmailAddress where
schema :: ValueSchema NamedSwaggerDoc EmailAddress
schema =
EmailAddress -> Text
fromEmail
(EmailAddress -> Text)
-> SchemaP NamedSwaggerDoc Value Value Text EmailAddress
-> ValueSchema NamedSwaggerDoc EmailAddress
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> (Text -> Either String EmailAddress)
-> SchemaP NamedSwaggerDoc Value Value Text EmailAddress
forall a.
Text
-> (Text -> Either String a)
-> SchemaP NamedSwaggerDoc Value Value Text a
parsedText
Text
"Email"
( Either String EmailAddress
-> (EmailAddress -> Either String EmailAddress)
-> Maybe EmailAddress
-> Either String EmailAddress
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(String -> Either String EmailAddress
forall a b. a -> Either a b
Left String
"Invalid email. Expected '<local>@<domain>'.")
EmailAddress -> Either String EmailAddress
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Maybe EmailAddress -> Either String EmailAddress)
-> (Text -> Maybe EmailAddress)
-> Text
-> Either String EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe EmailAddress
emailAddressText
)
instance S.FromHttpApiData EmailAddress where
parseUrlPiece :: Text -> Either Text EmailAddress
parseUrlPiece = Either Text EmailAddress
-> (EmailAddress -> Either Text EmailAddress)
-> Maybe EmailAddress
-> Either Text EmailAddress
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text EmailAddress
forall a b. a -> Either a b
Left Text
"Invalid email") EmailAddress -> Either Text EmailAddress
forall a b. b -> Either a b
Right (Maybe EmailAddress -> Either Text EmailAddress)
-> (Text -> Maybe EmailAddress) -> Text -> Either Text EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe EmailAddress
forall a. FromByteString a => ByteString -> Maybe a
fromByteString (ByteString -> Maybe EmailAddress)
-> (Text -> ByteString) -> Text -> Maybe EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
instance S.ToHttpApiData EmailAddress where
toUrlPiece :: EmailAddress -> Text
toUrlPiece = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (EmailAddress -> ByteString) -> EmailAddress -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString'
instance Arbitrary EmailAddress where
arbitrary :: Gen EmailAddress
arbitrary = Gen EmailAddress
arbitraryValidMail
instance C.Cql EmailAddress where
ctype :: Tagged EmailAddress ColumnType
ctype = ColumnType -> Tagged EmailAddress ColumnType
forall a b. b -> Tagged a b
C.Tagged ColumnType
C.TextColumn
fromCql :: Value -> Either String EmailAddress
fromCql (C.CqlText Text
t) = case Text -> Maybe EmailAddress
emailAddressText Text
t of
Just EmailAddress
e -> EmailAddress -> Either String EmailAddress
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmailAddress
e
Maybe EmailAddress
Nothing -> String -> Either String EmailAddress
forall a b. a -> Either a b
Left String
"fromCql: Invalid email"
fromCql Value
_ = String -> Either String EmailAddress
forall a b. a -> Either a b
Left String
"fromCql: email: CqlText expected"
toCql :: EmailAddress -> Value
toCql = Text -> Value
forall a. Cql a => a -> Value
C.toCql (Text -> Value) -> (EmailAddress -> Text) -> EmailAddress -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> Text
fromEmail
fromEmail :: EmailAddress -> Text
fromEmail :: EmailAddress -> Text
fromEmail = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (EmailAddress -> ByteString) -> EmailAddress -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> ByteString
toByteString
emailAddressText :: Text -> Maybe EmailAddress
emailAddressText :: Text -> Maybe EmailAddress
emailAddressText = ByteString -> Maybe EmailAddress
emailAddress (ByteString -> Maybe EmailAddress)
-> (Text -> ByteString) -> Text -> Maybe EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
arbitraryValidMail :: Gen EmailAddress
arbitraryValidMail :: Gen EmailAddress
arbitraryValidMail = do
String
loc <- Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Bool) -> Gen String
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` String -> Bool
isValidLoc
String
dom <- Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Bool) -> Gen String
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` String -> Bool
isValidDom
EmailAddress -> Gen EmailAddress
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmailAddress -> Gen EmailAddress)
-> (Maybe EmailAddress -> EmailAddress)
-> Maybe EmailAddress
-> Gen EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe EmailAddress -> EmailAddress
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe EmailAddress -> Gen EmailAddress)
-> Maybe EmailAddress -> Gen EmailAddress
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe EmailAddress
emailAddress (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
loc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dom)
where
notAt :: String -> Bool
notAt :: String -> Bool
notAt = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Char
'@'
notNull :: [a] -> Bool
notNull = Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
isValidLoc :: String -> Bool
isValidLoc :: String -> Bool
isValidLoc String
x =
String -> Bool
forall a. [a] -> Bool
notNull String
x
Bool -> Bool -> Bool
&& String -> Bool
notAt String
x
Bool -> Bool -> Bool
&& ByteString -> Bool
isValid (String -> ByteString
forall a. IsString a => String -> a
fromString (String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@mail.com"))
isValidDom :: String -> Bool
isValidDom :: String -> Bool
isValidDom String
x =
String -> Bool
forall a. [a] -> Bool
notNull String
x
Bool -> Bool -> Bool
&& String -> Bool
notAt String
x
Bool -> Bool -> Bool
&& ByteString -> Bool
isValid (String -> ByteString
forall a. IsString a => String -> a
fromString (String
"me@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x))
emailToSAMLNameID :: EmailAddress -> Either String SAML.NameID
emailToSAMLNameID :: EmailAddress -> Either String NameID
emailToSAMLNameID = Text -> Either String NameID
forall (m :: * -> *). MonadError String m => Text -> m NameID
SAML.emailNameID (Text -> Either String NameID)
-> (EmailAddress -> Text) -> EmailAddress -> Either String NameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> Text
fromEmail
emailFromSAML :: SAMLEmail.Email -> EmailAddress
emailFromSAML :: Email -> EmailAddress
emailFromSAML = Maybe EmailAddress -> EmailAddress
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe EmailAddress -> EmailAddress)
-> (Email -> Maybe EmailAddress) -> Email -> EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe EmailAddress
emailAddressText (Text -> Maybe EmailAddress)
-> (Email -> Text) -> Email -> Maybe EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Email -> Text
forall s.
(FoldCase s, ConvertibleStrings ByteString s) =>
Email -> s
SAMLEmail.render