{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

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

-- | A mock server for use in our testsuite, as well as for automated
-- compliance testing (e.g. with Runscope – see
-- <https://developer.okta.com/standards/SCIM/#step-2-test-your-scim-server>).
module Web.Scim.Server.Mock where

import Control.Monad.Morph
import Control.Monad.Reader
import Control.Monad.STM (STM, atomically)
import Data.Aeson
import Data.Hashable
import Data.Text (Text, pack, toCaseFold)
import Data.Time.Calendar
import Data.Time.Clock
import GHC.Exts (sortWith)
import ListT
import qualified Network.URI as URI
import Servant
import qualified StmContainers.Map as STMMap
import Text.Read (readMaybe)
import Web.Scim.Class.Auth
import Web.Scim.Class.Group hiding (value)
import Web.Scim.Class.User
import Web.Scim.Filter (AttrPath (..), CompValue (..), Filter (..), compareStr)
import Web.Scim.Handler
import Web.Scim.Schema.Common (WithId (WithId, value))
import qualified Web.Scim.Schema.Common as Common
import Web.Scim.Schema.Error
import Web.Scim.Schema.ListResponse
import Web.Scim.Schema.Meta
import Web.Scim.Schema.ResourceType
import Web.Scim.Schema.Schema (Schema (User20))
import Web.Scim.Schema.User

-- | Tag used in the mock server.
data Mock

-- | A simple ID type.
--
-- >>> eitherDecode' @Id . encode $ (Id 3)
-- Right (Id {unId = 3})
--
-- WARNING: {doctests don't work in our
-- infrastructure](https://github.com/zinfra/backend-issues/issues/1549), so this is
-- duplicated in the unit tests.
newtype Id = Id {Id -> Int
unId :: Int}
  deriving (Id -> Id -> Bool
(Id -> Id -> Bool) -> (Id -> Id -> Bool) -> Eq Id
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Id -> Id -> Bool
$c/= :: Id -> Id -> Bool
== :: Id -> Id -> Bool
$c== :: Id -> Id -> Bool
Eq, Int -> Id -> ShowS
[Id] -> ShowS
Id -> String
(Int -> Id -> ShowS)
-> (Id -> String) -> ([Id] -> ShowS) -> Show Id
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Id] -> ShowS
$cshowList :: [Id] -> ShowS
show :: Id -> String
$cshow :: Id -> String
showsPrec :: Int -> Id -> ShowS
$cshowsPrec :: Int -> Id -> ShowS
Show, Eq Id
Eq Id
-> (Id -> Id -> Ordering)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Id)
-> (Id -> Id -> Id)
-> Ord Id
Id -> Id -> Bool
Id -> Id -> Ordering
Id -> Id -> Id
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
min :: Id -> Id -> Id
$cmin :: Id -> Id -> Id
max :: Id -> Id -> Id
$cmax :: Id -> Id -> Id
>= :: Id -> Id -> Bool
$c>= :: Id -> Id -> Bool
> :: Id -> Id -> Bool
$c> :: Id -> Id -> Bool
<= :: Id -> Id -> Bool
$c<= :: Id -> Id -> Bool
< :: Id -> Id -> Bool
$c< :: Id -> Id -> Bool
compare :: Id -> Id -> Ordering
$ccompare :: Id -> Id -> Ordering
$cp1Ord :: Eq Id
Ord, Int -> Id -> Int
Id -> Int
(Int -> Id -> Int) -> (Id -> Int) -> Hashable Id
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Id -> Int
$chash :: Id -> Int
hashWithSalt :: Int -> Id -> Int
$chashWithSalt :: Int -> Id -> Int
Hashable, Id -> ByteString
Id -> Builder
Id -> Text
(Id -> Text)
-> (Id -> Builder)
-> (Id -> ByteString)
-> (Id -> Text)
-> ToHttpApiData Id
forall a.
(a -> Text)
-> (a -> Builder)
-> (a -> ByteString)
-> (a -> Text)
-> ToHttpApiData a
toQueryParam :: Id -> Text
$ctoQueryParam :: Id -> Text
toHeader :: Id -> ByteString
$ctoHeader :: Id -> ByteString
toEncodedUrlPiece :: Id -> Builder
$ctoEncodedUrlPiece :: Id -> Builder
toUrlPiece :: Id -> Text
$ctoUrlPiece :: Id -> Text
ToHttpApiData, ByteString -> Either Text Id
Text -> Either Text Id
(Text -> Either Text Id)
-> (ByteString -> Either Text Id)
-> (Text -> Either Text Id)
-> FromHttpApiData Id
forall a.
(Text -> Either Text a)
-> (ByteString -> Either Text a)
-> (Text -> Either Text a)
-> FromHttpApiData a
parseQueryParam :: Text -> Either Text Id
$cparseQueryParam :: Text -> Either Text Id
parseHeader :: ByteString -> Either Text Id
$cparseHeader :: ByteString -> Either Text Id
parseUrlPiece :: Text -> Either Text Id
$cparseUrlPiece :: Text -> Either Text Id
FromHttpApiData)

instance ToJSON Id where
  toJSON :: Id -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> (Id -> String) -> Id -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Id -> Int) -> Id -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Int
