jsonpatch 0.1.0.0 → 0.2.0.0

raw patch · 12 files changed

+250/−219 lines, 12 filesdep +optics-coredep −mtldep −opticsPVP ok

version bump matches the API change (PVP)

Dependencies added: optics-core

Dependencies removed: mtl, optics

API changes (from Hackage documentation)

Files

• jsonpatch.cabal +5/−4
• src/Data/Aeson/Optics/Ext.hs +30/−1
• src/Data/JSON/Patch/Apply.hs +38/−93
• src/Data/JSON/Patch/Error.hs +11/−14
• src/Data/JSON/Patch/Prelude.hs +19/−0
• src/Data/JSON/Patch/Type.hs +1/−3
• src/Data/JSON/Pointer.hs +35/−32
• src/Data/JSON/Pointer/Token.hs +35/−57
• test/Data/Aeson/Optics/ExtSpec.hs +24/−7
• test/Data/JSON/Patch/PointerSpec.hs +7/−6
• test/Data/JSON/PatchSpec.hs +3/−2
• test/Data/JSON/Pointer/TokenSpec.hs +42/−0

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               jsonpatch-version:            0.1.0.0+version:            0.2.0.0 license:            AGPL-3 license-file:       COPYING maintainer:         Patrick Brisbin@@ -39,6 +39,7 @@         Data.JSON.Patch         Data.JSON.Patch.Apply         Data.JSON.Patch.Error+        Data.JSON.Patch.Prelude         Data.JSON.Patch.Type         Data.JSON.Pointer         Data.JSON.Pointer.Token@@ -64,8 +65,7 @@         aeson-optics >=1.2.0.1,         attoparsec >=0.14.4,         base >=4.16.4.0 && <5,-        mtl >=2.2.2,-        optics >=0.4.2,+        optics-core >=0.4.1,         text >=1.2.5.0,         vector >=0.12.3.1 @@ -132,6 +132,7 @@         Data.Aeson.Optics.ExtSpec         Data.JSON.Patch.PointerSpec         Data.JSON.PatchSpec+        Data.JSON.Pointer.TokenSpec         Data.Vector.ExtSpec         Paths_jsonpatch @@ -159,7 +160,7 @@         hspec >=2.9.7,         hspec-expectations-json >=1.0.0.7,         jsonpatch,-        optics >=0.4.2,+        optics-core >=0.4.1,         path >=0.9.2,         vector >=0.12.3.1 

@@ -9,6 +9,7 @@ module Data.Aeson.Optics.Ext   ( atKey   , atNth+  , atEnd   ) where  import Prelude@@ -19,7 +20,7 @@ import Data.Aeson.Optics import Data.Vector qualified as V import Data.Vector.Ext qualified as V-import Optics+import Optics.Core  -- | Like 'key', but uses 'at' instead of 'ix'. This is handy when adding and -- removing object keys:@@ -68,4 +69,32 @@     Just x -> case nv of       Object km -> Object $ KeyMap.insert (Key.fromString $ show n) x km       Array vec -> Array $ V.insertAt n x vec+      v -> v++-- | List 'atNth' for the index /after/ the last value of an 'Array'+--+-- This only useful to normalize adds as a lens:+--+-- >>> ['a', 'b', 'c'] & atEnd ?~ 'x'+-- ['a', 'b', 'c', 'x']+--+-- Attempting to access this index on an array will always given 'Nothing'+--+-- >>> ['a', 'b', 'c'] ^? atEnd+-- Nothing+--+-- Most other operations are going to be a no-op.+atEnd :: AffineTraversal' Value (Maybe Value)+atEnd = atraversal matcher updater+ where+  matcher :: Value -> Either Value (Maybe Value)+  matcher = \case+    Array {} -> Right Nothing -- index after end doesn't exist+    v -> Left v++  updater :: Value -> Maybe Value -> Value+  updater nv = \case+    Nothing -> nv+    Just x -> case nv of+      Array vec -> Array $ vec <> pure x       v -> v

