{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- 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/>.

-- | SCIM user representation.
--
-- = Our interpretation of the spec
--
-- The spec can be read at <https://tools.ietf.org/html/rfc7643#section-4.1>.
-- While implementing the spec we had to resolve some ambiguities and place some
-- additional constraints on the possible SCIM server behavior we can support.
--
-- == Resource ID / user ID
--
-- The 'User' object doesn't contain a user ID (as in "opaque server-assigned
-- immutable ID") by design. IDs and metadata are added to types in a uniform
-- fashion by using @WithId@ and @WithMeta@.
--
-- == Optional fields
--
-- The spec only mandates the @userName@ and @id@ attribute. All other
-- attributes seem optional.
--
-- == Multi-valued fields
--
-- When a multi-valued field (e.g. @emails@) doesn't contain any values, it's
-- unclear whether we should serialize it as @[]@ or omit it entirely. We have
-- opted for the latter to conform to an example in the spec:
-- <https://tools.ietf.org/html/rfc7644#section-3.5.1>.
--
-- TODO(arianvp):
--  Multi-valued attributes actually have some more quirky semantics that we
--  currently don't support yet. E.g. if the multi-values have a
--  'primary' field then only one of the entires must have 'primary: true'
--  and all the others are either implied 'primary: false' or must be checked
--  that they're false
--
--
-- == Attribute names
--
-- When parsing JSON objects, we ignore capitalization differences in field
-- names -- e.g. both @USERNAME@ and @userName@ are accepted.
--  This is described by the spec  https://tools.ietf.org/html/rfc7643#section-2.1
module Web.Scim.Schema.User
  ( User (..),
    empty,
    NoUserExtra (..),
    applyPatch,
    resultToScimError,
    isUserSchema,
    module Web.Scim.Schema.UserTypes,
  )
where

import Control.Monad
import Control.Monad.Except
import Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.List ((\\))
import Data.Text (Text, pack)
import qualified Data.Text as Text
import GHC.Generics (Generic)
import Lens.Micro
import Web.Scim.AttrName
import Web.Scim.Filter (AttrPath (..))
import Web.Scim.Schema.Common
import Web.Scim.Schema.Error
import Web.Scim.Schema.PatchOp
import Web.Scim.Schema.Schema (Schema (..), getSchemaUri)
import Web.Scim.Schema.User.Address (Address)
import Web.Scim.Schema.User.Certificate (Certificate)
import Web.Scim.Schema.User.Email (Email)
import Web.Scim.Schema.User.IM (IM)
import Web.Scim.Schema.User.Name (Name)
import Web.Scim.Schema.User.Phone (Phone)
import Web.Scim.Schema.User.Photo (Photo)
import Web.Scim.Schema.UserTypes

-- | SCIM user record, parametrized with type-level @tag@ (see 'UserTypes').
data User tag = User
  { forall tag. User tag -> [Schema]
schemas :: [Schema],
    -- Mandatory fields
    forall tag. User tag -> Text
userName :: Text,
    -- Optional fields
    forall tag. User tag -> Maybe Text
externalId :: Maybe Text,
    forall tag. User tag -> Maybe Name
name :: Maybe Name,
    forall tag. User tag -> Maybe Text
displayName :: Maybe Text,
    forall tag. User tag -> Maybe Text
nickName :: Maybe Text,
    forall tag. User tag -> Maybe URI
profileUrl :: Maybe URI,
    forall tag. User tag -> Maybe Text
title :: Maybe Text,
    forall tag. User tag -> Maybe Text
userType :: Maybe Text,
    forall tag. User tag -> Maybe Text
preferredLanguage :: Maybe Text,
    forall tag. User tag -> Maybe Text
locale :: Maybe Text,
    forall tag. User tag -> Maybe ScimBool
active :: Maybe ScimBool,
    forall tag. User tag -> Maybe Text
password :: Maybe Text,
    -- Multi-valued fields
    forall tag. User tag -> [Email]
emails :: [Email],
    forall tag. User tag -> [Phone]
phoneNumbers :: [Phone],
    forall tag. User tag -> [IM]
ims :: [IM],
    forall tag. User tag -> [Photo]
photos :: [Photo],
    forall tag. User tag -> [Address]
addresses :: [Address],
    forall tag. User tag -> [Text]
entitlements :: [Text],
    forall tag. User tag -> [Text]
roles :: [Text],
    forall tag. User tag -> [Certificate]
x509Certificates :: [Certificate],
    -- Extra data.
    --
    -- During rendering, we'll convert it to JSON; if it's an object we'll merge it with the
    -- main user object, if it's @null@ we'll do nothing, otherwise we'll add it under the
    -- @"extra"@ field (though you should definitely not rely on this).
    --
    -- During parsing, we'll attempt to parse the /whole/ user object as @extra@, so your
    -- 'FromJSON' instance should be prepared to ignore unrelated fields. Also keep in mind that
    -- the SCIM spec requires field names to be case-insensitive, i.e. if you're looking for a
    -- field "foo" you should also handle a field called "FOO". Look at the @FromJSON User@
    -- instance to see how it can be done.
    --
    -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct
    -- rendering of optional and multivalued fields, lowercase objects, etc).
    forall tag. User tag -> UserExtra tag
extra :: UserExtra tag
  }
  deriving ((forall x. User tag -> Rep (User tag) x)
-> (forall x. Rep (User tag) x -> User tag) -> Generic (User tag)
forall x. Rep (User tag) x -> User tag
forall x. User tag -> Rep (User tag) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tag x. Rep (User tag) x -> User tag
forall tag x. User tag -> Rep (User tag) x
$cfrom :: forall tag x. User tag -> Rep (User tag) x
from :: forall x. User tag -> Rep (User tag) x
$cto :: forall tag x. Rep (User tag) x -> User tag
to :: forall x. Rep (User tag) x -> User tag
Generic)

