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