@@ -11,111 +11,56 @@   , PatchError (..)   ) where -import Prelude+import Data.JSON.Patch.Prelude -import Control.Monad (unless, void, when)-import Control.Monad.Except (MonadError, runExcept, throwError)-import Control.Monad.State (MonadState, execStateT, gets, modify, put)-import Data.Aeson-import Data.Aeson.KeyMap (KeyMap)-import Data.Aeson.Optics-import Data.Foldable (traverse_)+import Data.Aeson (Value (..)) import Data.JSON.Patch.Error import Data.JSON.Patch.Type import Data.JSON.Pointer import Data.JSON.Pointer.Token-import Data.Vector (Vector) import Data.Vector qualified as V-import Optics+import Optics.Core  applyPatches :: [Patch] -> Value -> Either PatchError Value-applyPatches ps = runExcept . execStateT (traverse_ applyPatch ps)--applyPatch :: (MonadError PatchError m, MonadState Value m) => Patch -> m ()-applyPatch = \case-  Add op -> add op.value op.path-  Remove op -> remove op.path-  Replace op -> remove op.path >> add op.value op.path-  Move op -> do-    v <- get op.from-    remove op.from-    add v op.path-  Copy op -> flip add op.path =<< get op.from-  Test op -> do-    v <- get op.path-    unless (v == op.value) $ throwError $ TestFailed op.path v op.value--get :: (MonadError PatchError m, MonadState Value m) => Pointer -> m Value-get = \case-  PointerEmpty -> gets id-  PointerPath ts t -> assertExists $ ts <> [t]-  PointerPathEnd ts -> do-    target <- assertExists ts-    vec <- assertArray ts target-    snd <$> assertUnsnoc ts vec--add :: (MonadError PatchError m, MonadState Value m) => Value -> Pointer -> m ()-add v = \case-  PointerEmpty -> put v-  PointerPath ts t -> do-    target <- assertExists ts--    -- Additional validations based on type of final target-    case t of-      K _ -> void $ assertObject ts target-      N n -> do-        case target of-          Object {} -> pure () -- n will be used as Key, no bounds check-          Array vec -> do-            when (n < 0) $ throwError $ IndexOutOfBounds ts n vec-            when (n > V.length vec) $ throwError $ IndexOutOfBounds ts n vec-          v' -> throwError $ InvalidArrayOperation ts v'--    modify $ tokensL ts % atTokenL t ?~ v-  PointerPathEnd ts -> do-    target <- assertExists ts-    void $ assertArray ts target-    modify $ tokensL ts % _Array %~ (<> pure v)+applyPatches ps v = foldM applyPatch v ps -remove :: (MonadError PatchError m, MonadState Value m) => Pointer -> m ()-remove = \case-  PointerEmpty -> put Null -- NB. unspecified behavior-  PointerPath ts t -> do-    void $ assertExists $ ts <> [t]+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 -    -- NB. odd that the tests don't exercise any additional validation (e.g.-    -- bounds checking) like we saw with add.+get :: Pointer -> Value -> Either PatchError Value+get p val = note (PointerNotFound p Nothing) $ val ^? pointerL p -    modify $ tokensL ts % atTokenL t .~ Nothing-  PointerPathEnd ts -> do-    target <- assertExists ts-    vec <- assertArray ts target-    (vs, _) <- assertUnsnoc ts vec-    modify $ tokensL ts % _Array .~ vs+add :: Value -> Pointer -> Value -> Either PatchError Value+add v p val = case splitPointer p of+  Nothing -> Right v+  Just (parent, t) -> do+    validateAdd parent t val+    Right $ val & atPointerL p ?~ v -assertExists-  :: (MonadError PatchError m, MonadState Value m) => [Token] -> m Value-assertExists ts =-  gets (preview $ tokensL ts) >>= \case-    Nothing -> throwError $ PointerNotFound ts Nothing-    Just v -> pure v+remove :: Pointer -> Value -> Either PatchError Value+remove p val = do+  void $ get p val+  Right $ val & atPointerL p .~ Nothing -assertObject :: MonadError PatchError m => [Token] -> Value -> m (KeyMap Value)-assertObject ts = \case-  Object o -> pure o-  v -> throwError $ InvalidObjectOperation ts v+test :: Value -> Value -> Pointer -> Value -> Either PatchError Value+test v expected p val =+  note (TestFailed p v expected) $ val <$ guard (v == expected) -assertArray :: MonadError PatchError m => [Token] -> Value -> m (Vector Value)-assertArray ts = \case-  Array vec -> pure vec-  v -> throwError $ InvalidArrayOperation ts v+validateAdd :: Pointer -> Token -> Value -> Either PatchError ()+validateAdd parent t val = do+  target <- get parent val -assertUnsnoc-  :: MonadError PatchError m-  => [Token]-  -> Vector Value-  -> m (Vector Value, Value)-assertUnsnoc ts vec =-  case V.unsnoc vec of-    Nothing -> throwError $ EmptyArray ts-    Just tp -> pure tp+  case (t, target) of+    (_, Object _) -> Right () -- everything works on objects+    (K _, v) -> Left $ InvalidObjectOperation parent v+    (N n, Array vec) -> do+      when (n < 0) $ Left $ IndexOutOfBounds parent n vec+      when (n > V.length vec) $ Left $ IndexOutOfBounds parent n vec+    (N _, v) -> Left $ InvalidArrayOperation parent v+    _ -> Right ()

