{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE StrictData #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Wire.API.User.Identity
  ( -- * UserIdentity
    UserIdentity (..),
    isSSOIdentity,
    newIdentity,
    emailIdentity,
    ssoIdentity,
    userIdentityObjectSchema,
    maybeUserIdentityObjectSchema,
    maybeUserIdentityFromComponents,

    -- * Phone
    Phone (..),
    parsePhone,
    isValidPhone,

    -- * Email
    module Wire.API.User.EmailAddress,

    -- * UserSSOId
    UserSSOId (..),
    mkSampleUref,
    mkSimpleSampleUref,
  )
where

import Cassandra qualified as C
import Control.Error (hush)
import Control.Lens (dimap, (.~), (?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as A
import Data.Aeson.Types qualified as A
import Data.ByteString (fromStrict, toStrict)
import Data.ByteString.UTF8 qualified as UTF8
import Data.OpenApi qualified as S
import Data.Schema
import Data.Text qualified as Text
import Data.Text.Encoding
import Data.Text.Encoding.Error
import Data.Text.Lazy qualified as LT
import Imports
import SAML2.WebSSO (UserRef (..))
import SAML2.WebSSO.Test.Arbitrary ()
import SAML2.WebSSO.Types qualified as SAML
import SAML2.WebSSO.XML qualified as SAML
import Servant
import System.FilePath ((</>))
import Text.Email.Parser
import URI.ByteString qualified as URI
import URI.ByteString.QQ (uri)
import Web.Scim.Schema.User.Email ()
import Wire.API.User.EmailAddress
import Wire.API.User.Phone
import Wire.API.User.Profile (fromName, mkName)
import Wire.Arbitrary (Arbitrary, GenericUniform (..))

--------------------------------------------------------------------------------
-- UserIdentity

-- | The private unique user identity that is used for login and
-- account recovery.
data UserIdentity
  = EmailIdentity EmailAddress
  | SSOIdentity UserSSOId (Maybe EmailAddress)
  deriving stock (UserIdentity -> UserIdentity -> Bool
(UserIdentity -> UserIdentity -> Bool)
-> (UserIdentity -> UserIdentity -> Bool) -> Eq UserIdentity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserIdentity -> UserIdentity -> Bool
== :: UserIdentity -> UserIdentity -> Bool
$c/= :: UserIdentity -> UserIdentity -> Bool
/= :: UserIdentity -> UserIdentity -> Bool
Eq, Eq UserIdentity
Eq UserIdentity =>
(UserIdentity -> UserIdentity -> Ordering)
-> (UserIdentity -> UserIdentity -> Bool)
-> (UserIdentity -> UserIdentity -> Bool)
-> (UserIdentity -> UserIdentity -> Bool)
-> (UserIdentity -> UserIdentity -> Bool)
-> (UserIdentity -> UserIdentity -> UserIdentity)
-> (UserIdentity -> UserIdentity -> UserIdentity)
-> Ord UserIdentity
UserIdentity -> UserIdentity -> Bool
UserIdentity -> UserIdentity -> Ordering
UserIdentity -> UserIdentity -> UserIdentity
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 :: UserIdentity -> UserIdentity -> Ordering
compare :: UserIdentity -> UserIdentity -> Ordering
$c< :: UserIdentity -> UserIdentity -> Bool
< :: UserIdentity -> UserIdentity -> Bool
$c<= :: UserIdentity -> UserIdentity -> Bool
<= :: UserIdentity -> UserIdentity -> Bool
$c> :: UserIdentity -> UserIdentity -> Bool
> :: UserIdentity -> UserIdentity -> Bool
$c>= :: UserIdentity -> UserIdentity -> Bool
>= :: UserIdentity -> UserIdentity -> Bool
$cmax :: UserIdentity -> UserIdentity -> UserIdentity
max :: UserIdentity -> UserIdentity -> UserIdentity
$cmin :: UserIdentity -> UserIdentity -> UserIdentity
min :: UserIdentity -> UserIdentity -> UserIdentity
Ord, Int -> UserIdentity -> ShowS
[UserIdentity] -> ShowS
UserIdentity -> String
(Int -> UserIdentity -> ShowS)
-> (UserIdentity -> String)
-> ([UserIdentity] -> ShowS)
-> Show UserIdentity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserIdentity -> ShowS
showsPrec :: Int -> UserIdentity -> ShowS
$cshow :: UserIdentity -> String
show :: UserIdentity -> String
$cshowList :: [UserIdentity] -> ShowS
showList :: [UserIdentity] -> ShowS
Show, (forall x. UserIdentity -> Rep UserIdentity x)
-> (forall x. Rep UserIdentity x -> UserIdentity)
-> Generic UserIdentity
forall x. Rep UserIdentity x -> UserIdentity
forall x. UserIdentity -> Rep UserIdentity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserIdentity -> Rep UserIdentity x
from :: forall x. UserIdentity -> Rep UserIdentity x
$cto :: forall x. Rep UserIdentity x -> UserIdentity
to :: forall x. Rep UserIdentity x -> UserIdentity
Generic)
  deriving (Gen UserIdentity
Gen UserIdentity
-> (UserIdentity -> [UserIdentity]) -> Arbitrary UserIdentity
UserIdentity -> [UserIdentity]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen UserIdentity
arbitrary :: Gen UserIdentity
$cshrink :: UserIdentity -> [UserIdentity]
shrink :: UserIdentity -> [UserIdentity]
Arbitrary) via (GenericUniform UserIdentity)

isSSOIdentity :: UserIdentity -> Bool
isSSOIdentity :: UserIdentity -> Bool
isSSOIdentity (SSOIdentity UserSSOId
_ Maybe EmailAddress
_) = Bool
True
isSSOIdentity UserIdentity
_ = Bool
False

userIdentityObjectSchema :: ObjectSchema SwaggerDoc UserIdentity
userIdentityObjectSchema :: ObjectSchema SwaggerDoc UserIdentity
userIdentityObjectSchema =
  UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> Maybe UserIdentity)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe UserIdentity) UserIdentity
-> ObjectSchema SwaggerDoc UserIdentity
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP
  SwaggerDoc Object [Pair] (Maybe UserIdentity) (Maybe UserIdentity)
-> (Maybe UserIdentity -> Parser UserIdentity)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe UserIdentity) UserIdentity
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
withParser SchemaP
  SwaggerDoc Object [Pair] (Maybe UserIdentity) (Maybe UserIdentity)
