Initial version.

MIT-LICENSE.txt

@@ -0,0 +1,20 @@
+The MIT License (MIT)
+Copyright (c) 2015 Ian Grant Jeffries
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
+OR OTHER DEALINGS IN THE SOFTWARE.

README.md

@@ -0,0 +1,10 @@
+# Summary
+
+[JSON Pointer](http://tools.ietf.org/html/rfc6901) library for Haskell.
+
+# Example
+
+```
+λ jsonPointer "/foo" >>= resolvePointer (Object $ singleton "foo" $ String "bar")
+Right (String "bar")
+```

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

hjsonpointer.cabal

@@ -0,0 +1,46 @@
+name:                   hjsonpointer
+version:                0.1.0.0
+synopsis:               JSON Pointer library for Haskell
+homepage:               https://github.com/seagreen/hjsonpointer
+license:                MIT
+license-file:           MIT-LICENSE.txt
+author:                 Ian Grant Jeffries
+maintainer:             ian@housejeffries.com
+category:               Data
+build-type:             Simple
+cabal-version:          >=1.10
+extra-source-files:     README.md
+
+library
+  hs-source-dirs:       src
+  exposed-modules:      Data.JsonPointer
+  default-language:     Haskell2010
+  default-extensions:   OverloadedStrings
+  ghc-options:          -Wall
+  build-depends:        aeson                >= 0.8  && < 0.9
+                      , base                 >= 4.7  && < 4.8
+                      , unordered-containers >= 0.2  && < 0.3
+                      , text                 >= 1.2  && < 1.3
+                      , vector               >= 0.10 && < 0.11
+
+test-suite unit
+  type:                 exitcode-stdio-1.0
+  hs-source-dirs:       tests
+  main-is:              Unit.hs
+  default-language:     Haskell2010
+  ghc-options:          -Wall
+  default-extensions:   OverloadedStrings
+  build-depends:        aeson
+                      , base
+                      , hjsonpointer
+                      , unordered-containers
+                      , text
+                      , vector
+                      , http-types           >= 0.8 && < 0.9
+                      , HUnit                >= 1.2 && < 1.3
+                      , test-framework       >= 0.8 && < 0.9
+                      , test-framework-hunit >= 0.3 && < 0.4
+
+source-repository head
+  type:               git
+  location:           git://github.com/seagreen/hjsonpointer.git

src/Data/JsonPointer.hs

@@ -0,0 +1,77 @@
+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 PointerErr
+  -- | The Text to build a JSON Pointer must either be empty
+  -- or start with a '/'.
+  = InvalidFirstChar
+  | UnescapedTilde
+  | ObjectLookupFailed
+  | ArrayIndexInvalid
+  | ArrayElemNotFound
+  | UnindexableValue
+  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 PointerErr JsonPointer
+jsonPointer t =
+  JsonPointer <$> (unescape =<< process (T.splitOn "/" t))
+  where
+    process ::[Text] -> Either PointerErr [Text]
+    process []     = Right []
+    process (x:xs) = do
+      unless (T.null x) $ Left InvalidFirstChar
+      Right xs
+
+    unescape :: [Text] -> Either PointerErr [Text]
+    unescape xs = do
+      void $ mapM checkValid xs
+      Right $ T.replace "~0" "~" . T.replace "~1" "/" <$> xs
+
+    checkValid :: Text -> Either PointerErr ()
+    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 :: Value -> JsonPointer -> Either PointerErr Value
+resolvePointer v p =
+  case _unJsonPointer p of
+    [] -> Right v
+    _  -> resolveRefTok v p >>= uncurry resolvePointer
+
+-- | For internal use and specialized applications that don't want to
+-- resolve the entire pointer at once.
+resolveRefTok :: Value -> JsonPointer -> Either PointerErr (Value, JsonPointer)
+resolveRefTok v p = do
+  case _unJsonPointer p of
+    []       -> Right (v, p)
+    (tok:ps) ->
+      case v of
+        Object h ->
+          case H.lookup tok h of
+            Nothing -> Left ObjectLookupFailed
+            Just vv -> Right (vv, JsonPointer ps)
+        Array vs -> do
+          case readMaybe (T.unpack tok) of
+            Nothing -> Left ArrayIndexInvalid
+            Just n  -> do
+              unless (n >= 0)          $ Left ArrayIndexInvalid
+              unless (n < V.length vs) $ Left ArrayElemNotFound
+              Right (vs V.! n, JsonPointer ps)
+        vv -> do
+          unless (null ps) $ Left UnindexableValue
+          Right (vv, JsonPointer [])

tests/Unit.hs

@@ -0,0 +1,80 @@
+module Main where
+
+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           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)
+
+
+main :: IO ()
+main = defaultMain
+  [ testGroup "unit"
+    [ 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)
+    ]
+
+jsonString :: Assertion
+jsonString =
+  void $ mapM
+    (\(a,expected) -> assertEqual ("Tried to resolve " <> show a) (Right expected)
+     $ jsonPointer a >>= resolvePointer specExample)
+    [ (""      , 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
+    (\(a,expected) -> assertEqual ("Tried to resolve " <> show a) (Right expected)
+     $ jsonPointer (decodeFragment a) >>= resolvePointer specExample)
+    [ ("#"      , 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