@@ -10,22 +10,19 @@   ( PatchError (..)   ) where -import Prelude+import Data.JSON.Patch.Prelude -import Control.Exception (Exception (..)) import Data.Aeson (Value) import Data.JSON.Pointer-import Data.JSON.Pointer.Token-import Data.Vector (Vector) import Data.Vector qualified as V  data PatchError   = ParseError Value String-  | PointerNotFound [Token] (Maybe String)-  | InvalidObjectOperation [Token] Value-  | InvalidArrayOperation [Token] Value-  | IndexOutOfBounds [Token] Int (Vector Value)-  | EmptyArray [Token]+  | PointerNotFound Pointer (Maybe String)+  | InvalidObjectOperation Pointer Value+  | InvalidArrayOperation Pointer Value+  | IndexOutOfBounds Pointer Int (Vector Value)+  | EmptyArray Pointer   | TestFailed Pointer Value Value   deriving stock (Show) @@ -37,17 +34,17 @@         <> ("\n  input: " <> show v)     PointerNotFound ts mType ->       "Path "-        <> tokensToString ts+        <> pointerToString ts         <> " does not exist"         <> maybe "" (" or is not " <>) mType     InvalidObjectOperation ts v ->       "Cannot perform object operation on non-object at "-        <> tokensToString ts+        <> pointerToString ts         <> ": "         <> show v     InvalidArrayOperation ts v ->       "Cannot perform array operation on non-array at "-        <> tokensToString ts+        <> pointerToString ts         <> ": "         <> show v     IndexOutOfBounds ts n vec ->@@ -56,9 +53,9 @@         <> " is out of bounds for vector of length "         <> show (V.length vec)         <> " at "-        <> tokensToString ts+        <> pointerToString ts     EmptyArray ts ->-      "Cannot perform operation on empty array at " <> tokensToString ts+      "Cannot perform operation on empty array at " <> pointerToString ts     TestFailed p actual expected ->       "Test failed at "         <> pointerToString p

@@ -0,0 +1,19 @@+module Data.JSON.Patch.Prelude+  ( module X+  , note+  ) where++import Prelude as X++import Control.Applicative as X (asum, (<|>))+import Control.Exception as X (Exception (..))+import Control.Monad as X (foldM, guard, unless, void, when)+import Data.Bifunctor as X (bimap, first, second)+import Data.List.NonEmpty as X (NonEmpty, nonEmpty)+import Data.Maybe as X (fromMaybe)+import Data.Text as X (Text, pack, unpack)+import Data.Vector as X (Vector)+import GHC.Generics as X (Generic)++note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right

@@ -16,12 +16,10 @@   , TestOp (..)   ) where -import Prelude+import Data.JSON.Patch.Prelude  import Data.Aeson import Data.JSON.Pointer-import Data.Text (Text)-import GHC.Generics (Generic)  data Patch   = Add AddOp

