git.iko.soy/typeable/hjsonschema
on master help sign in
typeable/hjsonschema/examples/AlternateSchema.hs
200 lines 7.1 kB history raw
1-- | An implementation of JSON Schema Draft 4 based on 'HashMap Text Value'
2-- instead of a custom record type like 'JSONSchema.Draft4'.
3--
4-- If you're writing code for a new schema specification you probably want
5-- to copy this module instead of the 'JSONSchema.Draft4'. While it's
6-- less convenient to write schemas in Haskell without a record type, you
7-- can get the implementation finished with far fewer lines of code.
8module AlternateSchema where
10import Protolude
12import Data.Aeson (FromJSON(..), Value(..), decodeStrict)
13import qualified Data.Aeson as AE
14import qualified Data.HashMap.Strict as HM
15import Data.Maybe (fromMaybe)
16import Data.Profunctor (Profunctor(..))
18import JSONSchema.Draft4 (ValidatorFailure(..), metaSchemaBytes)
19import JSONSchema.Fetch (SchemaWithURI(..), URISchemaMap(..))
20import qualified JSONSchema.Fetch as FE
21import JSONSchema.Types (Schema(..), Spec(..))
22import qualified JSONSchema.Types as JT
23import qualified JSONSchema.Validator.Draft4 as D4
24import JSONSchema.Validator.Reference (BaseURI(..), Scope(..),
25 updateResolutionScope)
27--------------------------------------------------
28-- * Basic fetching tools
29--------------------------------------------------
31referencesViaHTTP
32 :: SchemaWithURI Schema
33 -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema))
34referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo
36draft4FetchInfo :: FE.FetchInfo Schema
37draft4FetchInfo = FE.FetchInfo embedded (lookup "id") (lookup "$ref")
38 where
39 lookup :: Text -> Schema -> Maybe Text
40 lookup k (Schema s) =
41 case HM.lookup k s of
42 Just (String t) -> Just t
43 _ -> Nothing
45-- | An implementation of 'JT.embedded'.
46embedded :: Schema -> ([Schema], [Schema])
47embedded s =
48 JT.embedded (d4Spec mempty mempty (Scope s Nothing (BaseURI Nothing))) s
50--------------------------------------------------
51-- * Main API
52--------------------------------------------------
54validate
55 :: URISchemaMap Schema
56 -> SchemaWithURI Schema
57 -> Value
58 -> [ValidatorFailure]
59validate schemaMap sw =
60 JT.validate (d4Spec schemaMap visited scope) (_swSchema sw)
61 where
62 visited :: D4.VisitedSchemas
63 visited = D4.VisitedSchemas [(Nothing, Nothing)]
65 schemaId :: Maybe Text
66 schemaId = FE._fiId draft4FetchInfo (_swSchema sw)
68 scope :: Scope Schema
69 scope = Scope
70 { _topLevelDocument = _swSchema sw
71 , _documentURI = _swURI sw
72 , _currentBaseURI = updateResolutionScope (BaseURI (_swURI sw))
73 schemaId
74 }
76-- | A schema for schemas themselves. Uses @src/draft4.json@ which is loaded
77-- at compile time.
78metaSchema :: Schema
79metaSchema =
80 fromMaybe (panic "Schema decode failed (this should never happen)")
81 . decodeStrict
82 $ metaSchemaBytes
84checkSchema :: Schema -> [ValidatorFailure]
85checkSchema = validate schemaMap (SchemaWithURI metaSchema Nothing)
86 . Object
87 . _unSchema
88 where
89 schemaMap :: URISchemaMap Schema
90 schemaMap =
91 URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema"
92 metaSchema)
94--------------------------------------------------
95-- * Spec
96--------------------------------------------------
98validateSubschema
99 :: URISchemaMap Schema
100 -> D4.VisitedSchemas
101 -> Scope Schema
102 -> Schema
103 -> Value
104 -> [ValidatorFailure]
105validateSubschema schemaMap visited scope schema =
106 JT.validate (d4Spec schemaMap visited newScope) schema
107 where
108 schemaId :: Maybe Text
109 schemaId = FE._fiId draft4FetchInfo schema
111 newScope :: Scope Schema
112 newScope = scope
113 { _currentBaseURI = updateResolutionScope (_currentBaseURI scope)
114 schemaId
115 }
117d4Spec
118 :: URISchemaMap Schema
119 -> D4.VisitedSchemas
120 -> Scope Schema
121 -> Spec Schema ValidatorFailure
122 -- ^ Here we reuses 'ValidatorFailure' from
123 -- 'JSONSchema.Draft4.Failure'. If your validators have different
124 -- failure possibilities you'll need to create your own validator
125 -- failure type.
126d4Spec schemaMap visited scope =
127 Spec $
128 [ dimap
129 f
130 FailureRef
131 (D4.refValidator (FE.getReference schemaMap) updateScope
132 valRef visited scope)
133 ]
135 <> fmap (lmap disableIfRefPresent)
136 [ dimap f FailureMultipleOf D4.multipleOfValidator
137 , dimap f FailureMaximum D4.maximumValidator
138 , dimap f FailureMinimum D4.minimumValidator
140 , dimap f FailureMaxLength D4.maxLengthValidator
141 , dimap f FailureMinLength D4.minLengthValidator
142 , dimap f FailurePattern D4.patternValidator
144 , dimap f FailureMaxItems D4.maxItemsValidator
145 , dimap f FailureMinItems D4.minItemsValidator
146 , dimap f FailureUniqueItems D4.uniqueItemsValidator
147 , dimap
148 (fromMaybe D4.emptyItems . f)
149 (\err -> case err of
150 D4.IRInvalidItems e -> FailureItems e
151 D4.IRInvalidAdditional e -> FailureAdditionalItems e)
152 (D4.itemsRelatedValidator descend)
153 , lmap f D4.definitionsEmbedded
155 , dimap f FailureMaxProperties D4.maxPropertiesValidator
156 , dimap f FailureMinProperties D4.minPropertiesValidator
157 , dimap f FailureRequired D4.requiredValidator
158 , dimap f FailureDependencies (D4.dependenciesValidator descend)
159 , dimap
160 (fromMaybe D4.emptyProperties . f)
161 FailurePropertiesRelated
162 (D4.propertiesRelatedValidator descend)
164 , dimap f FailureEnum D4.enumValidator
165 , dimap f FailureType D4.typeValidator
166 , dimap f FailureAllOf (D4.allOfValidator lateral)
167 , dimap f FailureAnyOf (D4.anyOfValidator lateral)
168 , dimap f FailureOneOf (D4.oneOfValidator lateral)
169 , dimap f FailureNot (D4.notValidator lateral)
170 ]
171 where
172 f :: FromJSON a => Schema -> Maybe a
173 f (Schema a) =
174 case AE.fromJSON (Object a) of
175 AE.Error _ -> Nothing
176 AE.Success b -> Just b
178 disableIfRefPresent :: Schema -> Schema
179 disableIfRefPresent schema =
180 case FE._fiRef draft4FetchInfo schema of
181 Nothing -> schema
182 Just _ -> Schema mempty
184 updateScope :: BaseURI -> Schema -> BaseURI
185 updateScope uri schema =
186 updateResolutionScope uri (FE._fiId draft4FetchInfo schema)
188 valRef
189 :: D4.VisitedSchemas
190 -> Scope Schema
191 -> Schema
192 -> Value
193 -> [ValidatorFailure]
194 valRef vis sc = JT.validate (d4Spec schemaMap vis sc)
196 descend :: Schema -> Value -> [ValidatorFailure]
197 descend = validateSubschema schemaMap mempty scope
199 lateral :: Schema -> Value -> [ValidatorFailure]
200 lateral = validateSubschema schemaMap visited scope