@@ -1,169 +0,0 @@
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