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

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2020 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.Except
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.List ((\\))
import Data.Text (Text, pack, toLower)
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 @t@ (see 'UserTypes').
data User tag = User
  { User tag -> [Schema]
schemas :: [Schema],
    -- Mandatory fields
    User tag -> Text
userName :: Text,
    -- Optional fields
    User tag -> Maybe Text
externalId :: Maybe Text,
    User tag -> Maybe Name
name :: Maybe Name,
    User tag -> Maybe Text
displayName :: Maybe Text,
    User tag -> Maybe Text
nickName :: Maybe Text,
    User tag -> Maybe URI
profileUrl :: Maybe URI,
    User tag -> Maybe Text
title :: Maybe Text,
    User tag -> Maybe Text
userType :: Maybe Text,
    User tag -> Maybe Text
preferredLanguage :: Maybe Text,
    User tag -> Maybe Text
locale :: Maybe Text,
    User tag -> Maybe ScimBool
active :: Maybe ScimBool,
    User tag -> Maybe Text
password :: Maybe Text,
    -- Multi-valued fields
    User tag -> [Email]
emails :: [Email],
    User tag -> [Phone]
phoneNumbers :: [Phone],
    User tag -> [IM]
ims :: [IM],
    User tag -> [Photo]
photos :: [Photo],
    User tag -> [Address]
addresses :: [Address],
    User tag -> [Text]
entitlements :: [Text],
    User tag -> [Text]
roles :: [Text],
    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).
    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
$cto :: forall tag x. Rep (User tag) x -> User tag
$cfrom :: forall tag x. User tag -> Rep (User tag) x
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 :: [Schema] -> Text -> UserExtra tag -> User tag
empty [Schema]
schemas Text
userName UserExtra tag
extra =
  User :: forall tag.
