diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -63,7 +63,7 @@ ```haskell result :: Either PatchError Value -result = applyPatches patch [aesonQQ| +result = patchValue patch [aesonQQ| { "baz": "qux", "foo": "bar" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -63,7 +63,7 @@ ```haskell result :: Either PatchError Value -result = applyPatches patch [aesonQQ| +result = patchValue patch [aesonQQ| { "baz": "qux", "foo": "bar" diff --git a/jsonpatch.cabal b/jsonpatch.cabal --- a/jsonpatch.cabal +++ b/jsonpatch.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: jsonpatch -version: 0.2.0.0 +version: 0.2.1.0 license: AGPL-3 license-file: COPYING maintainer: Patrick Brisbin @@ -38,6 +38,7 @@ Data.Aeson.Optics.Ext Data.JSON.Patch Data.JSON.Patch.Apply + Data.JSON.Patch.Apply.AsValue Data.JSON.Patch.Error Data.JSON.Patch.Prelude Data.JSON.Patch.Type diff --git a/src/Data/JSON/Patch.hs b/src/Data/JSON/Patch.hs --- a/src/Data/JSON/Patch.hs +++ b/src/Data/JSON/Patch.hs @@ -9,8 +9,10 @@ module Data.JSON.Patch ( Patch , PatchError - , applyPatches + , patchValue + , patchAsValue ) where import Data.JSON.Patch.Apply +import Data.JSON.Patch.Apply.AsValue import Data.JSON.Patch.Type diff --git a/src/Data/JSON/Patch/Apply.hs b/src/Data/JSON/Patch/Apply.hs --- a/src/Data/JSON/Patch/Apply.hs +++ b/src/Data/JSON/Patch/Apply.hs @@ -7,8 +7,8 @@ -- Stability : experimental -- Portability : POSIX module Data.JSON.Patch.Apply - ( applyPatches - , PatchError (..) + ( PatchError (..) + , patchValue ) where import Data.JSON.Patch.Prelude @@ -21,17 +21,18 @@ import Data.Vector qualified as V import Optics.Core -applyPatches :: [Patch] -> Value -> Either PatchError Value -applyPatches ps v = foldM applyPatch v ps - -applyPatch :: Value -> Patch -> Either PatchError Value -applyPatch val = \case - Add op -> add op.value op.path val - Remove op -> remove op.path val - Replace op -> remove op.path val >>= add op.value op.path - Move op -> get op.from val >>= \v -> remove op.from val >>= add v op.path - Copy op -> get op.from val >>= \v -> add v op.path val - Test op -> get op.path val >>= \v -> test v op.value op.path val +-- | Apply the given 'Patch'es to the given 'Value' +patchValue :: [Patch] -> Value -> Either PatchError Value +patchValue patches target = foldM go target patches + where + go :: Value -> Patch -> Either PatchError Value + go val = \case + Add op -> add op.value op.path val + Remove op -> remove op.path val + Replace op -> remove op.path val >>= add op.value op.path + Move op -> get op.from val >>= \v -> remove op.from val >>= add v op.path + Copy op -> get op.from val >>= \v -> add v op.path val + Test op -> get op.path val >>= \v -> test v op.value op.path val get :: Pointer -> Value -> Either PatchError Value get p val = note (PointerNotFound p Nothing) $ val ^? pointerL p diff --git a/src/Data/JSON/Patch/Apply/AsValue.hs b/src/Data/JSON/Patch/Apply/AsValue.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Patch/Apply/AsValue.hs @@ -0,0 +1,64 @@ +-- | +-- +-- Module : Data.JSON.Patch.Apply.AsValue +-- Copyright : (c) 2025 Patrick Brisbin +-- License : AGPL-3 +-- Maintainer : pbrisbin@gmail.com +-- Stability : experimental +-- Portability : POSIX +module Data.JSON.Patch.Apply.AsValue + ( PatchError (..) + , patchAsValue + ) where + +import Data.JSON.Patch.Prelude + +import Data.Aeson (FromJSON, Result (..), ToJSON (..), Value (..), fromJSON) +import Data.Aeson.Optics (AsValue (..)) +import Data.JSON.Patch.Apply +import Optics.Core + +-- | A polymorphic version of 'patchValue' +-- +-- The @patch@ input uses 'AsValue' from @aeson-optics@, meaning you can supply +-- a variety of types such as 'ByteString' or 'Value' and it will be parsed into +-- @['Patches']@ (capturing failure as a 'PatchError'). +-- +-- The @v@ input can be any domain type with JSON instances. We don't use +-- 'AsValue' here as well, even though it provides the same functionality, +-- because it's unlikely your types will have this instance. +-- +-- @ +-- data Person = Person +-- { name :: Text +-- , age :: Int +-- } +-- deriving stock Generic +-- deriving anyclass (FromJSON, ToJSON) +-- +-- patchPersonR :: PersonId -> Handler Person +-- patchPersonR id = do +-- person <- runDB $ get id -- Person "pat" 19 +-- bytes <- getRequestBody -- "[{op:replace, path:/age, value:21}]" +-- +-- case patchAsValue bytes person of +-- Left err -> sendResponse 400 $ displayException err +-- Right updated -> do +-- runDB $ update id updated +-- sendResponse 200 updated -- Person "pat" 21 +-- @ +-- +-- If the patch creates a value that can't parse back to your domain type, that +-- will also be normalized to 'PatchError'. +patchAsValue + :: (AsValue patch, FromJSON v, ToJSON v) => patch -> v -> Either PatchError v +patchAsValue p target = do + pVal <- note (ParseError Null "not JSON") $ p ^? _Value + patches <- fromJSONEither pVal + result <- patchValue patches $ toJSON target + fromJSONEither result + +fromJSONEither :: FromJSON a => Value -> Either PatchError a +fromJSONEither v = case fromJSON v of + Error e -> Left $ ParseError v e + Success a -> Right a diff --git a/src/Data/JSON/Patch/Prelude.hs b/src/Data/JSON/Patch/Prelude.hs --- a/src/Data/JSON/Patch/Prelude.hs +++ b/src/Data/JSON/Patch/Prelude.hs @@ -1,3 +1,11 @@ +-- | +-- +-- Module : Data.JSON.Patch.Prelude +-- Copyright : (c) 2025 Patrick Brisbin +-- License : AGPL-3 +-- Maintainer : pbrisbin@gmail.com +-- Stability : experimental +-- Portability : POSIX module Data.JSON.Patch.Prelude ( module X , note diff --git a/src/Data/JSON/Patch/Type.hs b/src/Data/JSON/Patch/Type.hs --- a/src/Data/JSON/Patch/Type.hs +++ b/src/Data/JSON/Patch/Type.hs @@ -6,6 +6,8 @@ -- Maintainer : pbrisbin@gmail.com -- Stability : experimental -- Portability : POSIX +-- +-- module Data.JSON.Patch.Type ( Patch (..) , AddOp (..) diff --git a/src/Data/JSON/Pointer.hs b/src/Data/JSON/Pointer.hs --- a/src/Data/JSON/Pointer.hs +++ b/src/Data/JSON/Pointer.hs @@ -1,3 +1,12 @@ +-- | +-- +-- Module : Data.JSON.Pointer +-- Copyright : (c) 2025 Patrick Brisbin +-- License : AGPL-3 +-- Maintainer : pbrisbin@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- -- module Data.JSON.Pointer ( Pointer (..) diff --git a/test/Data/JSON/PatchSpec.hs b/test/Data/JSON/PatchSpec.hs --- a/test/Data/JSON/PatchSpec.hs +++ b/test/Data/JSON/PatchSpec.hs @@ -70,9 +70,7 @@ | otherwise = it comment = fromMaybe ("test #" <> show n) t.comment - result = case fromJSON t.patch of - Error err -> Left $ ParseError t.patch err - Success patches -> applyPatches patches t.doc + result = patchAsValue t.patch t.doc it' comment $ case (result, t.expected) of (Left ex, Left e) -> do diff --git a/test/Data/JSON/Pointer/TokenSpec.hs b/test/Data/JSON/Pointer/TokenSpec.hs --- a/test/Data/JSON/Pointer/TokenSpec.hs +++ b/test/Data/JSON/Pointer/TokenSpec.hs @@ -1,3 +1,11 @@ +-- | +-- +-- Module : Data.JSON.Pointer.TokenSpec +-- Copyright : (c) 2025 Patrick Brisbin +-- License : AGPL-3 +-- Maintainer : pbrisbin@gmail.com +-- Stability : experimental +-- Portability : POSIX module Data.JSON.Pointer.TokenSpec ( spec ) where