deriving instance (Show (UserExtra tag)) => Show (User tag)

deriving instance (Eq (UserExtra tag)) => Eq (User tag)

empty ::
  -- | Schemas
  [Schema] ->
  -- | userName
  Text ->
  -- | Extra data
  UserExtra tag ->
  User tag
empty :: forall tag. [Schema] -> Text -> UserExtra tag -> User tag
empty [Schema]
schemas Text
userName UserExtra tag
extra =
  User
    { schemas :: [Schema]
schemas = [Schema]
schemas,
      userName :: Text
userName = Text
userName,
      externalId :: Maybe Text
externalId = Maybe Text
forall a. Maybe a
Nothing,
      name :: Maybe Name
name = Maybe Name
forall a. Maybe a
Nothing,
      displayName :: Maybe Text
displayName = Maybe Text
forall a. Maybe a
Nothing,
      nickName :: Maybe Text
nickName = Maybe Text
forall a. Maybe a
Nothing,
      profileUrl :: Maybe URI
profileUrl = Maybe URI
forall a. Maybe a
Nothing,
      title :: Maybe Text
title = Maybe Text
forall a. Maybe a
Nothing,
      userType :: Maybe Text
userType = Maybe Text
forall a. Maybe a
Nothing,
      preferredLanguage :: Maybe Text
preferredLanguage = Maybe Text
forall a. Maybe a
Nothing,
      locale :: Maybe Text
locale = Maybe Text
forall a. Maybe a
Nothing,
      active :: Maybe ScimBool
active = Maybe ScimBool
forall a. Maybe a
Nothing,
      password :: Maybe Text
password = Maybe Text
forall a. Maybe a
Nothing,
      emails :: [Email]
emails = [],
      phoneNumbers :: [Phone]
phoneNumbers = [],
      ims :: [IM]
ims = [],
      photos :: [Photo]
photos = [],
      addresses :: [Address]
addresses = [],
      entitlements :: [Text]
entitlements = [],
      roles :: [Text]
roles = [],
      x509Certificates :: [Certificate]
x509Certificates = [],
      extra :: UserExtra tag
extra = UserExtra tag
extra
    }

