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
= InvalidFirstChar
| UnescapedTilde
| ObjectLookupFailed
| ArrayIndexInvalid
| ArrayElemNotFound
| UnindexableValue
deriving (Eq, Show)
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
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 [])