{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- 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 Web.Scim.Test.Util
  ( shouldRespondWith,
    shouldEventuallyRespondWith,

    -- * Making wai requests
    post,
    put,
    patch,
    AcceptanceConfig (..),
    defAcceptanceConfig,
    AcceptanceQueryConfig (..),
    defAcceptanceQueryConfig,
    post',
    put',
    patch',
    get',
    delete',
    (<//>),

    -- * Request/response quasiquoter
    scim,

    -- * JSON parsing
    Field (..),
    getField,

    -- * Tag
    TestTag,
  )
where

import qualified Control.Retry as Retry
import Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Aeson.QQ
import Data.Aeson.Types (JSONPathElement (Key))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as L
import Data.Proxy
import Data.Text
import Data.UUID as UUID
import Data.UUID.V4 as UUID
import GHC.Stack
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Haskell.TH.Quote
import Network.HTTP.Types
import Network.Wai (Application)
import Network.Wai.Test (SResponse)
import Test.Hspec.Expectations (expectationFailure)
import Test.Hspec.Wai hiding (patch, post, put, shouldRespondWith)
import Test.Hspec.Wai.Matcher (bodyEquals, match)
import Web.Scim.Class.Auth (AuthTypes (..))
import Web.Scim.Class.Group (GroupTypes (..))
import Web.Scim.Schema.Schema (Schema (CustomSchema, User20))
import Web.Scim.Schema.User (UserTypes (..))

-- | re-implementation of 'shouldRespondWith' with better error reporting.
-- FUTUREWORK: make this a PR upstream.  (while we're at it, we can also patch 'WaiSession'
-- and 'request' to keep track of the 'SRequest', and add that to the error message here with
-- the response.)
shouldRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
shouldRespondWith :: forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
shouldRespondWith WaiSession st SResponse
action ResponseMatcher
matcher =
  (String -> WaiSession st ())
-> (() -> WaiSession st ()) -> Either String () -> WaiSession st ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO () -> WaiSession st ()
forall a. IO a -> WaiSession st a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiSession st ())
-> (String -> IO ()) -> String -> WaiSession st ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> IO ()
String -> IO ()
expectationFailure) () -> WaiSession st ()
forall a. a -> WaiSession st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> WaiSession st ())
-> WaiSession st (Either String ()) -> WaiSession st ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WaiSession st SResponse
-> ResponseMatcher -> WaiSession st (Either String ())
forall st.
HasCallStack =>
WaiSession st SResponse
-> ResponseMatcher -> WaiSession st (Either String ())
doesRespondWith WaiSession st SResponse
action ResponseMatcher
matcher

doesRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiSession st (Either String ())
doesRespondWith :: forall st.
HasCallStack =>
WaiSession st SResponse
-> ResponseMatcher -> WaiSession st (Either String ())
doesRespondWith WaiSession st SResponse
action ResponseMatcher
matcher = do
  SResponse
r <- WaiSession st SResponse
action
  let extmsg :: String
extmsg = String
"  details:  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SResponse -> String
forall a. Show a => a -> String
show SResponse
r String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
  Either String () -> WaiSession st (Either String ())
forall a. a -> WaiSession st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> WaiSession st (Either String ()))
-> Either String () -> WaiSession st (Either String ())
forall a b. (a -> b) -> a -> b
$ Either String ()
-> (String -> Either String ()) -> Maybe String -> Either String ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either String ()
forall a b. b -> Either a b
Right ()) (String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ())
-> (String -> String) -> String -> Either String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
extmsg)) (SResponse -> ResponseMatcher -> Maybe String
match SResponse
r ResponseMatcher
matcher)

shouldEventuallyRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
shouldEventuallyRespondWith :: forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
shouldEventuallyRespondWith WaiSession st SResponse
action ResponseMatcher
matcher =
  (String -> WaiSession st ())
