{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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.RichInfo
  ( -- * RichInfo
    RichInfo (..),
    richInfoSize,
    richInfoMapURN,
    mkRichInfo,

    -- * RichInfoMapAndList
    RichInfoMapAndList (richInfoMap, richInfoAssocList),
    mkRichInfoMapAndList,
    toRichInfoAssocList,
    fromRichInfoAssocList,

    -- * RichInfoAssocList
    RichInfoAssocList (unRichInfoAssocList),
    mkRichInfoAssocList,
    normalizeRichInfoAssocList,
    richInfoAssocListURN,

    -- * RichField
    RichField (..),
  )
where

import Cassandra qualified as C
import Control.Lens ((%~), (?~), _1)
import Data.Aeson qualified as A
import Data.Aeson.Key qualified as A
import Data.Aeson.KeyMap qualified as A
import Data.Aeson.Types qualified as A
import Data.CaseInsensitive (CI)
import Data.CaseInsensitive qualified as CI
import Data.List.Extra (nubOrdOn)
import Data.Map qualified as Map
import Data.OpenApi qualified as S
import Data.Schema
import Data.Text qualified as Text
import Imports
import Test.QuickCheck qualified as QC
import Wire.Arbitrary (Arbitrary (arbitrary))

--------------------------------------------------------------------------------
-- RichInfo

-- | A 'RichInfoAssocList' that parses and renders as 'RichInfoMapAndList'.
newtype RichInfo = RichInfo {RichInfo -> RichInfoAssocList
unRichInfo :: RichInfoAssocList}
  deriving stock (RichInfo -> RichInfo -> Bool
(RichInfo -> RichInfo -> Bool)
-> (RichInfo -> RichInfo -> Bool) -> Eq RichInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RichInfo -> RichInfo -> Bool
== :: RichInfo -> RichInfo -> Bool
$c/= :: RichInfo -> RichInfo -> Bool
/= :: RichInfo -> RichInfo -> Bool
Eq, Int -> RichInfo -> ShowS
[RichInfo] -> ShowS
RichInfo -> String
(Int -> RichInfo -> ShowS)
-> (RichInfo -> String) -> ([RichInfo] -> ShowS) -> Show RichInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RichInfo -> ShowS
showsPrec :: Int -> RichInfo -> ShowS
$cshow :: RichInfo -> String
show :: RichInfo -> String
$cshowList :: [RichInfo] -> ShowS
showList :: [RichInfo] -> ShowS
Show, (forall x. RichInfo -> Rep RichInfo x)
-> (forall x. Rep RichInfo x -> RichInfo) -> Generic RichInfo
forall x. Rep RichInfo x -> RichInfo
forall x. RichInfo -> Rep RichInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RichInfo -> Rep RichInfo x
from :: forall x. RichInfo -> Rep RichInfo x
$cto :: forall x. Rep RichInfo x -> RichInfo
to :: forall x. Rep RichInfo x -> RichInfo
Generic)
  deriving newtype (Gen RichInfo
Gen RichInfo -> (RichInfo -> [RichInfo]) -> Arbitrary RichInfo
RichInfo -> [RichInfo]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen RichInfo
arbitrary :: Gen RichInfo
$cshrink :: RichInfo -> [RichInfo]
shrink :: RichInfo -> [RichInfo]
Arbitrary)
  deriving ([RichInfo] -> Value
[RichInfo] -> Encoding
RichInfo -> Value
RichInfo -> Encoding
(RichInfo -> Value)
-> (RichInfo -> Encoding)
-> ([RichInfo] -> Value)
-> ([RichInfo] -> Encoding)
-> ToJSON RichInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: RichInfo -> Value
toJSON :: RichInfo -> Value
$ctoEncoding :: RichInfo -> Encoding
toEncoding :: RichInfo -> Encoding
$ctoJSONList :: [RichInfo] -> Value
toJSONList :: [RichInfo] -> Value
$ctoEncodingList :: [RichInfo] -> Encoding
toEncodingList :: [RichInfo] -> Encoding
A.ToJSON, Value -> Parser [RichInfo]
Value -> Parser RichInfo
(Value -> Parser RichInfo)
-> (Value -> Parser [RichInfo]) -> FromJSON RichInfo
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser RichInfo
parseJSON :: Value -> Parser RichInfo
$cparseJSONList :: Value -> Parser [RichInfo]
parseJSONList :: Value -> Parser [RichInfo]
A.FromJSON, Typeable RichInfo
Typeable RichInfo =>
(Proxy RichInfo -> Declare (Definitions Schema) NamedSchema)
-> ToSchema RichInfo
Proxy RichInfo -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy RichInfo -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy RichInfo -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema RichInfo

instance ToSchema RichInfo where
  schema :: ValueSchema NamedSwaggerDoc RichInfo
schema =
    Text
-> CIObjectSchemaP SwaggerDoc RichInfo RichInfo
-> ValueSchema NamedSwaggerDoc RichInfo
forall doc doc' a b.
(HasObject doc doc', HasDescription doc' (Maybe Text)) =>
Text -> CIObjectSchemaP doc a b -> ValueSchemaP doc' a b
ciObject Text
"RichInfo" (CIObjectSchemaP SwaggerDoc RichInfo RichInfo
 -> ValueSchema NamedSwaggerDoc RichInfo)
-> CIObjectSchemaP SwaggerDoc RichInfo RichInfo
-> ValueSchema NamedSwaggerDoc RichInfo
forall a b. (a -> b) -> a -> b
$
      RichInfoAssocList -> RichInfo
RichInfo (RichInfoAssocList -> RichInfo)
-> (RichInfoMapAndList -> RichInfoAssocList)
-> RichInfoMapAndList
-> RichInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichInfoMapAndList -> RichInfoAssocList
toRichInfoAssocList (RichInfoMapAndList -> RichInfo)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfo
     RichInfoMapAndList
-> CIObjectSchemaP SwaggerDoc RichInfo RichInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RichInfoAssocList -> RichInfoMapAndList
fromRichInfoAssocList (RichInfoAssocList -> RichInfoMapAndList)
-> (RichInfo -> RichInfoAssocList)
-> RichInfo
-> RichInfoMapAndList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichInfo -> RichInfoAssocList
unRichInfo) (RichInfo -> RichInfoMapAndList)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     RichInfoMapAndList
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfo
     RichInfoMapAndList
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoMapAndList
  RichInfoMapAndList
richInfoMapAndListSchema

instance Monoid RichInfo where
  mempty :: RichInfo
mempty = RichInfoAssocList -> RichInfo
RichInfo RichInfoAssocList
forall a. Monoid a => a
mempty

instance Semigroup RichInfo where
  RichInfo RichInfoAssocList
a <> :: RichInfo -> RichInfo -> RichInfo
<> RichInfo RichInfoAssocList
b = RichInfoAssocList -> RichInfo
RichInfo (RichInfoAssocList -> RichInfo) -> RichInfoAssocList -> RichInfo
forall a b. (a -> b) -> a -> b
$ RichInfoAssocList
a RichInfoAssocList -> RichInfoAssocList -> RichInfoAssocList
forall a. Semigroup a => a -> a -> a
<> RichInfoAssocList
b

mkRichInfo :: [RichField] -> RichInfo
mkRichInfo :: [RichField] -> RichInfo
mkRichInfo = RichInfoAssocList -> RichInfo
RichInfo (RichInfoAssocList -> RichInfo)
-> ([RichField] -> RichInfoAssocList) -> [RichField] -> RichInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichInfoAssocList -> RichInfoAssocList
normalizeRichInfoAssocList (RichInfoAssocList -> RichInfoAssocList)
-> ([RichField] -> RichInfoAssocList)
-> [RichField]
-> RichInfoAssocList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RichField] -> RichInfoAssocList
RichInfoAssocList