unId

instance FromJSON Id where
  parseJSON :: Value -> Parser Id
parseJSON = Parser Id -> (Int -> Parser Id) -> Maybe Int -> Parser Id
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Id
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a number") (Id -> Parser Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> Parser Id) -> (Int -> Id) -> Int -> Parser Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Id
Id) (Maybe Int -> Parser Id)
-> (String -> Maybe Int) -> String -> Parser Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Parser Id)
-> (Value -> Parser String) -> Value -> Parser Id
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser String
forall a. FromJSON a => Value -> Parser a
parseJSON

type UserStorage = STMMap.Map Id (StoredUser Mock)

type GroupStorage = STMMap.Map Id (StoredGroup Mock)

data TestStorage = TestStorage
  { TestStorage -> UserStorage
userDB :: UserStorage,
    TestStorage -> GroupStorage
groupDB :: GroupStorage
  }

emptyTestStorage :: IO TestStorage
emptyTestStorage :: IO TestStorage
emptyTestStorage =
  UserStorage -> GroupStorage -> TestStorage
Map Id (WithMeta (WithId Id (User Mock)))
-> Map Id (WithMeta (WithId Id Group)) -> TestStorage
TestStorage (Map Id (WithMeta (WithId Id (User Mock)))
 -> Map Id (WithMeta (WithId Id Group)) -> TestStorage)
-> IO (Map Id (WithMeta (WithId Id (User Mock))))
-> IO (Map Id (WithMeta (WithId Id Group)) -> TestStorage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Id (WithMeta (WithId Id (User Mock))))
forall key value. IO (Map key value)
STMMap.newIO IO (Map Id (WithMeta (WithId Id Group)) -> TestStorage)
-> IO (Map Id (WithMeta (WithId Id Group))) -> IO TestStorage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Map Id (WithMeta (WithId Id Group)))
forall key value. IO (Map key value)
STMMap.newIO

-- in-memory implementation of the API for tests
type TestServer = ReaderT TestStorage Handler

liftSTM :: MonadIO m => STM a -> m a
liftSTM :: STM a -> m a
liftSTM = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (STM a -> IO a) -> STM a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically

hoistSTM :: (MFunctor t, MonadIO m) => t STM a -> t m a
hoistSTM :: t STM a -> t m a
hoistSTM = (forall a. STM a -> m a) -> t STM a -> t m a
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. STM a -> m a
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM

----------------------------------------------------------------------------
-- UserDB

instance UserTypes Mock where
  type UserId Mock = Id
  type UserExtra Mock = NoUserExtra
  supportedSchemas :: [Schema]
supportedSchemas = [Schema
User20]

instance UserDB Mock TestServer where
  getUsers :: AuthInfo Mock
-> Maybe Filter
-> ScimHandler TestServer (ListResponse (StoredUser Mock))
getUsers () Maybe Filter
mbFilter = do
    Map Id (WithMeta (WithId Id (User Mock)))
m <- TestStorage -> UserStorage
TestStorage -> Map Id (WithMeta (WithId Id (User Mock)))
userDB (TestStorage -> Map Id (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id (User Mock))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Id, WithMeta (WithId Id (User Mock)))]
users <- STM [(Id, WithMeta (WithId Id (User Mock)))]
-> ExceptT
     ScimError TestServer [(Id, WithMeta (WithId Id (User Mock)))]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM [(Id, WithMeta (WithId Id (User Mock)))]
 -> ExceptT
      ScimError TestServer [(Id, WithMeta (WithId Id (User Mock)))])
-> STM [(Id, WithMeta (WithId Id (User Mock)))]
-> ExceptT
     ScimError TestServer [(Id, WithMeta (WithId Id (User Mock)))]
forall a b. (a -> b) -> a -> b
$ ListT STM (Id, WithMeta (WithId Id (User Mock)))
-> STM [(Id, WithMeta (WithId Id (User Mock)))]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (Id, WithMeta (WithId Id (User Mock)))
 -> STM [(Id, WithMeta (WithId Id (User Mock)))])
-> ListT STM (Id, WithMeta (WithId Id (User Mock)))
-> STM [(Id, WithMeta (WithId Id (User Mock)))]
forall a b. (a -> b) -> a -> b
$ Map Id (WithMeta (WithId Id (User Mock)))
-> ListT STM (Id, WithMeta (WithId Id (User Mock)))
forall key value. Map key value -> ListT STM (key, value)
STMMap.listT Map Id (WithMeta (WithId Id (User Mock)))
m
    let check :: WithMeta (WithId Id (User Mock))