maybeUserIdentityObjectSchema (Parser UserIdentity
-> (UserIdentity -> Parser UserIdentity)
-> Maybe UserIdentity
-> Parser UserIdentity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser UserIdentity
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Missing 'email' or 'sso_id'.") UserIdentity -> Parser UserIdentity
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

maybeUserIdentityObjectSchema :: ObjectSchema SwaggerDoc (Maybe UserIdentity)
maybeUserIdentityObjectSchema :: SchemaP
  SwaggerDoc Object [Pair] (Maybe UserIdentity) (Maybe UserIdentity)
maybeUserIdentityObjectSchema =
  (Maybe UserIdentity -> UserIdentityComponents)
-> (UserIdentityComponents -> Maybe UserIdentity)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     UserIdentityComponents
     UserIdentityComponents
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe UserIdentity) (Maybe UserIdentity)
forall a b c d.
(a -> b)
-> (c -> d)
-> SchemaP SwaggerDoc Object [Pair] b c
-> SchemaP SwaggerDoc Object [Pair] a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Maybe UserIdentity -> UserIdentityComponents
maybeUserIdentityToComponents UserIdentityComponents -> Maybe UserIdentity
maybeUserIdentityFromComponents SchemaP
  SwaggerDoc
  Object
  [Pair]
  UserIdentityComponents
  UserIdentityComponents
userIdentityComponentsObjectSchema

type UserIdentityComponents = (Maybe EmailAddress, Maybe UserSSOId)

userIdentityComponentsObjectSchema :: ObjectSchema SwaggerDoc UserIdentityComponents
userIdentityComponentsObjectSchema :: SchemaP
  SwaggerDoc
  Object
  [Pair]
  UserIdentityComponents
  UserIdentityComponents