instance (FromJSON (UserExtra tag)) => FromJSON (User tag) where
  parseJSON :: Value -> Parser (User tag)
parseJSON = String
-> (Object -> Parser (User tag)) -> Value -> Parser (User tag)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"User" ((Object -> Parser (User tag)) -> Value -> Parser (User tag))
-> (Object -> Parser (User tag)) -> Value -> Parser (User tag)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    -- Lowercase all fields
    let o :: Object
o = [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Object)
-> (Object -> [(Key, Value)]) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Value) -> (Key, Value)) -> [(Key, Value)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (ASetter (Key, Value) (Key, Value) Key Key
-> (Key -> Key) -> (Key, Value) -> (Key, Value)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Key, Value) (Key, Value) Key Key
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Key, Value) (Key, Value) Key Key
_1 Key -> Key
lowerKey) ([(Key, Value)] -> [(Key, Value)])
-> (Object -> [(Key, Value)]) -> Object -> [(Key, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Object
obj
    [Schema]
schemas <-
      Object
o Object -> Key -> Parser (Maybe [Schema])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"schemas" Parser (Maybe [Schema])
-> (Maybe [Schema] -> [Schema]) -> Parser [Schema]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Maybe [Schema]
Nothing -> [Schema
User20]
        Just [Schema]
xs -> if Schema
User20 Schema -> [Schema] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Schema]
xs then [Schema]
xs else Schema
User20 Schema -> [Schema] -> [Schema]
forall a. a -> [a] -> [a]
: [Schema]
xs
    Text
userName <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"username"
    Maybe Text
externalId <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"externalid"
    Maybe Name
name <- Object
o Object -> Key -> Parser (Maybe Name)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name"
    Maybe Text
displayName <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"displayname"
    Maybe Text
nickName <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"nickname"
    Maybe URI
profileUrl <- Object
o Object -> Key -> Parser (Maybe URI)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"profileurl"
    Maybe Text
title <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"title"
    Maybe Text
userType <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"usertype"
    Maybe Text
preferredLanguage <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"preferredlanguage"
    Maybe Text
locale <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"locale"
    Maybe ScimBool
active <- Object
o Object -> Key -> Parser (Maybe ScimBool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"active"
    Maybe Text
password <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"password"
    [Email]
emails <- Object
o Object -> Key -> Parser (Maybe [Email])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"emails" Parser (Maybe [Email]) -> [Email] -> Parser [Email]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Phone]
phoneNumbers <- Object
o Object -> Key -> Parser (Maybe [Phone])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"phonenumbers" Parser (Maybe [Phone]) -> [Phone] -> Parser [Phone]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [IM]
ims <- Object
o Object -> Key -> Parser (Maybe [IM])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ims" Parser (Maybe [IM]) -> [IM] -> Parser [IM]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Photo]
photos <- Object
o Object -> Key -> Parser (Maybe [Photo])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"photos" Parser (Maybe [Photo]) -> [Photo] -> Parser [Photo]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Address]
addresses <- Object
o Object -> Key -> Parser (Maybe [Address])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"addresses" Parser (Maybe [Address]) -> [Address] -> Parser [Address]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Text]
entitlements <- Object
o Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"entitlements" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Text]
roles <- Object
o Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"roles" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Certificate]
x509Certificates <- Object
o Object -> Key -> Parser (Maybe [Certificate])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"x509certificates" Parser (Maybe [Certificate])
-> [Certificate] -> Parser [Certificate]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    UserExtra tag
extra <- Value -> Parser (UserExtra tag)
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
obj)
    User tag -> Parser (User tag)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure User {[Text]
[Schema]
[Address]
[Certificate]
[Email]
[IM]
[Phone]
[Photo]
Maybe Text
Maybe ScimBool
Maybe URI
Maybe Name
Text
UserExtra tag
schemas :: [Schema]
userName :: Text
externalId :: Maybe Text
name :: Maybe Name
displayName :: Maybe Text
nickName :: Maybe Text
profileUrl :: Maybe URI
title :: Maybe Text
userType :: Maybe Text
preferredLanguage :: Maybe Text
locale :: Maybe Text
active :: Maybe ScimBool
password :: Maybe Text
emails :: [Email]
phoneNumbers :: [Phone]
ims :: [IM]
photos :: [Photo]
addresses :: [Address]
entitlements :: [Text]
roles :: [Text]
x509Certificates :: [Certificate]
extra :: UserExtra tag
schemas :: [Schema]
userName :: Text
externalId :: Maybe Text
name :: Maybe Name
displayName :: Maybe Text
nickName :: Maybe Text
profileUrl :: Maybe URI
title :: Maybe Text
userType :: Maybe Text
preferredLanguage :: Maybe Text
locale :: Maybe Text
active :: Maybe ScimBool
password :: Maybe Text
emails :: [Email]
phoneNumbers :: [Phone]
ims :: [IM]
photos :: [Photo]
addresses :: [Address]
entitlements :: [Text]
roles :: [Text]
x509Certificates :: [Certificate]
extra :: UserExtra tag
..}