-> ExceptT ScimError TestServer Bool
check WithMeta (WithId Id (User Mock))
user = case Maybe Filter
mbFilter of
          Maybe Filter
Nothing -> Bool -> ExceptT ScimError TestServer Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          Just Filter
filter_ -> do
            let user' :: User Mock
user' = WithId Id (User Mock) -> User Mock
forall id a. WithId id a -> a
value (WithMeta (WithId Id (User Mock)) -> WithId Id (User Mock)
forall a. WithMeta a -> a
thing WithMeta (WithId Id (User Mock))
user) -- unwrap
            case Filter -> User Mock -> Either Text Bool
forall extra. Filter -> User extra -> Either Text Bool
filterUser Filter
filter_ User Mock
user' of
              Right Bool
res -> Bool -> ExceptT ScimError TestServer Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
res
              Left Text
err -> ScimError -> ExceptT ScimError TestServer Bool
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidFilter (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
err))
    [WithMeta (WithId Id (User Mock))]
-> ListResponse (WithMeta (WithId Id (User Mock)))
forall a. [a] -> ListResponse a
fromList ([WithMeta (WithId Id (User Mock))]
 -> ListResponse (WithMeta (WithId Id (User Mock))))
-> ([WithMeta (WithId Id (User Mock))]
    -> [WithMeta (WithId Id (User Mock))])
-> [WithMeta (WithId Id (User Mock))]
-> ListResponse (WithMeta (WithId Id (User Mock)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithMeta (WithId Id (User Mock)) -> Id)
-> [WithMeta (WithId Id (User Mock))]
-> [WithMeta (WithId Id (User Mock))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (WithId Id (User Mock) -> Id
forall id a. WithId id a -> id
Common.id (WithId Id (User Mock) -> Id)
-> (WithMeta (WithId Id (User Mock)) -> WithId Id (User Mock))
-> WithMeta (WithId Id (User Mock))
-> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithMeta (WithId Id (User Mock)) -> WithId Id (User Mock)
forall a. WithMeta a -> a
thing) ([WithMeta (WithId Id (User Mock))]
 -> ListResponse (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer [WithMeta (WithId Id (User Mock))]
-> ExceptT
     ScimError
     TestServer
     (ListResponse (WithMeta (WithId Id (User Mock))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WithMeta (WithId Id (User Mock))
 -> ExceptT ScimError TestServer Bool)
-> [WithMeta (WithId Id (User Mock))]
-> ExceptT ScimError TestServer [WithMeta (WithId Id (User Mock))]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM WithMeta (WithId Id (User Mock))
-> ExceptT ScimError TestServer Bool
check ((Id, WithMeta (WithId Id (User Mock)))
-> WithMeta (WithId Id (User Mock))
forall a b. (a, b) -> b
snd ((Id, WithMeta (WithId Id (User Mock)))
 -> WithMeta (WithId Id (User Mock)))
-> [(Id, WithMeta (WithId Id (User Mock)))]
-> [WithMeta (WithId Id (User Mock))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Id, WithMeta (WithId Id (User Mock)))]
users)

  getUser :: AuthInfo Mock
-> UserId Mock -> ScimHandler TestServer (StoredUser Mock)
getUser () UserId Mock
uid = do
    Map Id (WithMeta (WithId Id (User Mock)))
m <- TestStorage -> UserStorage
TestStorage -> Map Id (WithMeta (WithId Id (User Mock)))
userDB (TestStorage -> Map Id (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id (User Mock))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    STM (Maybe (WithMeta (WithId Id (User Mock))))
-> ExceptT
     ScimError TestServer (Maybe (WithMeta (WithId Id (User Mock))))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Id
-> Map Id (WithMeta (WithId Id (User Mock)))
-> STM (Maybe (WithMeta (WithId Id (User Mock))))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup UserId Mock
Id
uid Map Id (WithMeta (WithId Id (User Mock)))
m) ExceptT
  ScimError TestServer (Maybe (WithMeta (WithId Id (User Mock))))
-> (Maybe (WithMeta (WithId Id (User Mock)))
    -> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (WithMeta (WithId Id (User Mock)))
Nothing -> ScimError
-> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock)))
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> Text -> ScimError
notFound Text
"User" (String -> Text
pack (Id -> String
forall a. Show a => a -> String
show UserId Mock
Id
uid)))
      Just WithMeta (WithId Id (User Mock))
x -> WithMeta (WithId Id (User Mock))
-> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithMeta (WithId Id (User Mock))
x

  postUser :: AuthInfo Mock
-> User Mock -> ScimHandler TestServer (StoredUser Mock)
postUser () User Mock
user = do
    Map Id (WithMeta (WithId Id (User Mock)))
m <- TestStorage -> UserStorage
TestStorage -> Map Id (WithMeta (WithId Id (User Mock)))
userDB (TestStorage -> Map Id (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id (User Mock))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    Id
uid <- Int -> Id
Id (Int -> Id)
-> ExceptT ScimError TestServer Int
-> ExceptT ScimError TestServer Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Int -> ExceptT ScimError TestServer Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Map Id (WithMeta (WithId Id (User Mock))) -> STM Int
forall key value. Map key value -> STM Int
STMMap.size Map Id (WithMeta (WithId Id (User Mock)))
m)
    let newUser :: WithMeta (WithId Id (User Mock))
newUser = Meta -> WithId Id (User Mock) -> WithMeta (WithId Id (User Mock))
forall a. Meta -> a -> WithMeta a
WithMeta (ResourceType -> Meta
createMeta ResourceType
UserResource) (WithId Id (User Mock) -> WithMeta (WithId Id (User Mock)))
-> WithId Id (User Mock) -> WithMeta (WithId Id (User Mock))
forall a b. (a -> b) -> a -> b
$ Id -> User Mock -> WithId Id (User Mock)
forall id a. id -> a -> WithId id a
WithId Id
uid User Mock
user
    STM () -> ScimHandler TestServer ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM () -> ScimHandler TestServer ())
