git.iko.soy/typeable/hjsonpointer
on master help sign in
typeable/hjsonpointer/src/JSONPointer.hs
169 lines 5.5 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE OverloadedStrings #-}
5module JSONPointer where
7import Control.Monad (when)
8import Data.Aeson
9import qualified Data.Hashable as HA
10import qualified Data.HashMap.Strict as HM
11import Data.Semigroup (Semigroup)
12import Data.Text (Text)
13import qualified Data.Text as T
14import qualified Data.Vector as V
15import GHC.Generics (Generic)
16import Text.Read (readMaybe)
18--------------------------------------------------
19-- * Resolution
20--------------------------------------------------
22data ResolutionError
23 = ObjectLookupFailed
24 | ArrayIndexInvalid
25 | ArrayElemNotFound
26 | ExpectedObjectOrArray
27 deriving (Eq, Show)
29resolve :: Pointer -> Value -> Either ResolutionError Value
30resolve (Pointer []) v = Right v
31resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)
33--------------------------------------------------
34-- * Main types and escaping
35--------------------------------------------------
37newtype Pointer
38 = Pointer { _unPointer :: [Token] }
39 deriving (Eq, Show, Semigroup, Monoid, Generic)
41instance HA.Hashable Pointer
43instance 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
49instance 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.
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.
59newtype Token
60 = Token { _unToken :: Text }
61 deriving (Eq, Show, Generic)
63instance HA.Hashable Token
65-- | This escapes @"/"@ (because it's the token separator character).
66--
67-- It also escapes @"~"@ (because it's the escape character).
68escape :: Pointer -> Text
69escape (Pointer []) = ""
70escape (Pointer ts) =
71 T.cons '/'
72 . T.intercalate "/"
73 . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
74 $ ts
76data FormatError
77 = InvalidFirstChar
78 -- ^ JSON Pointers must either be empty or start with a @/@.
79 | UnescapedTilde
80 deriving (Eq, Show)
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.
91unescape :: Text -> Either FormatError Pointer
92unescape 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
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--------------------------------------------------
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.
118newtype Key
119 = Key { _unKey :: Text }
120 deriving (Eq, Show, Generic)
122instance HA.Hashable Key
124-- | A glorified @type@ alias. If you need to do JSON Pointer operations
125-- you're looking for 'Token' instead.
126newtype Index
127 = Index { _unIndex :: Int }
128 deriving (Eq, Show, Generic)
130instance HA.Hashable Index
132--------------------------------------------------
133-- * Internals
134--------------------------------------------------
136-- | For internal use (by 'unescape').
137unescapeToken :: Text -> Maybe Token
138unescapeToken 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
149 replace :: Text -> Text
150 replace = T.replace "~0" "~" . T.replace "~1" "/"
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.
156resolveToken :: Token -> Value -> Either ResolutionError Value
157resolveToken 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
165resolveToken tok (Object h) =
166 case HM.lookup (_unToken tok) h of
167 Nothing -> Left ObjectLookupFailed
168 Just res -> Right res
169resolveToken _ _ = Left ExpectedObjectOrArray