--------------------------------------------------------------------------------
-- RichInfoMapAndList

-- | Represents all the ways we can recieve 'RichInfo' from a SCIM peer.
--
-- 'richInfoMap' represents fields given under 'richInfoMapURN' as a JSON object (use case:
-- enterprise extensions as sent by eg. microsoft azure).
--
-- 'richInfoAssocList' represents fields given under 'richInfoAssocListURN' as an assoc list
-- (use case: wire native code; we used this so we can give the client arbitrary order in
-- which to show the rich info).
--
-- Internally we only store one assoc list.  This type is just to keep serialization separate
-- from the tricky semantics of how the map is merged into the list.  See
-- 'toRichInfoAssocList', 'fromRichInfoAssocList' for the merge semantics.
--
-- TODO: https://github.com/zinfra/backend-issues/issues/1627
data RichInfoMapAndList = RichInfoMapAndList
  { RichInfoMapAndList -> Map (CI Text) Text
richInfoMap :: Map (CI Text) Text,
    RichInfoMapAndList -> [RichField]
richInfoAssocList :: [RichField]
  }
  deriving stock (RichInfoMapAndList -> RichInfoMapAndList -> Bool
(RichInfoMapAndList -> RichInfoMapAndList -> Bool)
-> (RichInfoMapAndList -> RichInfoMapAndList -> Bool)
-> Eq RichInfoMapAndList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RichInfoMapAndList -> RichInfoMapAndList -> Bool
== :: RichInfoMapAndList -> RichInfoMapAndList -> Bool
$c/= :: RichInfoMapAndList -> RichInfoMapAndList -> Bool
/= :: RichInfoMapAndList -> RichInfoMapAndList -> Bool
Eq, Int -> RichInfoMapAndList -> ShowS
[RichInfoMapAndList] -> ShowS
RichInfoMapAndList -> String
(Int -> RichInfoMapAndList -> ShowS)
-> (RichInfoMapAndList -> String)
-> ([RichInfoMapAndList] -> ShowS)
-> Show RichInfoMapAndList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RichInfoMapAndList -> ShowS
showsPrec :: Int -> RichInfoMapAndList -> ShowS
$cshow :: RichInfoMapAndList -> String
show :: RichInfoMapAndList -> String
$cshowList :: [RichInfoMapAndList] -> ShowS
showList :: [RichInfoMapAndList] -> ShowS
Show, (forall x. RichInfoMapAndList -> Rep RichInfoMapAndList x)
-> (forall x. Rep RichInfoMapAndList x -> RichInfoMapAndList)
-> Generic RichInfoMapAndList
forall x. Rep RichInfoMapAndList x -> RichInfoMapAndList
forall x. RichInfoMapAndList -> Rep RichInfoMapAndList x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RichInfoMapAndList -> Rep RichInfoMapAndList x
from :: forall x. RichInfoMapAndList -> Rep RichInfoMapAndList x
$cto :: forall x. Rep RichInfoMapAndList x -> RichInfoMapAndList
to :: forall x. Rep RichInfoMapAndList x -> RichInfoMapAndList
Generic)

-- | 'CIObjectSchema' is a bit of a hack, so it is not included in schema-profunctor even
-- though it is pretty general.
--
-- [scim]{https://www.rfc-editor.org/rfc/rfc7644} requires case insensitivity in json object
-- field names.  while this violates the json standard, it is necessary to follow this
-- requirement in order to be interoperable.  for this purpose, 'CIObjectSchema' supports `Map
-- (CI Text) Value` in place of `A.Object`.  only use when you know what you're doing!
type CIObjectSchema doc a = CIObjectSchemaP doc a a

-- | See CIObjectSchema
type CIObjectSchemaP doc = SchemaP doc (Map (CI Text) A.Value) [(CI Text, A.Value)]

-- | See 'CIObjectSchema'.
ciObject ::
  forall doc doc' a b.
  (HasObject doc doc', S.HasDescription doc' (Maybe Text)) =>
  Text ->
  CIObjectSchemaP doc a b ->
  ValueSchemaP doc' a b
ciObject :: forall doc doc' a b.
(HasObject doc doc', HasDescription doc' (Maybe Text)) =>
Text -> CIObjectSchemaP doc a b -> ValueSchemaP doc' a b
ciObject Text
name CIObjectSchemaP doc a b
sch = doc'
-> (Value -> Parser b)
-> (a -> Maybe Value)
-> SchemaP doc' Value Value a b
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema doc'
s Value -> Parser b
r a -> Maybe Value
w
  where
    s :: doc'
    s :: doc'
s = Text -> doc -> doc'
forall doc ndoc. HasObject doc ndoc => Text -> doc -> ndoc
mkObject Text
name (CIObjectSchemaP doc a b -> doc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc CIObjectSchemaP doc a b
sch) doc' -> (doc' -> doc') -> doc'
forall a b. a -> (a -> b) -> b
& doc' -> doc'
desc
      where
        desc :: doc' -> doc'
desc = (Maybe Text -> Identity (Maybe Text)) -> doc' -> Identity doc'
forall s a. HasDescription s a => Lens' s a
Lens' doc' (Maybe Text)
S.description ((Maybe Text -> Identity (Maybe Text)) -> doc' -> Identity doc')
-> Text -> doc' -> doc'
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Text
"json object with case-insensitive fields." :: Text)

    r :: A.Value -> A.Parser b
    r :: Value -> Parser b
r = String -> (Object -> Parser b) -> Value -> Parser b
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject (Text -> String
Text.unpack Text
name) Object -> Parser b
f
      where
        f :: A.Object -> A.Parser b
        f :: Object -> Parser b
f = CIObjectSchemaP doc a b -> Map (CI Text) Value -> Parser b
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn CIObjectSchemaP doc a b
sch (Map (CI Text) Value -> Parser b)
-> (Object -> Map (CI Text) Value) -> Object -> Parser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Map (CI Text) Value
g

        g :: A.Object -> Map (CI Text) A.Value
        g :: Object -> Map (CI Text) Value
