{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
-- | Description: JSON Pointers as described in RFC 6901.
module Data.Aeson.Pointer (
  Pointer(..),
  Key(..),
  Path,
  -- * Representing pointers
  formatPointer,
  parsePointer,
  -- * Using pointers
  get,
  pointerFailure,
) where

import           Control.Applicative
import           Data.Aeson
import           Data.Aeson.Types
import qualified Data.ByteString.Lazy.Char8 as BS
import           Data.Char                  (isNumber)
import qualified Data.HashMap.Strict        as HM
import           Data.Monoid
import           Data.Scientific
import           Data.Semigroup             (Semigroup)
import           Data.Text                  (Text)
import qualified Data.Text                  as T
import qualified Data.Vector                as V

-- * Patch components

-- | Path components to traverse a single layer of a JSON document.
data Key
    = OKey Text -- ^ Traverse a 'Value' with an 'Object' constructor.
    | AKey Int  -- ^ Traverse a 'Value' with an 'Array' constructor.
  deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Eq Key
Eq Key =>
(Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c< :: Key -> Key -> Bool
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
$cp1Ord :: Eq Key
Ord, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show)

instance ToJSON Key where
    toJSON :: Key -> Value
toJSON (OKey t :: Text
t) = Text -> Value
String Text
t
    toJSON (AKey a :: Int
a) = Scientific -> Value
Number (Scientific -> Value) -> (Int -> Scientific) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> (Int -> Integer) -> Int -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Int
a

instance FromJSON Key where
    parseJSON :: Value -> Parser Key
parseJSON (String t :: Text
t) = Key -> Parser Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Parser Key) -> Key -> Parser Key
forall a b. (a -> b) -> a -> b
$ Text -> Key
OKey Text
t
    parseJSON (Number n :: Scientific
n) =
        case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n of
            Nothing -> String -> Parser Key
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "A numeric key must be a positive whole number."
            Just n' :: Int
n' -> Key -> Parser Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Parser Key) -> Key -> Parser Key
forall a b. (a -> b) -> a -> b
$ Int -> Key
AKey Int
n'
    parseJSON _ = String -> Parser Key
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "A key element must be a number or a string."

formatKey :: Key -> Text
formatKey :: Key -> Text
formatKey (AKey i :: Int
i) = String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i)
formatKey (OKey t :: Text
t) = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
esc Text
t
  where
    esc :: Char -> Text
    esc :: Char -> Text
esc '~' = "~0"
    esc '/' = "~1"
    esc c :: Char
c = Char -> Text
T.singleton Char
c

-- * Pointers

-- | A sequence of 'Key's forms a path through a JSON document.
type Path = [Key]

