@@ -0,0 +1,169 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
5+module JSONPointer where
7+import Control.Monad (when)
9+import qualified Data.Hashable as HA
10+import qualified Data.HashMap.Strict as HM
11+import Data.Semigroup (Semigroup)
12+import Data.Text (Text)
13+import qualified Data.Text as T
14+import qualified Data.Vector as V
15+import GHC.Generics (Generic)
16+import Text.Read (readMaybe)
18+--------------------------------------------------
20+--------------------------------------------------
26+ | ExpectedObjectOrArray
29+resolve :: Pointer -> Value -> Either ResolutionError Value
30+resolve (Pointer []) v = Right v
31+resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)
33+--------------------------------------------------
34+-- * Main types and escaping
35+--------------------------------------------------
38+ = Pointer { _unPointer :: [Token] }
39+ deriving (Eq, Show, Semigroup, Monoid, Generic)
41+instance HA.Hashable Pointer
43+instance FromJSON Pointer where
44+ parseJSON = withText "JSON Pointer" $ \t ->
46+ Left e -> fail (show e)
49+instance ToJSON Pointer where
50+ toJSON = String . escape
52+-- | We don't try to distinguish between integer tokens and string
53+-- tokens since all tokens start as strings, and all tokens can
54+-- be used to resolve JSON objects.
56+-- Since these are unescaped you can write @"/"@ and @"~"@ normally.
57+-- (e.g. if you're referencing a key such as @"abc/123"@, go ahead
58+-- and write that exactly.
60+ = Token { _unToken :: Text }
61+ deriving (Eq, Show, Generic)
63+instance HA.Hashable Token
65+-- | This escapes @"/"@ (because it's the token separator character).
67+-- It also escapes @"~"@ (because it's the escape character).
68+escape :: Pointer -> Text
69+escape (Pointer []) = ""
73+ . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
78+ -- ^ JSON Pointers must either be empty or start with a @/@.
82+-- | JSON Pointers must either be empty or start with a @/@. This means
83+-- that if you're turning a URI Fragment into a JSON Pointer you must
84+-- drop the initial @#@.
86+-- Note that the unescaping happening here is not the same as URI
87+-- decoding. If you are turning a URI fragment into a JSON Pointer you
88+-- must URI decode the 'Text' before using it as an argument to this
89+-- function. There's an example of how to do this in the tests using
90+-- "Network.HTTP.Types.URI.urlDecode" from http-types.
91+unescape :: Text -> Either FormatError Pointer
93+ case T.splitOn "/" txt of
94+ [] -> Right (Pointer [])
95+ "":xs -> Pointer <$> traverse f xs
96+ _ -> Left InvalidFirstChar
98+ f :: Text -> Either FormatError Token
99+ f t = case unescapeToken t of
100+ Nothing -> Left UnescapedTilde
101+ Just tok -> Right tok
103+--------------------------------------------------
106+-- $ These aren't used by the rest of the library
107+-- (as explained in the docs for 'Token').
109+-- However, they might be useful if you need to distinguish JSON Pointer
110+-- tokens from plain 'Text' or 'Int' without losing information by
111+-- converting to 'Token'.
112+--------------------------------------------------
114+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
115+-- you're looking for 'Token' instead.
117+-- NOTE: Unlike 'Token' this is escaped.
119+ = Key { _unKey :: Text }
120+ deriving (Eq, Show, Generic)
122+instance HA.Hashable Key
124+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
125+-- you're looking for 'Token' instead.
127+ = Index { _unIndex :: Int }
128+ deriving (Eq, Show, Generic)
130+instance HA.Hashable Index
132+--------------------------------------------------
134+--------------------------------------------------
136+-- | For internal use (by 'unescape').
137+unescapeToken :: Text -> Maybe Token
139+ | not (isValid t) = Nothing
140+ | otherwise = Just . Token . replace $ t
142+ -- All tildes must be followed by 0s or 1s.
143+ isValid :: Text -> Bool
144+ isValid x = all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes
146+ afterTildes :: [Text]
147+ afterTildes = drop 1 $ T.splitOn "~" x
149+ replace :: Text -> Text
150+ replace = T.replace "~0" "~" . T.replace "~1" "/"
152+-- | For internal use (by 'resolve').
154+-- Might also be useful for specialized applications that don't
155+-- want to resolve an entire pointer at once.
156+resolveToken :: Token -> Value -> Either ResolutionError Value
157+resolveToken tok (Array vs) =
158+ case readMaybe . T.unpack . _unToken $ tok of
159+ Nothing -> Left ArrayIndexInvalid
161+ when (n < 0) (Left ArrayIndexInvalid)
163+ Nothing -> Left ArrayElemNotFound
164+ Just res -> Right res
165+resolveToken tok (Object h) =
166+ case HM.lookup (_unToken tok) h of
167+ Nothing -> Left ObjectLookupFailed
168+ Just res -> Right res
169+resolveToken _ _ = Left ExpectedObjectOrArray