@@ -4,57 +4,60 @@   , pointerFromText   , pointerToText   , pointerToString+  , pointerL+  , atPointerL+  , splitPointer   ) where -import Prelude+import Data.JSON.Patch.Prelude -import Data.Aeson (FromJSON (..), withText)+import Data.Aeson (FromJSON (..), Value, withText)+import Data.Aeson.Optics (_JSON) import Data.Attoparsec.Text import Data.JSON.Pointer.Token-import Data.List.NonEmpty (nonEmpty) import Data.List.NonEmpty qualified as NE-import Data.Text (Text, unpack) import Data.Text qualified as T+import Optics.Core -data Pointer-  = -- | @""@ means whole-document-    PointerEmpty-  | -- | @"/[.../]x"@ means path to a key or index @x@-    ---    -- NB. @"/"@ naturally becomes @'PointerPath' [] ('K' "")@-    PointerPath [Token] Token-  | -- | @"/[.../]-"@ means path to last element of an array-    PointerPathEnd [Token]+newtype Pointer = Pointer+  { tokens :: [Token]+  }   deriving stock (Eq, Show)  instance FromJSON Pointer where   parseJSON = withText "Pointer" $ either fail pure . pointerFromText  pointerFromText :: Text -> Either String Pointer-pointerFromText = \case-  "" -> Right PointerEmpty-  "/" -> Right $ PointerPath [] $ K ""-  "/-" -> Right $ PointerPathEnd []-  p -> case T.stripSuffix "/-" p of-    Nothing -> parseOnly pointerPathP p-    Just p' -> parseOnly pointerPathEndP p'+pointerFromText = parseOnly pointerP +pointerP :: Parser Pointer+pointerP = do+  ts <- (char '/' *> tokenP `sepBy1` char '/' <|> pure []) <* endOfInput+  pure $ Pointer ts++tokenP :: Parser Token+tokenP =+  either (fail . ("invalid token: " <>)) pure+    . tokenFromText+    =<< takeTill (== '/')+ pointerToText :: Pointer -> Text-pointerToText = \case-  PointerEmpty -> ""-  PointerPath ts t -> tokensToText $ ts <> [t]-  PointerPathEnd ts -> tokensToText ts <> "/-"+pointerToText = ("/" <>) . T.intercalate "/" . map tokenToText . (.tokens)  pointerToString :: Pointer -> String pointerToString = unpack . pointerToText -pointerPathP :: Parser Pointer-pointerPathP = do-  ts <- maybe (fail "") pure . nonEmpty =<< pointerP-  pure $ PointerPath (NE.init ts) $ NE.last ts+-- | Access a 'Pointer' like 'ix', used for indexing+pointerL :: Pointer -> AffineTraversal' Value Value+pointerL = foldr ((%) . tokenL) (castOptic simple) . (.tokens) -pointerPathEndP :: Parser Pointer-pointerPathEndP = PointerPathEnd <$> pointerP+-- | Access a 'Pointer' like 'at', used for adding or removing+atPointerL :: Pointer -> AffineTraversal' Value (Maybe Value)+atPointerL p = case splitPointer p of+  Nothing -> castOptic _JSON -- hack to return as-is+  Just (parent, t) -> pointerL parent % atTokenL t -pointerP :: Parser [Token]-pointerP = char '/' *> tokenP `sepBy1` char '/' <* endOfInput+splitPointer :: Pointer -> Maybe (Pointer, Token)+splitPointer p = go <$> nonEmpty p.tokens+ where+  go x = (Pointer $ NE.init x, NE.last x)