-- | Pointer to a location in a JSON document.
--
-- Defined in RFC 6901 <http://tools.ietf.org/html/rfc6901>
newtype Pointer = Pointer { Pointer -> [Key]
pointerPath :: Path }
  deriving (Pointer -> Pointer -> Bool
(Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool) -> Eq Pointer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pointer -> Pointer -> Bool
$c/= :: Pointer -> Pointer -> Bool
== :: Pointer -> Pointer -> Bool
$c== :: Pointer -> Pointer -> Bool
Eq, Eq Pointer
Eq Pointer =>
(Pointer -> Pointer -> Ordering)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Pointer)
-> (Pointer -> Pointer -> Pointer)
-> Ord Pointer
Pointer -> Pointer -> Bool
Pointer -> Pointer -> Ordering
Pointer -> Pointer -> Pointer
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Pointer -> Pointer -> Pointer
$cmin :: Pointer -> Pointer -> Pointer
max :: Pointer -> Pointer -> Pointer
$cmax :: Pointer -> Pointer -> Pointer
>= :: Pointer -> Pointer -> Bool
$c>= :: Pointer -> Pointer -> Bool
> :: Pointer -> Pointer -> Bool
$c> :: Pointer -> Pointer -> Bool
<= :: Pointer -> Pointer -> Bool
$c<= :: Pointer -> Pointer -> Bool
< :: Pointer -> Pointer -> Bool
$c< :: Pointer -> Pointer -> Bool
compare :: Pointer -> Pointer -> Ordering
$ccompare :: Pointer -> Pointer -> Ordering
$cp1Ord :: Eq Pointer
Ord, Int -> Pointer -> ShowS
[Pointer] -> ShowS
Pointer -> String
(Int -> Pointer -> ShowS)
-> (Pointer -> String) -> ([Pointer] -> ShowS) -> Show Pointer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pointer] -> ShowS
$cshowList :: [Pointer] -> ShowS
show :: Pointer -> String
$cshow :: Pointer -> String
showsPrec :: Int -> Pointer -> ShowS
$cshowsPrec :: Int -> Pointer -> ShowS
Show, b -> Pointer -> Pointer
NonEmpty Pointer -> Pointer
Pointer -> Pointer -> Pointer
(Pointer -> Pointer -> Pointer)
-> (NonEmpty Pointer -> Pointer)
-> (forall b. Integral b => b -> Pointer -> Pointer)
-> Semigroup Pointer
forall b. Integral b => b -> Pointer -> Pointer
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Pointer -> Pointer
$cstimes :: forall b. Integral b => b -> Pointer -> Pointer
sconcat :: NonEmpty Pointer -> Pointer
$csconcat :: NonEmpty Pointer -> Pointer
<> :: Pointer -> Pointer -> Pointer
$c<> :: Pointer -> Pointer -> Pointer
Semigroup, Semigroup Pointer
Pointer
Semigroup Pointer =>
Pointer
-> (Pointer -> Pointer -> Pointer)
-> ([Pointer] -> Pointer)
-> Monoid Pointer
[Pointer] -> Pointer
Pointer -> Pointer -> Pointer
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Pointer] -> Pointer
$cmconcat :: [Pointer] -> Pointer
mappend :: Pointer -> Pointer -> Pointer
$cmappend :: Pointer -> Pointer -> Pointer
mempty :: Pointer
$cmempty :: Pointer
$cp1Monoid :: Semigroup Pointer
Monoid)

-- | Format a 'Pointer' as described in RFC 6901.
--
-- >>> formatPointer (Pointer [])
-- ""
-- >>> formatPointer (Pointer [OKey ""])
-- "/"
-- >>> formatPointer (Pointer [OKey " "])
-- "/ "
-- >>> formatPointer (Pointer [OKey "foo"])
-- "/foo"
-- >>> formatPointer (Pointer [OKey "foo", AKey 0])
-- "/foo/0"
-- >>> formatPointer (Pointer [OKey "a/b"])
-- "/a~1b"
-- >>> formatPointer (Pointer [OKey "c%d"])
-- "/c%d"
-- >>> formatPointer (Pointer [OKey "e^f"])
-- "/e^f"
-- >>> formatPointer (Pointer [OKey "g|h"])
-- "/g|h"
-- >>> formatPointer (Pointer [OKey "i\\j"])
-- "/i\\j"
-- >>> formatPointer (Pointer [OKey "k\"l"])
-- "/k\"l"
-- >>> formatPointer (Pointer [OKey "m~n"])
-- "/m~0n"
formatPointer :: Pointer -> Text
formatPointer :: Pointer -> Text
formatPointer (Pointer []) = ""
formatPointer (Pointer path :: [Key]
path) = "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate "/" (Key -> Text
formatKey (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Key]
path)

-- | Parse a 'Pointer' as described in RFC 6901.
parsePointer :: Text -> Parser Pointer
parsePointer :: Text -> Parser Pointer
parsePointer t :: Text
t
  | Text -> Bool
T.null Text
t = Pointer -> Parser Pointer
forall (m :: * -> *) a. Monad m => a -> m a
return ([Key] -> Pointer
Pointer [])
  | Bool