-> STM () -> ScimHandler TestServer ()
forall a b. (a -> b) -> a -> b
$ WithMeta (WithId Id (User Mock))
-> Id -> Map Id (WithMeta (WithId Id (User Mock))) -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
STMMap.insert WithMeta (WithId Id (User Mock))
newUser Id
uid Map Id (WithMeta (WithId Id (User Mock)))
m
    WithMeta (WithId Id (User Mock))
-> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock)))
forall (m :: * -> *) a. Monad m => a -> m a
return WithMeta (WithId Id (User Mock))
newUser

  putUser :: AuthInfo Mock
-> UserId Mock
-> User Mock
-> ScimHandler TestServer (StoredUser Mock)
putUser () UserId Mock
uid User Mock
user = do
    Map Id (WithMeta (WithId Id (User Mock)))
m <- TestStorage -> UserStorage
TestStorage -> Map Id (WithMeta (WithId Id (User Mock)))
userDB (TestStorage -> Map Id (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id (User Mock))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    STM (Maybe (WithMeta (WithId Id (User Mock))))
-> ExceptT
     ScimError TestServer (Maybe (WithMeta (WithId Id (User Mock))))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Id
-> Map Id (WithMeta (WithId Id (User Mock)))
-> STM (Maybe (WithMeta (WithId Id (User Mock))))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup UserId Mock
Id
uid Map Id (WithMeta (WithId Id (User Mock)))
m) ExceptT
  ScimError TestServer (Maybe (WithMeta (WithId Id (User Mock))))
-> (Maybe (WithMeta (WithId Id (User Mock)))
    -> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (WithMeta (WithId Id (User Mock)))
Nothing -> ScimError
-> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock)))
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> Text -> ScimError
notFound Text
"User" (String -> Text
pack (Id -> String
forall a. Show a => a -> String
show UserId Mock
Id
uid)))
      Just WithMeta (WithId Id (User Mock))
stored -> do
        let newUser :: WithMeta (WithId Id (User Mock))
newUser = Meta -> WithId Id (User Mock) -> WithMeta (WithId Id (User Mock))
forall a. Meta -> a -> WithMeta a
WithMeta (WithMeta (WithId Id (User Mock)) -> Meta
forall a. WithMeta a -> Meta
meta WithMeta (WithId Id (User Mock))
stored) (WithId Id (User Mock) -> WithMeta (WithId Id (User Mock)))
-> WithId Id (User Mock) -> WithMeta (WithId Id (User Mock))
forall a b. (a -> b) -> a -> b
$ Id -> User Mock -> WithId Id (User Mock)
forall id a. id -> a -> WithId id a
WithId UserId Mock
Id
uid User Mock
user
        STM () -> ScimHandler TestServer ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM () -> ScimHandler TestServer ())
-> STM () -> ScimHandler TestServer ()
forall a b. (a -> b) -> a -> b
$ WithMeta (WithId Id (User Mock))
-> Id -> Map Id (WithMeta (WithId Id (User Mock))) -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
STMMap.insert WithMeta (WithId Id (User Mock))
newUser UserId Mock
Id
uid Map Id (WithMeta (WithId Id (User Mock)))
m
        WithMeta (WithId Id (User Mock))
