git.iko.soy/schematic
on union help sign in
schematic/src/Data/Schematic/JsonSchema.hs
105 lines 3.8 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE OverloadedLabels #-}
4{-# LANGUAGE TemplateHaskell #-}
6module Data.Schematic.JsonSchema
7 ( toJsonSchema
8 , toJsonSchema'
9 ) where
11import Control.Monad.State.Strict
12import Data.Aeson as J
13import Data.Foldable as F
14import Data.HashMap.Strict as H
15import Data.List.NonEmpty as NE
16import Data.Schematic.Schema as S
17import Data.Singletons
18import Data.Text
19import Data.Traversable
20import JSONSchema.Draft4.Schema as D4
21import JSONSchema.Validator.Draft4 as D4
24draft4 :: Text
25draft4 = "http://json-schema.org/draft-04/schema#"
27textConstraint :: DemotedTextConstraint -> State D4.Schema ()
28textConstraint (DTEq n) = modify $ \s -> s
29 { _schemaMinLength = pure $ fromIntegral n
30 , _schemaMaxLength = pure $ fromIntegral n }
31textConstraint (DTLt n) = modify $ \s -> s
32 { _schemaMaxLength = pure . fromIntegral $ n + 1 }
33textConstraint (DTLe n) = modify $ \s -> s
34 { _schemaMaxLength = pure . fromIntegral $ n }
35textConstraint (DTGt n) =
36 let n' = if n == 0 then 0 else n - 1
37 in modify $ \s -> s { _schemaMinLength = pure . fromIntegral $ n' }
38textConstraint (DTGe n) = modify $ \s -> s
39 { _schemaMinLength = pure . fromIntegral $ n }
40textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }
41textConstraint (DTEnum ss) =
42 let ss' = if F.length ss == 0 then [] else NE.fromList $ J.String <$> ss
43 in modify $ \s -> s { _schemaEnum = pure ss' }
45numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()
46numberConstraint (DNLe n) = modify $ \s -> s
47 { _schemaMaximum = pure . fromIntegral $ n }
48numberConstraint (DNLt n) = modify $ \s -> s
49 { _schemaMaximum = pure . fromIntegral $ n + 1 }
50numberConstraint (DNGt n) = modify $ \s -> s
51 { _schemaMinimum = pure . fromIntegral $ n }
52numberConstraint (DNGe n) =
53 let n' = if n == 0 then 0 else n - 1
54 in modify $ \s -> s { _schemaMinimum = pure . fromIntegral $ n' }
55numberConstraint (DNEq n) = modify $ \s -> s
56 { _schemaMinimum = pure $ fromIntegral n
57 , _schemaMaximum = pure $ fromIntegral n }
59arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()
60arrayConstraint (DAEq _) = pure ()
62toJsonSchema
63 :: forall proxy schema
64 . SingI schema
65 => proxy (schema :: S.Schema)
66 -> Maybe D4.Schema
67toJsonSchema _ = do
68 js <- toJsonSchema' $ fromSing (sing :: Sing schema)
69 pure $ js { _schemaVersion = pure draft4 }
71toJsonSchema'
72 :: DemotedSchema
73 -> Maybe D4.Schema
74toJsonSchema' = \case
75 DSchemaText tcs ->
76 pure $ execState (traverse_ textConstraint tcs) $ emptySchema
77 { _schemaType = pure $ TypeValidatorString D4.SchemaString }
78 DSchemaNumber ncs ->
79 pure $ execState (traverse_ numberConstraint ncs) $ emptySchema
80 { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }
81 DSchemaBoolean -> pure $ emptySchema
82 { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }
83 DSchemaObject objs -> do
84 res <- for objs $ \(n,s) -> do
85 s' <- toJsonSchema' s
86 pure (n, s')
87 pure $ emptySchema
88 { _schemaType = pure $ TypeValidatorString D4.SchemaObject
89 , _schemaProperties = pure $ H.fromList res }
90 DSchemaArray acs sch -> do
91 res <- toJsonSchema' sch
92 pure $ execState (traverse_ arrayConstraint acs) $ emptySchema
93 { _schemaType = pure $ TypeValidatorString D4.SchemaArray
94 , _schemaItems = pure $ ItemsArray [res] }
95 DSchemaNull -> pure $ emptySchema
96 { _schemaType = pure $ TypeValidatorString D4.SchemaNull }
97 DSchemaOptional sch -> do
98 snull <- toJsonSchema' DSchemaNull
99 sres <- toJsonSchema' sch
100 pure $ emptySchema { _schemaOneOf = pure (snull :| [sres]) }
101 DSchemaUnion sch -> do
102 schemaUnion <- traverse toJsonSchema' sch >>= \case
103 [] -> Nothing
104 x -> Just x
105 pure $ emptySchema { _schemaAnyOf = pure $ NE.fromList schemaUnion }