instance (ToJSON (UserExtra tag)) => ToJSON (User tag) where
  toJSON :: User tag -> Value
toJSON User {[Text]
[Schema]
[Address]
[Certificate]
[Email]
[IM]
[Phone]
[Photo]
Maybe Text
Maybe ScimBool
Maybe URI
Maybe Name
Text
UserExtra tag
schemas :: forall tag. User tag -> [Schema]
userName :: forall tag. User tag -> Text
externalId :: forall tag. User tag -> Maybe Text
name :: forall tag. User tag -> Maybe Name
displayName :: forall tag. User tag -> Maybe Text
nickName :: forall tag. User tag -> Maybe Text
profileUrl :: forall tag. User tag -> Maybe URI
title :: forall tag. User tag -> Maybe Text
userType :: forall tag. User tag -> Maybe Text
preferredLanguage :: forall tag. User tag -> Maybe Text
locale :: forall tag. User tag -> Maybe Text
active :: forall tag. User tag -> Maybe ScimBool
password :: forall tag. User tag -> Maybe Text
emails :: forall tag. User tag -> [Email]
phoneNumbers :: forall tag. User tag -> [Phone]
ims :: forall tag. User tag -> [IM]
photos :: forall tag. User tag -> [Photo]
addresses :: forall tag. User tag -> [Address]
entitlements :: forall tag. User tag -> [Text]
roles :: forall tag. User tag -> [Text]
x509Certificates :: forall tag. User tag -> [Certificate]
extra :: forall tag. User tag -> UserExtra tag
schemas :: [Schema]
userName :: Text
externalId :: Maybe Text
name :: Maybe Name
displayName :: Maybe Text
nickName :: Maybe Text
profileUrl :: Maybe URI
title :: Maybe Text
userType :: Maybe Text
preferredLanguage :: Maybe Text
locale :: Maybe Text
active :: Maybe ScimBool
password :: Maybe Text
emails :: [Email]
phoneNumbers :: [Phone]
ims :: [IM]
photos :: [Photo]
addresses :: [Address]
entitlements :: [Text]
roles :: [Text]
x509Certificates :: [Certificate]
extra :: UserExtra tag
..} =
    let mainObject :: Object
mainObject =
          [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Object) -> [(Key, Value)] -> Object