-> ExceptT ScimError TestServer (WithMeta (WithId Id (User Mock)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithMeta (WithId Id (User Mock))
newUser

  deleteUser :: AuthInfo Mock -> UserId Mock -> ScimHandler TestServer ()
deleteUser () UserId Mock
uid = do
    Map Id (WithMeta (WithId Id (User Mock)))
m <- TestStorage -> UserStorage
TestStorage -> Map Id (WithMeta (WithId Id (User Mock)))
userDB (TestStorage -> Map Id (WithMeta (WithId Id (User Mock))))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id (User Mock))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    STM (Maybe (WithMeta (WithId Id (User Mock))))
-> ExceptT
     ScimError TestServer (Maybe (WithMeta (WithId Id (User Mock))))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Id
-> Map Id (WithMeta (WithId Id (User Mock)))
-> STM (Maybe (WithMeta (WithId Id (User Mock))))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup UserId Mock
Id
uid Map Id (WithMeta (WithId Id (User Mock)))
m) ExceptT
  ScimError TestServer (Maybe (WithMeta (WithId Id (User Mock))))
-> (Maybe (WithMeta (WithId Id (User Mock)))
    -> ScimHandler TestServer ())
-> ScimHandler TestServer ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (WithMeta (WithId Id (User Mock)))
Nothing -> ScimError -> ScimHandler TestServer ()
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> Text -> ScimError
notFound Text
"User" (String -> Text
pack (Id -> String
forall a. Show a => a -> String
show UserId Mock
Id
uid)))
      Just WithMeta (WithId Id (User Mock))
_ -> STM () -> ScimHandler TestServer ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM () -> ScimHandler TestServer ())
-> STM () -> ScimHandler TestServer ()
forall a b. (a -> b) -> a -> b
$ Id -> Map Id (WithMeta (WithId Id (User Mock))) -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
STMMap.delete UserId Mock
Id
uid Map Id (WithMeta (WithId Id (User Mock)))
m

-- (there seems to be no readOnly fields in User)
assertMutability :: User Mock -> StoredUser Mock -> Bool
assertMutability :: User Mock -> StoredUser Mock -> Bool
assertMutability User Mock
_newUser StoredUser Mock
_stored = Bool
True

----------------------------------------------------------------------------
-- GroupDB

instance GroupTypes Mock where
  type GroupId Mock = Id

instance GroupDB Mock TestServer where
  getGroups :: AuthInfo Mock
-> ScimHandler TestServer (ListResponse (StoredGroup Mock))
getGroups () = do
    Map Id (WithMeta (WithId Id Group))
m <- TestStorage -> GroupStorage
TestStorage -> Map Id (WithMeta (WithId Id Group))
groupDB (TestStorage -> Map Id (WithMeta (WithId Id Group)))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id Group)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Id, WithMeta (WithId Id Group))]
groups <- STM [(Id, WithMeta (WithId Id Group))]
-> ExceptT ScimError TestServer [(Id, WithMeta (WithId Id Group))]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM [(Id, WithMeta (WithId Id Group))]
 -> ExceptT ScimError TestServer [(Id, WithMeta (WithId Id Group))])
-> STM [(Id, WithMeta (WithId Id Group))]
-> ExceptT ScimError TestServer [(Id, WithMeta (WithId Id Group))]
forall a b. (a -> b) -> a -> b
$ ListT STM (Id, WithMeta (WithId Id Group))
-> STM [(Id, WithMeta (WithId Id Group))]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (Id, WithMeta (WithId Id Group))
 -> STM [(Id, WithMeta (WithId Id Group))])
-> ListT STM (Id, WithMeta (WithId Id Group))
-> STM [(Id, WithMeta (WithId Id Group))]
forall a b. (a -> b) -> a -> b
$ Map Id (WithMeta (WithId Id Group))
-> ListT STM (Id, WithMeta (WithId Id Group))
forall key value. Map key value -> ListT STM (key, value)
STMMap.listT Map Id (WithMeta (WithId Id Group))
m
    ListResponse (WithMeta (WithId Id Group))
-> ExceptT
     ScimError TestServer (ListResponse (WithMeta (WithId Id Group)))
forall (m :: * -> *) a. Monad m => a -> m a
return (ListResponse (WithMeta (WithId Id Group))
 -> ExceptT
      ScimError TestServer (ListResponse (WithMeta (WithId Id Group))))
-> ListResponse (WithMeta (WithId Id Group))
-> ExceptT
     ScimError TestServer (ListResponse (WithMeta (WithId Id Group)))
forall a b. (a -> b) -> a -> b
$ [WithMeta (WithId Id Group)]
-> ListResponse (WithMeta (WithId Id Group))
forall a. [a] -> ListResponse a
fromList ([WithMeta (WithId Id Group)]
 -> ListResponse (WithMeta (WithId Id Group)))
