{-# OPTIONS_GHC -Wno-orphans #-}

module Wire.API.User.EmailAddress
  ( fromEmail,
    emailAddress,
    emailAddressText,
    module Text.Email.Parser,
    emailToSAMLNameID,
    emailFromSAML,
  )
where

-----
-- This is where we declare orphan instances
-----

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

--------------------------------------------------------------------------------
-- Email

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
  -- By generating arbitrary Text and then encoding as bytestrings
  -- we avoid the risk of generating invalid UTF-8 bytes.
  arbitrary :: Gen EmailAddress
arbitrary = Gen EmailAddress
arbitraryValidMail

-- loc <- fromString <$> listOf1 arbitraryMailString
-- dom <- fromString <$> listOf1 arbitraryMailString
-- pure $ unsafeEmailAddress loc dom

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

-- | Generates any Unicode character (but not a surrogate)
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))

-- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this
-- function total without all that praying and hoping.
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