forall a b. (a -> b) -> a -> b
$
            [[(Key, Value)]] -> [(Key, Value)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [Key
"schemas" Key -> [Schema] -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.= [Schema]
schemas],
                [Key
"userName" Key -> Text -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.= Text
userName],
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"externalId" Maybe Text
externalId,
                Key -> Maybe Name -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"name" Maybe Name
name,
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"displayName" Maybe Text
displayName,
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"nickName" Maybe Text
nickName,
                Key -> Maybe URI -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"profileUrl" Maybe URI
profileUrl,
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"title" Maybe Text
title,
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"userType" Maybe Text
userType,
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"preferredLanguage" Maybe Text
preferredLanguage,
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"locale" Maybe Text
locale,
                Key -> Maybe ScimBool -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"active" Maybe ScimBool
active,
                Key -> Maybe Text -> [(Key, Value)]
forall {a} {v}. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
optionalField Key
"password" Maybe Text
password,
                Key -> [Email] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"emails" [Email]
emails,
                Key -> [Phone] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"phoneNumbers" [Phone]
phoneNumbers,
                Key -> [IM] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"ims" [IM]
ims,
                Key -> [Photo] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"photos" [Photo]
photos,
                Key -> [Address] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"addresses" [Address]
addresses,
                Key -> [Text] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"entitlements" [Text]
entitlements,
                Key -> [Text] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"roles" [Text]
roles,
                Key -> [Certificate] -> [(Key, Value)]
forall {a} {a}. (KeyValue a, ToJSON a) => Key -> [a] -> [a]
multiValuedField Key
"x509Certificates" [Certificate]
x509Certificates
              ]
        extraObject :: Object
extraObject = case UserExtra tag -> Value
forall a. ToJSON a => a -> Value
toJSON UserExtra tag
extra of
          Value
Null -> Object
forall a. Monoid a => a
mempty
          Object Object
x -> Object
x
          Value
other -> [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [Key
"extra" Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.= Value
other]
     in Object -> Value
Object (Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
KeyMap.union Object
mainObject Object
extraObject)
    where
      -- Omit a field if it's Nothing
      optionalField :: Key -> Maybe v -> [a]
optionalField Key
fname = \case
        Maybe v
Nothing -> []
        Just v
x -> [Key
fname Key -> v -> a
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> a
.= v
x]
      -- Omit a field if it's []
      multiValuedField :: Key -> [a] -> [a]
multiValuedField Key
fname = \case
        [] -> []
        [a]
xs -> [Key
fname Key -> [a] -> a
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> a
.= [a]
xs]

-- | A type used to indicate that the SCIM record doesn't have any extra data. Encoded as an
-- empty map.
data NoUserExtra = NoUserExtra
  deriving (NoUserExtra -> NoUserExtra -> Bool
(NoUserExtra -> NoUserExtra -> Bool)
-> (NoUserExtra -> NoUserExtra -> Bool) -> Eq NoUserExtra
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoUserExtra -> NoUserExtra -> Bool
== :: NoUserExtra -> NoUserExtra -> Bool
$c/= :: NoUserExtra -> NoUserExtra -> Bool
/= :: NoUserExtra -> NoUserExtra -> Bool
Eq, Int -> NoUserExtra -> ShowS
[NoUserExtra] -> ShowS
NoUserExtra -> String
(Int -> NoUserExtra -> ShowS)
-> (NoUserExtra -> String)
-> ([NoUserExtra] -> ShowS)
-> Show NoUserExtra
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoUserExtra -> ShowS
showsPrec :: Int -> NoUserExtra -> ShowS
$cshow :: NoUserExtra -> String
show :: NoUserExtra -> String
$cshowList :: [NoUserExtra] -> ShowS
showList :: [NoUserExtra] -> ShowS
Show)

instance FromJSON NoUserExtra where
  parseJSON :: Value -> Parser NoUserExtra
parseJSON = String
-> (Object -> Parser NoUserExtra) -> Value -> Parser NoUserExtra
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NoUserExtra" ((Object -> Parser NoUserExtra) -> Value -> Parser NoUserExtra)
-> (Object -> Parser NoUserExtra) -> Value -> Parser NoUserExtra
forall a b. (a -> b) -> a -> b
$ \Object
_ -> NoUserExtra -> Parser NoUserExtra
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoUserExtra
NoUserExtra

instance ToJSON NoUserExtra where
  toJSON :: NoUserExtra -> Value
toJSON NoUserExtra
_ = [(Key, Value)] -> Value
object []

instance Patchable NoUserExtra where
  applyOperation :: forall (m :: * -> *).
MonadError ScimError m =>
NoUserExtra -> Operation -> m NoUserExtra
applyOperation NoUserExtra
_ Operation
_ = ScimError -> m NoUserExtra
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimError -> m NoUserExtra) -> ScimError -> m NoUserExtra
forall a b. (a -> b) -> a -> b
$ ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidValue (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"there are no user extra attributes to patch")