g = [(CI Text, Value)] -> Map (CI Text) Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CI Text, Value)] -> Map (CI Text) Value)
-> (Object -> [(CI Text, Value)]) -> Object -> Map (CI Text) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair -> (CI Text, Value)) -> [Pair] -> [(CI Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key -> Identity (CI Text)) -> Pair -> Identity (CI Text, Value)
forall s t a b. Field1 s t a b => Lens s t a b
Lens Pair (CI Text, Value) Key (CI Text)
_1 ((Key -> Identity (CI Text)) -> Pair -> Identity (CI Text, Value))
-> (Key -> CI Text) -> Pair -> (CI Text, Value)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text) -> (Key -> Text) -> Key -> CI Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
A.toText)) ([Pair] -> [(CI Text, Value)])
-> (Object -> [Pair]) -> Object -> [(CI Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
A.toList

    w :: a -> Maybe A.Value
    w :: a -> Maybe Value
w = ([(CI Text, Value)] -> Value)
-> Maybe [(CI Text, Value)] -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Pair] -> Value
A.object ([Pair] -> Value)
-> ([(CI Text, Value)] -> [Pair]) -> [(CI Text, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CI Text, Value)] -> [Pair]
f) (Maybe [(CI Text, Value)] -> Maybe Value)
-> (a -> Maybe [(CI Text, Value)]) -> a -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIObjectSchemaP doc a b -> a -> Maybe [(CI Text, Value)]
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut CIObjectSchemaP doc a b
sch
      where
        f :: [(CI Text, A.Value)] -> [A.Pair]
        f :: [(CI Text, Value)] -> [Pair]
f = ((CI Text, Value) -> Pair) -> [(CI Text, Value)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CI Text
k, Value
v) -> Text -> Key
A.fromText (CI Text -> Text
forall s. CI s -> s
CI.original CI Text
k) Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= Value
v)

-- | See 'CIObjectSchema'.
ciField ::
  forall doc doc' a.
  (HasField doc doc', S.HasDescription doc' (Maybe Text)) =>
  CI Text ->
  ValueSchema doc a ->
  CIObjectSchema doc' a
ciField :: forall doc doc' a.
(HasField doc doc', HasDescription doc' (Maybe Text)) =>
CI Text -> ValueSchema doc a -> CIObjectSchema doc' a
ciField CI Text
name ValueSchema doc a
sch = doc'
-> (Map (CI Text) Value -> Parser a)
-> (a -> Maybe [(CI Text, Value)])
-> SchemaP doc' (Map (CI Text) Value) [(CI Text, Value)] a a
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema doc'
s Map (CI Text) Value -> Parser a
r a -> Maybe [(CI Text, Value)]
w
  where
    s :: doc'
    s :: doc'
s = forall doc (f :: * -> *). FieldFunctor doc f => doc -> doc
mkDocF @doc' @Identity (Text -> doc -> doc'
forall ndoc doc. HasField ndoc doc => Text -> ndoc -> doc
mkField (CI Text -> Text
forall s. CI s -> s
CI.original CI Text
name) (ValueSchema doc a -> doc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ValueSchema doc a
sch)) doc' -> (doc' -> doc') -> doc'
forall a b. a -> (a -> b) -> b
& doc' -> doc'
desc
      where
        desc :: doc' -> doc'
desc = (Maybe Text -> Identity (Maybe Text)) -> doc' -> Identity doc'
forall s a. HasDescription s a => Lens' s a
Lens' doc' (Maybe Text)
S.description ((Maybe Text -> Identity (Maybe Text)) -> doc' -> Identity doc')
-> Text -> doc' -> doc'
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Text
"json field with case-insensitive keys." :: Text)

    r :: Map (CI Text) A.Value -> A.Parser a
    r :: Map (CI Text) Value -> Parser a
r = Parser a -> (Value -> Parser a) -> Maybe Value -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"missing object field " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CI Text -> String
forall a. Show a => a -> String
show CI Text
name) (ValueSchema doc a -> Value -> Parser a
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn ValueSchema doc a
sch) (Maybe Value -> Parser a)
-> (Map (CI Text) Value -> Maybe Value)
-> Map (CI Text) Value
-> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Map (CI Text) Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI Text
name

    w :: a -> Maybe [(CI Text, A.Value)]
    w :: a -> Maybe [(CI Text, Value)]