userIdentityComponentsObjectSchema =
  (,)
    (Maybe EmailAddress -> Maybe UserSSOId -> UserIdentityComponents)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     UserIdentityComponents
     (Maybe EmailAddress)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     UserIdentityComponents
     (Maybe UserSSOId -> UserIdentityComponents)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserIdentityComponents -> Maybe EmailAddress
forall a b. (a, b) -> a
fst (UserIdentityComponents -> Maybe EmailAddress)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe EmailAddress) (Maybe EmailAddress)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     UserIdentityComponents
     (Maybe EmailAddress)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP SwaggerDoc Object [Pair] EmailAddress (Maybe EmailAddress)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe EmailAddress) (Maybe EmailAddress)
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (ST
-> SchemaP NamedSwaggerDoc Value Value EmailAddress EmailAddress
-> SchemaP
     SwaggerDoc Object [Pair] EmailAddress (Maybe EmailAddress)
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
ST
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField ST
"email" SchemaP NamedSwaggerDoc Value Value EmailAddress EmailAddress
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
    SchemaP
  SwaggerDoc
  Object
  [Pair]
  UserIdentityComponents
  (Maybe UserSSOId -> UserIdentityComponents)
-> SchemaP
     SwaggerDoc Object [Pair] UserIdentityComponents (Maybe UserSSOId)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     UserIdentityComponents
     UserIdentityComponents
forall a b.
SchemaP SwaggerDoc Object [Pair] UserIdentityComponents (a -> b)
-> SchemaP SwaggerDoc Object [Pair] UserIdentityComponents a
-> SchemaP SwaggerDoc Object [Pair] UserIdentityComponents b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UserIdentityComponents -> Maybe UserSSOId
forall a b. (a, b) -> b
snd (UserIdentityComponents -> Maybe UserSSOId)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe UserSSOId) (Maybe UserSSOId)
-> SchemaP
     SwaggerDoc Object [Pair] UserIdentityComponents (Maybe UserSSOId)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP SwaggerDoc Object [Pair] UserSSOId (Maybe UserSSOId)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe UserSSOId) (Maybe UserSSOId)
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (ST
-> SchemaP NamedSwaggerDoc Value Value UserSSOId UserSSOId
-> SchemaP SwaggerDoc Object [Pair] UserSSOId (Maybe UserSSOId)
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
ST
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField ST
"sso_id" SchemaP NamedSwaggerDoc Value Value UserSSOId UserSSOId
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema)

maybeUserIdentityFromComponents :: UserIdentityComponents -> Maybe UserIdentity
maybeUserIdentityFromComponents :: UserIdentityComponents -> Maybe UserIdentity
maybeUserIdentityFromComponents = \case
  (Maybe EmailAddress
maybeEmail, Just UserSSOId
ssoid) -> UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> Maybe UserIdentity)
-> UserIdentity -> Maybe UserIdentity
forall a b. (a -> b) -> a -> b
$ UserSSOId -> Maybe EmailAddress -> UserIdentity
SSOIdentity UserSSOId
ssoid Maybe EmailAddress
maybeEmail
  (Just EmailAddress
email, Maybe UserSSOId
Nothing) -> UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> Maybe UserIdentity)
-> UserIdentity -> Maybe UserIdentity
forall a b. (a -> b) -> a -> b
$ EmailAddress -> UserIdentity
EmailIdentity EmailAddress
email
  (Maybe EmailAddress
Nothing, Maybe UserSSOId
Nothing) -> Maybe UserIdentity
forall a. Maybe a
Nothing

maybeUserIdentityToComponents :: Maybe UserIdentity -> UserIdentityComponents
maybeUserIdentityToComponents :: Maybe UserIdentity -> UserIdentityComponents
maybeUserIdentityToComponents Maybe UserIdentity
Nothing = (Maybe EmailAddress
forall a. Maybe a
Nothing, Maybe UserSSOId
forall a. Maybe a
Nothing)
maybeUserIdentityToComponents (Just (EmailIdentity EmailAddress
email)) = (EmailAddress -> Maybe EmailAddress
forall a. a -> Maybe a
Just EmailAddress
email, Maybe UserSSOId
forall a. Maybe a
Nothing)
maybeUserIdentityToComponents (Just (SSOIdentity UserSSOId
ssoid Maybe EmailAddress
m_email)) = (Maybe EmailAddress
m_email, UserSSOId -> Maybe UserSSOId
forall a. a -> Maybe a
Just UserSSOId
ssoid)