@@ -8,83 +8,61 @@ -- Portability : POSIX module Data.JSON.Pointer.Token   ( Token (..)-  , tokenP-  , tokensToText-  , tokensToString-  , tokensL+  , tokenFromText+  , tokenToText   , tokenL   , atTokenL   ) where -import Prelude+import Data.JSON.Patch.Prelude -import Control.Applicative (optional, (<|>)) import Data.Aeson (Key, Value (..)) import Data.Aeson.Key qualified as Key-import Data.Aeson.Optics+import Data.Aeson.Optics (key, nth) import Data.Aeson.Optics.Ext-import Data.Attoparsec.Text-import Data.Text (Text, pack, unpack)+import Data.Char (isDigit) import Data.Text qualified as T-import Optics+import Optics.Core import Text.Read (readEither) -data Token = K Key | N Int+data Token = N Int | E | K Key   deriving stock (Eq, Show) -tokensToString :: [Token] -> String-tokensToString = unpack . tokensToText--tokensToText :: [Token] -> Text-tokensToText ts = "/" <> T.intercalate "/" (map tokenToText ts)--tokenToText :: Token -> Text-tokenToText = \case-  K k -> Key.toText k-  N n -> pack $ show n--tokensL :: [Token] -> AffineTraversal' Value Value-tokensL = foldr ((%) . tokenL) $ castOptic simple---- | Access a key or array index like 'ix'+-- | Access a key or array index like 'ix', used for indexing tokenL :: Token -> AffineTraversal' Value Value tokenL t = case t of-  K k -> key k   N n -> nth n+  E -> atEnd % _Just+  K k -> key k --- | Access a key or array index, but 'at'-like+-- | Access a key or array index like 'at', used for adding or removing atTokenL :: Token -> AffineTraversal' Value (Maybe Value) atTokenL = \case-  K k -> atKey k   N n -> atNth n--tokenP :: Parser Token-tokenP = wtf <|> N <$> indexP <|> K <$> keyP---- |------ The tests love to use this value as an example. I'm clearly confused because--- I would expect it to fail 'indexP', backtrack, then succeed in 'keyP', but it--- causes errors with "endOfInput", so we'll special case it for now.-wtf :: Parser Token-wtf = K . Key.fromText <$> string "1e0"+  E -> atEnd+  K k -> atKey k -keyP :: Parser Key-keyP =-  Key.fromText-    . T.replace "~0" "~"-    . T.replace "~1" "/"-    <$> takeTill (== '/')+tokenFromText :: Text -> Either String Token+tokenFromText = \case+  "" -> Right $ K ""+  "-" -> Right E+  t | T.all isDigit t -> N <$> readDigits t+  -- The spec doesn't allow this (negative indexes), but the tests use it to+  -- trigger the lower bounds error example.+  t | Just ('-', n) <- T.uncons t, T.all isDigit n -> N . negate <$> readDigits n+  t -> Right $ K $ Key.fromText $ T.replace "~0" "~" $ T.replace "~1" "/" t -indexP :: Parser Int-indexP = do-  f <- maybe id (const negate) <$> optional (char '-')-  f <$> nonzeroP <|> 0 <$ char '0'+readDigits :: Text -> Either String Int+readDigits t+  | t == "0" = Right 0+  | T.isPrefixOf "0" t = Left "leading zeros"+  | otherwise =+      first (\msg -> "could not read digits " <> unpack t <> ": " <> msg)+        $ readEither+        $ unpack t -nonzeroP :: Parser Int-nonzeroP = do-  ds <- (:) <$> satisfy (inClass "1-9") <*> many' digit-  either (err ds) pure $ readEither ds- where-  err :: String -> String -> Parser a-  err x msg = fail $ "Unable to read integer from " <> x <> ": " <> msg+tokenToText :: Token -> Text+tokenToText = \case+  K k -> T.replace "/" "~1" $ T.replace "~" "~0" $ Key.toText k+  N n -> pack $ show n+  E -> "-"