w = (Value -> [(CI Text, Value)])
-> Maybe Value -> Maybe [(CI Text, Value)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CI Text, Value) -> [(CI Text, Value)] -> [(CI Text, Value)]
forall a. a -> [a] -> [a]
: []) ((CI Text, Value) -> [(CI Text, Value)])
-> (Value -> (CI Text, Value)) -> Value -> [(CI Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI Text
name,)) (Maybe Value -> Maybe [(CI Text, Value)])
-> (a -> Maybe Value) -> a -> Maybe [(CI Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueSchema doc a -> a -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut ValueSchema doc a
sch

-- | See 'CIObjectSchema'.
ciOptField ::
  forall doc' doc a.
  (HasField doc' doc, S.HasDescription doc (Maybe Text)) =>
  CI Text ->
  ValueSchema doc' a ->
  CIObjectSchemaP doc a (Maybe a)
ciOptField :: forall doc' doc a.
(HasField doc' doc, HasDescription doc (Maybe Text)) =>
CI Text -> ValueSchema doc' a -> CIObjectSchemaP doc a (Maybe a)
ciOptField CI Text
name ValueSchema doc' a
sch = doc
-> (Map (CI Text) Value -> Parser (Maybe a))
-> (a -> Maybe [(CI Text, Value)])
-> SchemaP doc (Map (CI Text) Value) [(CI Text, Value)] a (Maybe a)
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema doc
s Map (CI Text) Value -> Parser (Maybe a)
r a -> Maybe [(CI Text, Value)]
w
  where
    s :: doc
    s :: doc
s = forall doc (f :: * -> *). FieldFunctor doc f => doc -> doc
mkDocF @doc @Identity (Text -> doc' -> doc
forall ndoc doc. HasField ndoc doc => Text -> ndoc -> doc
mkField (CI Text -> Text
forall s. CI s -> s
CI.original CI Text
name) (ValueSchema doc' a -> doc'
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ValueSchema doc' a
sch)) doc -> (doc -> doc) -> doc
forall a b. a -> (a -> b) -> b
& doc -> doc
desc
      where
        desc :: doc -> doc
desc = (Maybe Text -> Identity (Maybe Text)) -> doc -> Identity doc
forall s a. HasDescription s a => Lens' s a
Lens' doc (Maybe Text)
S.description ((Maybe Text -> Identity (Maybe Text)) -> doc -> Identity doc)
-> Text -> doc -> doc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Text
"optional json field with case-insensitive keys." :: Text)

    r :: Map (CI Text) A.Value -> A.Parser (Maybe a)
    r :: Map (CI Text) Value -> Parser (Maybe a)
r Map (CI Text) Value
obj = case CI Text -> Map (CI Text) Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI Text
name Map (CI Text) Value
obj of
      Maybe Value
Nothing -> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Just Value
a -> (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (ValueSchema doc' a -> Value -> Parser a
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn ValueSchema doc' a
sch Value
a)

    w :: a -> Maybe [(CI Text, A.Value)]
    w :: a -> Maybe [(CI Text, Value)]
w = (Value -> [(CI Text, Value)])
-> Maybe Value -> Maybe [(CI Text, Value)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CI Text, Value) -> [(CI Text, Value)] -> [(CI Text, Value)]
forall a. a -> [a] -> [a]
: []) ((CI Text, Value) -> [(CI Text, Value)])
-> (Value -> (CI Text, Value)) -> Value -> [(CI Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI Text
name,)) (Maybe Value -> Maybe [(CI Text, Value)])
-> (a -> Maybe Value) -> a -> Maybe [(CI Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueSchema doc' a -> a -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut ValueSchema doc' a
sch

richInfoMapAndListSchema :: CIObjectSchema SwaggerDoc RichInfoMapAndList
richInfoMapAndListSchema :: SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoMapAndList
  RichInfoMapAndList
richInfoMapAndListSchema =
  SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoMapAndList
  RichInfoMapAndList
-> (RichInfoMapAndList -> Parser RichInfoMapAndList)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     RichInfoMapAndList
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
withParser
    ( Map (CI Text) Text -> [RichField] -> RichInfoMapAndList
RichInfoMapAndList
        (Map (CI Text) Text -> [RichField] -> RichInfoMapAndList)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     (Map (CI Text) Text)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     ([RichField] -> RichInfoMapAndList)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RichInfoMapAndList -> Map (CI Text) Text
richInfoMap
          (RichInfoMapAndList -> Map (CI Text) Text)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     (Map (CI Text) Text)
     (Map (CI Text) Text)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     (Map (CI Text) Text)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= ( Map (CI Text) Text
-> Maybe (Map (CI Text) Text) -> Map (CI Text) Text
forall a. a -> Maybe a -> a
fromMaybe Map (CI Text) Text
forall a. Monoid a => a
mempty
                 (Maybe (Map (CI Text) Text) -> Map (CI Text) Text)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     (Map (CI Text) Text)
     (Maybe (Map (CI Text) Text))
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     (Map (CI Text) Text)
     (Map (CI Text) Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI Text
-> ValueSchema SwaggerDoc (Map (CI Text) Text)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     (Map (CI Text) Text)
     (Maybe (Map (CI Text) Text))
forall doc' doc a.
(HasField doc' doc, HasDescription doc (Maybe Text)) =>
CI Text -> ValueSchema doc' a -> CIObjectSchemaP doc a (Maybe a)
ciOptField CI Text
forall s. IsString s => s
richInfoMapURN ((CI Text -> Text)
-> (Text -> CI Text)
-> ValueSchema NamedSwaggerDoc Text
-> ValueSchema SwaggerDoc (Map (CI Text) Text)
forall ndoc doc k a.
(HasMap ndoc doc, Ord k) =>
(k -> Text)
-> (Text -> k) -> ValueSchema ndoc a -> ValueSchema doc (Map k a)
mapWithKeys CI Text -> Text
forall s. CI s -> s
CI.original Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk ValueSchema NamedSwaggerDoc Text
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
             )
        SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoMapAndList
  ([RichField] -> RichInfoMapAndList)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     [RichField]
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     RichInfoMapAndList
forall a b.
SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoMapAndList
  (a -> b)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     a
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RichInfoMapAndList -> [RichField]
richInfoAssocList
          (RichInfoMapAndList -> [RichField])
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     [RichField]
     [RichField]
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoMapAndList
     [RichField]
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= ( [RichField] -> Maybe [RichField] -> [RichField]
forall a. a -> Maybe a -> a
fromMaybe [RichField]
forall a. Monoid a => a
mempty
                 (Maybe [RichField] -> [RichField])
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     [RichField]
     (Maybe [RichField])
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     [RichField]
     [RichField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI Text
-> ValueSchema NamedSwaggerDoc [RichField]
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     [RichField]
     (Maybe [RichField])
forall doc' doc a.
(HasField doc' doc, HasDescription doc (Maybe Text)) =>
CI Text -> ValueSchema doc' a -> CIObjectSchemaP doc a (Maybe a)
ciOptField
                   CI Text
forall s. IsString s => s
richInfoAssocListURN
                   ( RichInfoAssocList -> [RichField]
unRichInfoAssocList
                       (RichInfoAssocList -> [RichField])
-> SchemaP
     NamedSwaggerDoc Value Value [RichField] RichInfoAssocList
-> ValueSchema NamedSwaggerDoc [RichField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> CIObjectSchemaP SwaggerDoc [RichField] RichInfoAssocList
-> SchemaP
     NamedSwaggerDoc Value Value [RichField] RichInfoAssocList
forall doc doc' a b.
(HasObject doc doc', HasDescription doc' (Maybe Text)) =>
Text -> CIObjectSchemaP doc a b -> ValueSchemaP doc' a b
ciObject
                         Text
"RichInfoAssocList"
                         ( [RichField] -> RichInfoAssocList
RichInfoAssocList
                             ([RichField] -> RichInfoAssocList)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     RichInfoAssocList
-> CIObjectSchemaP SwaggerDoc [RichField] RichInfoAssocList
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= CI Text
-> ValueSchema SwaggerDoc RichInfoAssocList
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     RichInfoAssocList
forall doc doc' a.
(HasField doc doc', HasDescription doc' (Maybe Text)) =>
CI Text -> ValueSchema doc a -> CIObjectSchema doc' a
ciField
                               CI Text
"richInfo"
                               (SchemaP
  NamedSwaggerDoc Value Value RichInfoAssocList RichInfoAssocList
-> ValueSchema SwaggerDoc RichInfoAssocList
forall doc doc' v m a b.
HasObject doc doc' =>
SchemaP doc' v m a b -> SchemaP doc v m a b
unnamed SchemaP
  NamedSwaggerDoc Value Value RichInfoAssocList RichInfoAssocList
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema ValueSchema SwaggerDoc RichInfoAssocList
-> ValueSchema SwaggerDoc RichInfoAssocList
-> ValueSchema SwaggerDoc RichInfoAssocList
forall a. Semigroup a => a -> a -> a
<> ValueSchema SwaggerDoc RichInfoAssocList
richInfoAssocListSchemaLegacy)
                         )
                   )
             )
    )
    (RichInfoMapAndList -> Parser RichInfoMapAndList
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RichInfoMapAndList -> Parser RichInfoMapAndList)
-> (RichInfoMapAndList -> RichInfoMapAndList)
-> RichInfoMapAndList
-> Parser RichInfoMapAndList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichInfoMapAndList -> RichInfoMapAndList
normalizeRichInfoMapAndList)
  where
    richInfoAssocListSchemaLegacy :: ValueSchema SwaggerDoc RichInfoAssocList
    richInfoAssocListSchemaLegacy :: ValueSchema SwaggerDoc RichInfoAssocList
richInfoAssocListSchemaLegacy = [RichField] -> RichInfoAssocList
RichInfoAssocList ([RichField] -> RichInfoAssocList)
-> SchemaP SwaggerDoc Value Value RichInfoAssocList [RichField]
-> ValueSchema SwaggerDoc RichInfoAssocList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RichInfoAssocList -> [RichField]
unRichInfoAssocList (RichInfoAssocList -> [RichField])
-> SchemaP SwaggerDoc Value Value [RichField] [RichField]
-> SchemaP SwaggerDoc Value Value RichInfoAssocList [RichField]
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= ValueSchema NamedSwaggerDoc RichField
-> SchemaP SwaggerDoc Value Value [RichField] [RichField]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array (forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema @RichField)

-- | Uses 'normalizeRichInfoMapAndList'.
mkRichInfoMapAndList :: [RichField] -> RichInfoMapAndList
mkRichInfoMapAndList :: [RichField] -> RichInfoMapAndList
mkRichInfoMapAndList = RichInfoMapAndList -> RichInfoMapAndList
normalizeRichInfoMapAndList (RichInfoMapAndList -> RichInfoMapAndList)
-> ([RichField] -> RichInfoMapAndList)
-> [RichField]
-> RichInfoMapAndList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (CI Text) Text -> [RichField] -> RichInfoMapAndList
RichInfoMapAndList Map (CI Text) Text
forall a. Monoid a => a
mempty

-- | Remove fields with @""@ values; make both map and assoc list contain the union of their
-- data; handle case insensitivity.  See also: 'normalizeRichInfo'.
normalizeRichInfoMapAndList :: RichInfoMapAndList -> RichInfoMapAndList
normalizeRichInfoMapAndList :: RichInfoMapAndList -> RichInfoMapAndList
normalizeRichInfoMapAndList = RichInfoAssocList -> RichInfoMapAndList
fromRichInfoAssocList (RichInfoAssocList -> RichInfoMapAndList)
-> (RichInfoMapAndList -> RichInfoAssocList)
-> RichInfoMapAndList
-> RichInfoMapAndList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichInfoMapAndList -> RichInfoAssocList
toRichInfoAssocList

-- | Lossy transformation of map-and-list representation into list-only representation.  The
-- order of the list part of 'RichInfo' is not changed in the output; keys in the map that do
-- not appear in the list are appended in alpha order.
--
-- Uses 'mkRichInfoAssocList'; used as one half of 'normalizeRichInfoAssocList'.
toRichInfoAssocList :: RichInfoMapAndList -> RichInfoAssocList
toRichInfoAssocList :: RichInfoMapAndList -> RichInfoAssocList
toRichInfoAssocList (RichInfoMapAndList Map (CI Text) Text
mp [RichField]
al) =
  [RichField] -> RichInfoAssocList
mkRichInfoAssocList ([RichField] -> RichInfoAssocList)
-> [RichField] -> RichInfoAssocList
forall a b. (a -> b) -> a -> b
$ ([RichField] -> (CI Text, Text) -> [RichField])
-> [RichField] -> [(CI Text, Text)] -> [RichField]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [RichField] -> (CI Text, Text) -> [RichField]
go [RichField]
al (Map (CI Text) Text -> [(CI Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (CI Text) Text
mp)
  where
    go :: [RichField] -> (CI Text, Text) -> [RichField]
    go :: [RichField] -> (CI Text, Text) -> [RichField]
go [RichField]
rfs (CI Text
key, Text
val) =
      case (RichField -> Bool) -> [RichField] -> ([RichField], [RichField])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\(RichField CI Text
rfKey Text
_) -> CI Text
rfKey CI Text -> CI Text -> Bool
forall a. Eq a => a -> a -> Bool
== CI Text
key) [RichField]
rfs of
        ([RichField]
xs, []) -> [RichField]
xs [RichField] -> [RichField] -> [RichField]
forall a. Semigroup a => a -> a -> a
<> [CI Text -> Text -> RichField
RichField CI Text
key Text
val]
        ([RichField]
xs, RichField
_ : [RichField]
ys) -> [RichField]
xs [RichField] -> [RichField] -> [RichField]
forall a. Semigroup a => a -> a -> a
<> [CI Text -> Text -> RichField
RichField CI Text
key Text
val] [RichField] -> [RichField] -> [RichField]
forall a. Semigroup a => a -> a -> a
<> [RichField]
ys

-- | This is called by spar to recover the more type that also contains a map.  Since we don't
-- know where the data came from when it was posted or where the SCIM peer expects the data to
-- be (map or assoc list), we copy the assoc list into the map, and provide all attributes
-- twice.
--
-- Used as the other half of 'normalizeRichInfoAssocList' (next to 'toRichInfoAssocList'.
fromRichInfoAssocList :: RichInfoAssocList -> RichInfoMapAndList
fromRichInfoAssocList :: RichInfoAssocList -> RichInfoMapAndList
fromRichInfoAssocList (RichInfoAssocList [RichField]
riList) =
  RichInfoMapAndList
    { $sel:richInfoMap:RichInfoMapAndList :: Map (CI Text) Text
richInfoMap = Map (CI Text) Text
riMap,
      $sel:richInfoAssocList:RichInfoMapAndList :: [RichField]
richInfoAssocList = [RichField]
riList'
    }
  where
    riList' :: [RichField]
riList' = [RichField] -> [RichField]
normalizeRichInfoAssocListInt [RichField]
riList
    riMap :: Map (CI Text) Text
riMap = [(CI Text, Text)] -> Map (CI Text) Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CI Text, Text)] -> Map (CI Text) Text)
-> [(CI Text, Text)] -> Map (CI Text) Text
forall a b. (a -> b) -> a -> b
$ (\(RichField CI Text
k Text
v) -> (CI Text
k, Text
v)) (RichField -> (CI Text, Text)) -> [RichField] -> [(CI Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RichField]
riList'

instance Arbitrary RichInfoMapAndList where
  arbitrary :: Gen RichInfoMapAndList
arbitrary = [RichField] -> RichInfoMapAndList
mkRichInfoMapAndList ([RichField] -> RichInfoMapAndList)
-> Gen [RichField] -> Gen RichInfoMapAndList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [RichField]
forall a. Arbitrary a => Gen a
arbitrary

-- | Uniform Resource Names used for serialization of 'RichInfo'.
richInfoMapURN, richInfoAssocListURN :: (IsString s) => s
richInfoMapURN :: forall s. IsString s => s
richInfoMapURN = s
"urn:ietf:params:scim:schemas:extension:wire:1.0:User"
richInfoAssocListURN :: forall s. IsString s => s
richInfoAssocListURN = s
"urn:wire:scim:schemas:profile:1.0"

--------------------------------------------------------------------------------
-- RichInfoAssocList

newtype RichInfoAssocList = RichInfoAssocList {RichInfoAssocList -> [RichField]
unRichInfoAssocList :: [RichField]}
  deriving stock (RichInfoAssocList -> RichInfoAssocList -> Bool
(RichInfoAssocList -> RichInfoAssocList -> Bool)
-> (RichInfoAssocList -> RichInfoAssocList -> Bool)
-> Eq RichInfoAssocList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RichInfoAssocList -> RichInfoAssocList -> Bool
== :: RichInfoAssocList -> RichInfoAssocList -> Bool
$c/= :: RichInfoAssocList -> RichInfoAssocList -> Bool
/= :: RichInfoAssocList -> RichInfoAssocList -> Bool
Eq, Int -> RichInfoAssocList -> ShowS
[RichInfoAssocList] -> ShowS
RichInfoAssocList -> String
(Int -> RichInfoAssocList -> ShowS)
-> (RichInfoAssocList -> String)
-> ([RichInfoAssocList] -> ShowS)
-> Show RichInfoAssocList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RichInfoAssocList -> ShowS
showsPrec :: Int -> RichInfoAssocList -> ShowS
$cshow :: RichInfoAssocList -> String
show :: RichInfoAssocList -> String
$cshowList :: [RichInfoAssocList] -> ShowS
showList :: [RichInfoAssocList] -> ShowS
Show, (forall x. RichInfoAssocList -> Rep RichInfoAssocList x)
-> (forall x. Rep RichInfoAssocList x -> RichInfoAssocList)
-> Generic RichInfoAssocList
forall x. Rep RichInfoAssocList x -> RichInfoAssocList
forall x. RichInfoAssocList -> Rep RichInfoAssocList x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RichInfoAssocList -> Rep RichInfoAssocList x
from :: forall x. RichInfoAssocList -> Rep RichInfoAssocList x
$cto :: forall x. Rep RichInfoAssocList x -> RichInfoAssocList
to :: forall x. Rep RichInfoAssocList x -> RichInfoAssocList
Generic)
  deriving ([RichInfoAssocList] -> Value
[RichInfoAssocList] -> Encoding
RichInfoAssocList -> Value
RichInfoAssocList -> Encoding
(RichInfoAssocList -> Value)
-> (RichInfoAssocList -> Encoding)
-> ([RichInfoAssocList] -> Value)
-> ([RichInfoAssocList] -> Encoding)
-> ToJSON RichInfoAssocList
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: RichInfoAssocList -> Value
toJSON :: RichInfoAssocList -> Value
$ctoEncoding :: RichInfoAssocList -> Encoding
toEncoding :: RichInfoAssocList -> Encoding
$ctoJSONList :: [RichInfoAssocList] -> Value
toJSONList :: [RichInfoAssocList] -> Value
$ctoEncodingList :: [RichInfoAssocList] -> Encoding
toEncodingList :: [RichInfoAssocList] -> Encoding
A.ToJSON, Value -> Parser [RichInfoAssocList]
Value -> Parser RichInfoAssocList
(Value -> Parser RichInfoAssocList)
-> (Value -> Parser [RichInfoAssocList])
-> FromJSON RichInfoAssocList
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser RichInfoAssocList
parseJSON :: Value -> Parser RichInfoAssocList
$cparseJSONList :: Value -> Parser [RichInfoAssocList]
parseJSONList :: Value -> Parser [RichInfoAssocList]
A.FromJSON, Typeable RichInfoAssocList
Typeable RichInfoAssocList =>
(Proxy RichInfoAssocList
 -> Declare (Definitions Schema) NamedSchema)
-> ToSchema RichInfoAssocList
Proxy RichInfoAssocList -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy RichInfoAssocList -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy RichInfoAssocList -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via (Schema RichInfoAssocList)

-- | Uses 'normalizeRichInfoAssocList'.
mkRichInfoAssocList :: [RichField] -> RichInfoAssocList
mkRichInfoAssocList :: [RichField] -> RichInfoAssocList
mkRichInfoAssocList = [RichField] -> RichInfoAssocList
RichInfoAssocList ([RichField] -> RichInfoAssocList)
-> ([RichField] -> [RichField]) -> [RichField] -> RichInfoAssocList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RichField] -> [RichField]
normalizeRichInfoAssocListInt

normalizeRichInfoAssocList :: RichInfoAssocList -> RichInfoAssocList
normalizeRichInfoAssocList :: RichInfoAssocList -> RichInfoAssocList
normalizeRichInfoAssocList = [RichField] -> RichInfoAssocList
RichInfoAssocList ([RichField] -> RichInfoAssocList)
-> (RichInfoAssocList -> [RichField])
-> RichInfoAssocList
-> RichInfoAssocList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RichField] -> [RichField]
normalizeRichInfoAssocListInt ([RichField] -> [RichField])
-> (RichInfoAssocList -> [RichField])
-> RichInfoAssocList
-> [RichField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichInfoAssocList -> [RichField]
unRichInfoAssocList

normalizeRichInfoAssocListInt :: [RichField] -> [RichField]
normalizeRichInfoAssocListInt :: [RichField] -> [RichField]
normalizeRichInfoAssocListInt = (RichField -> Text) -> [RichField] -> [RichField]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn RichField -> Text
nubber ([RichField] -> [RichField])
-> ([RichField] -> [RichField]) -> [RichField] -> [RichField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RichField -> Bool) -> [RichField] -> [RichField]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
forall a. Monoid a => a
mempty) (Text -> Bool) -> (RichField -> Text) -> RichField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichField -> Text
richFieldValue)
  where
    -- see also: https://github.com/basvandijk/case-insensitive/issues/31
    nubber :: RichField -> Text
nubber = Text -> Text
Text.toLower (Text -> Text) -> (RichField -> Text) -> RichField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toCaseFold (Text -> Text) -> (RichField -> Text) -> RichField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.foldedCase (CI Text -> Text) -> (RichField -> CI Text) -> RichField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichField -> CI Text
richFieldType

instance Monoid RichInfoAssocList where
  mempty :: RichInfoAssocList
mempty = [RichField] -> RichInfoAssocList
RichInfoAssocList [RichField]
forall a. Monoid a => a
mempty

instance Semigroup RichInfoAssocList where
  RichInfoAssocList [RichField]
a <> :: RichInfoAssocList -> RichInfoAssocList -> RichInfoAssocList
<> RichInfoAssocList [RichField]
b = [RichField] -> RichInfoAssocList
RichInfoAssocList ([RichField] -> RichInfoAssocList)
-> [RichField] -> RichInfoAssocList
forall a b. (a -> b) -> a -> b
$ [RichField]
a [RichField] -> [RichField] -> [RichField]
forall a. Semigroup a => a -> a -> a
<> [RichField]
b

instance ToSchema RichInfoAssocList where
  schema :: SchemaP
  NamedSwaggerDoc Value Value RichInfoAssocList RichInfoAssocList
schema = Text
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     RichInfoAssocList
-> SchemaP
     NamedSwaggerDoc Value Value RichInfoAssocList RichInfoAssocList
forall doc doc' a b.
(HasObject doc doc', HasDescription doc' (Maybe Text)) =>
Text -> CIObjectSchemaP doc a b -> ValueSchemaP doc' a b
ciObject Text
"RichInfoAssocList" SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoAssocList
  RichInfoAssocList
richInfoAssocListSchema
    where
      richInfoAssocListSchema :: CIObjectSchema SwaggerDoc RichInfoAssocList
      richInfoAssocListSchema :: SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoAssocList
  RichInfoAssocList
richInfoAssocListSchema =
        SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoAssocList
  (Int, [RichField])
-> ((Int, [RichField]) -> Parser RichInfoAssocList)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     RichInfoAssocList
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
withParser
          ( (,)
              (Int -> [RichField] -> (Int, [RichField]))
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     Int
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     ([RichField] -> (Int, [RichField]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> RichInfoAssocList -> Int
forall a b. a -> b -> a
const (Int
0 :: Int) (RichInfoAssocList -> Int)
-> SchemaP
     SwaggerDoc (Map (CI Text) Value) [(CI Text, Value)] Int Int
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     Int
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= CI Text
-> ValueSchema NamedSwaggerDoc Int
-> SchemaP
     SwaggerDoc (Map (CI Text) Value) [(CI Text, Value)] Int Int
forall doc doc' a.
(HasField doc doc', HasDescription doc' (Maybe Text)) =>
CI Text -> ValueSchema doc a -> CIObjectSchema doc' a
ciField CI Text
"version" ValueSchema NamedSwaggerDoc Int
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
              SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoAssocList
  ([RichField] -> (Int, [RichField]))
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     [RichField]
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     (Int, [RichField])
forall a b.
SchemaP
  SwaggerDoc
  (Map (CI Text) Value)
  [(CI Text, Value)]
  RichInfoAssocList
  (a -> b)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     a
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RichInfoAssocList -> [RichField]
unRichInfoAssocList (RichInfoAssocList -> [RichField])
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     [RichField]
     [RichField]
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     [RichField]
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= CI Text
-> SchemaP SwaggerDoc Value Value [RichField] [RichField]
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     [RichField]
     [RichField]
forall doc doc' a.
(HasField doc doc', HasDescription doc' (Maybe Text)) =>
CI Text -> ValueSchema doc a -> CIObjectSchema doc' a
ciField CI Text
"fields" (ValueSchema NamedSwaggerDoc RichField
-> SchemaP SwaggerDoc Value Value [RichField] [RichField]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema NamedSwaggerDoc RichField
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
          )
          (((Int, [RichField]) -> Parser RichInfoAssocList)
 -> SchemaP
      SwaggerDoc
      (Map (CI Text) Value)
      [(CI Text, Value)]
      RichInfoAssocList
      RichInfoAssocList)
-> ((Int, [RichField]) -> Parser RichInfoAssocList)
-> SchemaP
     SwaggerDoc
     (Map (CI Text) Value)
     [(CI Text, Value)]
     RichInfoAssocList
     RichInfoAssocList
forall a b. (a -> b) -> a -> b
$ \(Int
version, [RichField]
fields) ->
            [RichField] -> RichInfoAssocList
mkRichInfoAssocList ([RichField] -> RichInfoAssocList)
-> Parser [RichField] -> Parser RichInfoAssocList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [RichField] -> Parser [RichField]
validateRichInfoAssocList Int
version [RichField]
fields

validateRichInfoAssocList :: Int -> [RichField] -> A.Parser [RichField]
validateRichInfoAssocList :: Int -> [RichField] -> Parser [RichField]
validateRichInfoAssocList Int
version [RichField]
fields = do
  Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"unknown version: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
version
  [CI Text] -> Parser ()
checkDuplicates ((RichField -> CI Text) -> [RichField] -> [CI Text]
forall a b. (a -> b) -> [a] -> [b]
map RichField -> CI Text
richFieldType [RichField]
fields)
  [RichField] -> Parser [RichField]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [RichField]
fields
  where
    checkDuplicates :: [CI Text] -> A.Parser ()
    checkDuplicates :: [CI Text] -> Parser ()
checkDuplicates [CI Text]
xs =
      case ([CI Text] -> Bool) -> [[CI Text]] -> [[CI Text]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> ([CI Text] -> Int) -> [CI Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CI Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([[CI Text]] -> [[CI Text]])
-> ([CI Text] -> [[CI Text]]) -> [CI Text] -> [[CI Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CI Text] -> [[CI Text]]
forall a. Eq a => [a] -> [[a]]
group ([CI Text] -> [[CI Text]])
-> ([CI Text] -> [CI Text]) -> [CI Text] -> [[CI Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CI Text] -> [CI Text]
forall a. Ord a => [a] -> [a]
sort ([CI Text] -> [[CI Text]]) -> [CI Text] -> [[CI Text]]
forall a b. (a -> b) -> a -> b
$ [CI Text]
xs of
        [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [[CI Text]]
ds -> String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"duplicate fields: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [CI Text] -> String
forall a. Show a => a -> String
show (([CI Text] -> CI Text) -> [[CI Text]] -> [CI Text]
forall a b. (a -> b) -> [a] -> [b]
map [CI Text] -> CI Text
forall a. HasCallStack => [a] -> a
head [[CI Text]]
ds))

instance Arbitrary RichInfoAssocList where
  arbitrary :: Gen RichInfoAssocList
arbitrary = [RichField] -> RichInfoAssocList
mkRichInfoAssocList ([RichField] -> RichInfoAssocList)
-> Gen [RichField] -> Gen RichInfoAssocList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [RichField]
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: RichInfoAssocList -> [RichInfoAssocList]
shrink (RichInfoAssocList [RichField]
things) = [RichField] -> RichInfoAssocList
mkRichInfoAssocList ([RichField] -> RichInfoAssocList)
-> [[RichField]] -> [RichInfoAssocList]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RichField] -> [[RichField]]
forall a. Arbitrary a => a -> [a]
QC.shrink [RichField]
things

instance C.Cql RichInfoAssocList where
  ctype :: Tagged RichInfoAssocList ColumnType
ctype = ColumnType -> Tagged RichInfoAssocList ColumnType
forall a b. b -> Tagged a b
C.Tagged ColumnType
C.BlobColumn
  toCql :: RichInfoAssocList -> Value
toCql = Blob -> Value
forall a. Cql a => a -> Value
C.toCql (Blob -> Value)
-> (RichInfoAssocList -> Blob) -> RichInfoAssocList -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Blob
C.Blob (ByteString -> Blob)
-> (RichInfoAssocList -> ByteString) -> RichInfoAssocList -> Blob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RichInfoAssocList -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode
  fromCql :: Value -> Either String RichInfoAssocList
fromCql (C.CqlBlob ByteString
v) = ByteString -> Either String RichInfoAssocList
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode ByteString
v
  fromCql Value
_ = String -> Either String RichInfoAssocList
forall a b. a -> Either a b
Left String
"RichInfo: Blob expected"

--------------------------------------------------------------------------------
-- RichField

data RichField = RichField
  { RichField -> CI Text
richFieldType :: CI Text,
    RichField -> Text
richFieldValue :: Text
  }
  deriving stock (RichField -> RichField -> Bool
(RichField -> RichField -> Bool)
-> (RichField -> RichField -> Bool) -> Eq RichField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RichField -> RichField -> Bool
== :: RichField -> RichField -> Bool
$c/= :: RichField -> RichField -> Bool
/= :: RichField -> RichField -> Bool
Eq, Int -> RichField -> ShowS
[RichField] -> ShowS
RichField -> String
(Int -> RichField -> ShowS)
-> (RichField -> String)
-> ([RichField] -> ShowS)
-> Show RichField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RichField -> ShowS
showsPrec :: Int -> RichField -> ShowS
$cshow :: RichField -> String
show :: RichField -> String
$cshowList :: [RichField] -> ShowS
showList :: [RichField] -> ShowS
Show, (forall x. RichField -> Rep RichField x)
-> (forall x. Rep RichField x -> RichField) -> Generic RichField
forall x. Rep RichField x -> RichField
forall x. RichField -> Rep RichField x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RichField -> Rep RichField x
from :: forall x. RichField -> Rep RichField x
$cto :: forall x. Rep RichField x -> RichField
to :: forall x. Rep RichField x -> RichField
Generic)
  deriving ([RichField] -> Value
[RichField] -> Encoding
RichField -> Value
RichField -> Encoding
(RichField -> Value)
-> (RichField -> Encoding)
-> ([RichField] -> Value)
-> ([RichField] -> Encoding)
-> ToJSON RichField
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: RichField -> Value
toJSON :: RichField -> Value
$ctoEncoding :: RichField -> Encoding
toEncoding :: RichField -> Encoding
$ctoJSONList :: [RichField] -> Value
toJSONList :: [RichField] -> Value
$ctoEncodingList :: [RichField] -> Encoding
toEncodingList :: [RichField] -> Encoding
A.ToJSON, Value -> Parser [RichField]
Value -> Parser RichField
(Value -> Parser RichField)
-> (Value -> Parser [RichField]) -> FromJSON RichField
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser RichField
parseJSON :: Value -> Parser RichField
$cparseJSONList :: Value -> Parser [RichField]
parseJSONList :: Value -> Parser [RichField]
A.FromJSON, Typeable RichField
Typeable RichField =>
(Proxy RichField -> Declare (Definitions Schema) NamedSchema)
-> ToSchema RichField
Proxy RichField -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy RichField -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy RichField -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via (Schema RichField)

instance ToSchema RichField where
  -- NB: "name" would be a better name for 'richFieldType', but "type" is used because we
  -- also have "type" in SCIM; and the reason we use "type" for SCIM is that @{"type": ...,
  -- "value": ...}@ is how all other SCIM payloads are formatted, so it's quite possible
  -- that some provisioning agent would support "type" but not "name".
  schema :: ValueSchema NamedSwaggerDoc RichField
schema =
    Text
-> SchemaP SwaggerDoc Object [Pair] RichField RichField
-> ValueSchema NamedSwaggerDoc RichField
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"RichField" (SchemaP SwaggerDoc Object [Pair] RichField RichField
 -> ValueSchema NamedSwaggerDoc RichField)
-> SchemaP SwaggerDoc Object [Pair] RichField RichField
-> ValueSchema NamedSwaggerDoc RichField
forall a b. (a -> b) -> a -> b
$
      CI Text -> Text -> RichField
RichField
        (CI Text -> Text -> RichField)
-> SchemaP SwaggerDoc Object [Pair] RichField (CI Text)
-> SchemaP SwaggerDoc Object [Pair] RichField (Text -> RichField)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RichField -> CI Text
richFieldType (RichField -> CI Text)
-> SchemaP SwaggerDoc Object [Pair] (CI Text) (CI Text)
-> SchemaP SwaggerDoc Object [Pair] RichField (CI Text)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value (CI Text) (CI Text)
-> SchemaP SwaggerDoc Object [Pair] (CI Text) (CI Text)
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"type" (CI Text -> Text
forall s. CI s -> s
CI.original (CI Text -> Text)
-> SchemaP NamedSwaggerDoc Value Value Text (CI Text)
-> SchemaP NamedSwaggerDoc Value Value (CI Text) (CI Text)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= (Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text)
-> ValueSchema NamedSwaggerDoc Text
-> SchemaP NamedSwaggerDoc Value Value Text (CI Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSchema NamedSwaggerDoc Text
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema))
        SchemaP SwaggerDoc Object [Pair] RichField (Text -> RichField)
-> SchemaP SwaggerDoc Object [Pair] RichField Text
-> SchemaP SwaggerDoc Object [Pair] RichField RichField
forall a b.
SchemaP SwaggerDoc Object [Pair] RichField (a -> b)
-> SchemaP SwaggerDoc Object [Pair] RichField a
-> SchemaP SwaggerDoc Object [Pair] RichField b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RichField -> Text
richFieldValue (RichField -> Text)
-> SchemaP SwaggerDoc Object [Pair] Text Text
-> SchemaP SwaggerDoc Object [Pair] RichField Text
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> ValueSchema NamedSwaggerDoc Text
-> SchemaP SwaggerDoc Object [Pair] Text Text
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"value" ValueSchema NamedSwaggerDoc Text
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema

instance Arbitrary RichField where
  arbitrary :: Gen RichField
arbitrary =
    CI Text -> Text -> RichField
RichField
      (CI Text -> Text -> RichField)
-> Gen (CI Text) -> Gen (Text -> RichField)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text)
-> (PrintableString -> Text) -> PrintableString -> CI Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (PrintableString -> String) -> PrintableString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintableString -> String
QC.getPrintableString (PrintableString -> CI Text)
-> Gen PrintableString -> Gen (CI Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen PrintableString
forall a. Arbitrary a => Gen a
arbitrary)
      Gen (Text -> RichField) -> Gen Text -> Gen RichField
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Text
Text.pack (String -> Text)
-> (PrintableString -> String) -> PrintableString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintableString -> String
QC.getPrintableString (PrintableString -> Text) -> Gen PrintableString -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen PrintableString
forall a. Arbitrary a => Gen a
arbitrary)
  shrink :: RichField -> [RichField]
shrink (RichField CI Text
k Text
v) = CI Text -> Text -> RichField
RichField (CI Text -> Text -> RichField) -> [CI Text] -> [Text -> RichField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI Text -> [CI Text]
forall a. Arbitrary a => a -> [a]
QC.shrink CI Text
k [Text -> RichField] -> [Text] -> [RichField]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> [Text]
forall a. Arbitrary a => a -> [a]
QC.shrink Text
v

--------------------------------------------------------------------------------
-- convenience functions

-- | Calculate the length of user-supplied data in 'RichInfo'. Used for enforcing
-- 'setRichInfoLimit'
--
-- NB: we could just calculate the length of JSON-encoded payload, but it is fragile because
-- if our JSON encoding changes, existing payloads might become unacceptable.
richInfoSize :: RichInfo -> Int
richInfoSize :: RichInfo -> Int
richInfoSize (RichInfo (RichInfoAssocList [RichField]
fields)) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Text -> Int
Text.length (CI Text -> Text
forall s. CI s -> s
CI.original CI Text
t) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
v | RichField CI Text
t Text
v <- [RichField]
fields]