diff --git a/Example.hs b/Example.hs new file mode 100644 --- /dev/null +++ b/Example.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (unless) +import Data.Aeson +import qualified Data.Aeson.Pointer as P + +main :: IO () +main = do + -- JSON Pointers must either be empty or start with a /. + pntr1 <- case P.unescape "/foo/0" of + Left _ -> error "Failed to construct JSON Pointer." + Right pntr -> return pntr + + -- We can also write JSON Pointers in Haskell. + let pntr2 = P.Pointer [P.Token "/"] + -- When we do this we don't have to escape / or ~ characters + -- (as ~1 and ~0 respectively) like we do in an escaped JSON + -- Pointer string. + unless (P.unescape "/~1" == Right pntr2) (error "ohno!") + + print (P.resolve pntr1 document) + print (P.resolve pntr2 document) + + where + document :: Value + document = object [ "foo" .= [String "bar", String "baz"] + , "/" .= String "quux" + ] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,28 +2,45 @@ [JSON Pointer](http://tools.ietf.org/html/rfc6901) library for Haskell. +[Hackage](https://hackage.haskell.org/package/hjsonpointer) / [GitHub](https://github.com/seagreen/hjsonpointer) / [Travis CI](https://travis-ci.org/seagreen/hjsonpointer) + # Example -``` +```haskell {-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Monad (unless) import Data.Aeson -import qualified Data.HashMap.Strict as H -import Data.JsonPointer +import qualified Data.Aeson.Pointer as P main :: IO () -main = - case jsonPointer "/foo" of - Left e -> print e - Right pntr -> - case resolvePointer pntr (Object $ H.singleton "foo" $ String "bar") of - Left e2 -> print e2 - Right v -> print v +main = do + -- JSON Pointers must either be empty or start with a /. + pntr1 <- case P.unescape "/foo/0" of + Left _ -> error "Failed to construct JSON Pointer." + Right pntr -> pure pntr + + -- We can also write JSON Pointers in Haskell. + let pntr2 = P.Pointer [P.Token "/"] + -- When we do this we don't have to escape / or ~ characters + -- (as ~1 and ~0 respectively) like we do in an escaped JSON + -- Pointer string. + unless (P.unescape "/~1" == Right pntr2) (error "ohno!") + + print (P.resolve pntr1 document) + print (P.resolve pntr2 document) + + where + document :: Value + document = object [ "foo" .= [String "bar", String "baz"] + , "/" .= String "quux" + ] ``` Output: ``` -String "bar" +Right (String "bar") +Right (String "quux") ``` diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,13 @@ +# 0.3 + ++ Rewrite. + +# 0.2 + ++ Fix mistake in `resolveRefTok`. ++ Split errors over two types. ++ Switch the order of pointer and value arguments for functions that take both. The pointer now comes first. + +# 0.1 + ++ Initial implementation. diff --git a/changelog.txt b/changelog.txt deleted file mode 100644 --- a/changelog.txt +++ /dev/null @@ -1,9 +0,0 @@ -# 0.2 - -Fix mistake in resolveRefTok. -Split errors over two types. -Switch the order of pointer and value arguments for functions that take both. The pointer now comes first. - -# 0.1 - -Initial implementation. diff --git a/hjsonpointer.cabal b/hjsonpointer.cabal --- a/hjsonpointer.cabal +++ b/hjsonpointer.cabal @@ -1,5 +1,5 @@ name: hjsonpointer -version: 0.2.0.4 +version: 0.3.0.0 synopsis: JSON Pointer library homepage: https://github.com/seagreen/hjsonpointer license: MIT @@ -9,17 +9,20 @@ category: Data build-type: Simple cabal-version: >=1.10 -extra-source-files: changelog.txt +tested-with: GHC == 7.8.4, GHC == 7.10.3 +extra-source-files: changelog.md README.md library hs-source-dirs: src - exposed-modules: Data.JsonPointer + exposed-modules: Data.Aeson.Pointer default-language: Haskell2010 default-extensions: OverloadedStrings + other-extensions: GeneralizedNewtypeDeriving ghc-options: -Wall - build-depends: aeson >= 0.7 && < 0.10 + build-depends: aeson >= 0.7 && < 0.12 , base >= 4.6 && < 4.9 + , QuickCheck >= 2.8 && < 2.9 , unordered-containers >= 0.2 && < 0.3 , text >= 1.2 && < 1.3 , vector >= 0.10 && < 0.12 @@ -37,10 +40,19 @@ , unordered-containers , text , vector - , http-types >= 0.8 && < 0.9 - , HUnit >= 1.2 && < 1.4 - , test-framework >= 0.8 && < 0.9 - , test-framework-hunit >= 0.3 && < 0.4 + , http-types >= 0.8 && < 0.10 + , HUnit >= 1.2 && < 1.4 + , test-framework >= 0.8 && < 0.9 + , test-framework-hunit >= 0.3 && < 0.4 + , test-framework-quickcheck2 >= 0.3 && < 0.4 + +executable example + main-is: Example.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: aeson + , base + , hjsonpointer source-repository head type: git diff --git a/src/Data/Aeson/Pointer.hs b/src/Data/Aeson/Pointer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Pointer.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Aeson.Pointer where + +import Control.Monad (when) +import Data.Aeson +import qualified Data.HashMap.Strict as H +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Test.QuickCheck +import Text.Read (readMaybe) + +-- For GHCs before 7.10: +import Control.Applicative +import Data.Monoid +import Data.Traversable + +newtype Pointer + = Pointer { _unPointer :: [Token] } + deriving (Eq, Show, Monoid, Arbitrary) + +instance FromJSON Pointer where + parseJSON = withText "JSON Pointer" $ \t -> + case unescape t of + Left e -> fail (show e) + Right p -> pure p + +instance ToJSON Pointer where + toJSON = String . escape + +-- | We don't try to distinguish between integer tokens and string +-- tokens since all tokens start as strings, and all tokens can +-- be used to resolve JSON objects. +newtype Token = Token { _unToken :: Text } deriving (Eq, Show) + +instance Arbitrary Token where + arbitrary = Token . T.pack <$> arbitrary + +escape :: Pointer -> Text +escape (Pointer []) = "" +escape (Pointer ts) = + T.cons '/' + . T.intercalate "/" + . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken) + $ ts + +-- * Unescaping + +data FormatError + = InvalidFirstChar + -- ^ JSON Pointers must either be empty or start with a @/@. + | UnescapedTilde + deriving (Eq, Show) + + +-- | JSON Pointers must either be empty or start with a @/@. This means +-- that if you're turning a URI Fragment into a JSON Pointer you must +-- drop the initial @#@. +-- +-- Note that the unescaping happening here is not the same as URI +-- decoding. If you are turning a URI fragment into a JSON Pointer you +-- must URI decode the 'Text' before using it as an argument to this +-- function. There's an example of how to do this in the tests using +-- "Network.HTTP.Types.URI.urlDecode" from http-types. +unescape :: Text -> Either FormatError Pointer +unescape txt = + case T.splitOn "/" txt of + [] -> Right (Pointer []) + "":xs -> Pointer <$> traverse f xs + _ -> Left InvalidFirstChar + where + f :: Text -> Either FormatError Token + f t = case unescapeToken t of + Nothing -> Left UnescapedTilde + Just tok -> Right tok + +-- | For internal use by 'unescape'. +unescapeToken :: Text -> Maybe Token +unescapeToken t + | not (isValid t) = Nothing + | otherwise = Just . Token . replace $ t + where + -- All tildes must be followed by 0s or 1s. + isValid :: Text -> Bool + isValid x = all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes + where + afterTildes :: [Text] + afterTildes = drop 1 $ T.splitOn "~" x + + replace :: Text -> Text + replace = T.replace "~0" "~" . T.replace "~1" "/" + +-- * Resolution + +data ResolutionError + = ObjectLookupFailed + | ArrayIndexInvalid + | ArrayElemNotFound + | ExpectedObjectOrArray + deriving (Eq, Show) + +resolve :: Pointer -> Value -> Either ResolutionError Value +resolve (Pointer []) v = Right v +resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts) + +-- | For internal use (or specialized applications that don't want to +-- resolve an entire pointer at once). +resolveToken :: Token -> Value -> Either ResolutionError Value +resolveToken tok (Array vs) = + case readMaybe . T.unpack . _unToken $ tok of + Nothing -> Left ArrayIndexInvalid + Just n -> do + when (n < 0) (Left ArrayIndexInvalid) + case vs V.!? n of + Nothing -> Left ArrayElemNotFound + Just res -> Right res +resolveToken tok (Object h) = + case H.lookup (_unToken tok) h of + Nothing -> Left ObjectLookupFailed + Just res -> Right res +resolveToken _ _ = Left ExpectedObjectOrArray diff --git a/src/Data/JsonPointer.hs b/src/Data/JsonPointer.hs deleted file mode 100644 --- a/src/Data/JsonPointer.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Data.JsonPointer where - -import Control.Applicative -import Control.Monad -import Data.Aeson -import qualified Data.HashMap.Strict as H -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Vector as V -import Text.Read (readMaybe) - -newtype JsonPointer = JsonPointer { _unJsonPointer :: [Text] } deriving (Eq, Show) - -data PointerFormatError - -- | The Text to build a JSON Pointer must either be empty - -- or start with a "/". - = InvalidFirstChar - | UnescapedTilde - deriving (Eq, Show) - -data ResolutionError - = ObjectLookupFailed - | ArrayIndexInvalid - | ArrayElemNotFound - | ExpectedObjectOrArray - deriving (Eq, Show) - --- | The Text to build a JSON Pointer must either be empty or start --- with a "/". If you're turning a URI Fragment into a JSON Pointer --- you must drop the initial "#". -jsonPointer :: Text -> Either PointerFormatError JsonPointer -jsonPointer t = - JsonPointer <$> (unescape =<< process (T.splitOn "/" t)) - where - process ::[Text] -> Either PointerFormatError [Text] - process [] = Right [] - process (x:xs) - -- This checks that the JsonPointer started with a "/": - | (not . T.null $ x) = Left InvalidFirstChar - | otherwise = Right xs - - unescape :: [Text] -> Either PointerFormatError [Text] - unescape xs = do - void $ mapM checkValid xs - Right $ T.replace "~0" "~" . T.replace "~1" "/" <$> xs - - checkValid :: Text -> Either PointerFormatError () - checkValid x = do - let afterTildes = drop 1 $ T.splitOn "~" x - if all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes - then Right () - else Left UnescapedTilde - -resolvePointer :: JsonPointer -> Value -> Either ResolutionError Value -resolvePointer p v = - case _unJsonPointer p of - [] -> Right v - _ -> resolveRefTok p v >>= uncurry resolvePointer - --- | For internal use and specialized applications that don't want to --- resolve the entire pointer at once. -resolveRefTok :: JsonPointer -> Value -> Either ResolutionError (JsonPointer, Value) -resolveRefTok p v = do - case _unJsonPointer p of - [] -> Right (p, v) - (tok:ps) -> - case v of - Object h -> - case H.lookup tok h of - Nothing -> Left ObjectLookupFailed - Just vv -> Right (JsonPointer ps, vv) - Array vs -> do - case readMaybe (T.unpack tok) of - Nothing -> Left ArrayIndexInvalid - Just n -> do - when (n < 0) $ Left ArrayIndexInvalid - when (n >= V.length vs) $ Left ArrayElemNotFound - Right (JsonPointer ps, vs V.! n) - _ -> Left ExpectedObjectOrArray diff --git a/tests/Unit.hs b/tests/Unit.hs --- a/tests/Unit.hs +++ b/tests/Unit.hs @@ -1,87 +1,90 @@ + module Main where -import Control.Applicative import Control.Arrow -import Control.Monad import Data.Aeson -import qualified Data.HashMap.Strict as H -import Data.JsonPointer -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T +import qualified Data.Aeson.Pointer as P +import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding -import qualified Data.Vector as V -import Network.HTTP.Types.URI -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit hiding (Test) +import qualified Data.Vector as V +import Network.HTTP.Types.URI (urlDecode) +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit hiding (Test) +-- For GHCs before 7.10: +import Control.Applicative +import Data.Foldable +import Data.Monoid main :: IO () main = defaultMain [ testGroup "unit" - [ testCase "Can be represented in a JSON string value" jsonString + [ testProperty "Storing a Pointer as JSON doesn't change its value" roundtrip + , testCase "Can be represented in a JSON string value" jsonString , testCase "Can be represented in a URI fragment identifier" uriFragment ] ] -specExample :: Value -specExample = - Object $ H.fromList - [ ("foo" , Array $ V.fromList ["bar", "baz"]) - , ("" , Number 0) - , ("a/b" , Number 1) - , ("c%d" , Number 2) - , ("e^f" , Number 3) - , ("g|h" , Number 4) - , ("i\\j", Number 5) - , ("k\"l", Number 6) - , (" " , Number 7) - , ("m~n" , Number 8) - ] - -resolvesTo :: (Text, Value) -> Assertion -resolvesTo (t, expected) = - case jsonPointer t of - Left e -> assertFailure (show e <> " error for pointer: " <> show t) - Right p -> - assertEqual ("Resolved value for pointer: " <> show t) - (Right expected) - $ resolvePointer p specExample +roundtrip :: P.Pointer -> Bool +roundtrip a = Just a == decode (encode a) jsonString :: Assertion -jsonString = - void $ mapM resolvesTo - [ ("" , specExample) - , ("/foo" , Array $ V.fromList ["bar", "baz"]) - , ("/foo/0", String "bar") - , ("/" , Number 0) - , ("/a~1b" , Number 1) - , ("/c%d" , Number 2) - , ("/e^f" , Number 3) - , ("/g|h" , Number 4) - , ("/i\\j" , Number 5) - , ("/k\"l" , Number 6) - , ("/ " , Number 7) - , ("/m~0n" , Number 8) - ] +jsonString = traverse_ resolvesTo + [ ("" , specExample) + , ("/foo" , Array $ V.fromList ["bar", "baz"]) + , ("/foo/0", String "bar") + , ("/" , Number 0) + , ("/a~1b" , Number 1) + , ("/c%d" , Number 2) + , ("/e^f" , Number 3) + , ("/g|h" , Number 4) + , ("/i\\j" , Number 5) + , ("/k\"l" , Number 6) + , ("/ " , Number 7) + , ("/m~0n" , Number 8) + ] uriFragment :: Assertion -uriFragment = - void $ mapM resolvesTo $ first decodeFragment <$> - [ ("#" , specExample) - , ("#/foo" , Array $ V.fromList ["bar", "baz"]) - , ("#/foo/0", String "bar") - , ("#/" , Number 0) - , ("#/a~1b" , Number 1) - , ("#/c%25d", Number 2) - , ("#/e%5Ef", Number 3) - , ("#/g%7Ch", Number 4) - , ("#/i%5Cj", Number 5) - , ("#/k%22l", Number 6) - , ("#/%20" , Number 7) - , ("#/m~0n" , Number 8) - ] +uriFragment = traverse_ resolvesTo . fmap (first decodeFragment) $ + [ ("#" , specExample) + , ("#/foo" , Array $ V.fromList ["bar", "baz"]) + , ("#/foo/0", String "bar") + , ("#/" , Number 0) + , ("#/a~1b" , Number 1) + , ("#/c%25d", Number 2) + , ("#/e%5Ef", Number 3) + , ("#/g%7Ch", Number 4) + , ("#/i%5Cj", Number 5) + , ("#/k%22l", Number 6) + , ("#/%20" , Number 7) + , ("#/m~0n" , Number 8) + ] where decodeFragment :: Text -> Text decodeFragment = T.drop 1 . decodeUtf8 . urlDecode True . encodeUtf8 + +resolvesTo :: (Text, Value) -> Assertion +resolvesTo (t, expected) = + case P.unescape t of + Left e -> assertFailure (show e <> " error for pointer: " <> show t) + Right p -> assertEqual + ("Resolved value for pointer: " <> show t) + (Right expected) + (P.resolve p specExample) + +specExample :: Value +specExample = object + [ "foo" .= (["bar", "baz"] :: [Text]) + , "" .= (0 :: Int) + , "a/b" .= (1 :: Int) + , "c%d" .= (2 :: Int) + , "e^f" .= (3 :: Int) + , "g|h" .= (4 :: Int) + , "i\\j" .= (5 :: Int) + , "k\"l" .= (6 :: Int) + , " " .= (7 :: Int) + , "m~n" .= (8 :: Int) + ]