newIdentity :: Maybe EmailAddress -> Maybe UserSSOId -> Maybe UserIdentity
newIdentity :: Maybe EmailAddress -> Maybe UserSSOId -> Maybe UserIdentity
newIdentity Maybe EmailAddress
email (Just UserSSOId
sso) = UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> Maybe UserIdentity)
-> UserIdentity -> Maybe UserIdentity
forall a b. (a -> b) -> a -> b
$! UserSSOId -> Maybe EmailAddress -> UserIdentity
SSOIdentity UserSSOId
sso Maybe EmailAddress
email
newIdentity (Just EmailAddress
e) Maybe UserSSOId
Nothing = UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> Maybe UserIdentity)
-> UserIdentity -> Maybe UserIdentity
forall a b. (a -> b) -> a -> b
$! EmailAddress -> UserIdentity
EmailIdentity EmailAddress
e
newIdentity Maybe EmailAddress
Nothing Maybe UserSSOId
Nothing = Maybe UserIdentity
forall a. Maybe a
Nothing

emailIdentity :: UserIdentity -> Maybe EmailAddress
emailIdentity :: UserIdentity -> Maybe EmailAddress
emailIdentity (EmailIdentity EmailAddress
email) = EmailAddress -> Maybe EmailAddress
forall a. a -> Maybe a
Just EmailAddress
email
emailIdentity (SSOIdentity UserSSOId
_ (Just EmailAddress
email)) = EmailAddress -> Maybe EmailAddress
forall a. a -> Maybe a
Just EmailAddress
email
emailIdentity (SSOIdentity UserSSOId
_ Maybe EmailAddress
_) = Maybe EmailAddress
forall a. Maybe a
Nothing

ssoIdentity :: UserIdentity -> Maybe UserSSOId
ssoIdentity :: UserIdentity -> Maybe UserSSOId
ssoIdentity (SSOIdentity UserSSOId
ssoid Maybe EmailAddress
_) = UserSSOId -> Maybe UserSSOId
forall a. a -> Maybe a
Just UserSSOId
ssoid
ssoIdentity UserIdentity
_ = Maybe UserSSOId
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- UserSSOId

-- | User's external identity.
--
-- NB: this type is serialized to the full xml encoding of the `SAML.UserRef` components, but
-- deserialiation is more lenient: it also allows for the `Issuer` to be a plain URL (without
-- xml around it), and the `NameID` to be an email address (=> format "email") or an arbitrary
-- text (=> format "unspecified").  This is for backwards compatibility and general
-- robustness.
--
-- FUTUREWORK: we should probably drop this entirely and store saml and scim data in separate
-- database columns.
data UserSSOId
  = UserSSOId SAML.UserRef
  | UserScimExternalId Text
  deriving stock (UserSSOId -> UserSSOId -> Bool
(UserSSOId -> UserSSOId -> Bool)
-> (UserSSOId -> UserSSOId -> Bool) -> Eq UserSSOId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserSSOId -> UserSSOId -> Bool
== :: UserSSOId -> UserSSOId -> Bool
$c/= :: UserSSOId -> UserSSOId -> Bool
/= :: UserSSOId -> UserSSOId -> Bool
Eq, Int -> UserSSOId -> ShowS
[UserSSOId] -> ShowS
UserSSOId -> String
(Int -> UserSSOId -> ShowS)
-> (UserSSOId -> String)
-> ([UserSSOId] -> ShowS)
-> Show UserSSOId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserSSOId -> ShowS
showsPrec :: Int -> UserSSOId -> ShowS
$cshow :: UserSSOId -> String
show :: UserSSOId -> String
$cshowList :: [UserSSOId] -> ShowS
showList :: [UserSSOId] -> ShowS
Show, (forall x. UserSSOId -> Rep UserSSOId x)
-> (forall x. Rep UserSSOId x -> UserSSOId) -> Generic UserSSOId
forall x. Rep UserSSOId x -> UserSSOId
forall x. UserSSOId -> Rep UserSSOId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserSSOId -> Rep UserSSOId x
from :: forall x. UserSSOId -> Rep UserSSOId x
$cto :: forall x. Rep UserSSOId x -> UserSSOId
to :: forall x. Rep UserSSOId x -> UserSSOId
Generic)
  deriving (Gen UserSSOId
Gen UserSSOId -> (UserSSOId -> [UserSSOId]) -> Arbitrary UserSSOId
UserSSOId -> [UserSSOId]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen UserSSOId
arbitrary :: Gen UserSSOId
$cshrink :: UserSSOId -> [UserSSOId]
shrink :: UserSSOId -> [UserSSOId]
Arbitrary) via (GenericUniform UserSSOId)