otherwise = [Key] -> Pointer
Pointer ([Key] -> Pointer) -> Parser [Key] -> Parser Pointer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Key) -> [Text] -> Parser [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Parser Key
forall (m :: * -> *). MonadFail m => Text -> m Key
key (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop 1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn "/" Text
t)
  where
    step :: Text -> Text
step t :: Text
t
      | "0" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Char -> Text -> Text
T.cons '~' (Text -> Text
T.tail Text
t)
      | "1" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Char -> Text -> Text
T.cons '/' (Text -> Text
T.tail Text
t)
      | Bool
otherwise = Char -> Text -> Text
T.cons '~' Text
t
    unesc :: Text -> Text
    unesc :: Text -> Text
unesc t :: Text
t =
      let l :: [Text]
l = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '~') Text
t
      in [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take 1 [Text]
l [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
step ([Text] -> [Text]
forall a. [a] -> [a]
tail [Text]
l)
    key :: Text -> m Key
key t :: Text
t
      | Text -> Bool
T.null Text
t         = String -> m Key
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "JSON components must not be empty."
      | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isNumber Text
t = Key -> m Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Key
AKey (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t))
      | Bool
otherwise        = Key -> m Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> m Key) -> Key -> m Key
forall a b. (a -> b) -> a -> b
$ Text -> Key
OKey (Text -> Text
unesc Text
t)

instance ToJSON Pointer where
    toJSON :: Pointer -> Value
toJSON pointer :: Pointer
pointer =
        Text -> Value
String (Pointer -> Text
formatPointer Pointer
pointer)

instance FromJSON Pointer where
    parseJSON :: Value -> Parser Pointer
parseJSON = ShowS -> Parser Pointer -> Parser Pointer
forall a. ShowS -> Parser a -> Parser a
modifyFailure ("Could not parse JSON pointer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) (Parser Pointer -> Parser Pointer)
-> (Value -> Parser Pointer) -> Value -> Parser Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Pointer
parse
      where
        parse :: Value -> Parser Pointer
parse (String t :: Text
t) = Text -> Parser Pointer
parsePointer Text
t
        parse _ = String -> Parser Pointer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "A JSON pointer must be a string."

-- | Follow a 'Pointer' through a JSON document as described in RFC 6901.
get :: Pointer -> Value -> Result Value
get :: Pointer -> Value -> Result Value
get (Pointer []) v :: Value
v = Value -> Result Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
get (Pointer (AKey i :: Int
i : path :: [Key]
path)) (Array v :: Array
v) =
  Result Value
-> (Value -> Result Value) -> Maybe Value -> Result Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Result Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "") Value -> Result Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Array
v Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
V.!? Int
i) Result Value -> (Value -> Result Value) -> Result Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pointer -> Value -> Result Value
get ([Key] -> Pointer
Pointer [Key]
path)
get (Pointer (OKey n :: Text
n : path :: [Key]
path)) (Object v :: Object
v) =
  Result Value
-> (Value -> Result Value) -> Maybe Value -> Result Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Result Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "") Value -> Result Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
n Object
v) Result Value -> (Value -> Result Value) -> Result Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pointer -> Value -> Result Value
get ([Key] -> Pointer
Pointer [Key]
path)
get pointer :: Pointer
pointer value :: Value
value = Pointer -> Value -> Result Value
forall a. Pointer -> Value -> Result a
pointerFailure Pointer
pointer Value
value

-- | Report an error while following a pointer.
pointerFailure :: Pointer -> Value -> Result a
pointerFailure :: Pointer -> Value -> Result a
pointerFailure (Pointer []) value :: Value
value = String -> Result a
forall a. String -> Result a
Error "Cannot follow empty pointer. This is impossible."
pointerFailure (Pointer path :: [Key]
path@(key :: Key
key:_)) value :: Value
value =
    String -> Result a
forall a. String -> Result a
Error (String -> Result a)
-> (ByteString -> String) -> ByteString -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack (ByteString -> Result a) -> ByteString -> Result a
forall a b. (a -> b) -> a -> b
$ "Cannot follow pointer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ". Expected " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ty ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> " but got " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
doc
  where
    doc :: ByteString
doc = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
value
    pt :: ByteString
pt = [Key] -> ByteString
forall a. ToJSON a => a -> ByteString
encode [Key]
path
    ty :: ByteString
ty = case Key
key of
           (AKey _) -> "array"
           (OKey _) -> "object"


-- $setup
-- >>> :set -XOverloadedStrings