-> (() -> WaiSession st ()) -> Either String () -> WaiSession st ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO () -> WaiSession st ()
forall a. IO a -> WaiSession st a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiSession st ())
-> (String -> IO ()) -> String -> WaiSession st ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> IO ()
String -> IO ()
expectationFailure) () -> WaiSession st ()
forall a. a -> WaiSession st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either String () -> WaiSession st ())
-> WaiSession st (Either String ()) -> WaiSession st ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RetryPolicyM (WaiSession st)
-> (RetryStatus -> Either String () -> WaiSession st Bool)
-> (RetryStatus -> WaiSession st (Either String ()))
-> WaiSession st (Either String ())
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
Retry.retrying
      (Int -> RetryPolicyM (WaiSession st)
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
Retry.exponentialBackoff Int
66000 RetryPolicyM (WaiSession st)
-> RetryPolicyM (WaiSession st) -> RetryPolicyM (WaiSession st)
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
Retry.limitRetries Int
6)
      (\RetryStatus
_ -> Bool -> WaiSession st Bool
forall a. a -> WaiSession st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> WaiSession st Bool)
-> (Either String () -> Bool)
-> Either String ()
-> WaiSession st Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> (() -> Bool) -> Either String () -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True) (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
False))
      (\RetryStatus
_ -> WaiSession st SResponse
-> ResponseMatcher -> WaiSession st (Either String ())
forall st.
HasCallStack =>
WaiSession st SResponse
-> ResponseMatcher -> WaiSession st (Either String ())
doesRespondWith WaiSession st SResponse
action ResponseMatcher
matcher)

data AcceptanceConfig tag = AcceptanceConfig
  { forall tag.
AcceptanceConfig tag -> IO (Application, AcceptanceQueryConfig tag)
scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag),
    -- TODO: add a destructor, something like: @destroy :: CustomEnv tag -> IO ()@,
    forall tag. AcceptanceConfig tag -> IO Text
genUserName :: IO Text,
    -- | some acceptance tests match against a fully rendered
    -- response body, which will not work when running the test
    -- as a library user (since the response will have more and
    -- other information).  if you leave this on 'False' (default
    -- from 'defAcceptanceConfig'), the test will only check some
    -- invariants on the response instead that must hold in all
    -- cases.
    forall tag. AcceptanceConfig tag -> Bool
responsesFullyKnown :: Bool
  }

defAcceptanceConfig :: IO Application -> AcceptanceConfig tag
defAcceptanceConfig :: forall tag. IO Application -> AcceptanceConfig tag
defAcceptanceConfig IO Application
scimApp = AcceptanceConfig {Bool
IO (Application, AcceptanceQueryConfig tag)
IO Text
scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag)
genUserName :: IO Text
responsesFullyKnown :: Bool
scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag)
genUserName :: IO Text
responsesFullyKnown :: Bool
..}
  where
    scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag)