instance C.Cql UserSSOId where
  ctype :: Tagged UserSSOId ColumnType
ctype = ColumnType -> Tagged UserSSOId ColumnType
forall a b. b -> Tagged a b
C.Tagged ColumnType
C.TextColumn

  fromCql :: Value -> Either String UserSSOId
fromCql (C.CqlText ST
t) = case ByteString -> Either String UserSSOId
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> Either String UserSSOId)
-> ByteString -> Either String UserSSOId
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict (ST -> ByteString
encodeUtf8 ST
t) of
    Right UserSSOId
i -> UserSSOId -> Either String UserSSOId
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserSSOId
i
    Left String
msg -> String -> Either String UserSSOId
forall a b. a -> Either a b
Left (String -> Either String UserSSOId)
-> String -> Either String UserSSOId
forall a b. (a -> b) -> a -> b
$ String
"fromCql: Invalid UserSSOId: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
  fromCql Value
_ = String -> Either String UserSSOId
forall a b. a -> Either a b
Left String
"fromCql: UserSSOId: CqlText expected"

  toCql :: UserSSOId -> Value
toCql = ST -> Value
forall a. Cql a => a -> Value
C.toCql (ST -> Value) -> (UserSSOId -> ST) -> UserSSOId -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> ST
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> ST) -> (UserSSOId -> ByteString) -> UserSSOId -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (UserSSOId -> ByteString) -> UserSSOId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserSSOId -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode

instance Ord UserSSOId where
  compare :: UserSSOId -> UserSSOId -> Ordering
