git.iko.soy/schematic
on superrecord help sign in
schematic/src/Data/Schematic.hs
147 lines 4.7 kB history raw
1{-# OPTIONS -fprint-explicit-kinds #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
4module Data.Schematic
5 ( module Data.Schematic.Schema
6 , module Data.Schematic.Lens
7 , module Data.Schematic.Migration
8 , module Data.Schematic.Utils
9 , decodeAndValidateJson
10 , parseAndValidateJson
11 , parseAndValidateJsonBy
12 , parseAndValidateVersionedJson
13 , parseAndValidateTopVersionJson
14 , decodeAndValidateVersionedJson
15 , parseAndValidateWithMList
16 , decodeAndValidateVersionedWithMList
17 , isValid
18 , isDecodingError
19 , isValidationError
20 , ParseResult(..)
21 , Migratable
22 ) where
24import Control.Monad.Validation
25import Data.Aeson as J
26import Data.Aeson.Types as J
27import Data.ByteString.Lazy as BL
28import Data.Functor.Identity
29import Data.Schematic.Lens
30import Data.Schematic.Migration
31import Data.Schematic.Schema
32import Data.Schematic.Utils
33import Data.Schematic.Validation
34import Data.Singletons.Prelude
35import Data.Text as T
38parseAndValidateJson
39 :: forall schema
40 . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
41 => J.Value
42 -> ParseResult (JsonRepr schema)
43parseAndValidateJson v =
44 case parseEither parseJSON v of
45 Left s -> DecodingError $ T.pack s
46 Right jsonRepr ->
47 let
48 validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr
49 res = runIdentity . runValidationTEither $ validate
50 in case res of
51 Left em -> ValidationError em
52 Right () -> Valid jsonRepr
54parseAndValidateJsonBy
55 :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
56 => proxy schema
57 -> J.Value
58 -> ParseResult (JsonRepr schema)
59parseAndValidateJsonBy _ = parseAndValidateJson
61parseAndValidateTopVersionJson
62 :: forall proxy (v :: Versioned)
63 . (SingI (TopVersion (AllVersions v)))
64 => proxy v
65 -> J.Value
66 -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
67parseAndValidateTopVersionJson _ v =
68 case parseEither parseJSON v of
69 Left s -> DecodingError $ T.pack s
70 Right jsonRepr ->
71 let
72 validate =
73 validateJsonRepr (sing :: Sing (TopVersion (AllVersions v))) [] jsonRepr
74 res = runIdentity . runValidationTEither $ validate
75 in case res of
76 Left em -> ValidationError em
77 Right () -> Valid jsonRepr
79class Migratable (revisions :: [(Revision, Schema)]) where
80 mparse
81 :: Sing revisions
82 -> J.Value
83 -> ParseResult (JsonRepr (Snd (Head revisions)))
85instance
86 {-# OVERLAPPING #-}
87 ( TopLevel (Snd rev), SingI (Snd rev) )
88 => Migratable '[rev] where
89 mparse _ = parseAndValidateJson
91instance {-# OVERLAPPABLE #-}
92 ( Migratable (Tail revisions)
93 , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))
94 , SingI (Snd (Head revisions)))
95 => Migratable revisions where
96 mparse s v = case parseEither parseJSON v of
97 Left _ ->
98 migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions)))))
99 Right x -> Valid x
101parseAndValidateVersionedJson
102 :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))
103 => proxy v
104 -> J.Value
105 -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
106parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
108parseAndValidateWithMList
109 :: MList revisions
110 -> J.Value
111 -> ParseResult (JsonRepr (Head revisions))
112parseAndValidateWithMList MNil v = parseAndValidateJson v
113parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of
114 Valid a -> Valid a
115 DecodingError _ -> f <$> parseAndValidateWithMList tl v
116 ValidationError _ -> f <$> parseAndValidateWithMList tl v
118decodeAndValidateJson
119 :: forall schema
120 . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
121 => BL.ByteString
122 -> ParseResult (JsonRepr schema)
123decodeAndValidateJson bs = case decode bs of
124 Nothing -> DecodingError "malformed json"
125 Just x -> parseAndValidateJson x
127decodeAndValidateVersionedJson
128 :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))
129 => proxy versioned
130 -> BL.ByteString
131 -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))
132decodeAndValidateVersionedJson vp bs = case decode bs of
133 Nothing -> DecodingError "malformed json"
134 Just x -> parseAndValidateVersionedJson vp x
136type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
137 MapSnd '[] = '[]
138 MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
140decodeAndValidateVersionedWithMList
141 :: proxy versioned
142 -> MList (MapSnd (AllVersions versioned))
143 -> BL.ByteString
144 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
145decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
146 Nothing -> DecodingError "malformed json"
147 Just x -> parseAndValidateWithMList mlist x