-> ([WithMeta (WithId Id Group)] -> [WithMeta (WithId Id Group)])
-> [WithMeta (WithId Id Group)]
-> ListResponse (WithMeta (WithId Id Group))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithMeta (WithId Id Group) -> Id)
-> [WithMeta (WithId Id Group)] -> [WithMeta (WithId Id Group)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (WithId Id Group -> Id
forall id a. WithId id a -> id
Common.id (WithId Id Group -> Id)
-> (WithMeta (WithId Id Group) -> WithId Id Group)
-> WithMeta (WithId Id Group)
-> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithMeta (WithId Id Group) -> WithId Id Group
forall a. WithMeta a -> a
thing) ([WithMeta (WithId Id Group)]
 -> ListResponse (WithMeta (WithId Id Group)))
-> [WithMeta (WithId Id Group)]
-> ListResponse (WithMeta (WithId Id Group))
forall a b. (a -> b) -> a -> b
$ (Id, WithMeta (WithId Id Group)) -> WithMeta (WithId Id Group)
forall a b. (a, b) -> b
snd ((Id, WithMeta (WithId Id Group)) -> WithMeta (WithId Id Group))
-> [(Id, WithMeta (WithId Id Group))]
-> [WithMeta (WithId Id Group)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Id, WithMeta (WithId Id Group))]
groups

  getGroup :: AuthInfo Mock
-> GroupId Mock -> ScimHandler TestServer (StoredGroup Mock)
getGroup () GroupId Mock
gid = do
    Map Id (WithMeta (WithId Id Group))
m <- TestStorage -> GroupStorage
TestStorage -> Map Id (WithMeta (WithId Id Group))
groupDB (TestStorage -> Map Id (WithMeta (WithId Id Group)))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id Group)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    STM (Maybe (WithMeta (WithId Id Group)))
-> ExceptT
     ScimError TestServer (Maybe (WithMeta (WithId Id Group)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Id
-> Map Id (WithMeta (WithId Id Group))
-> STM (Maybe (WithMeta (WithId Id Group)))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup GroupId Mock
Id
gid Map Id (WithMeta (WithId Id Group))
m) ExceptT ScimError TestServer (Maybe (WithMeta (WithId Id Group)))
-> (Maybe (WithMeta (WithId Id Group))
    -> ExceptT ScimError TestServer (WithMeta (WithId Id Group)))
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (WithMeta (WithId Id Group))
Nothing -> ScimError
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> Text -> ScimError
notFound Text
"Group" (String -> Text
pack (Id -> String
forall a. Show a => a -> String
show GroupId Mock
Id
gid)))
      Just WithMeta (WithId Id Group)
grp -> WithMeta (WithId Id Group)
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithMeta (WithId Id Group)
grp

  postGroup :: AuthInfo Mock -> Group -> ScimHandler TestServer (StoredGroup Mock)
postGroup () Group
grp = do
    Map Id (WithMeta (WithId Id Group))
m <- TestStorage -> GroupStorage
TestStorage -> Map Id (WithMeta (WithId Id Group))
groupDB (TestStorage -> Map Id (WithMeta (WithId Id Group)))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id Group)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    Id
gid <- Int -> Id
Id (Int -> Id)
-> ExceptT ScimError TestServer Int
-> ExceptT ScimError TestServer Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Int -> ExceptT ScimError TestServer Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Map Id (WithMeta (WithId Id Group)) -> STM Int
forall key value. Map key value -> STM Int
STMMap.size Map Id (WithMeta (WithId Id Group))
m)
    let newGroup :: WithMeta (WithId Id Group)
newGroup = Meta -> WithId Id Group -> WithMeta (WithId Id Group)
forall a. Meta -> a -> WithMeta a
WithMeta (ResourceType -> Meta
createMeta ResourceType
GroupResource) (WithId Id Group -> WithMeta (WithId Id Group))
-> WithId Id Group -> WithMeta (WithId Id Group)
forall a b. (a -> b) -> a -> b
$ Id -> Group -> WithId Id Group
forall id a. id -> a -> WithId id a
WithId Id
gid Group
grp
    STM () -> ScimHandler TestServer ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM () -> ScimHandler TestServer ())
-> STM () -> ScimHandler TestServer ()
forall a b. (a -> b) -> a -> b
$ WithMeta (WithId Id Group)
-> Id -> Map Id (WithMeta (WithId Id Group)) -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
STMMap.insert WithMeta (WithId Id Group)
newGroup Id
gid Map Id (WithMeta (WithId Id Group))
m
    WithMeta (WithId Id Group)
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (m :: * -> *) a. Monad m => a -> m a
return WithMeta (WithId Id Group)
newGroup

  putGroup :: AuthInfo Mock
-> GroupId Mock
-> Group
-> ScimHandler TestServer (StoredGroup Mock)
putGroup () GroupId Mock
gid Group
grp = do
    Map Id (WithMeta (WithId Id Group))
