diff --git a/.gitignore b/.gitignore index 4d207b7..c8194af 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,2 @@ .stack-work - +/*.lock diff --git a/aeson-diff.cabal b/aeson-diff.cabal index e7ffa49..076682a 100644 --- a/aeson-diff.cabal +++ b/aeson-diff.cabal @@ -19,10 +19,11 @@ cabal-version: >=1.10 extra-source-files: README.md , CHANGELOG.md , stack.yaml + , test/data/diff-cases/*.json + , test/data/patch-cases/*.json + , test/data/patch-cases/*.txt , test/data/rfc6902/*.json , test/data/rfc6902/*.txt - , test/data/cases/*.json - , test/data/cases/*.txt source-repository HEAD type: git @@ -84,11 +85,29 @@ test-suite properties , unordered-containers , vector -test-suite examples +test-suite patch-examples default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: examples.hs + main-is: patch-examples.hs + build-depends: base + , Glob + , QuickCheck + , aeson + , aeson-diff + , bytestring + , directory + , filepath + , quickcheck-instances + , text + , unordered-containers + , vector + +test-suite diff-examples + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: diff-examples.hs build-depends: base , Glob , QuickCheck diff --git a/lib/Data/Aeson/Diff.hs b/lib/Data/Aeson/Diff.hs index 55f006a..5c8f04b 100644 --- a/lib/Data/Aeson/Diff.hs +++ b/lib/Data/Aeson/Diff.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE ViewPatterns #-} -- | Description: Extract and apply patches on JSON documents. -- -- This module implements data types and operations to represent the @@ -19,6 +19,7 @@ module Data.Aeson.Diff ( diff', patch, applyOperation, + renderDiff, ) where import Control.Applicative @@ -31,12 +32,15 @@ import Data.Foldable (foldlM) import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS import Data.List (groupBy, intercalate) import Data.Maybe import Data.Monoid import Data.Scientific import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as TE import Data.Vector (Vector) import qualified Data.Vector as V import Data.Vector.Distance @@ -84,8 +88,11 @@ ins cfg p v = [Add p v] del :: Config -> Pointer -> Value -> [Operation] del Config{..} p v = if configTstBeforeRem - then [Tst p v, Rem p] - else [Rem p] + then [Tst p v, Rem p (Just v)] + else [Rem p (Just v)] + +mov :: Config -> Pointer -> Pointer -> [Operation] +mov _ t f = [Mov t f] -- | Construct a patch which changes 'Rep' operation. rep :: Config -> Pointer -> Value -> [Operation] @@ -128,38 +135,41 @@ diff' cfg@Config{..} v v' = Patch (worker mempty v v') -- For values of different types, replace v1 with v2. _ -> rep cfg p v2 + objectFindDel :: Value -> [(Text, Value)] -> Maybe (Text, [(Text, Value)]) + objectFindDel _ [] = Nothing + objectFindDel needle (d@(k, straw) : ds) + | needle == straw = Just (k, ds) + | otherwise = (\(k, t) -> (k, d:t)) <$> objectFindDel needle ds + objectMoves :: ([Operation], [Operation], [(Text, Value)]) -> Text -> Value -> ([Operation], [Operation], [(Text, Value)]) + objectMoves (as, ms, del) k v = + case objectFindDel v del of + Nothing -> (ins cfg (Pointer [OKey k]) v <> as, ms, del) + Just (k2, del') -> (as, mov cfg (Pointer [OKey k]) (Pointer [OKey k2]) <> ms, del') + -- Walk the keys in two objects, producing a 'Patch'. workObject :: Pointer -> Object -> Object -> [Operation] workObject path o1 o2 = - let k1 = HM.keys o1 - k2 = HM.keys o2 - -- Deletions - del_keys :: [Text] - del_keys = filter (not . (`elem` k2)) k1 - deletions :: [Operation] - deletions = concatMap - (\k -> del cfg (Pointer [OKey k]) (fromJust $ HM.lookup k o1)) - del_keys - -- Insertions - ins_keys = filter (not . (`elem` k1)) k2 - insertions :: [Operation] - insertions = concatMap - (\k -> ins cfg (Pointer [OKey k]) (fromJust $ HM.lookup k o2)) - ins_keys + let k1 = HM.keysSet o1 + k2 = HM.keysSet o2 + -- Changed keys + dels' = HM.filterWithKey (\k v -> not $ k `HS.member` k2) o1 + adds' = HM.filterWithKey (\k v -> not $ k `HS.member` k1) o2 + chg_keys = HS.intersection k1 k2 + (insertions, moves, deletions') = HM.foldlWithKey' objectMoves ([], [], HM.toList dels') adds' + deletions = concatMap (\(k,v) -> del cfg (Pointer [OKey k]) v) deletions' -- Changes - chg_keys = filter (`elem` k2) k1 changes :: [Operation] changes = concatMap (\k -> worker (Pointer [OKey k]) (fromJust $ HM.lookup k o1) (fromJust $ HM.lookup k o2)) - chg_keys - in modifyPointer (path <>) <$> (deletions <> insertions <> changes) + (HS.toList chg_keys) + in modifyPointer (path <>) <$> (insertions <> deletions <> moves <> changes) -- Use an adaption of the Wagner-Fischer algorithm to find the shortest -- sequence of changes between two JSON arrays. workArray :: Pointer -> Array -> Array -> [Operation] - workArray path ss tt = fmap (modifyPointer (path <>)) . snd . fmap concat $ leastChanges params ss tt + workArray path ss tt = rewriteLocalMoves . fmap (modifyPointer (path <>)) . snd . fmap concat $ leastChanges params ss tt where params :: Params Value [Operation] (Sum Int) params = Params{..} @@ -206,6 +216,24 @@ diff' cfg@Config{..} v v' = Patch (worker mempty v v') | otherwise = 0 pos Tst{changePointer=Pointer path} = 0 +-- | Replace add/remove pairs with moves. +-- +-- This only works for sibling keys and for values that are otherwise unmodified. +-- And it's inefficient to boot. +rewriteLocalMoves :: [Operation] -> [Operation] +rewriteLocalMoves ops = ops + +renderDiff :: Operation -> Text +renderDiff (Add (formatPointer -> p) (formatValue -> v)) = T.unwords ["ADD", p, v] +renderDiff (Cpy (formatPointer -> p1) (formatPointer -> p2)) = T.unwords ["COPY", p1, p2] +renderDiff (Mov (formatPointer -> p1) (formatPointer -> p2)) = T.unwords ["MOVE", p1, p2] +renderDiff (Rem (formatPointer -> p) _) = T.unwords ["REMOVE", p] +renderDiff (Rep (formatPointer -> p) (formatValue -> v)) = T.unwords ["REPLACE", p, v] +renderDiff (Tst (formatPointer -> p) (formatValue -> v)) = T.unwords ["TEST", p, v] + +formatValue :: Value -> Text +formatValue = TE.decodeUtf8 . BS.toStrict . encode + -- * Patching -- | Apply a patch to a JSON document. @@ -223,7 +251,7 @@ applyOperation -> Result Value applyOperation op json = case op of Add path v' -> applyAdd path v' json - Rem path -> applyRem path json + Rem path _ -> applyRem path json Rep path v' -> applyRep path v' json Tst path v -> applyTst path v json Cpy path from -> applyCpy path from json diff --git a/lib/Data/Aeson/Patch.hs b/lib/Data/Aeson/Patch.hs index 5907a95..f63b151 100644 --- a/lib/Data/Aeson/Patch.hs +++ b/lib/Data/Aeson/Patch.hs @@ -64,7 +64,7 @@ data Operation -- ^ http://tools.ietf.org/html/rfc6902#section-4.5 | Mov { changePointer :: Pointer, fromPointer :: Pointer } -- ^ http://tools.ietf.org/html/rfc6902#section-4.4 - | Rem { changePointer :: Pointer } + | Rem { changePointer :: Pointer, deletedValue :: Maybe Value } -- ^ http://tools.ietf.org/html/rfc6902#section-4.2 | Rep { changePointer :: Pointer, changeValue :: Value } -- ^ http://tools.ietf.org/html/rfc6902#section-4.3 @@ -88,7 +88,7 @@ instance ToJSON Operation where , "path" .= p , "from" .= f ] - toJSON (Rem p) = object + toJSON (Rem p _) = object [ ("op", "remove") , "path" .= p ] @@ -110,7 +110,7 @@ instance FromJSON Operation where = (op v "add" *> (Add <$> v .: "path" <*> v .: "value")) <|> (op v "copy" *> (Cpy <$> v .: "path" <*> v .: "from")) <|> (op v "move" *> (Mov <$> v .: "path" <*> v .: "from")) - <|> (op v "remove" *> (Rem <$> v .: "path")) + <|> (op v "remove" *> (Rem <$> v .: "path" <*> (pure Nothing))) <|> (op v "replace" *> (Rep <$> v .: "path" <*> v .: "value")) <|> (op v "test" *> (Tst <$> v .: "path" <*> v .: "value")) <|> fail ("Expected a JSON patch operation, encountered: " <> BS.unpack (encode o)) diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..8d62222 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 523700 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/7.yaml + sha256: 8e3f3c894be74d71fa4bf085e0a8baae7e4d7622d07ea31a52736b80f8b9bb1a + original: lts-14.7 diff --git a/test/data/diff-cases/c1-a.json b/test/data/diff-cases/c1-a.json new file mode 100644 index 0000000..5e19304 --- /dev/null +++ b/test/data/diff-cases/c1-a.json @@ -0,0 +1 @@ +["a", "b", "c"] \ No newline at end of file diff --git a/test/data/diff-cases/c1-b.json b/test/data/diff-cases/c1-b.json new file mode 100644 index 0000000..30432d1 --- /dev/null +++ b/test/data/diff-cases/c1-b.json @@ -0,0 +1 @@ +["a", "c", "b"] \ No newline at end of file diff --git a/test/data/diff-cases/c1-patch.json b/test/data/diff-cases/c1-patch.json new file mode 100644 index 0000000..55ad233 --- /dev/null +++ b/test/data/diff-cases/c1-patch.json @@ -0,0 +1,7 @@ +[ + { + "op": "move", + "from": "/1", + "path": "/2" + } +] \ No newline at end of file diff --git a/test/data/diff-cases/c2-a.json b/test/data/diff-cases/c2-a.json new file mode 100644 index 0000000..5527ab8 --- /dev/null +++ b/test/data/diff-cases/c2-a.json @@ -0,0 +1,5 @@ +{ + "a": 1, + "b": 2, + "c": 3 +} \ No newline at end of file diff --git a/test/data/diff-cases/c2-b.json b/test/data/diff-cases/c2-b.json new file mode 100644 index 0000000..7fd6b56 --- /dev/null +++ b/test/data/diff-cases/c2-b.json @@ -0,0 +1,5 @@ +{ + "a": 1, + "c": 3, + "d": 2 +} \ No newline at end of file diff --git a/test/data/diff-cases/c2-patch.json b/test/data/diff-cases/c2-patch.json new file mode 100644 index 0000000..27f8572 --- /dev/null +++ b/test/data/diff-cases/c2-patch.json @@ -0,0 +1,7 @@ +[ + { + "op": "move", + "from": "/b", + "path": "/d" + } +] \ No newline at end of file diff --git a/test/data/cases/case1-original.json b/test/data/patch-cases/case1-original.json similarity index 100% rename from test/data/cases/case1-original.json rename to test/data/patch-cases/case1-original.json diff --git a/test/data/cases/case1-patch.json b/test/data/patch-cases/case1-patch.json similarity index 100% rename from test/data/cases/case1-patch.json rename to test/data/patch-cases/case1-patch.json diff --git a/test/data/cases/case1-result.json b/test/data/patch-cases/case1-result.json similarity index 100% rename from test/data/cases/case1-result.json rename to test/data/patch-cases/case1-result.json diff --git a/test/data/cases/case2-original.json b/test/data/patch-cases/case2-original.json similarity index 100% rename from test/data/cases/case2-original.json rename to test/data/patch-cases/case2-original.json diff --git a/test/data/cases/case2-patch.json b/test/data/patch-cases/case2-patch.json similarity index 100% rename from test/data/cases/case2-patch.json rename to test/data/patch-cases/case2-patch.json diff --git a/test/data/cases/case2-result.json b/test/data/patch-cases/case2-result.json similarity index 100% rename from test/data/cases/case2-result.json rename to test/data/patch-cases/case2-result.json diff --git a/test/data/cases/case3-error.txt b/test/data/patch-cases/case3-error.txt similarity index 100% rename from test/data/cases/case3-error.txt rename to test/data/patch-cases/case3-error.txt diff --git a/test/data/cases/case3-original.json b/test/data/patch-cases/case3-original.json similarity index 100% rename from test/data/cases/case3-original.json rename to test/data/patch-cases/case3-original.json diff --git a/test/data/cases/case3-patch.json b/test/data/patch-cases/case3-patch.json similarity index 100% rename from test/data/cases/case3-patch.json rename to test/data/patch-cases/case3-patch.json diff --git a/test/data/cases/case4-error.txt b/test/data/patch-cases/case4-error.txt similarity index 100% rename from test/data/cases/case4-error.txt rename to test/data/patch-cases/case4-error.txt diff --git a/test/data/cases/case4-original.json b/test/data/patch-cases/case4-original.json similarity index 100% rename from test/data/cases/case4-original.json rename to test/data/patch-cases/case4-original.json diff --git a/test/data/cases/case4-patch.json b/test/data/patch-cases/case4-patch.json similarity index 100% rename from test/data/cases/case4-patch.json rename to test/data/patch-cases/case4-patch.json diff --git a/test/data/cases/case5-error.txt b/test/data/patch-cases/case5-error.txt similarity index 100% rename from test/data/cases/case5-error.txt rename to test/data/patch-cases/case5-error.txt diff --git a/test/data/cases/case5-original.json b/test/data/patch-cases/case5-original.json similarity index 100% rename from test/data/cases/case5-original.json rename to test/data/patch-cases/case5-original.json diff --git a/test/data/cases/case5-patch.json b/test/data/patch-cases/case5-patch.json similarity index 100% rename from test/data/cases/case5-patch.json rename to test/data/patch-cases/case5-patch.json diff --git a/test/diff-examples.hs b/test/diff-examples.hs new file mode 100644 index 0000000..fc35589 --- /dev/null +++ b/test/diff-examples.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TupleSections #-} + +-- | Test examples from RFC 6902 sections A.1 to A.16. + +module Main where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Diff +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Char +import Data.Either +import Data.Functor +import Data.List (isInfixOf, nub) +import Data.Maybe +import Data.Monoid +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.FilePath.Glob + +roots :: [FilePath] +roots = ["test/data/diff-cases"] + +globPattern :: FilePath +globPattern = "*.*" + +derp :: String -> a +derp msg = throw (AssertionFailed $ " " <> msg) + +readOriginal :: FilePath -> FilePath -> IO Value +readOriginal root name = do + let file = root name <> "-a.json" + doc <- eitherDecodeStrict <$> BS.readFile file + + return $ either (\e -> derp $ "Could not decode original: " <> e) id doc + +readChanged :: FilePath -> FilePath -> IO Value +readChanged root name = do + let file = root name <> "-b.json" + doc <- eitherDecodeStrict <$> BS.readFile file + + return $ either (\e -> derp $ "Could not decode changed: " <> e) id doc + +readPatch :: FilePath -> FilePath -> IO Patch +readPatch root name = do + let file = root name <> "-patch.json" + doc <- eitherDecodeStrict <$> BS.readFile file + + return $ either (\e -> derp $ "Could not decode patch: " <> e) id doc + +readExample :: FilePath -> FilePath -> IO (Value, Value, Patch) +readExample root name = + (,,) <$> readOriginal root name + <*> readChanged root name + <*> readPatch root name + +-- | Check example and, if it fails, return an error message. +runExample :: (Value, Value, Patch) -> Maybe String +runExample (doc, changed, res) = + case diff doc changed of + dest | dest == res -> success "Result matches target" + | otherwise -> failure ("Result patch did not match: " <> BL.unpack (encode dest)) + where + success n = Nothing + failure n = Just ("Test Fails - " <> n) + +testExample :: FilePath -> FilePath -> IO (Maybe String) +testExample root name = do + r <- try (runExample <$> readExample root name) + return $ either err id r + where + err :: AssertionFailed -> Maybe String + err e = Just ("Error: " <> show e) + +runSuite :: FilePath -> IO [(FilePath, Maybe String)] +runSuite root = do + -- Gather directories in test/data + let p = simplify (compile globPattern) + examples <- nub . fmap (takeWhile (/= '-')) . filter (match p) <$> getDirectoryContents root + -- Test each of them + mapM (\nom -> (nom,) <$> testExample root nom) examples + +main :: IO () +main = do + args <- getArgs + results <- concat <$> mapM runSuite (if null args then roots else args) + mapM_ display results + -- Failure. + when (any (isJust . snd) results) + exitFailure + where + display :: (FilePath, Maybe String) -> IO () + display (name, Nothing) = + putStrLn $ "SUCCESS: " <> name + display (name, Just err) = + putStrLn $ "FAILURE: " <> name <> ": " <> err diff --git a/test/examples.hs b/test/patch-examples.hs similarity index 98% rename from test/examples.hs rename to test/patch-examples.hs index 77cc87b..1491103 100644 --- a/test/examples.hs +++ b/test/patch-examples.hs @@ -25,7 +25,7 @@ import System.FilePath import System.FilePath.Glob roots :: [FilePath] -roots = ["test/data/rfc6902", "test/data/cases"] +roots = ["test/data/rfc6902", "test/data/patch-cases"] globPattern :: FilePath globPattern = "*.*" @@ -40,7 +40,6 @@ readDocument root name = do return $ either (\e -> derp $ "Could not decode document: " <> e) id doc - readPatch :: FilePath -> FilePath -> IO (Either String Patch) readPatch root name = do let file = root name <> "-patch.json" @@ -66,7 +65,7 @@ readResult root name = do handle :: IOException -> IO (Maybe a) handle e = return Nothing -readExample :: FilePath -> FilePath -> IO (Value, Either String Patch, Either String Value) +readExample :: FilePath -> FilePath -> IO (Value, Either String Patch , Either String Value) readExample root name = (,,) <$> readDocument root name <*> readPatch root name