Pointer.hs

{-# 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