[Schema]
-> Text
-> Maybe Text
-> Maybe Name
-> Maybe Text
-> Maybe Text
-> Maybe URI
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe ScimBool
-> Maybe Text
-> [Email]
-> [Phone]
-> [IM]
-> [Photo]
-> [Address]
-> [Text]
-> [Text]
-> [Certificate]
-> UserExtra tag
-> User tag
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 = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Object)
-> (Object -> [(Text, Value)]) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> (Text, Value))
-> [(Text, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (ASetter (Text, Value) (Text, Value) Text Text
-> (Text -> Text) -> (Text, Value) -> (Text, Value)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Text, Value) (Text, Value) Text Text
forall s t a b. Field1 s t a b => Lens s t a b
_1 Text -> Text
toLower) ([(Text, Value)] -> [(Text, Value)])
-> (Object -> [(Text, Value)]) -> Object -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Object
obj
    [Schema]
schemas <-
      Object
o Object -> Text -> Parser (Maybe [Schema])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"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 (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 -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"username"
    Maybe Text
externalId <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"externalid"
    Maybe Name
name <- Object
o Object -> Text -> Parser (Maybe Name)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"name"
    Maybe Text
displayName <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"displayname"
    Maybe Text
nickName <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"nickname"
    Maybe URI
profileUrl <- Object
o Object -> Text -> Parser (Maybe URI)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"profileurl"
    Maybe Text
title <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"title"
    Maybe Text
userType <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"usertype"
    Maybe Text
preferredLanguage <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"preferredlanguage"
    Maybe Text
locale <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"locale"
    Maybe ScimBool
active <- Object
o Object -> Text -> Parser (Maybe ScimBool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"active"
    Maybe Text
password <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"password"
    [Email]
emails <- Object
o Object -> Text -> Parser (Maybe [Email])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"emails" Parser (Maybe [Email]) -> [Email] -> Parser [Email]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Phone]
phoneNumbers <- Object
o Object -> Text -> Parser (Maybe [Phone])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"phonenumbers" Parser (Maybe [Phone]) -> [Phone] -> Parser [Phone]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [IM]
ims <- Object
o Object -> Text -> Parser (Maybe [IM])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"ims" Parser (Maybe [IM]) -> [IM] -> Parser [IM]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Photo]
photos <- Object
o Object -> Text -> Parser (Maybe [Photo])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"photos" Parser (Maybe [Photo]) -> [Photo] -> Parser [Photo]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Address]
addresses <- Object
o Object -> Text -> Parser (Maybe [Address])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"addresses" Parser (Maybe [Address]) -> [Address] -> Parser [Address]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Text]
entitlements <- Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"entitlements" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Text]
roles <- Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"roles" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Certificate]
x509Certificates <- Object
o Object -> Text -> Parser (Maybe [Certificate])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"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 (f :: * -> *) a. Applicative f => a -> f a
pure User :: forall tag.
[Schema]
-> Text
-> Maybe Text
-> Maybe Name
-> Maybe Text
-> Maybe Text
-> Maybe URI
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe ScimBool
-> Maybe Text
-> [Email]
-> [Phone]
-> [IM]
-> [Photo]
-> [Address]
-> [Text]
-> [Text]
-> [Certificate]
-> UserExtra tag
-> User tag
User {[Text]
[Schema]
[Address]
[Certificate]
[Email]
[IM]
[Phone]
[Photo]
Maybe Text
Maybe ScimBool
Maybe URI
Maybe Name
Text
UserExtra tag
extra :: UserExtra tag
x509Certificates :: [Certificate]
roles :: [Text]
entitlements :: [Text]
addresses :: [Address]
photos :: [Photo]
ims :: [IM]
phoneNumbers :: [Phone]
emails :: [Email]
password :: Maybe Text
active :: Maybe ScimBool
locale :: Maybe Text
preferredLanguage :: Maybe Text
userType :: Maybe Text
title :: Maybe Text
profileUrl :: Maybe URI
nickName :: Maybe Text
displayName :: Maybe Text
name :: Maybe Name
externalId :: Maybe Text
userName :: Text
schemas :: [Schema]
extra :: UserExtra tag
x509Certificates :: [Certificate]
roles :: [Text]
entitlements :: [Text]
addresses :: [Address]
photos :: [Photo]
ims :: [IM]
phoneNumbers :: [Phone]
emails :: [Email]
password :: Maybe Text
active :: Maybe ScimBool
locale :: Maybe Text
preferredLanguage :: Maybe Text
userType :: Maybe Text
title :: Maybe Text
profileUrl :: Maybe URI
nickName :: Maybe Text
displayName :: Maybe Text
name :: Maybe Name
externalId :: Maybe Text
userName :: Text
schemas :: [Schema]
..}

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
extra :: UserExtra tag
x509Certificates :: [Certificate]
roles :: [Text]
entitlements :: [Text]
addresses :: [Address]
photos :: [Photo]
ims :: [IM]
phoneNumbers :: [Phone]
emails :: [Email]
password :: Maybe Text
active :: Maybe ScimBool
locale :: Maybe Text
preferredLanguage :: Maybe Text
userType :: Maybe Text
title :: Maybe Text
profileUrl :: Maybe URI
nickName :: Maybe Text
displayName :: Maybe Text
name :: Maybe Name
externalId :: Maybe Text
userName :: Text
schemas :: [Schema]
extra :: forall tag. User tag -> UserExtra tag
x509Certificates :: forall tag. User tag -> [Certificate]
roles :: forall tag. User tag -> [Text]
entitlements :: forall tag. User tag -> [Text]
addresses :: forall tag. User tag -> [Address]
photos :: forall tag. User tag -> [Photo]
ims :: forall tag. User tag -> [IM]
phoneNumbers :: forall tag. User tag -> [Phone]
emails :: forall tag. User tag -> [Email]
password :: forall tag. User tag -> Maybe Text
active :: forall tag. User tag -> Maybe ScimBool
locale :: forall tag. User tag -> Maybe Text
preferredLanguage :: forall tag. User tag -> Maybe Text
userType :: forall tag. User tag -> Maybe Text
title :: forall tag. User tag -> Maybe Text
profileUrl :: forall tag. User tag -> Maybe URI
nickName :: forall tag. User tag -> Maybe Text
displayName :: forall tag. User tag -> Maybe Text
name :: forall tag. User tag -> Maybe Name
externalId :: forall tag. User tag -> Maybe Text
userName :: forall tag. User tag -> Text
schemas :: forall tag. User tag -> [Schema]
..} =
    let mainObject :: Object
mainObject =
          [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$
            [[(Text, Value)]] -> [(Text, Value)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [Text
"schemas" Text -> [Schema] -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Schema]
schemas],
                [Text
"userName" Text -> Text -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
userName],
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"externalId" Maybe Text
externalId,
                Text -> Maybe Name -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"name" Maybe Name
name,
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"displayName" Maybe Text
displayName,
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"nickName" Maybe Text
nickName,
                Text -> Maybe URI -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"profileUrl" Maybe URI
profileUrl,
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"title" Maybe Text
title,
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"userType" Maybe Text
userType,
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"preferredLanguage" Maybe Text
preferredLanguage,
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"locale" Maybe Text
locale,
                Text -> Maybe ScimBool -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"active" Maybe ScimBool
active,
                Text -> Maybe Text -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"password" Maybe Text
password,
                Text -> [Email] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"emails" [Email]
emails,
                Text -> [Phone] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"phoneNumbers" [Phone]
phoneNumbers,
                Text -> [IM] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"ims" [IM]
ims,
                Text -> [Photo] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"photos" [Photo]
photos,
                Text -> [Address] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"addresses" [Address]
addresses,
                Text -> [Text] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"entitlements" [Text]
entitlements,
                Text -> [Text] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"roles" [Text]
roles,
                Text -> [Certificate] -> [(Text, Value)]
forall a a. (KeyValue a, ToJSON a) => Text -> [a] -> [a]
multiValuedField Text
"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 -> [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [Text
"extra" Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
other]
     in Object -> Value