@@ -17,7 +17,7 @@ import Data.Aeson.Optics.Ext import Data.Aeson.QQ import Data.Foldable (for_)-import Optics+import Optics.Core import Test.Hspec  spec :: Spec@@ -49,7 +49,7 @@       input & atNth 2 .~ Nothing & (`shouldBe` [aesonQQ| ["a", "b"] |])       input & atNth 3 .~ Nothing & (`shouldBe` input) -    context "targeting an Object" $ do+    context "Objects behave like atKey" $ do       let input = [aesonQQ| {"0":"a", "1":"b", "2":"c"} |]        for_ [-1 .. 3] $ \n -> do@@ -59,11 +59,28 @@           add l = input & l ?~ "x"           remove l = input & l .~ Nothing -        it ("indexes like atKey for " <> show n) $ do+        it ("test index " <> show n) $ do           index (atNth n) `shouldBe` index (atKey k)--        it ("adds like atKey for " <> show n) $ do           add (atNth n) `shouldBe` add (atKey k)--        it ("removes like atKey for " <> show n) $ do           remove (atNth n) `shouldBe` remove (atKey k)++  describe "atEnd" $ do+    it "always indexes as Nothing" $ do+      let input = [aesonQQ| ["a", "b"] |]++      input ^? atEnd % _Just `shouldBe` Nothing++    it "allows appending to an array" $ do+      let input = [aesonQQ| ["a", "b"] |]++      input & atEnd ?~ "x" & (`shouldBe` [aesonQQ| ["a", "b", "x"] |])++    it "cannot remove the non-existent index" $ do+      let input = [aesonQQ| ["a", "b"] |]++      input & atEnd .~ Nothing & (`shouldBe` input)++    it "leaves other types alone" $ do+      let input = [aesonQQ| {"a": "b"} |]++      input & atEnd ?~ "x" & (`shouldBe` input)

@@ -21,33 +21,34 @@   describe "pointerFromText" $ do     context "success" $ do       it "empty" $ do-        pointerFromText "" `shouldBe` Right PointerEmpty+        pointerFromText "" `shouldBe` Right (Pointer [])        it "root-only" $ do-        pointerFromText "/" `shouldBe` Right (PointerPath [] $ K "")+        pointerFromText "/" `shouldBe` Right (Pointer [K ""])        it "path" $ do         pointerFromText "/foo/0/bar/1/baz"           `shouldBe` Right-            ( PointerPath+            ( Pointer                 [ K "foo"                 , N 0                 , K "bar"                 , N 1+                , K "baz"                 ]-                $ K "baz"             )        it "path end of array" $ do         pointerFromText "/foo/0/bar/1/-"           `shouldBe` Right-            ( PointerPathEnd+            ( Pointer                 [ K "foo"                 , N 0                 , K "bar"                 , N 1+                , E                 ]             )        it "handles implementation-specific numeric parsing" $ do-        pointerFromText "/1e0" `shouldBe` Right (PointerPath [] $ K "1e0")+        pointerFromText "/1e0" `shouldBe` Right (Pointer [K "1e0"])

@@ -102,8 +102,9 @@  spec :: Spec spec = do-  context "json-patch-tests main" $ runPatchTests [relfile|tests.json|]-  context "json-patch-tests RFC6092" $ runPatchTests [relfile|spec_tests.json|]+  context "json-patch-tests" $ do+    context "tests.json" $ runPatchTests [relfile|tests.json|]+    context "spec_tests.json" $ runPatchTests [relfile|spec_tests.json|]  decodeFileThrow :: FromJSON a => Path b File -> IO a decodeFileThrow file = do

@@ -0,0 +1,42 @@+module Data.JSON.Pointer.TokenSpec+  ( spec+  ) where++import Prelude++import Data.Either (isLeft)+import Data.Foldable (for_)+import Data.JSON.Pointer.Token+import Test.Hspec++spec :: Spec+spec = do+  describe "tokenFromText" $ do+    it "parses numbers" $ do+      tokenFromText "0" `shouldBe` Right (N 0)++    it "parses end-of-array" $ do+      tokenFromText "-" `shouldBe` Right E++    it "parses object keys" $ do+      tokenFromText "foo" `shouldBe` Right (K "foo")++    it "unescapes ~0 and ~1" $ do+      tokenFromText "fo~0o~1bar" `shouldBe` Right (K "fo~o/bar")++    it "round-trips with tokenToText" $ do+      let ts =+            [ N 0+            , E+            , K "foo"+            , K "fo~o/bar"+            ]++      for_ ts $ \t -> do+        tokenFromText (tokenToText t) `shouldBe` Right t++    it "parses numeric-looking keys as keys" $ do+      tokenFromText "1e0" `shouldBe` Right (K "1e0")++    it "rejects leading zeros" $ do+      tokenFromText "01" `shouldSatisfy` isLeft