git.iko.soy/typeable/hjsonpointer
on master help sign in
Initial version.
0f08784Ian Grant Jeffries
MIT-LICENSE.txtnew file+20
compare with master
unifiedsplit
@@ -0,0 +1,20 @@
1+The MIT License (MIT)
2+Copyright (c) 2015 Ian Grant Jeffries
3+
4+Permission is hereby granted, free of charge, to any person obtaining a copy
5+of this software and associated documentation files (the "Software"), to deal
6+in the Software without restriction, including without limitation the rights
7+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
8+copies of the Software, and to permit persons to whom the Software is
9+furnished to do so, subject to the following conditions:
10+
11+The above copyright notice and this permission notice shall be included in all
12+copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
18+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
19+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
20+OR OTHER DEALINGS IN THE SOFTWARE.
README.mdnew file+10
@@ -0,0 +1,10 @@
1+# Summary
2+
3+[JSON Pointer](http://tools.ietf.org/html/rfc6901) library for Haskell.
4+
5+# Example
6+
7+```
8+λ jsonPointer "/foo" >>= resolvePointer (Object $ singleton "foo" $ String "bar")
9+Right (String "bar")
10+```
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
hjsonpointer.cabalnew file+46
@@ -0,0 +1,46 @@
1+name: hjsonpointer
2+version: 0.1.0.0
3+synopsis: JSON Pointer library for Haskell
4+homepage: https://github.com/seagreen/hjsonpointer
5+license: MIT
6+license-file: MIT-LICENSE.txt
7+author: Ian Grant Jeffries
8+maintainer: ian@housejeffries.com
9+category: Data
10+build-type: Simple
11+cabal-version: >=1.10
12+extra-source-files: README.md
13+
14+library
15+ hs-source-dirs: src
16+ exposed-modules: Data.JsonPointer
17+ default-language: Haskell2010
18+ default-extensions: OverloadedStrings
19+ ghc-options: -Wall
20+ build-depends: aeson >= 0.8 && < 0.9
21+ , base >= 4.7 && < 4.8
22+ , unordered-containers >= 0.2 && < 0.3
23+ , text >= 1.2 && < 1.3
24+ , vector >= 0.10 && < 0.11
25+
26+test-suite unit
27+ type: exitcode-stdio-1.0
28+ hs-source-dirs: tests
29+ main-is: Unit.hs
30+ default-language: Haskell2010
31+ ghc-options: -Wall
32+ default-extensions: OverloadedStrings
33+ build-depends: aeson
34+ , base
35+ , hjsonpointer
36+ , unordered-containers
37+ , text
38+ , vector
39+ , http-types >= 0.8 && < 0.9
40+ , HUnit >= 1.2 && < 1.3
41+ , test-framework >= 0.8 && < 0.9
42+ , test-framework-hunit >= 0.3 && < 0.4
43+
44+source-repository head
45+ type: git
46+ location: git://github.com/seagreen/hjsonpointer.git
src/Data/JsonPointer.hsnew file+77
@@ -0,0 +1,77 @@
1+module Data.JsonPointer where
2+
3+import Control.Applicative
4+import Control.Monad
5+import Data.Aeson
6+import qualified Data.HashMap.Strict as H
7+import Data.Text (Text)
8+import qualified Data.Text as T
9+import qualified Data.Vector as V
10+import Text.Read (readMaybe)
11+
12+newtype JsonPointer = JsonPointer { _unJsonPointer :: [Text] } deriving (Eq, Show)
13+
14+data PointerErr
15+ -- | The Text to build a JSON Pointer must either be empty
16+ -- or start with a '/'.
17+ = InvalidFirstChar
18+ | UnescapedTilde
19+ | ObjectLookupFailed
20+ | ArrayIndexInvalid
21+ | ArrayElemNotFound
22+ | UnindexableValue
23+ deriving (Eq, Show)
24+
25+-- The Text to build a JSON Pointer must either be empty or start
26+-- with a '/'. If you're turning a URI Fragment into a JSON Pointer
27+-- you must drop the initial '#'.
28+jsonPointer :: Text -> Either PointerErr JsonPointer
29+jsonPointer t =
30+ JsonPointer <$> (unescape =<< process (T.splitOn "/" t))
31+ where
32+ process ::[Text] -> Either PointerErr [Text]
33+ process [] = Right []
34+ process (x:xs) = do
35+ unless (T.null x) $ Left InvalidFirstChar
36+ Right xs
37+
38+ unescape :: [Text] -> Either PointerErr [Text]
39+ unescape xs = do
40+ void $ mapM checkValid xs
41+ Right $ T.replace "~0" "~" . T.replace "~1" "/" <$> xs
42+
43+ checkValid :: Text -> Either PointerErr ()
44+ checkValid x = do
45+ let afterTildes = drop 1 $ T.splitOn "~" x
46+ if all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes
47+ then Right ()
48+ else Left UnescapedTilde
49+
50+resolvePointer :: Value -> JsonPointer -> Either PointerErr Value
51+resolvePointer v p =
52+ case _unJsonPointer p of
53+ [] -> Right v
54+ _ -> resolveRefTok v p >>= uncurry resolvePointer
55+
56+-- | For internal use and specialized applications that don't want to
57+-- resolve the entire pointer at once.
58+resolveRefTok :: Value -> JsonPointer -> Either PointerErr (Value, JsonPointer)
59+resolveRefTok v p = do
60+ case _unJsonPointer p of
61+ [] -> Right (v, p)
62+ (tok:ps) ->
63+ case v of
64+ Object h ->
65+ case H.lookup tok h of
66+ Nothing -> Left ObjectLookupFailed
67+ Just vv -> Right (vv, JsonPointer ps)
68+ Array vs -> do
69+ case readMaybe (T.unpack tok) of
70+ Nothing -> Left ArrayIndexInvalid
71+ Just n -> do
72+ unless (n >= 0) $ Left ArrayIndexInvalid
73+ unless (n < V.length vs) $ Left ArrayElemNotFound
74+ Right (vs V.! n, JsonPointer ps)
75+ vv -> do
76+ unless (null ps) $ Left UnindexableValue
77+ Right (vv, JsonPointer [])
tests/Unit.hsnew file+80
@@ -0,0 +1,80 @@
1+module Main where
2+
3+import Control.Monad
4+import Data.Aeson
5+import qualified Data.HashMap.Strict as H
6+import Data.JsonPointer
7+import Data.Monoid
8+import Data.Text (Text)
9+import qualified Data.Text as T
10+import Data.Text.Encoding
11+import qualified Data.Vector as V
12+import Network.HTTP.Types.URI
13+import Test.Framework (defaultMain, testGroup)
14+import Test.Framework.Providers.HUnit (testCase)
15+import Test.HUnit hiding (Test)
16+
17+
18+main :: IO ()
19+main = defaultMain
20+ [ testGroup "unit"
21+ [ testCase "Can be represented in a JSON string value" jsonString
22+ , testCase "Can be represented in a URI fragment identifier" uriFragment
23+ ]
24+ ]
25+
26+specExample :: Value
27+specExample =
28+ Object $ H.fromList
29+ [ ("foo" , Array $ V.fromList ["bar", "baz"])
30+ , ("" , Number 0)
31+ , ("a/b" , Number 1)
32+ , ("c%d" , Number 2)
33+ , ("e^f" , Number 3)
34+ , ("g|h" , Number 4)
35+ , ("i\\j", Number 5)
36+ , ("k\"l", Number 6)
37+ , (" " , Number 7)
38+ , ("m~n" , Number 8)
39+ ]
40+
41+jsonString :: Assertion
42+jsonString =
43+ void $ mapM
44+ (\(a,expected) -> assertEqual ("Tried to resolve " <> show a) (Right expected)
45+ $ jsonPointer a >>= resolvePointer specExample)
46+ [ ("" , specExample)
47+ , ("/foo" , Array $ V.fromList ["bar", "baz"])
48+ , ("/foo/0", String "bar")
49+ , ("/" , Number 0)
50+ , ("/a~1b" , Number 1)
51+ , ("/c%d" , Number 2)
52+ , ("/e^f" , Number 3)
53+ , ("/g|h" , Number 4)
54+ , ("/i\\j" , Number 5)
55+ , ("/k\"l" , Number 6)
56+ , ("/ " , Number 7)
57+ , ("/m~0n" , Number 8)
58+ ]
59+
60+uriFragment :: Assertion
61+uriFragment =
62+ void $ mapM
63+ (\(a,expected) -> assertEqual ("Tried to resolve " <> show a) (Right expected)
64+ $ jsonPointer (decodeFragment a) >>= resolvePointer specExample)
65+ [ ("#" , specExample)
66+ , ("#/foo" , Array $ V.fromList ["bar", "baz"])
67+ , ("#/foo/0", String "bar")
68+ , ("#/" , Number 0)
69+ , ("#/a~1b" , Number 1)
70+ , ("#/c%25d", Number 2)
71+ , ("#/e%5Ef", Number 3)
72+ , ("#/g%7Ch", Number 4)
73+ , ("#/i%5Cj", Number 5)
74+ , ("#/k%22l", Number 6)
75+ , ("#/%20" , Number 7)
76+ , ("#/m~0n" , Number 8)
77+ ]
78+ where
79+ decodeFragment :: Text -> Text
80+ decodeFragment = T.drop 1 . decodeUtf8 . urlDecode True . encodeUtf8