m <- TestStorage -> GroupStorage
TestStorage -> Map Id (WithMeta (WithId Id Group))
groupDB (TestStorage -> Map Id (WithMeta (WithId Id Group)))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id Group)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    STM (Maybe (WithMeta (WithId Id Group)))
-> ExceptT
     ScimError TestServer (Maybe (WithMeta (WithId Id Group)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Id
-> Map Id (WithMeta (WithId Id Group))
-> STM (Maybe (WithMeta (WithId Id Group)))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup GroupId Mock
Id
gid Map Id (WithMeta (WithId Id Group))
m) ExceptT ScimError TestServer (Maybe (WithMeta (WithId Id Group)))
-> (Maybe (WithMeta (WithId Id Group))
    -> ExceptT ScimError TestServer (WithMeta (WithId Id Group)))
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (WithMeta (WithId Id Group))
Nothing -> ScimError
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> Text -> ScimError
notFound Text
"Group" (String -> Text
pack (Id -> String
forall a. Show a => a -> String
show GroupId Mock
Id
gid)))
      Just WithMeta (WithId Id Group)
stored -> do
        let newGroup :: WithMeta (WithId Id Group)
newGroup = Meta -> WithId Id Group -> WithMeta (WithId Id Group)
forall a. Meta -> a -> WithMeta a
WithMeta (WithMeta (WithId Id Group) -> Meta
forall a. WithMeta a -> Meta
meta WithMeta (WithId Id Group)
stored) (WithId Id Group -> WithMeta (WithId Id Group))
-> WithId Id Group -> WithMeta (WithId Id Group)
forall a b. (a -> b) -> a -> b
$ Id -> Group -> WithId Id Group
forall id a. id -> a -> WithId id a
WithId GroupId Mock
Id
gid Group
grp
        STM () -> ScimHandler TestServer ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM () -> ScimHandler TestServer ())
-> STM () -> ScimHandler TestServer ()
forall a b. (a -> b) -> a -> b
$ WithMeta (WithId Id Group)
-> Id -> Map Id (WithMeta (WithId Id Group)) -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
STMMap.insert WithMeta (WithId Id Group)
newGroup GroupId Mock
Id
gid Map Id (WithMeta (WithId Id Group))
m
        WithMeta (WithId Id Group)
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithMeta (WithId Id Group)
newGroup

  patchGroup :: AuthInfo Mock
-> GroupId Mock
-> Value
-> ScimHandler TestServer (StoredGroup Mock)
patchGroup AuthInfo Mock
_ GroupId Mock
_ Value
_ = ScimError
-> ExceptT ScimError TestServer (WithMeta (WithId Id Group))
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> ScimError
serverError Text
"PATCH /Users not implemented")

  deleteGroup :: AuthInfo Mock -> GroupId Mock -> ScimHandler TestServer ()
deleteGroup () GroupId Mock
gid = do
    Map Id (WithMeta (WithId Id Group))
