module Web.Scim.Schema.PatchOp where
import Control.Applicative
import Control.Monad.Except
import Data.Aeson.Types (FromJSON (parseJSON), ToJSON (toJSON), Value (String), object, withObject, withText, (.:), (.:?), (.=))
import qualified Data.Aeson.Types as Aeson
import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly)
import Data.Bifunctor (first)
import qualified Data.HashMap.Strict as HM
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, toCaseFold, toLower)
import Data.Text.Encoding (encodeUtf8)
import Web.Scim.AttrName (AttrName (..))
import Web.Scim.Filter (AttrPath (..), SubAttr (..), ValuePath (..), pAttrPath, pSubAttr, pValuePath, rAttrPath, rSubAttr, rValuePath)
import Web.Scim.Schema.Error
import Web.Scim.Schema.Schema (Schema (PatchOp20))
import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas))
newtype PatchOp tag = PatchOp
{PatchOp tag -> [Operation]
getOperations :: [Operation]}
deriving (PatchOp tag -> PatchOp tag -> Bool
(PatchOp tag -> PatchOp tag -> Bool)
-> (PatchOp tag -> PatchOp tag -> Bool) -> Eq (PatchOp tag)
forall tag. PatchOp tag -> PatchOp tag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PatchOp tag -> PatchOp tag -> Bool
$c/= :: forall tag. PatchOp tag -> PatchOp tag -> Bool
== :: PatchOp tag -> PatchOp tag -> Bool
$c== :: forall tag. PatchOp tag -> PatchOp tag -> Bool
Eq, Int -> PatchOp tag -> ShowS
[PatchOp tag] -> ShowS
PatchOp tag -> String
(Int -> PatchOp tag -> ShowS)
-> (PatchOp tag -> String)
-> ([PatchOp tag] -> ShowS)
-> Show (PatchOp tag)
forall tag. Int -> PatchOp tag -> ShowS
forall tag. [PatchOp tag] -> ShowS
forall tag. PatchOp tag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PatchOp tag] -> ShowS
$cshowList :: forall tag. [PatchOp tag] -> ShowS
show :: PatchOp tag -> String
$cshow :: forall tag. PatchOp tag -> String
showsPrec :: Int -> PatchOp tag -> ShowS
$cshowsPrec :: forall tag. Int -> PatchOp tag -> ShowS
Show)
data Operation = Operation
{ Operation -> Op
op :: Op,
Operation -> Maybe Path
path :: Maybe Path,
Operation -> Maybe Value
value :: Maybe Value
}
deriving (Operation -> Operation -> Bool
(Operation -> Operation -> Bool)
-> (Operation -> Operation -> Bool) -> Eq Operation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Operation -> Operation -> Bool
$c/= :: Operation -> Operation -> Bool
== :: Operation -> Operation -> Bool
$c== :: Operation -> Operation -> Bool
Eq, Int -> Operation -> ShowS
[Operation] -> ShowS
Operation -> String
(Int -> Operation -> ShowS)
-> (Operation -> String)
-> ([Operation] -> ShowS)
-> Show Operation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Operation] -> ShowS
$cshowList :: [Operation] -> ShowS
show :: Operation -> String
$cshow :: Operation -> String
showsPrec :: Int -> Operation -> ShowS
$cshowsPrec :: Int -> Operation -> ShowS
Show)
data Op
= Add
| Replace
| Remove
deriving (Op -> Op -> Bool
(Op -> Op -> Bool) -> (Op -> Op -> Bool) -> Eq Op
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Op -> Op -> Bool
$c/= :: Op -> Op -> Bool
== :: Op -> Op -> Bool
$c== :: Op -> Op -> Bool
Eq, Int -> Op -> ShowS
[Op] -> ShowS
Op -> String
(Int -> Op -> ShowS)
-> (Op -> String) -> ([Op] -> ShowS) -> Show Op
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Op] -> ShowS
$cshowList :: [Op] -> ShowS
show :: Op -> String
$cshow :: Op -> String
showsPrec :: Int -> Op -> ShowS
$cshowsPrec :: Int -> Op -> ShowS
Show, Int -> Op
Op -> Int
Op -> [Op]
Op -> Op
Op -> Op -> [Op]
Op -> Op -> Op -> [Op]
(Op -> Op)
-> (Op -> Op)
-> (Int -> Op)
-> (Op -> Int)
-> (Op -> [Op])
-> (Op -> Op -> [Op])
-> (Op -> Op -> [Op])
-> (Op -> Op -> Op -> [Op])
-> Enum Op
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Op -> Op -> Op -> [Op]
$cenumFromThenTo :: Op -> Op -> Op -> [Op]
enumFromTo :: Op -> Op -> [Op]
$cenumFromTo :: Op -> Op -> [Op]
enumFromThen :: Op -> Op -> [Op]
$cenumFromThen :: Op -> Op -> [Op]
enumFrom :: Op -> [Op]
$cenumFrom :: Op -> [Op]
fromEnum :: Op -> Int
$cfromEnum :: Op -> Int
toEnum :: Int -> Op
$ctoEnum :: Int -> Op
pred :: Op -> Op
$cpred :: Op -> Op
succ :: Op -> Op
$csucc :: Op -> Op
Enum, Op
Op -> Op -> Bounded Op
forall a. a -> a -> Bounded a
maxBound :: Op
$cmaxBound :: Op
minBound :: Op
$cminBound :: Op
Bounded)
data Path
= NormalPath AttrPath
| IntoValuePath ValuePath (Maybe SubAttr)
deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> String
$cshow :: Path -> String
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show)
parsePath :: [Schema] -> Text -> Either String Path
parsePath :: [Schema] -> Text -> Either String Path
parsePath [Schema]
schemas' = Parser Path -> ByteString -> Either String Path
forall a. Parser a -> ByteString -> Either String a
parseOnly ([Schema] -> Parser Path
pPath [Schema]
schemas' Parser Path -> Parser ByteString () -> Parser Path
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput) (ByteString -> Either String Path)
-> (Text -> ByteString) -> Text -> Either String Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
pPath :: [Schema] -> Parser Path
pPath :: [Schema] -> Parser Path
pPath [Schema]
schemas' =
ValuePath -> Maybe SubAttr -> Path
IntoValuePath (ValuePath -> Maybe SubAttr -> Path)
-> Parser ByteString ValuePath
-> Parser ByteString (Maybe SubAttr -> Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Schema] -> Parser ByteString ValuePath
pValuePath [Schema]
schemas' Parser ByteString (Maybe SubAttr -> Path)
-> Parser ByteString (Maybe SubAttr) -> Parser Path
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString SubAttr -> Parser ByteString (Maybe SubAttr)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString SubAttr
pSubAttr
Parser Path -> Parser Path -> Parser Path
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AttrPath -> Path
NormalPath (AttrPath -> Path) -> Parser ByteString AttrPath -> Parser Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Schema] -> Parser ByteString AttrPath
pAttrPath [Schema]
schemas'
rPath :: Path -> Text
rPath :: Path -> Text
rPath (NormalPath AttrPath
attrPath) = AttrPath -> Text
rAttrPath AttrPath
attrPath
rPath (IntoValuePath ValuePath
valuePath Maybe SubAttr
subAttr) = ValuePath -> Text
rValuePath ValuePath
valuePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (SubAttr -> Text) -> Maybe SubAttr -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" SubAttr -> Text
rSubAttr Maybe SubAttr
subAttr
instance UserTypes tag => FromJSON (PatchOp tag) where
parseJSON :: Value -> Parser (PatchOp tag)
parseJSON = String
-> (Object -> Parser (PatchOp tag))
-> Value
-> Parser (PatchOp tag)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PatchOp" ((Object -> Parser (PatchOp tag)) -> Value -> Parser (PatchOp tag))
-> (Object -> Parser (PatchOp tag))
-> Value
-> Parser (PatchOp tag)
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
let o :: Object
o = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Value)] -> Object)
-> (Object -> [(Text, Value)]) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> (Text, Value))
-> [(Text, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> (Text, Value) -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Text
toLower) ([(Text, Value)] -> [(Text, Value)])
-> (Object -> [(Text, Value)]) -> Object -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Object
v
[Schema]
schemas' :: [Schema] <- Object
o Object -> Text -> Parser [Schema]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"schemas"
Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ Schema
PatchOp20 Schema -> [Schema] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Schema]
schemas'
[Operation]
operations <- (Value -> Parser [Operation])
-> Object -> Text -> Parser [Operation]
forall a. (Value -> Parser a) -> Object -> Text -> Parser a
Aeson.explicitParseField ((Value -> Parser Operation) -> Value -> Parser [Operation]
forall a. (Value -> Parser a) -> Value -> Parser [a]
Aeson.listParser ((Value -> Parser Operation) -> Value -> Parser [Operation])
-> (Value -> Parser Operation) -> Value -> Parser [Operation]
forall a b. (a -> b) -> a -> b
$ [Schema] -> Value -> Parser Operation
operationFromJSON (UserTypes tag => [Schema]
forall tag. UserTypes tag => [Schema]
supportedSchemas @tag)) Object
o Text
"operations"
PatchOp tag -> Parser (PatchOp tag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatchOp tag -> Parser (PatchOp tag))
-> PatchOp tag -> Parser (PatchOp tag)
forall a b. (a -> b) -> a -> b
$ [Operation] -> PatchOp tag
forall tag. [Operation] -> PatchOp tag
PatchOp [Operation]
operations
instance ToJSON (PatchOp tag) where
toJSON :: PatchOp tag -> Value
toJSON (PatchOp [Operation]
operations) =
[(Text, Value)] -> Value
object [Text
"operations" Text -> [Operation] -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Operation]
operations, Text
"schemas" Text -> [Schema] -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Schema
PatchOp20]]
operationFromJSON :: [Schema] -> Value -> Aeson.Parser Operation
operationFromJSON :: [Schema] -> Value -> Parser Operation
operationFromJSON [Schema]
schemas' =
String -> (Object -> Parser Operation) -> Value -> Parser Operation
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Operation" ((Object -> Parser Operation) -> Value -> Parser Operation)
-> (Object -> Parser Operation) -> Value -> Parser Operation
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
let o :: Object
o = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Value)] -> Object)
-> (Object -> [(Text, Value)]) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> (Text, Value))
-> [(Text, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> (Text, Value) -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Text
toLower) ([(Text, Value)] -> [(Text, Value)])
-> (Object -> [(Text, Value)]) -> Object -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Object
v
Op -> Maybe Path -> Maybe Value -> Operation
Operation
(Op -> Maybe Path -> Maybe Value -> Operation)
-> Parser Op -> Parser (Maybe Path -> Maybe Value -> Operation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Text -> Parser Op
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"op")
Parser (Maybe Path -> Maybe Value -> Operation)
-> Parser (Maybe Path) -> Parser (Maybe Value -> Operation)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Value -> Parser Path) -> Object -> Text -> Parser (Maybe Path)
forall a. (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
Aeson.explicitParseFieldMaybe ([Schema] -> Value -> Parser Path
pathFromJSON [Schema]
schemas') Object
o Text
"path")
Parser (Maybe Value -> Operation)
-> Parser (Maybe Value) -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"value")
pathFromJSON :: [Schema] -> Value -> Aeson.Parser Path
pathFromJSON :: [Schema] -> Value -> Parser Path
pathFromJSON [Schema]
schemas' =
String -> (Text -> Parser Path) -> Value -> Parser Path
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Path" ((Text -> Parser Path) -> Value -> Parser Path)
-> (Text -> Parser Path) -> Value -> Parser Path
forall a b. (a -> b) -> a -> b
$ (String -> Parser Path)
-> (Path -> Parser Path) -> Either String Path -> Parser Path
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Path
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Path -> Parser Path
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Path -> Parser Path)
-> (Text -> Either String Path) -> Text -> Parser Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Schema] -> Text -> Either String Path
parsePath [Schema]
schemas')
instance ToJSON Operation where
toJSON :: Operation -> Value
toJSON (Operation Op
op' Maybe Path
path' Maybe Value
value') =
[(Text, Value)] -> Value
object ([(Text, Value)] -> Value) -> [(Text, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ (Text
"op" Text -> Op -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Op
op') (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
: [[(Text, Value)]] -> [(Text, Value)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Text -> Maybe Path -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"path" Maybe Path
path', Text -> Maybe Value -> [(Text, Value)]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
optionalField Text
"value" Maybe Value
value']
where
optionalField :: Text -> Maybe v -> [a]
optionalField Text
fname = \case
Maybe v
Nothing -> []
Just v
x -> [Text
fname Text -> v -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
x]
instance FromJSON Op where
parseJSON :: Value -> Parser Op
parseJSON = String -> (Text -> Parser Op) -> Value -> Parser Op
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Op" ((Text -> Parser Op) -> Value -> Parser Op)
-> (Text -> Parser Op) -> Value -> Parser Op
forall a b. (a -> b) -> a -> b
$ \Text
op' ->
case Text -> Text
toCaseFold Text
op' of
Text
"add" -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
Add
Text
"replace" -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
Replace
Text
"remove" -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
Remove
Text
_ -> String -> Parser Op
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unknown operation"
instance ToJSON Op where
toJSON :: Op -> Value
toJSON Op
Add = Text -> Value
String Text
"add"
toJSON Op
Replace = Text -> Value
String Text
"replace"
toJSON Op
Remove = Text -> Value
String Text
"remove"
instance ToJSON Path where
toJSON :: Path -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Path -> Text) -> Path -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Text
rPath
class Patchable a where
applyOperation :: (MonadError ScimError m) => a -> Operation -> m a
instance Patchable (HM.HashMap Text Text) where
applyOperation :: HashMap Text Text -> Operation -> m (HashMap Text Text)
applyOperation HashMap Text Text
theMap (Operation Op
Remove (Just (NormalPath (AttrPath Maybe Schema
_schema (AttrName Text
attrName) Maybe SubAttr
_subAttr))) Maybe Value
_) =
HashMap Text Text -> m (HashMap Text Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text Text -> m (HashMap Text Text))
-> HashMap Text Text -> m (HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> HashMap Text Text -> HashMap Text Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
attrName HashMap Text Text
theMap
applyOperation HashMap Text Text
theMap (Operation Op
_AddOrReplace (Just (NormalPath (AttrPath Maybe Schema
_schema (AttrName Text
attrName) Maybe SubAttr
_subAttr))) (Just (String Text
val))) =
HashMap Text Text -> m (HashMap Text Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text Text -> m (HashMap Text Text))
-> HashMap Text Text -> m (HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
attrName Text
val HashMap Text Text
theMap
applyOperation HashMap Text Text
_ Operation
_ = ScimError -> m (HashMap Text Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScimError -> m (HashMap Text Text))
-> ScimError -> m (HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
InvalidValue (Maybe Text -> ScimError) -> Maybe Text -> ScimError
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Unsupported operation"