----------------------------------------------------------------------------
-- Applying

-- | Applies a JSON Patch to a SCIM Core User
-- Only supports the core attributes.
-- Evenmore, only some hand-picked ones currently.
-- We'll have to think how patch is going to work in the presence of extensions.
-- Also, we can probably make  PatchOp type-safe to some extent (Read arianvp's thesis :))
applyPatch ::
  ( Patchable (UserExtra tag),
    FromJSON (UserExtra tag),
    MonadError ScimError m,
    UserTypes tag
  ) =>
  User tag ->
  PatchOp tag ->
  m (User tag)
applyPatch :: forall tag (m :: * -> *).
(Patchable (UserExtra tag), FromJSON (UserExtra tag),
 MonadError ScimError m, UserTypes tag) =>
User tag -> PatchOp tag -> m (User tag)
applyPatch = (([Operation] -> m (User tag))
-> (PatchOp tag -> [Operation]) -> PatchOp tag -> m (User tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchOp tag -> [Operation]
forall tag. PatchOp tag -> [Operation]
getOperations) (([Operation] -> m (User tag)) -> PatchOp tag -> m (User tag))
-> (User tag -> [Operation] -> m (User tag))
-> User tag
-> PatchOp tag
-> m (User tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (User tag -> Operation -> m (User tag))
-> User tag -> [Operation] -> m (User tag)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM User tag -> Operation -> m (User tag)
forall a (m :: * -> *).
(Patchable a, MonadError ScimError m) =>
a -> Operation -> m a
forall (m :: * -> *).
MonadError ScimError m =>
User tag -> Operation -> m (User tag)
applyOperation

resultToScimError :: (MonadError ScimError m) => Result a -> m a
resultToScimError :: forall (m :: * -> *) a. MonadError ScimError m => Result a -> m a
resultToScimError (Error String
reason) = ScimError -> m a
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimError -> m a) -> ScimError -> m a
forall a b. (a -> b) -> a -> b
$ ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidValue (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
pack String
reason))
resultToScimError (Success a
a) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- TODO(arianvp): support multi-valued and complex attributes.
-- TODO(arianvp): Actually do this in some kind of type-safe way. e.g.
-- have a UserPatch type.
--
-- What I understand from the spec:  The difference between add an replace is only
-- in the fact that replace will not concat multi-values, and behaves differently for complex values too.
-- For simple attributes, add and replace are identical.
applyUserOperation ::
  forall m tag.
  ( UserTypes tag,
    FromJSON (User tag),
    Patchable (UserExtra tag),
    MonadError ScimError m
  ) =>
  User tag ->
  Operation ->
  m (User tag)
applyUserOperation :: forall (m :: * -> *) tag.
(UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag),
 MonadError ScimError m) =>
User tag -> Operation -> m (User tag)
applyUserOperation User tag
user (Operation Op
Add Maybe Path
path Maybe Value
value) = User tag -> Operation -> m (User tag)
forall (m :: * -> *) tag.
(UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag),
 MonadError ScimError m) =>
User tag -> Operation -> m (User tag)
applyUserOperation User tag
user (Op -> Maybe Path -> Maybe Value -> Operation
Operation Op
Replace Maybe Path
path Maybe Value
value)
applyUserOperation User tag
user (Operation Op
Replace (Just (NormalPath (AttrPath Maybe Schema
_schema AttrName
attr Maybe SubAttr
_subAttr))) (Just Value
value)) =
  case AttrName
attr of
    AttrName
