@@ -0,0 +1,169 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+module JSONPointer where
6+
7+import Control.Monad (when)
8+import Data.Aeson
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)
17+
18+--------------------------------------------------
19+-- * Resolution
20+--------------------------------------------------
21+
22+data ResolutionError
23+ = ObjectLookupFailed
24+ | ArrayIndexInvalid
25+ | ArrayElemNotFound
26+ | ExpectedObjectOrArray
27+ deriving (Eq, Show)
28+
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)
32+
33+--------------------------------------------------
34+-- * Main types and escaping
35+--------------------------------------------------
36+
37+newtype Pointer
38+ = Pointer { _unPointer :: [Token] }
39+ deriving (Eq, Show, Semigroup, Monoid, Generic)
40+
41+instance HA.Hashable Pointer
42+
43+instance FromJSON Pointer where
44+ parseJSON = withText "JSON Pointer" $ \t ->
45+ case unescape t of
46+ Left e -> fail (show e)
47+ Right p -> pure p
48+
49+instance ToJSON Pointer where
50+ toJSON = String . escape
51+
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.
55+--
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.
59+newtype Token
60+ = Token { _unToken :: Text }
61+ deriving (Eq, Show, Generic)
62+
63+instance HA.Hashable Token
64+
65+-- | This escapes @"/"@ (because it's the token separator character).
66+--
67+-- It also escapes @"~"@ (because it's the escape character).
68+escape :: Pointer -> Text
69+escape (Pointer []) = ""
70+escape (Pointer ts) =
71+ T.cons '/'
72+ . T.intercalate "/"
73+ . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
74+ $ ts
75+
76+data FormatError
77+ = InvalidFirstChar
78+ -- ^ JSON Pointers must either be empty or start with a @/@.
79+ | UnescapedTilde
80+ deriving (Eq, Show)
81+
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 @#@.
85+--
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
92+unescape txt =
93+ case T.splitOn "/" txt of
94+ [] -> Right (Pointer [])
95+ "":xs -> Pointer <$> traverse f xs
96+ _ -> Left InvalidFirstChar
97+ where
98+ f :: Text -> Either FormatError Token
99+ f t = case unescapeToken t of
100+ Nothing -> Left UnescapedTilde
101+ Just tok -> Right tok
102+
103+--------------------------------------------------
104+-- * Wrapper Types
105+--
106+-- $ These aren't used by the rest of the library
107+-- (as explained in the docs for 'Token').
108+--
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+--------------------------------------------------
113+
114+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
115+-- you're looking for 'Token' instead.
116+--
117+-- NOTE: Unlike 'Token' this is escaped.
118+newtype Key
119+ = Key { _unKey :: Text }
120+ deriving (Eq, Show, Generic)
121+
122+instance HA.Hashable Key
123+
124+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
125+-- you're looking for 'Token' instead.
126+newtype Index
127+ = Index { _unIndex :: Int }
128+ deriving (Eq, Show, Generic)
129+
130+instance HA.Hashable Index
131+
132+--------------------------------------------------
133+-- * Internals
134+--------------------------------------------------
135+
136+-- | For internal use (by 'unescape').
137+unescapeToken :: Text -> Maybe Token
138+unescapeToken t
139+ | not (isValid t) = Nothing
140+ | otherwise = Just . Token . replace $ t
141+ where
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
145+ where
146+ afterTildes :: [Text]
147+ afterTildes = drop 1 $ T.splitOn "~" x
148+
149+ replace :: Text -> Text
150+ replace = T.replace "~0" "~" . T.replace "~1" "/"
151+
152+-- | For internal use (by 'resolve').
153+--
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
160+ Just n -> do
161+ when (n < 0) (Left ArrayIndexInvalid)
162+ case vs V.!? n of
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