scimAppAndConfig = (,AcceptanceQueryConfig tag
forall tag. AcceptanceQueryConfig tag
defAcceptanceQueryConfig) (Application -> (Application, AcceptanceQueryConfig tag))
-> IO Application -> IO (Application, AcceptanceQueryConfig tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Application
scimApp
    genUserName :: IO Text
genUserName = (Text
"Test_User_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (UUID -> Text) -> UUID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Text
UUID.toText (UUID -> Text) -> IO UUID -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom
    responsesFullyKnown :: Bool
responsesFullyKnown = Bool
False

data AcceptanceQueryConfig tag = AcceptanceQueryConfig
  { forall tag. AcceptanceQueryConfig tag -> ByteString
scimPathPrefix :: BS.ByteString,
    forall tag. AcceptanceQueryConfig tag -> ByteString
scimAuthToken :: BS.ByteString
  }

defAcceptanceQueryConfig :: AcceptanceQueryConfig tag
defAcceptanceQueryConfig :: forall tag. AcceptanceQueryConfig tag
defAcceptanceQueryConfig = AcceptanceQueryConfig {ByteString
scimPathPrefix :: ByteString
scimAuthToken :: ByteString
scimPathPrefix :: ByteString
scimAuthToken :: ByteString
..}
  where
    scimPathPrefix :: ByteString
scimPathPrefix = ByteString
""
    scimAuthToken :: ByteString
scimAuthToken = ByteString
"authorized"

----------------------------------------------------------------------------
-- Redefine wai test helpers to include scim+json content type

-- | avoid multiple @/@.  (kill at most one @/@ at the end of first arg and beginning of
-- second arg, resp., then add one during concatenation.
--
-- >>> ["a" <//> "b", "a" <//> "/b", "a/" <//> "b", "a/" <//> "/b"]
-- ["a/b","a/b","a/b","a/b"]
--
-- WARNING: {doctests don't work in our
-- infrastructure](https://github.com/zinfra/backend-issues/issues/1549), so this is
-- duplicated in the unit tests.
(<//>) :: ByteString -> ByteString -> ByteString
<//> :: ByteString -> ByteString -> ByteString
(<//>) ByteString
a ByteString
b = ByteString
a' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b'
  where
    a' :: ByteString
a' = ByteString
-> ((ByteString, Char) -> ByteString)
-> Maybe (ByteString, Char)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
a (\(ByteString
t, Char
l) -> if Char
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' then ByteString
t else ByteString
a) (Maybe (ByteString, Char) -> ByteString)
-> Maybe (ByteString, Char) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, Char)
BS8.unsnoc ByteString
a
    b' :: ByteString
b' = ByteString
-> ((Char, ByteString) -> ByteString)
-> Maybe (Char, ByteString)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
b (\(Char
h, ByteString
t) -> if Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' then ByteString
t else ByteString
b) (Maybe (Char, ByteString) -> ByteString)
-> Maybe (Char, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (Char, ByteString)
BS8.uncons ByteString
b

post :: ByteString -> L.ByteString -> WaiSession st SResponse
post :: forall st. ByteString -> ByteString -> WaiSession st SResponse
post ByteString
path = ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
forall st.
ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
request ByteString
methodPost ByteString
path [(HeaderName
hContentType, ByteString
"application/scim+json")]

put :: ByteString -> L.ByteString -> WaiSession st SResponse
put :: forall st. ByteString -> ByteString -> WaiSession st SResponse
put ByteString
path = ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
forall st.
ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
request ByteString
methodPut ByteString
path [(HeaderName
hContentType, ByteString
"application/scim+json")]

patch :: ByteString -> L.ByteString -> WaiSession st SResponse
patch :: forall st. ByteString -> ByteString -> WaiSession st SResponse
patch ByteString
path = ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
forall st.
ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
request ByteString
methodPatch ByteString
path [(HeaderName
hContentType, ByteString
"application/scim+json")]

request' :: Method -> AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse
request' :: forall tag st.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
request' ByteString
method (AcceptanceQueryConfig ByteString
prefix ByteString
token) ByteString
path = ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
forall st.
ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession st SResponse
request ByteString
method (ByteString
prefix ByteString -> ByteString -> ByteString
<//> ByteString
path) [(HeaderName
hAuthorization, ByteString
token), (HeaderName
hContentType, ByteString
"application/scim+json")]

get' :: AcceptanceQueryConfig tag -> ByteString -> WaiSession st SResponse
get' :: forall tag st.
AcceptanceQueryConfig tag -> ByteString -> WaiSession st SResponse
get' AcceptanceQueryConfig tag
cfg ByteString
path = ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
forall tag st.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
request' ByteString
methodGet AcceptanceQueryConfig tag
cfg ByteString
path ByteString
""

post' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse
post' :: forall tag st.
AcceptanceQueryConfig tag
-> ByteString -> ByteString -> WaiSession st SResponse
post' = ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
forall tag st.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
request' ByteString
methodPost

put' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse
put' :: forall tag st.
AcceptanceQueryConfig tag
-> ByteString -> ByteString -> WaiSession st SResponse
put' = ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
forall tag st.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
request' ByteString
methodPut

patch' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse
patch' :: forall tag st.
AcceptanceQueryConfig tag
-> ByteString -> ByteString -> WaiSession st SResponse
patch' = ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
forall tag st.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
request' ByteString
methodPatch

delete' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse
delete' :: forall tag st.
AcceptanceQueryConfig tag
-> ByteString -> ByteString -> WaiSession st SResponse
delete' = ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
forall tag st.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession st SResponse
request' ByteString
methodDelete

----------------------------------------------------------------------------
-- Redefine wai quasiquoter
--
-- This code was taken from Test.Hspec.Wai.JSON and modified to accept
-- @application/scim+json@. In order to keep the code simple, we also
-- require @charset=utf-8@, even though the original implementation
-- considers it optional.

-- | A response matcher and quasiquoter that should be used instead of
-- 'Test.Hspec.Wai.JSON.json'.
scim :: QuasiQuoter
scim :: QuasiQuoter
scim =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = \String
input -> [|fromValue $(QuasiQuoter -> String -> Q Exp
quoteExp QuasiQuoter
aesonQQ String
input)|],
      quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. HasCallStack => String -> a
error String
"No quotePat defined for Test.Util.scim",
      quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. HasCallStack => String -> a
error String
"No quoteType defined for Test.Util.scim",
      quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"No quoteDec defined for Test.Util.scim"
    }

class FromValue a where
  fromValue :: Value -> a

instance FromValue ResponseMatcher where
  fromValue :: Value -> ResponseMatcher
fromValue = Int -> [MatchHeader] -> MatchBody -> ResponseMatcher
ResponseMatcher Int
200 [MatchHeader
matchHeader] (MatchBody -> ResponseMatcher)
-> (Value -> MatchBody) -> Value -> ResponseMatcher
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> MatchBody
equalsJSON
    where
      matchHeader :: MatchHeader
matchHeader = HeaderName
"Content-Type" HeaderName -> ByteString -> MatchHeader
<:> ByteString
"application/scim+json;charset=utf-8"

equalsJSON :: Value -> MatchBody
equalsJSON :: Value -> MatchBody
equalsJSON Value
expected = ([Header] -> ByteString -> Maybe String) -> MatchBody
MatchBody [Header] -> ByteString -> Maybe String
matcher
  where
    matcher :: [Header] -> ByteString -> Maybe String
matcher [Header]
headers ByteString
actualBody = case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
actualBody of
      Just Value
actual | Value
actual Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
expected -> Maybe String
forall a. Maybe a
Nothing
      Maybe Value
_ -> let MatchBody [Header] -> ByteString -> Maybe String
m = ByteString -> MatchBody
bodyEquals (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
expected) in [Header] -> ByteString -> Maybe String
m [Header]
headers ByteString
actualBody

instance FromValue L.ByteString where
  fromValue :: Value -> ByteString
fromValue = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode

instance FromValue Value where
  fromValue :: Value -> Value
fromValue = Value -> Value
forall a. a -> a
id

----------------------------------------------------------------------------
-- Ad-hoc JSON parsing

-- | A way to parse out a single value from a JSON object by specifying the
-- field as a type-level string. Very useful when you don't want to create
-- extra types.
newtype Field (s :: Symbol) a = Field a
  deriving (Field s a -> Field s a -> Bool
(Field s a -> Field s a -> Bool)
-> (Field s a -> Field s a -> Bool) -> Eq (Field s a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: Symbol) a. Eq a => Field s a -> Field s a -> Bool
$c== :: forall (s :: Symbol) a. Eq a => Field s a -> Field s a -> Bool
== :: Field s a -> Field s a -> Bool
$c/= :: forall (s :: Symbol) a. Eq a => Field s a -> Field s a -> Bool
/= :: Field s a -> Field s a -> Bool
Eq, Eq (Field s a)
Eq (Field s a) =>
(Field s a -> Field s a -> Ordering)
-> (Field s a -> Field s a -> Bool)
-> (Field s a -> Field s a -> Bool)
-> (Field s a -> Field s a -> Bool)
-> (Field s a -> Field s a -> Bool)
-> (Field s a -> Field s a -> Field s a)
-> (Field s a -> Field s a -> Field s a)
-> Ord (Field s a)
Field s a -> Field s a -> Bool
Field s a -> Field s a -> Ordering
Field s a -> Field s a -> Field s a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (s :: Symbol) a. Ord a => Eq (Field s a)
forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Bool
forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Ordering
forall (s :: Symbol) a.
Ord a =>
Field s a -> Field s a -> Field s a
$ccompare :: forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Ordering
compare :: Field s a -> Field s a -> Ordering
$c< :: forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Bool
< :: Field s a -> Field s a -> Bool
$c<= :: forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Bool
<= :: Field s a -> Field s a -> Bool
$c> :: forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Bool
> :: Field s a -> Field s a -> Bool
$c>= :: forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Bool
>= :: Field s a -> Field s a -> Bool
$cmax :: forall (s :: Symbol) a.
Ord a =>
Field s a -> Field s a -> Field s a
max :: Field s a -> Field s a -> Field s a
$cmin :: forall (s :: Symbol) a.
Ord a =>
Field s a -> Field s a -> Field s a
min :: Field s a -> Field s a -> Field s a
Ord, Int -> Field s a -> String -> String
[Field s a] -> String -> String
Field s a -> String
(Int -> Field s a -> String -> String)
-> (Field s a -> String)
-> ([Field s a] -> String -> String)
-> Show (Field s a)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (s :: Symbol) a.
Show a =>
Int -> Field s a -> String -> String
forall (s :: Symbol) a. Show a => [Field s a] -> String -> String
forall (s :: Symbol) a. Show a => Field s a -> String
$cshowsPrec :: forall (s :: Symbol) a.
Show a =>
Int -> Field s a -> String -> String
showsPrec :: Int -> Field s a -> String -> String
$cshow :: forall (s :: Symbol) a. Show a => Field s a -> String
show :: Field s a -> String
$cshowList :: forall (s :: Symbol) a. Show a => [Field s a] -> String -> String
showList :: [Field s a] -> String -> String
Show, ReadPrec [Field s a]
ReadPrec (Field s a)
Int -> ReadS (Field s a)
ReadS [Field s a]
(Int -> ReadS (Field s a))
-> ReadS [Field s a]
-> ReadPrec (Field s a)
-> ReadPrec [Field s a]
-> Read (Field s a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (s :: Symbol) a. Read a => ReadPrec [Field s a]
forall (s :: Symbol) a. Read a => ReadPrec (Field s a)
forall (s :: Symbol) a. Read a => Int -> ReadS (Field s a)
forall (s :: Symbol) a. Read a => ReadS [Field s a]
$creadsPrec :: forall (s :: Symbol) a. Read a => Int -> ReadS (Field s a)
readsPrec :: Int -> ReadS (Field s a)
$creadList :: forall (s :: Symbol) a. Read a => ReadS [Field s a]
readList :: ReadS [Field s a]
$creadPrec :: forall (s :: Symbol) a. Read a => ReadPrec (Field s a)
readPrec :: ReadPrec (Field s a)
$creadListPrec :: forall (s :: Symbol) a. Read a => ReadPrec [Field s a]
readListPrec :: ReadPrec [Field s a]
Read, (forall a b. (a -> b) -> Field s a -> Field s b)
-> (forall a b. a -> Field s b -> Field s a) -> Functor (Field s)
forall a b. a -> Field s b -> Field s a
forall a b. (a -> b) -> Field s a -> Field s b
forall (s :: Symbol) a b. a -> Field s b -> Field s a
forall (s :: Symbol) a b. (a -> b) -> Field s a -> Field s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (s :: Symbol) a b. (a -> b) -> Field s a -> Field s b
fmap :: forall a b. (a -> b) -> Field s a -> Field s b
$c<$ :: forall (s :: Symbol) a b. a -> Field s b -> Field s a
<$ :: forall a b. a -> Field s b -> Field s a
Functor)

getField :: Field s a -> a
getField :: forall (s :: Symbol) a. Field s a -> a
getField (Field a
a) = a
a

-- Copied from https://hackage.haskell.org/package/aeson-extra-0.4.1.1/docs/src/Data.Aeson.Extra.SingObject.html
instance (KnownSymbol s, FromJSON a) => FromJSON (Field s a) where
  parseJSON :: Value -> Parser (Field s a)
parseJSON = String
-> (Object -> Parser (Field s a)) -> Value -> Parser (Field s a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (String
"Field " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Key -> String
forall a. Show a => a -> String
show Key
key) ((Object -> Parser (Field s a)) -> Value -> Parser (Field s a))
-> (Object -> Parser (Field s a)) -> Value -> Parser (Field s a)
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
    case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key Object
obj of
      Maybe Value
Nothing -> String -> Parser (Field s a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Field s a)) -> String -> Parser (Field s a)
forall a b. (a -> b) -> a -> b
$ String
"key " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not present"
      Just Value
v -> a -> Field s a
forall (s :: Symbol) a. a -> Field s a
Field (a -> Field s a) -> Parser a -> Parser (Field s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
key
    where
      key :: Key
key = String -> Key
Key.fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s)

instance (KnownSymbol s, ToJSON a) => ToJSON (Field s a) where
  toJSON :: Field s a -> Value
toJSON (Field a
x) = [Pair] -> Value
object [Key
key Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= a
x]
    where
      key :: Key
key = String -> Key
Key.fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s)

----------------------------------------------------------------------------
-- Tag

-- | A type-level tag for 'UserTypes', 'AuthTypes', etc. that allows picking any types we
-- might need in tests.
data TestTag id authData authInfo userExtra

instance UserTypes (TestTag id authData authInfo userExtra) where
  type UserId (TestTag id authData authInfo userExtra) = id
  type UserExtra (TestTag id authData authInfo userExtra) = userExtra
  supportedSchemas :: [Schema]
supportedSchemas = [Schema
User20, Text -> Schema
CustomSchema Text
"urn:hscim:test"]

instance GroupTypes (TestTag id authData authInfo userExtra) where
  type GroupId (TestTag id authData authInfo userExtra) = id

instance AuthTypes (TestTag id authData authInfo userExtra) where
  type AuthData (TestTag id authData authInfo userExtra) = authData
  type AuthInfo (TestTag id authData authInfo userExtra) = authInfo