"username" ->
      (\Text
x -> User tag
user {userName = x}) (Text -> User tag) -> m Text -> m (User tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result Text -> m Text
forall (m :: * -> *) a. MonadError ScimError m => Result a -> m a
resultToScimError (Value -> Result Text
forall a. FromJSON a => Value -> Result a
fromJSON Value
value)
    AttrName
"displayname" ->
      (\Maybe Text
x -> User tag
user {displayName = x}) (Maybe Text -> User tag) -> m (Maybe Text) -> m (User tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result (Maybe Text) -> m (Maybe Text)
forall (m :: * -> *) a. MonadError ScimError m => Result a -> m a
resultToScimError (Value -> Result (Maybe Text)
forall a. FromJSON a => Value -> Result a
fromJSON Value
value)
    AttrName
"externalid" ->
      (\Maybe Text
x -> User tag
user {externalId = x}) (Maybe Text -> User tag) -> m (Maybe Text) -> m (User tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result (Maybe Text) -> m (Maybe Text)
forall (m :: * -> *) a. MonadError ScimError m => Result a -> m a
resultToScimError (Value -> Result (Maybe Text)
forall a. FromJSON a => Value -> Result a
fromJSON Value
value)
    AttrName
"active" ->
      (\Maybe ScimBool
x -> User tag
user {active = x}) (Maybe ScimBool -> User tag) -> m (Maybe ScimBool) -> m (User tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result (Maybe ScimBool) -> m (Maybe ScimBool)
forall (m :: * -> *) a. MonadError ScimError m => Result a -> m a
resultToScimError (Value -> Result (Maybe ScimBool)
forall a. FromJSON a => Value -> Result a
fromJSON Value
value)
    AttrName
"roles" ->
      (\[Text]
x -> User tag
user {roles = x}) ([Text] -> User tag) -> m [Text] -> m (User tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result [Text] -> m [Text]
forall (m :: * -> *) a. MonadError ScimError m => Result a -> m a
resultToScimError (Value -> Result [Text]
forall a. FromJSON a => Value -> Result a
fromJSON Value
value)
    AttrName
_ -> ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidPath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"we only support attributes username, displayname, externalid, active, roles"))
applyUserOperation User tag
_ (Operation Op
Replace (Just (IntoValuePath ValuePath
_ Maybe SubAttr
_)) Maybe Value
_) = do
  ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidPath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"can not lens into multi-valued attributes yet"))
applyUserOperation User tag
user (Operation Op
Replace Maybe Path
Nothing (Just Value
value)) = do
  case Value
value of
    Object Object
hm | [AttrName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Text -> AttrName
AttrName (Text -> AttrName) -> (Key -> Text) -> Key -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText (Key -> AttrName) -> [Key] -> [AttrName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
hm) [AttrName] -> [AttrName] -> [AttrName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [AttrName
"username", AttrName
"displayname", AttrName
"externalid", AttrName
"active", AttrName
"roles"]) -> do
      (User tag
u :: User tag) <- Result (User tag) -> m (User tag)
forall (m :: * -> *) a. MonadError ScimError m => Result a -> m a
resultToScimError (Result (User tag) -> m (User tag))
-> Result (User tag) -> m (User tag)
forall a b. (a -> b) -> a -> b
$ Value -> Result (User tag)
forall a. FromJSON a => Value -> Result a
fromJSON Value
value
      User tag -> m (User tag)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User tag -> m (User tag)) -> User tag -> m (User tag)
forall a b. (a -> b) -> a -> b
$
        User tag
user
          { userName = userName u,
            displayName = displayName u,
            externalId = externalId u,
            active = active u
          }
    Value
_ -> ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidPath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"we only support attributes username, displayname, externalid, active, roles"))
applyUserOperation User tag
_ (Operation Op
Replace Maybe Path
_ Maybe Value
Nothing) =
  ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidValue (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"No value was provided"))
applyUserOperation User tag
_ (Operation Op
Remove Maybe Path
Nothing Maybe Value
_) = ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
NoTarget Maybe Text
forall a. Maybe a
Nothing)
applyUserOperation User tag
user (Operation Op
Remove (Just (NormalPath (AttrPath Maybe Schema
_schema AttrName
attr Maybe SubAttr
_subAttr))) Maybe Value
_value) =
  case AttrName
attr of
    AttrName
