{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

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

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 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 qualified Data.HashMap.Strict as SMap
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 SResponse -> ResponseMatcher -> WaiExpectation
shouldRespondWith :: WaiSession SResponse -> ResponseMatcher -> WaiExpectation
shouldRespondWith WaiSession SResponse
action ResponseMatcher
matcher =
  (String -> WaiExpectation)
-> (() -> WaiExpectation) -> Either String () -> WaiExpectation
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO () -> WaiExpectation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WaiExpectation)
-> (String -> IO ()) -> String -> WaiExpectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> IO ()
String -> IO ()
expectationFailure) () -> WaiExpectation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> WaiExpectation)
-> WaiSession (Either String ()) -> WaiExpectation
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack =>
WaiSession SResponse
-> ResponseMatcher -> WaiSession (Either String ())
WaiSession SResponse
-> ResponseMatcher -> WaiSession (Either String ())
doesRespondWith WaiSession SResponse
action ResponseMatcher
matcher

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

data AcceptanceConfig tag = AcceptanceConfig
  { AcceptanceConfig tag -> IO (Application, AcceptanceQueryConfig tag)
scimAppAndConfig :: IO (Application, AcceptanceQueryConfig 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.
    AcceptanceConfig tag -> Bool
responsesFullyKnown :: Bool
  }

defAcceptanceConfig :: IO Application -> AcceptanceConfig tag
defAcceptanceConfig :: IO Application -> AcceptanceConfig tag
defAcceptanceConfig IO Application
scimApp = AcceptanceConfig :: forall tag.
IO (Application, AcceptanceQueryConfig tag)
-> IO Text -> Bool -> AcceptanceConfig tag
AcceptanceConfig {Bool
IO (Application, AcceptanceQueryConfig tag)
IO Text
responsesFullyKnown :: Bool
genUserName :: IO Text
scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag)
responsesFullyKnown :: Bool
genUserName :: IO Text
scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag)
..}
  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
  { AcceptanceQueryConfig tag -> ByteString
scimPathPrefix :: BS.ByteString,
    AcceptanceQueryConfig tag -> ByteString
scimAuthToken :: BS.ByteString
  }

defAcceptanceQueryConfig :: AcceptanceQueryConfig tag
defAcceptanceQueryConfig :: AcceptanceQueryConfig tag
defAcceptanceQueryConfig = AcceptanceQueryConfig :: forall tag. ByteString -> ByteString -> AcceptanceQueryConfig tag
AcceptanceQueryConfig {ByteString
scimAuthToken :: ByteString
scimPathPrefix :: ByteString
scimAuthToken :: ByteString
scimPathPrefix :: 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 SResponse
post :: ByteString -> ByteString -> WaiSession SResponse
post ByteString
path = ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession SResponse
request ByteString
methodPost ByteString
path [(HeaderName
hContentType, ByteString
"application/scim+json")]

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

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

request' :: Method -> AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse
request' :: ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession SResponse
request' ByteString
method (AcceptanceQueryConfig ByteString
prefix ByteString
token) ByteString
path = ByteString
-> ByteString -> [Header] -> ByteString -> WaiSession 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 SResponse
get' :: AcceptanceQueryConfig tag -> ByteString -> WaiSession SResponse
get' AcceptanceQueryConfig tag
cfg ByteString
path = ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession SResponse
forall tag.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession SResponse
request' ByteString
methodGet AcceptanceQueryConfig tag
cfg ByteString
path ByteString
""

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

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

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

delete' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse
delete' :: AcceptanceQueryConfig tag
-> ByteString -> ByteString -> WaiSession SResponse
delete' = ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession SResponse
forall tag.
ByteString
-> AcceptanceQueryConfig tag
-> ByteString
-> ByteString
-> WaiSession 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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = \String
input -> [|fromValue $(quoteExp aesonQQ 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
/= :: 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
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
min :: 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
max :: Field s a -> Field s a -> Field s a
$cmax :: forall (s :: Symbol) a.
Ord a =>
Field s a -> Field s a -> Field s a
>= :: 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
$c< :: forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Bool
compare :: Field s a -> Field s a -> Ordering
$ccompare :: forall (s :: Symbol) a. Ord a => Field s a -> Field s a -> Ordering
$cp1Ord :: forall (s :: Symbol) a. Ord a => Eq (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
showList :: [Field s a] -> String -> String
$cshowList :: forall (s :: Symbol) a. Show a => [Field s a] -> String -> String
show :: Field s a -> String
$cshow :: forall (s :: Symbol) a. Show a => Field s a -> String
showsPrec :: Int -> Field s a -> String -> String
$cshowsPrec :: forall (s :: Symbol) a.
Show a =>
Int -> 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]
readListPrec :: ReadPrec [Field s a]
$creadListPrec :: forall (s :: Symbol) a. Read a => ReadPrec [Field s a]
readPrec :: ReadPrec (Field s a)
$creadPrec :: forall (s :: Symbol) a. Read a => ReadPrec (Field s a)
readList :: ReadS [Field s a]
$creadList :: forall (s :: Symbol) a. Read a => ReadS [Field s a]
readsPrec :: Int -> ReadS (Field s a)
$creadsPrec :: forall (s :: Symbol) a. Read a => Int -> ReadS (Field s a)
Read, a -> Field s b -> Field s a
(a -> b) -> Field s a -> Field s b
(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
<$ :: a -> Field s b -> Field s a
$c<$ :: forall (s :: Symbol) a b. a -> Field s b -> Field s a
fmap :: (a -> b) -> Field s a -> Field s b
$cfmap :: forall (s :: Symbol) a b. (a -> b) -> Field s a -> Field s b
Functor)

getField :: Field s a -> a
getField :: 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
<> Text -> String
forall a. Show a => a -> String
show Text
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 Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
SMap.lookup Text
key Object
obj of
      Maybe Value
Nothing -> String -> Parser (Field s 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]
++ Text -> String
forall a. Show a => a -> String
show Text
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
<?> Text -> JSONPathElement
Key Text
key
    where
      key :: Text
key = String -> Text
pack (String -> Text) -> String -> Text
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 [Text
key Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
x]
    where
      key :: Text
key = String -> Text
pack (String -> Text) -> String -> Text
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