git.iko.soy/typeable/hjsonpointer
on 1.4.0 help sign in
typeable/hjsonpointer/src/JSONPointer.hs
173 lines 5.7 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 Test.QuickCheck
17import Text.Read (readMaybe)
19--------------------------------------------------
20-- * Resolution
21--------------------------------------------------
23data ResolutionError
24 = ObjectLookupFailed
25 | ArrayIndexInvalid
26 | ArrayElemNotFound
27 | ExpectedObjectOrArray
28 deriving (Eq, Show)
30resolve :: Pointer -> Value -> Either ResolutionError Value
31resolve (Pointer []) v = Right v
32resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)
34--------------------------------------------------
35-- * Main types and escaping
36--------------------------------------------------
38newtype Pointer
39 = Pointer { _unPointer :: [Token] }
40 deriving (Eq, Show, Semigroup, Monoid, Generic, Arbitrary)
42instance HA.Hashable Pointer
44instance FromJSON Pointer where
45 parseJSON = withText "JSON Pointer" $ \t ->
46 case unescape t of
47 Left e -> fail (show e)
48 Right p -> pure p
50instance ToJSON Pointer where
51 toJSON = String . escape
53-- | We don't try to distinguish between integer tokens and string
54-- tokens since all tokens start as strings, and all tokens can
55-- be used to resolve JSON objects.
56--
57-- Since these are unescaped you can write @"/"@ and @"~"@ normally.
58-- (e.g. if you're referencing a key such as @"abc/123"@, go ahead
59-- and write that exactly.
60newtype Token
61 = Token { _unToken :: Text }
62 deriving (Eq, Show, Generic)
64instance HA.Hashable Token
66instance Arbitrary Token where
67 arbitrary = Token . T.pack <$> arbitrary
69-- | This escapes @"/"@ (because it's the token separator character).
70--
71-- It also escapes @"~"@ (because it's the escape character).
72escape :: Pointer -> Text
73escape (Pointer []) = ""
74escape (Pointer ts) =
75 T.cons '/'
76 . T.intercalate "/"
77 . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
78 $ ts
80data FormatError
81 = InvalidFirstChar
82 -- ^ JSON Pointers must either be empty or start with a @/@.
83 | UnescapedTilde
84 deriving (Eq, Show)
86-- | JSON Pointers must either be empty or start with a @/@. This means
87-- that if you're turning a URI Fragment into a JSON Pointer you must
88-- drop the initial @#@.
89--
90-- Note that the unescaping happening here is not the same as URI
91-- decoding. If you are turning a URI fragment into a JSON Pointer you
92-- must URI decode the 'Text' before using it as an argument to this
93-- function. There's an example of how to do this in the tests using
94-- "Network.HTTP.Types.URI.urlDecode" from http-types.
95unescape :: Text -> Either FormatError Pointer
96unescape txt =
97 case T.splitOn "/" txt of
98 [] -> Right (Pointer [])
99 "":xs -> Pointer <$> traverse f xs
100 _ -> Left InvalidFirstChar
101 where
102 f :: Text -> Either FormatError Token
103 f t = case unescapeToken t of
104 Nothing -> Left UnescapedTilde
105 Just tok -> Right tok
107--------------------------------------------------
108-- * Wrapper Types
109--
110-- $ These aren't used by the rest of the library
111-- (as explained in the docs for 'Token').
112--
113-- However, they might be useful if you need to distinguish JSON Pointer
114-- tokens from plain 'Text' or 'Int' without losing information by
115-- converting to 'Token'.
116--------------------------------------------------
118-- | A glorified @type@ alias. If you need to do JSON Pointer operations
119-- you're looking for 'Token' instead.
120--
121-- NOTE: Unlike 'Token' this is escaped.
122newtype Key
123 = Key { _unKey :: Text }
124 deriving (Eq, Show, Generic)
126instance HA.Hashable Key
128-- | A glorified @type@ alias. If you need to do JSON Pointer operations
129-- you're looking for 'Token' instead.
130newtype Index
131 = Index { _unIndex :: Int }
132 deriving (Eq, Show, Generic)
134instance HA.Hashable Index
136--------------------------------------------------
137-- * Internals
138--------------------------------------------------
140-- | For internal use (by 'unescape').
141unescapeToken :: Text -> Maybe Token
142unescapeToken t
143 | not (isValid t) = Nothing
144 | otherwise = Just . Token . replace $ t
145 where
146 -- All tildes must be followed by 0s or 1s.
147 isValid :: Text -> Bool
148 isValid x = all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes
149 where
150 afterTildes :: [Text]
151 afterTildes = drop 1 $ T.splitOn "~" x
153 replace :: Text -> Text
154 replace = T.replace "~0" "~" . T.replace "~1" "/"
156-- | For internal use (by 'resolve').
157--
158-- Might also be useful for specialized applications that don't
159-- want to resolve an entire pointer at once.
160resolveToken :: Token -> Value -> Either ResolutionError Value
161resolveToken tok (Array vs) =
162 case readMaybe . T.unpack . _unToken $ tok of
163 Nothing -> Left ArrayIndexInvalid
164 Just n -> do
165 when (n < 0) (Left ArrayIndexInvalid)
166 case vs V.!? n of
167 Nothing -> Left ArrayElemNotFound
168 Just res -> Right res
169resolveToken tok (Object h) =
170 case HM.lookup (_unToken tok) h of
171 Nothing -> Left ObjectLookupFailed
172 Just res -> Right res
173resolveToken _ _ = Left ExpectedObjectOrArray