"username" -> ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
Mutability Maybe Text
forall a. Maybe a
Nothing)
    AttrName
"displayname" -> User tag -> m (User tag)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User tag -> m (User tag)) -> User tag -> m (User tag)
forall a b. (a -> b) -> a -> b
$ User tag
user {displayName = Nothing}
    AttrName
"externalid" -> User tag -> m (User tag)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User tag -> m (User tag)) -> User tag -> m (User tag)
forall a b. (a -> b) -> a -> b
$ User tag
user {externalId = Nothing}
    AttrName
"active" -> User tag -> m (User tag)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User tag -> m (User tag)) -> User tag -> m (User tag)
forall a b. (a -> b) -> a -> b
$ User tag
user {active = Nothing}
    AttrName
"roles" -> User tag -> m (User tag)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User tag -> m (User tag)) -> User tag -> m (User tag)
forall a b. (a -> b) -> a -> b
$ User tag
user {roles = []}
    AttrName
_ -> User tag -> m (User tag)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure User tag
user
applyUserOperation User tag
_ (Operation Op
Remove (Just (IntoValuePath ValuePath
_ Maybe SubAttr
_)) Maybe Value
_) = do
  ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidPath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"can not lens into multi-valued attributes yet"))

instance (UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag)) => Patchable (User tag) where
  applyOperation :: forall (m :: * -> *).
MonadError ScimError m =>
User tag -> Operation -> m (User tag)
applyOperation User tag
user op :: Operation
op@(Operation Op
_ (Just (NormalPath (AttrPath Maybe Schema
schema AttrName
_ Maybe SubAttr
_))) Maybe Value
_)
    | Maybe Schema -> Bool
isUserSchema Maybe Schema
schema = User tag -> Operation -> m (User tag)
forall (m :: * -> *) tag.
(UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag),
 MonadError ScimError m) =>
User tag -> Operation -> m (User tag)
applyUserOperation User tag
user Operation
op
    | Maybe Schema -> Bool
isSupportedCustomSchema Maybe Schema
schema = (\UserExtra tag
x -> User tag
user {extra = x}) (UserExtra tag -> User tag) -> m (UserExtra tag) -> m (User tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserExtra tag -> Operation -> m (UserExtra tag)
forall a (m :: * -> *).
(Patchable a, MonadError ScimError m) =>
a -> Operation -> m a
forall (m :: * -> *).
MonadError ScimError m =>
UserExtra tag -> Operation -> m (UserExtra tag)
applyOperation (User tag -> UserExtra tag
forall tag. User tag -> UserExtra tag
extra User tag
user) Operation
op
    | Bool
otherwise =
        ScimError -> m (User tag)
forall a. ScimError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimError -> m (User tag)) -> ScimError -> m (User tag)
forall a b. (a -> b) -> a -> b
$ ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidPath (Maybe Text -> ScimError) -> Maybe Text -> ScimError
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"we only support these schemas: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " ((Schema -> Text) -> [Schema] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Schema -> Text
getSchemaUri (forall tag. UserTypes tag => [Schema]
supportedSchemas @tag))
    where
      isSupportedCustomSchema :: Maybe Schema -> Bool
isSupportedCustomSchema = Bool -> (Schema -> Bool) -> Maybe Schema -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Schema -> [Schema] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall tag. UserTypes tag => [Schema]
supportedSchemas @tag)
  applyOperation User tag
user Operation
op = User tag -> Operation -> m (User tag)
forall (m :: * -> *) tag.
(UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag),
 MonadError ScimError m) =>
User tag -> Operation -> m (User tag)
applyUserOperation User tag
user Operation
op

-- Omission of a schema for users is implicitly the core schema
-- TODO(arianvp): Link to part of the spec that claims this.
isUserSchema :: Maybe Schema -> Bool
isUserSchema :: Maybe Schema -> Bool
isUserSchema = Bool -> (Schema -> Bool) -> Maybe Schema -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Schema -> Schema -> Bool
forall a. Eq a => a -> a -> Bool
== Schema
User20)