diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for jsonpath-hs + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Akshay Mankar (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Akshay Mankar nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# jsonpath-hs + +Implementation of jsonpath as [described by Steffen Göessner](https://goessner.net/articles/JsonPath/). + +## State of this library + +This library is still work in progress, but feel free to use it create issues. It lacks some features and has a few variances from the description. + +### Missing Features +* The Length funtion: The ability to say `$.length`. It will just look for `length` key as of now. +* ScriptExpression: The ability to say things like `$.book[(3+1)]` + +### Variances +* The `$` sign in the beginning is not compulsory +* The `$..*` will not produce the root object itself. +## Shout out to [JSON-Path-Test-Suite](https://github.com/gregsdennis/JSON-Path-Test-Suite/tree/master/Tests) +I have copied a few of the tests from there, I will probably just sub-module the repository if and when the whole test suite is green. + +## Uses +I am using this library to support GCP authentication in the [Kubernetes haskell client](http://github.com/kubernetes-client/haskell). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/jsonpath.cabal b/jsonpath.cabal new file mode 100644 --- /dev/null +++ b/jsonpath.cabal @@ -0,0 +1,72 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: fabb3215a8083837cad56530f0576cfca0cb5d7f685b839c26adcf1f3eb129ab + +name: jsonpath +version: 0.1.0.0 +synopsis: Library to parse and execute JSONPath +description: Please see the README on GitHub at +category: Text, Web, JSON +homepage: https://github.com/akshaymankar/jsonpath-hs#readme +bug-reports: https://github.com/akshaymankar/jsonpath-hs/issues +author: Akshay Mankar +maintainer: itsakshaymankar@gmail.com +copyright: Akshay Mankar +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/akshaymankar/jsonpath-hs + +library + exposed-modules: + Data.JSONPath + Data.JSONPath.Execute + Data.JSONPath.ExecutionResult + Data.JSONPath.Parser + Data.JSONPath.Types + other-modules: + Paths_jsonpath + hs-source-dirs: + src + build-depends: + aeson >=1.4.2 && <1.5 + , attoparsec >=0.13.2 && <0.14 + , base >=4.7 && <5 + , text >=1.2.3 && <1.3 + , unordered-containers >=0.2.10 && <0.3 + , vector >=0.12.0 && <0.13 + default-language: Haskell2010 + +test-suite jsonpath-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Data.JSONPathSpec + Paths_jsonpath + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.4.2 && <1.5 + , aeson-casing + , attoparsec >=0.13.2 && <0.14 + , base >=4.7 && <5 + , bytestring + , file-embed + , hspec + , hspec-attoparsec + , jsonpath + , text >=1.2.3 && <1.3 + , unordered-containers >=0.2.10 && <0.3 + , vector >=0.12.0 && <0.13 + default-language: Haskell2010 diff --git a/src/Data/JSONPath.hs b/src/Data/JSONPath.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSONPath.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.JSONPath + ( module Data.JSONPath.Types + , module Data.JSONPath.Parser + , module Data.JSONPath.Execute + ) +where + +import Data.JSONPath.Types +import Data.JSONPath.Parser +import Data.JSONPath.Execute diff --git a/src/Data/JSONPath/Execute.hs b/src/Data/JSONPath/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSONPath/Execute.hs @@ -0,0 +1,106 @@ +module Data.JSONPath.Execute + (executeJSONPath, executeJSONPathEither, executeJSONPathElement) +where + +import Data.Aeson +import Data.Aeson.Text +import Data.Function ((&)) +import Data.HashMap.Strict as Map +import Data.JSONPath.Types +import Data.Text (unpack) + +import qualified Data.Text.Lazy as LazyText +import qualified Data.Vector as V + +executeJSONPath :: [JSONPathElement] -> Value -> ExecutionResult Value +executeJSONPath [] val = ResultError "empty json path" +executeJSONPath (j:[]) val = executeJSONPathElement j val +executeJSONPath (j:js) val = executeJSONPath js =<< executeJSONPathElement j val + +executeJSONPathEither :: [JSONPathElement] -> Value -> Either String [Value] +executeJSONPathEither js val = resultToEither $ executeJSONPath js val + +executeJSONPathElement :: JSONPathElement -> Value -> ExecutionResult Value +executeJSONPathElement (KeyChild key) val = + case val of + Object o -> Map.lookup key o + & (maybeToResult (notFoundErr key o)) + _ -> ResultError $ expectedObjectErr val +executeJSONPathElement (AnyChild) val = + case val of + Object o -> ResultList $ Map.elems o + Array a -> ResultList $ V.toList a + _ -> ResultError $ expectedObjectErr val +executeJSONPathElement (Slice slice) val = + case val of + Array a -> executeSliceElement slice a + _ -> ResultError $ expectedArrayErr val +executeJSONPathElement (SliceUnion first second) val = + case val of + Array a -> appendResults (executeSliceElement first a) (executeSliceElement second a) + _ -> ResultError $ expectedArrayErr val +executeJSONPathElement (Filter _ jsonPath cond lit) val = + case val of + Array a -> do + let l = V.toList a + ResultList $ Prelude.map (executeJSONPath jsonPath) l + & zip l + & excludeSndErrors + & Prelude.foldr (\(x,ys) acc -> if length ys == 1 then (x, head ys):acc else acc) [] + & Prelude.filter (\(origVal, exprVal) -> executeCondition exprVal cond lit) + & Prelude.map fst + _ -> ResultError $ expectedArrayErr val +executeJSONPathElement s@(Search js) val = + let x = either (const []) id $ executeJSONPathEither js val + y = excludeErrors $ valMap (executeJSONPathElement s) val + in if Prelude.null x && Prelude.null y + then ResultError "Search failed" + else ResultList $ x ++ y + +valMap :: ToJSON b => (Value -> ExecutionResult b) -> Value -> [ExecutionResult b] +valMap f v@(Object o) = elems $ Map.map f o +valMap f (Array a) = V.toList $ V.map f a +valMap _ v = pure $ ResultError $ "Expected object or array, found " <> (encodeJSONToString v) + +executeCondition :: Value -> Condition -> Literal -> Bool +executeCondition (Number n1) Equal (LitNumber n2) = n1 == (fromInteger $ toInteger n2) +executeCondition (String s1) Equal (LitString s2) = s1 == s2 + +executeSliceElement :: SliceElement -> V.Vector Value -> ExecutionResult Value +executeSliceElement (SingleIndex i) v = if i < 0 + then maybeToResult (invalidIndexErr i v) $ (V.!?) v (V.length v + i) + else maybeToResult (invalidIndexErr i v) $ (V.!?) v i +executeSliceElement (SimpleSlice start end) v = sliceEither v start end 1 +executeSliceElement (SliceWithStep start end step) v = sliceEither v start end step +executeSliceElement (SliceTo end) v = sliceEither v 0 end 1 +executeSliceElement (SliceToWithStep end step) v = sliceEither v 0 end step +executeSliceElement (SliceFrom start) v = sliceEither v start (-1) 1 +executeSliceElement (SliceFromWithStep start step) v = sliceEither v start (-1) step +executeSliceElement (SliceWithOnlyStep step) v = sliceEither v 0 (-1) step + +sliceEither :: ToJSON a + => V.Vector a -> Int -> Int -> Int -> ExecutionResult a +sliceEither v start end step = let len = V.length v + realStart = if start < 0 then len + start else start + realEnd = if end < 0 then len + end + 1 else end + in if realStart < realEnd + then appendResults (indexEither v realStart) (sliceEither v (realStart + step) realEnd step) + else ResultList [] + +indexEither :: ToJSON a => V.Vector a -> Int -> ExecutionResult a +indexEither v i = (V.!?) v i + & maybeToResult (invalidIndexErr i v) + +excludeSndErrors :: [(c, ExecutionResult a)] -> [(c, [a])] +excludeSndErrors xs = Prelude.foldr accumulateFn ([] :: [(c, b)]) xs where + accumulateFn (x, ResultList ys) acc = (x, ys):acc + accumulateFn (x, ResultValue y) acc = (x, [y]):acc + accumulateFn (x, _) acc = acc + +encodeJSONToString :: ToJSON a => a -> String +encodeJSONToString x = LazyText.unpack $ encodeToLazyText x + +notFoundErr key o = "expected key " <> unpack key <> " in object " <> (encodeJSONToString o) +invalidIndexErr i a = "index " <> show i <> " invalid for array " <> (encodeJSONToString a) +expectedObjectErr val = "expected object, found " <> (encodeJSONToString val) +expectedArrayErr val = "expected array, found " <> (encodeJSONToString val) diff --git a/src/Data/JSONPath/ExecutionResult.hs b/src/Data/JSONPath/ExecutionResult.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSONPath/ExecutionResult.hs @@ -0,0 +1,59 @@ +module Data.JSONPath.ExecutionResult where + +data ExecutionResult a = ResultList [a] + | ResultValue a + | ResultError String + +instance Functor ExecutionResult where + fmap f (ResultList xs) = ResultList $ Prelude.map f xs + fmap f (ResultValue x) = ResultValue $ f x + fmap f (ResultError err) = ResultError err + +instance Applicative ExecutionResult where + pure = ResultValue + (<*>) (ResultList fs) (ResultList xs) = ResultList $ fs <*> xs + (<*>) (ResultList fs) (ResultValue x) = ResultList $ Prelude.map (\f -> f x) fs + (<*>) (ResultValue f) (ResultList xs) = ResultList $ Prelude.map f xs + (<*>) (ResultValue f) (ResultValue x) = ResultValue $ f x + (<*>) (ResultError e) _ = ResultError e + (<*>) _ (ResultError e) = ResultError e + +instance Monad ExecutionResult where + (>>=) (ResultValue x) f = f x + (>>=) (ResultList xs) f = concatResults $ Prelude.map f xs + (>>=) (ResultError e) f = ResultError e + +concatResults :: [ExecutionResult a] -> ExecutionResult a +concatResults [] = ResultList [] +concatResults (ResultList xs:rs) = case concatResults rs of + ResultList ys -> ResultList (xs ++ ys) + ResultValue y -> ResultList (y:xs) + e -> e +concatResults (ResultValue x:[]) = ResultValue x +concatResults (ResultValue x:rs) = case concatResults rs of + ResultList ys -> ResultList (x:ys) + ResultValue y -> ResultList [x,y] + e -> e +concatResults (e:_) = e + +appendResults :: ExecutionResult a -> ExecutionResult a -> ExecutionResult a +appendResults (ResultValue x) (ResultValue y) = ResultList [x,y] +appendResults (ResultValue x) (ResultList ys) = ResultList $ x:ys +appendResults (ResultList xs) (ResultValue y) = ResultList $ y:xs +appendResults (ResultList xs) (ResultList ys) = ResultList $ xs ++ ys +appendResults _ e = e + +maybeToResult :: String -> Maybe a ->ExecutionResult a +maybeToResult _ (Just x) = ResultValue x +maybeToResult err _ = ResultError err + +resultToEither :: ExecutionResult a -> Either String [a] +resultToEither (ResultList xs) = return xs +resultToEither (ResultValue x) = return [x] +resultToEither (ResultError e) = Left e + +excludeErrors :: [ExecutionResult a] -> [a] +excludeErrors [] = [] +excludeErrors (ResultError _:rs) = excludeErrors rs +excludeErrors (ResultList xs:rs) = xs ++ excludeErrors rs +excludeErrors (ResultValue x:rs) = x:(excludeErrors rs) diff --git a/src/Data/JSONPath/Parser.hs b/src/Data/JSONPath/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSONPath/Parser.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.JSONPath.Parser + (jsonPathElement, jsonPath) +where + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text as A +import Data.Functor +import Data.JSONPath.Types + +jsonPath :: Parser [JSONPathElement] +jsonPath = do + _ <- skip (== '$') <|> pure () + many1 jsonPathElement + +jsonPathElement :: Parser JSONPathElement +jsonPathElement = do + (keyChildDot "keyChldDot") + <|> (keyChildBracket "keyChildBracket") + <|> (keyChildren "keyChildren") + <|> (anyChild "anyChild") + <|> (slice "slice") + <|> (sliceUnion "sliceUnion") + <|> (filterParser "filterParser") + <|> (search "serach") + <|> (searchBeginingWithSlice "serachBegingingWithSlice") + +slice :: Parser JSONPathElement +slice = Slice <$> ignoreSurroundingSqBr sliceWithoutBrackets + +sliceWithoutBrackets = (sliceWithStep "sliceWithStep") + <|> (simpleSlice "simpleSlice") + <|> (sliceFromWithStep "sliceFromWithStep") + <|> (sliceFrom "sliceFrom") + <|> (singleIndex "singleIndex") + <|> (sliceToWithStep "sliceToWithStep") + <|> (sliceTo "sliceTo") + <|> (sliceWithOnlyStep "sliceWithOnlyStep") + +singleIndex :: Parser SliceElement +singleIndex = SingleIndex <$> signed decimal + +keyChildBracket :: Parser JSONPathElement +keyChildBracket = KeyChild + <$> (string "['" *> takeWhile1 (inClass "a-zA-Z0-9_-") <* string "']") + +keyChildDot :: Parser JSONPathElement +keyChildDot = KeyChild + <$> (char '.' *> takeWhile1 (inClass "a-zA-Z0-9_-")) + +keyChildren :: Parser JSONPathElement +keyChildren = do + _ <- string "['" + firstKey <- takeWhile1 (inClass "a-zA-Z0-9_-") + restKeys <- many' $ char '.' *> takeWhile1 (inClass "a-zA-Z0-9_-") + _ <- string "']" + return $ KeyChildren (firstKey:restKeys) + +anyChild :: Parser JSONPathElement +anyChild = AnyChild <$ (string ".*" <|> string "[*]") + +-- peekAssertClosingSqBr :: Parser () +-- peekAssertClosingSqBr + +simpleSlice :: Parser SliceElement +simpleSlice = do + start <- signed decimal + _ <- char ':' + end <- signed decimal + return $ SimpleSlice start end + +sliceWithStep :: Parser SliceElement +sliceWithStep = do + start <- signed decimal + _ <- char ':' + end <- signed decimal + _ <- char ':' + step <- signed decimal + return $ SliceWithStep start end step + +sliceFrom :: Parser SliceElement +sliceFrom = do + start <- signed decimal + _ <- char ':' + return $ SliceFrom start + +sliceFromWithStep :: Parser SliceElement +sliceFromWithStep = do + start <- signed decimal + _ <- string "::" + step <- signed decimal + return $ SliceFromWithStep start step + +sliceTo :: Parser SliceElement +sliceTo = do + _ <- char ':' + end <- signed decimal + return $ SliceTo end + +sliceToWithStep :: Parser SliceElement +sliceToWithStep = do + _ <- char ':' + end <- signed decimal + _ <- char ':' + step <- signed decimal + return $ SliceToWithStep end step + +sliceWithOnlyStep :: Parser SliceElement +sliceWithOnlyStep = do + _ <- string "::" + step <- signed decimal + return $ SliceWithOnlyStep step + +sliceUnion :: Parser JSONPathElement +sliceUnion = ignoreSurroundingSqBr $ do + firstElement <- sliceWithoutBrackets "firstElement" + _ <- char ',' + secondElement <- sliceWithoutBrackets "secondElement" + return $ SliceUnion firstElement secondElement + +filterParser :: Parser JSONPathElement +filterParser = do + _ <- string "[?(" "[?(" + b <- beginingPoint "begining point" + js <- jsonPath "jsonPathElements" + c <- condition "condition" + l <- literal "literal" + _ <- string ")]" ")]" + return $ Filter b js c l + +search :: Parser JSONPathElement +search = do + _ <- char '.' + isDot <- (== '.') <$> peekChar' + if isDot + then Search <$> many1 jsonPathElement + else fail "not a search element" + +searchBeginingWithSlice :: Parser JSONPathElement +searchBeginingWithSlice = do + _ <- string ".." + isBracket <- (== '[') <$> peekChar' + if isBracket + then Search <$> many1 jsonPathElement + else fail "not a search element" + +beginingPoint :: Parser BegingingPoint +beginingPoint = do + ((char '$' $> Root) <|> (char '@' $> CurrentObject)) + +condition :: Parser Condition +condition = ignoreSurroundingSpace + $ string "==" $> Equal + <|> string "!=" $> NotEqual + <|> string ">" $> GreaterThan + <|> string "<" $> SmallerThan + +literal :: Parser Literal +literal = do + (LitNumber <$> signed decimal) + <|> LitString <$> (char '"' *> A.takeWhile (/= '"') <* char '"') + +ignoreSurroundingSpace :: Parser a -> Parser a +ignoreSurroundingSpace p = many' space *> p <* many' space + +ignoreSurroundingSqBr :: Parser a -> Parser a +ignoreSurroundingSqBr p = char '[' *> p <* char ']' diff --git a/src/Data/JSONPath/Types.hs b/src/Data/JSONPath/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSONPath/Types.hs @@ -0,0 +1,45 @@ +module Data.JSONPath.Types + ( BegingingPoint(..) + , Condition(..) + , Literal(..) + , JSONPathElement(..) + , SliceElement(..) + , module Data.JSONPath.ExecutionResult + ) +where + +import Data.Text +import Data.JSONPath.ExecutionResult + +data BegingingPoint = Root + | CurrentObject + deriving (Show, Eq) + +data Condition = Equal + | NotEqual + | GreaterThan + | SmallerThan + deriving (Show, Eq) + +data Literal = LitNumber Int + | LitString Text + deriving (Show, Eq) + +data SliceElement = SingleIndex Int + | SimpleSlice Int Int + | SliceWithStep Int Int Int + | SliceTo Int + | SliceToWithStep Int Int + | SliceFrom Int + | SliceFromWithStep Int Int + | SliceWithOnlyStep Int + deriving (Show, Eq) + +data JSONPathElement = KeyChild Text + | KeyChildren [Text] + | AnyChild + | Slice SliceElement + | SliceUnion SliceElement SliceElement + | Filter BegingingPoint [JSONPathElement] Condition Literal + | Search [JSONPathElement] + deriving (Show, Eq) diff --git a/test/Data/JSONPathSpec.hs b/test/Data/JSONPathSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/JSONPathSpec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.JSONPathSpec where + +import Data.Aeson +import Data.Aeson.Casing +import Data.Aeson.Text +import Data.Aeson.TH +import Data.Attoparsec.Text +import Data.Either +import Data.FileEmbed +import Data.JSONPath +import Data.Text (Text, unpack) +import GHC.Generics +import Test.Hspec +import Test.Hspec.Attoparsec + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Lazy as LazyText +import qualified Data.Vector as V + +data Test = Test { path :: Text + , result :: Value + } + deriving (Eq, Show, Generic) + +data TestGroup = TestGroup { groupTitle :: Text + , groupData :: Value + , groupTests :: [Test] + } + deriving (Eq, Show, Generic) + +$(deriveJSON defaultOptions ''Test) +$(deriveJSON (aesonPrefix snakeCase) ''TestGroup) + +spec :: Spec +spec = + let testFiles = map snd $(embedDir "test/resources/json-path-tests") + testVals :: Either String [TestGroup] + testVals = sequenceA $ map (eitherDecode . LBS.fromStrict) testFiles + in case testVals of + Left e -> describe "JSONPath Tests" + $ it "shouldn't fail to parse test files" + $ expectationFailure ("failed to parse test files with error: \n" <> e) + Right gs -> describe "JSONPath" + $ do + mapM_ group gs + describe "Parser" $ do + it "should parse basic things" $ do + (".foo" :: Text) ~> (jsonPathElement <* endOfInput) + `shouldParse` KeyChild "foo" + ("$.foo" :: Text) ~> (jsonPath <* endOfInput) + `shouldParse` [KeyChild "foo"] + +parseJSONPath :: Text -> Either String [JSONPathElement] +parseJSONPath = parseOnly (jsonPath <* endOfInput) + +group :: TestGroup -> Spec +group TestGroup{..} = describe (unpack groupTitle) + $ mapM_ (test groupData) groupTests + +test :: Value -> Test -> Spec +test testData (Test path expected) = + let result = parseJSONPath path >>= (flip executeJSONPathEither testData) + in it (unpack path) $ + case expected of + Array a -> case result of + Left err -> expectationFailure $ "Unexpected Left: " <> err + Right r -> r `shouldMatchList` (V.toList a) + Bool False -> result `shouldSatisfy` isLeft + v -> expectationFailure $ "Invalid result in test data " <> (LazyText.unpack $ encodeToLazyText v) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}