m <- TestStorage -> GroupStorage
TestStorage -> Map Id (WithMeta (WithId Id Group))
groupDB (TestStorage -> Map Id (WithMeta (WithId Id Group)))
-> ExceptT ScimError TestServer TestStorage
-> ExceptT
     ScimError TestServer (Map Id (WithMeta (WithId Id Group)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT ScimError TestServer TestStorage
forall r (m :: * -> *). MonadReader r m => m r
ask
    STM (Maybe (WithMeta (WithId Id Group)))
-> ExceptT
     ScimError TestServer (Maybe (WithMeta (WithId Id Group)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (Id
-> Map Id (WithMeta (WithId Id Group))
-> STM (Maybe (WithMeta (WithId Id Group)))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup GroupId Mock
Id
gid Map Id (WithMeta (WithId Id Group))
m) ExceptT ScimError TestServer (Maybe (WithMeta (WithId Id Group)))
-> (Maybe (WithMeta (WithId Id Group))
    -> ScimHandler TestServer ())
-> ScimHandler TestServer ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (WithMeta (WithId Id Group))
Nothing -> ScimError -> ScimHandler TestServer ()
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> Text -> ScimError
notFound Text
"Group" (String -> Text
pack (Id -> String
forall a. Show a => a -> String
show GroupId Mock
Id
gid)))
      Just WithMeta (WithId Id Group)
_ -> STM () -> ScimHandler TestServer ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
liftSTM (STM () -> ScimHandler TestServer ())
-> STM () -> ScimHandler TestServer ()
forall a b. (a -> b) -> a -> b
$ Id -> Map Id (WithMeta (WithId Id Group)) -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
STMMap.delete GroupId Mock
Id
gid Map Id (WithMeta (WithId Id Group))
m

----------------------------------------------------------------------------
-- AuthDB

instance AuthTypes Mock where
  type AuthData Mock = Text
  type AuthInfo Mock = ()

instance AuthDB Mock TestServer where
  authCheck :: Maybe (AuthData Mock) -> ScimHandler TestServer (AuthInfo Mock)
authCheck = \case
    Just AuthData Mock
"authorized" -> () -> ScimHandler TestServer ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe (AuthData Mock)
_ -> ScimError -> ScimHandler TestServer ()
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> ScimError
unauthorized Text
"expected 'authorized'")

----------------------------------------------------------------------------
-- Misc

-- 2018-01-01 00:00
testDate :: UTCTime
testDate :: UTCTime
testDate =
  UTCTime :: Day -> DiffTime -> UTCTime
UTCTime
    { utctDay :: Day
utctDay = Integer -> Day
ModifiedJulianDay Integer
58119,
      utctDayTime :: DiffTime
utctDayTime = DiffTime
0
    }

-- static meta for testing
createMeta :: ResourceType -> Meta
createMeta :: ResourceType -> Meta
createMeta ResourceType
rType =
  Meta :: ResourceType -> UTCTime -> UTCTime -> ETag -> URI -> Meta
Meta
    { resourceType :: ResourceType
resourceType = ResourceType
rType,
      created :: UTCTime
created = UTCTime
testDate,
      lastModified :: UTCTime
lastModified = UTCTime
testDate,
      version :: ETag
version = Text -> ETag
Weak Text
"testVersion",
      location :: URI
location =
        URI -> URI
Common.URI (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$ -- FUTUREWORK: getting the actual schema, authority, and path here
        -- is a bit of work, but it may be required one day.
          String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"https:" (URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> URIAuth -> Maybe URIAuth
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> URIAuth
URI.URIAuth String
"" String
"example.com" String
"") String
"/Users/id" String
"" String
""
    }

-- Natural transformation from our transformer stack to the Servant stack
-- this takes the initial environment and returns the transformation
nt :: TestStorage -> ScimHandler TestServer a -> Handler a
nt :: TestStorage -> ScimHandler TestServer a -> Handler a
nt TestStorage
storage =
  (ReaderT TestStorage Handler a -> TestStorage -> Handler a)
-> TestStorage -> ReaderT TestStorage Handler a -> Handler a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT TestStorage Handler a -> TestStorage -> Handler a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TestStorage
storage
    (ReaderT TestStorage Handler a -> Handler a)
-> (ScimHandler TestServer a -> ReaderT TestStorage Handler a)
-> ScimHandler TestServer a
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ScimError -> ReaderT TestStorage Handler a)
-> forall a.
   ScimHandler TestServer a -> ReaderT TestStorage Handler a
forall (m :: * -> *).
Monad m =>
(forall a. ScimError -> m a) -> forall a. ScimHandler m a -> m a
fromScimHandler (Handler a -> ReaderT TestStorage Handler a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler a -> ReaderT TestStorage Handler a)
-> (ScimError -> Handler a)
-> ScimError
-> ReaderT TestStorage Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler a)
-> (ScimError -> ServerError) -> ScimError -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScimError -> ServerError
scimToServerError)

-- | Check whether a user satisfies the filter.
--
-- Returns 'Left' if the filter is constructed incorrectly (e.g. tries to
-- compare a username with a boolean).
--
-- TODO(arianvp): We need to generalise filtering at some point probably.
filterUser :: Filter -> User extra -> Either Text Bool
filterUser :: Filter -> User extra -> Either Text Bool
filterUser (FilterAttrCompare (AttrPath Maybe Schema
schema' AttrName
attrib Maybe SubAttr
subAttr) CompareOp
op CompValue
val) User extra
user
  | Maybe Schema -> Bool
isUserSchema Maybe Schema
schema' =
    case (Maybe SubAttr
subAttr, CompValue
val) of
      (Maybe SubAttr
Nothing, (ValString Text
str))
        | AttrName
attrib AttrName -> AttrName -> Bool
forall a. Eq a => a -> a -> Bool
== AttrName
"userName" ->
          Bool -> Either Text Bool
forall a b. b -> Either a b
Right (CompareOp -> Text -> Text -> Bool
compareStr CompareOp
op (Text -> Text
toCaseFold (User extra -> Text
forall tag. User tag -> Text
userName User extra
user)) (Text -> Text
toCaseFold Text
str))
      (Maybe SubAttr
Nothing, CompValue
_)
        | AttrName
attrib AttrName -> AttrName -> Bool
forall a. Eq a => a -> a -> Bool
== AttrName
"userName" ->
          Text -> Either Text Bool
forall a b. a -> Either a b
Left Text
"usernames can only be compared with strings"
      (Maybe SubAttr
_, CompValue
_) ->
        Text -> Either Text Bool
forall a b. a -> Either a b
Left Text
"Only search on usernames is currently supported"
  | Bool
otherwise = Text -> Either Text Bool
forall a b. a -> Either a b
Left Text
"Invalid schema. Only user schema is supported"