compare (UserSSOId UserRef
ref1) (UserSSOId UserRef
ref2) = UserRef
ref1 UserRef -> UserRef -> Ordering
`ordUserRef` UserRef
ref2
  compare (UserSSOId UserRef
_) (UserScimExternalId ST
_) = Ordering
LT
  compare (UserScimExternalId ST
_) (UserSSOId UserRef
_) = Ordering
GT
  compare (UserScimExternalId ST
t1) (UserScimExternalId ST
t2) = ST
t1 ST -> ST -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` ST
t2

-- FUTUREWORK(mangoiv): this should be upstreamed, there's no reason why SAML.UserRef doesn't have
-- an Ord instane, both of its constituents have one
ordUserRef :: SAML.UserRef -> SAML.UserRef -> Ordering
ordUserRef :: UserRef -> UserRef -> Ordering
ordUserRef (UserRef Issuer
tenant1 NameID
subject1) (UserRef Issuer
tenant2 NameID
subject2) =
  Issuer -> Issuer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Issuer
tenant1 Issuer
tenant2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> NameID -> NameID -> Ordering
forall a. Ord a => a -> a -> Ordering
compare NameID
subject1 NameID
subject2

-- | FUTUREWORK: This schema should ideally be a choice of either tenant+subject, or scim_external_id
-- but this is currently not possible to derive in swagger2
-- Maybe this becomes possible with swagger 3?
instance S.ToSchema UserSSOId where
  declareNamedSchema :: Proxy UserSSOId -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy UserSSOId
_ = do
    Referenced Schema
tenantSchema <- Proxy ST -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Text) -- FUTUREWORK: 'Issuer'
    Referenced Schema
subjectSchema <- Proxy ST -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Text) -- FUTUREWORK: 'NameID'
    Referenced Schema
scimSchema <- Proxy ST -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Text)
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
      Maybe ST -> Schema -> NamedSchema
S.NamedSchema (ST -> Maybe ST
forall a. a -> Maybe a
Just ST
"UserSSOId") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
        Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_
            ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
S.OpenApiObject
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap ST (Referenced Schema)
 -> Identity (InsOrdHashMap ST (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap ST (Referenced Schema))
S.properties
            ((InsOrdHashMap ST (Referenced Schema)
  -> Identity (InsOrdHashMap ST (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap ST (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ (ST
"tenant", Referenced Schema
tenantSchema),
                 (ST
"subject", Referenced Schema
subjectSchema),
                 (ST
"scim_external_id", Referenced Schema
scimSchema)
               ]

instance ToJSON UserSSOId where
  toJSON :: UserSSOId -> Value
toJSON = \case
    UserSSOId (SAML.UserRef Issuer
tenant NameID
subject) -> [Pair] -> Value
A.object [Key
"tenant" Key -> LText -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= Issuer -> LText
forall a. HasXML a => a -> LText
SAML.encodeElem Issuer
tenant, Key
"subject" Key -> LText -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= NameID -> LText
forall a. HasXML a => a -> LText
SAML.encodeElem NameID
subject]
    UserScimExternalId ST
eid -> [Pair] -> Value
A.object [Key
"scim_external_id" Key -> ST -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= ST
eid]

instance FromJSON UserSSOId where
  parseJSON :: Value -> Parser UserSSOId
parseJSON = String -> (Object -> Parser UserSSOId) -> Value -> Parser UserSSOId
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"UserSSOId" ((Object -> Parser UserSSOId) -> Value -> Parser UserSSOId)
-> (Object -> Parser UserSSOId) -> Value -> Parser UserSSOId
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Maybe Issuer
mtenant <- Maybe LText -> Parser (Maybe Issuer)
lenientlyParseSAMLIssuer (Maybe LText -> Parser (Maybe Issuer))
-> Parser (Maybe LText) -> Parser (Maybe Issuer)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
obj Object -> Key -> Parser (Maybe LText)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
A..:? Key
"tenant")
    Maybe NameID
msubject <- Maybe LText -> Parser (Maybe NameID)
lenientlyParseSAMLNameID (Maybe LText -> Parser (Maybe NameID))
-> Parser (Maybe LText) -> Parser (Maybe NameID)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
obj Object -> Key -> Parser (Maybe LText)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
A..:? Key
"subject")
    Maybe ST
meid <- Object
obj Object -> Key -> Parser (Maybe ST)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
A..:? Key
"scim_external_id"
    case (Maybe Issuer
mtenant, Maybe NameID
msubject, Maybe ST
meid) of
      (Just Issuer
tenant, Just NameID
subject, Maybe ST
Nothing) -> UserSSOId -> Parser UserSSOId
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserSSOId -> Parser UserSSOId) -> UserSSOId -> Parser UserSSOId
forall a b. (a -> b) -> a -> b
$ UserRef -> UserSSOId
UserSSOId (Issuer -> NameID -> UserRef
SAML.UserRef Issuer
tenant NameID
subject)
      (Maybe Issuer
Nothing, Maybe NameID
Nothing, Just ST
eid) -> UserSSOId -> Parser UserSSOId
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserSSOId -> Parser UserSSOId) -> UserSSOId -> Parser UserSSOId
forall a b. (a -> b) -> a -> b
$ ST -> UserSSOId
UserScimExternalId ST
eid
      (Maybe Issuer, Maybe NameID, Maybe ST)
_ -> String -> Parser UserSSOId
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"either need tenant and subject, or scim_external_id, but not both"

lenientlyParseSAMLIssuer :: Maybe LText -> A.Parser (Maybe SAML.Issuer)
lenientlyParseSAMLIssuer :: Maybe LText -> Parser (Maybe Issuer)
lenientlyParseSAMLIssuer Maybe LText
mbtxt = Maybe LText -> (LText -> Parser Issuer) -> Parser (Maybe Issuer)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe LText
mbtxt ((LText -> Parser Issuer) -> Parser (Maybe Issuer))
-> (LText -> Parser Issuer) -> Parser (Maybe Issuer)
forall a b. (a -> b) -> a -> b
$ \LText
txt -> do
  let asxml :: Either String SAML.Issuer
      asxml :: Either String Issuer
asxml = LText -> Either String Issuer
forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
LText -> m a
SAML.decodeElem LText
txt

      asurl :: Either String SAML.Issuer
      asurl :: Either String Issuer
asurl =
        (URIParseError -> String)
-> (URIRef Absolute -> Issuer)
-> Either URIParseError (URIRef Absolute)
-> Either String Issuer
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap URIParseError -> String
forall a. Show a => a -> String
show URIRef Absolute -> Issuer
SAML.Issuer (Either URIParseError (URIRef Absolute) -> Either String Issuer)
-> Either URIParseError (URIRef Absolute) -> Either String Issuer
forall a b. (a -> b) -> a -> b
$
          URIParserOptions
-> ByteString -> Either URIParseError (URIRef Absolute)
URI.parseURI URIParserOptions
URI.laxURIParserOptions (ST -> ByteString
encodeUtf8 (ST -> ByteString) -> (LText -> ST) -> LText -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> ST
LT.toStrict (LText -> ByteString) -> LText -> ByteString
forall a b. (a -> b) -> a -> b
$ LText
txt)

      err :: String
      err :: String
err = String
"lenientlyParseSAMLIssuer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Either String Issuer, Either String Issuer, Maybe LText) -> String
forall a. Show a => a -> String
show (Either String Issuer
asxml, Either String Issuer
asurl, Maybe LText
mbtxt)

  Parser Issuer
-> (Issuer -> Parser Issuer) -> Maybe Issuer -> Parser Issuer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Issuer
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err) Issuer -> Parser Issuer
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Issuer -> Parser Issuer) -> Maybe Issuer -> Parser Issuer
forall a b. (a -> b) -> a -> b
$ Either String Issuer -> Maybe Issuer
forall a b. Either a b -> Maybe b
hush Either String Issuer
asxml Maybe Issuer -> Maybe Issuer -> Maybe Issuer
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either String Issuer -> Maybe Issuer
forall a b. Either a b -> Maybe b
hush Either String Issuer
asurl

lenientlyParseSAMLNameID :: Maybe LText -> A.Parser (Maybe SAML.NameID)
lenientlyParseSAMLNameID :: Maybe LText -> Parser (Maybe NameID)
lenientlyParseSAMLNameID Maybe LText
Nothing = Maybe NameID -> Parser (Maybe NameID)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NameID
forall a. Maybe a
Nothing
lenientlyParseSAMLNameID (Just LText
txt) = do
  let asxml :: Either String SAML.NameID
      asxml :: Either String NameID
asxml = LText -> Either String NameID
forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
LText -> m a
SAML.decodeElem LText
txt

      asemail :: Either String SAML.NameID
      asemail :: Either String NameID
asemail =
        Either String NameID
-> (EmailAddress -> Either String NameID)
-> Maybe EmailAddress
-> Either String NameID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (String -> Either String NameID
forall a b. a -> Either a b
Left String
"not an email")
          EmailAddress -> Either String NameID
emailToSAMLNameID
          (ST -> Maybe EmailAddress
emailAddressText (ST -> Maybe EmailAddress)
-> (LText -> ST) -> LText -> Maybe EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> ST
LT.toStrict (LText -> Maybe EmailAddress) -> LText -> Maybe EmailAddress
forall a b. (a -> b) -> a -> b
$ LText
txt)

      astxt :: Either String SAML.NameID
      astxt :: Either String NameID
astxt = do
        Name
nm <- ST -> Either String Name
mkName (ST -> Either String Name)
-> (LText -> ST) -> LText -> Either String Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> ST
LT.toStrict (LText -> Either String Name) -> LText -> Either String Name
forall a b. (a -> b) -> a -> b
$ LText
txt
        UnqualifiedNameID
-> Maybe ST -> Maybe ST -> Maybe ST -> Either String NameID
forall (m :: * -> *).
MonadError String m =>
UnqualifiedNameID -> Maybe ST -> Maybe ST -> Maybe ST -> m NameID
SAML.mkNameID (ST -> UnqualifiedNameID
SAML.mkUNameIDUnspecified (Name -> ST
fromName Name
nm)) Maybe ST
forall a. Maybe a
Nothing Maybe ST
forall a. Maybe a
Nothing Maybe ST
forall a. Maybe a
Nothing

      err :: String
      err :: String
err = String
"lenientlyParseSAMLNameID: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Either String NameID, Either String NameID, Either String NameID,
 LText)
-> String
forall a. Show a => a -> String
show (Either String NameID
asxml, Either String NameID
asemail, Either String NameID
astxt, LText
txt)

  Parser (Maybe NameID)
-> (NameID -> Parser (Maybe NameID))
-> Maybe NameID
-> Parser (Maybe NameID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (String -> Parser (Maybe NameID)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err)
    (Maybe NameID -> Parser (Maybe NameID)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NameID -> Parser (Maybe NameID))
-> (NameID -> Maybe NameID) -> NameID -> Parser (Maybe NameID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameID -> Maybe NameID
forall a. a -> Maybe a
Just)
    (Either String NameID -> Maybe NameID
forall a b. Either a b -> Maybe b
hush Either String NameID
asxml Maybe NameID -> Maybe NameID -> Maybe NameID
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either String NameID -> Maybe NameID
forall a b. Either a b -> Maybe b
hush Either String NameID
asemail Maybe NameID -> Maybe NameID -> Maybe NameID
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either String NameID -> Maybe NameID
forall a b. Either a b -> Maybe b
hush Either String NameID
astxt)

-- | For testing.  Create a sample 'SAML.UserRef' value with random seeds to make 'Issuer' and
-- 'NameID' unique.  FUTUREWORK: move to saml2-web-sso.
mkSampleUref :: Text -> Text -> SAML.UserRef
mkSampleUref :: ST -> ST -> UserRef
mkSampleUref ST
iseed ST
nseed = Issuer -> NameID -> UserRef
SAML.UserRef Issuer
issuer NameID
nameid
  where
    issuer :: SAML.Issuer
    issuer :: Issuer
issuer =
      URIRef Absolute -> Issuer
SAML.Issuer
        ( [uri|http://example.com/|]
            URIRef Absolute
-> (URIRef Absolute -> URIRef Absolute) -> URIRef Absolute
forall a b. a -> (a -> b) -> b
& (ByteString -> Identity ByteString)
-> URIRef Absolute -> Identity (URIRef Absolute)
forall a (f :: * -> *).
Functor f =>
(ByteString -> f ByteString) -> URIRef a -> f (URIRef a)
URI.pathL
              ((ByteString -> Identity ByteString)
 -> URIRef Absolute -> Identity (URIRef Absolute))
-> ByteString -> URIRef Absolute -> URIRef Absolute
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> ByteString
UTF8.fromString (String
"/" String -> ShowS
</> ST -> String
Text.unpack ST
iseed)
        )

    nameid :: SAML.NameID
    nameid :: NameID
nameid = NameID -> Either String NameID -> NameID
forall b a. b -> Either a b -> b
fromRight (String -> NameID
forall a. HasCallStack => String -> a
error String
"impossible") (Either String NameID -> NameID) -> Either String NameID -> NameID
forall a b. (a -> b) -> a -> b
$ do
      UnqualifiedNameID
unqualified <- ST -> Either String UnqualifiedNameID
forall (m :: * -> *).
MonadError String m =>
ST -> m UnqualifiedNameID
SAML.mkUNameIDEmail (ST -> Either String UnqualifiedNameID)
-> ST -> Either String UnqualifiedNameID
forall a b. (a -> b) -> a -> b
$ ST
"me" ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> ST
nseed ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> ST
"@example.com"
      UnqualifiedNameID
-> Maybe ST -> Maybe ST -> Maybe ST -> Either String NameID
forall (m :: * -> *).
MonadError String m =>
UnqualifiedNameID -> Maybe ST -> Maybe ST -> Maybe ST -> m NameID
SAML.mkNameID UnqualifiedNameID
unqualified Maybe ST
forall a. Maybe a
Nothing Maybe ST
forall a. Maybe a
Nothing Maybe ST
forall a. Maybe a
Nothing

-- | @mkSampleUref "" ""@
mkSimpleSampleUref :: SAML.UserRef
mkSimpleSampleUref :: UserRef
mkSimpleSampleUref = ST -> ST -> UserRef
mkSampleUref ST
"" ST
""