Object (Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union Object
mainObject Object
extraObject)
    where
      -- Omit a field if it's Nothing
      optionalField :: Text -> Maybe v -> [a]
optionalField Text
fname = \case
        Maybe v
Nothing -> []
        Just v
x -> [Text
fname Text -> v -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
x]
      -- Omit a field if it's []
      multiValuedField :: Text -> [a] -> [a]
multiValuedField Text
fname = \case
        [] -> []
        [a]
xs -> [Text
fname Text -> [a] -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [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
/= :: NoUserExtra -> NoUserExtra -> Bool
$c/= :: NoUserExtra -> NoUserExtra -> Bool
== :: NoUserExtra -> NoUserExtra -> Bool
$c== :: 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
showList :: [NoUserExtra] -> ShowS
$cshowList :: [NoUserExtra] -> ShowS
show :: NoUserExtra -> String
$cshow :: NoUserExtra -> String
showsPrec :: Int -> NoUserExtra -> ShowS
$cshowsPrec :: Int -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure NoUserExtra
NoUserExtra

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

instance Patchable NoUserExtra where
  applyOperation :: NoUserExtra -> Operation -> m NoUserExtra
applyOperation NoUserExtra
_ Operation
_ = ScimError -> m NoUserExtra
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 :: 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
applyOperation

resultToScimError :: (MonadError ScimError m) => Result a -> m a
resultToScimError :: Result a -> m a
resultToScimError (Error String
reason) = 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 (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 :: 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 :: Text
userName = Text
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 :: Maybe Text
displayName = Maybe Text
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 :: Maybe Text
externalId = Maybe Text
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 :: Maybe ScimBool
active = Maybe ScimBool
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
_ -> ScimError -> m (User tag)
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"))
applyUserOperation User tag
_ (Operation Op
Replace (Just (IntoValuePath ValuePath
_ Maybe SubAttr
_)) Maybe Value
_) = do
  ScimError -> m (User tag)
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 (t :: * -> *) a. Foldable t => t a -> Bool
null ((Text -> AttrName
AttrName (Text -> AttrName) -> [Text] -> [AttrName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> [Text]
forall k v. HashMap k v -> [k]
HM.keys Object
hm) [AttrName] -> [AttrName] -> [AttrName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [AttrName
"username", AttrName
"displayname", AttrName
"externalid", AttrName
"active"]) -> 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 (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 :: Text
userName = User tag -> Text
forall tag. User tag -> Text
userName User tag
u,
            displayName :: Maybe Text
displayName = User tag -> Maybe Text
forall tag. User tag -> Maybe Text
displayName User tag
u,
            externalId :: Maybe Text
externalId = User tag -> Maybe Text
forall tag. User tag -> Maybe Text
externalId User tag
u,
            active :: Maybe ScimBool
active = User tag -> Maybe ScimBool
forall tag. User tag -> Maybe ScimBool
active User tag
u
          }
    Value
_ -> ScimError -> m (User tag)
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"))
applyUserOperation User tag
_ (Operation Op
Replace Maybe Path
_ Maybe Value
Nothing) =
  ScimError -> m (User tag)
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 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 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 (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 :: Maybe Text
displayName = Maybe Text
forall a. Maybe a
Nothing}
    AttrName
"externalid" -> User tag -> m (User tag)
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 :: Maybe Text
externalId = Maybe Text
forall a. Maybe a
Nothing}
    AttrName
"active" -> User tag -> m (User tag)
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 :: Maybe ScimBool
active = Maybe ScimBool
forall a. Maybe a
Nothing}
    AttrName
_ -> User tag -> m (User tag)
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 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 :: 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 :: UserExtra tag
extra = UserExtra tag
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
applyOperation (User tag -> UserExtra tag
forall tag. User tag -> UserExtra tag
extra User tag
user) Operation
op
    | Bool
otherwise =
      ScimError -> m (User tag)
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
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Schema -> Text) -> [Schema] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Schema -> Text
getSchemaUri (UserTypes tag => [Schema]
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` UserTypes tag => [Schema]
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)