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