schematic/src/Data/Schematic.hs at df04fe4b34560e4aac8d9b53251e0ffeec5038ca · typeable/schematic · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
{-# OPTIONS -fprint-explicit-kinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Data.Schematic
  ( module Data.Schematic.JsonSchema
  , module Data.Schematic.Helpers
  , module Data.Schematic.Lens
  , module Data.Schematic.Migration
  , module Data.Schematic.Schema
  , module Data.Schematic.Constraints
  , module Data.Schematic.Compat
  , decodeAndValidateJson
  , parseAndValidateJson
  , parseAndValidateTopVersionJson
  , parseAndValidateWithMList
  , decodeAndValidateVersionedWithMList
  , decodeAndValidateVersionedWithPureMList
  , isValid
  , isDecodingError
  , isValidationError
  , ParseResult(..)
  , withRepr
  , field
  ) where

import Control.Monad.Validation
import Data.Aeson as J
import Data.Aeson.Types as J
import Data.ByteString.Lazy as BL
import Data.Functor.Identity as F
import Data.Schematic.Compat
import Data.Schematic.Constraints
import Data.Schematic.DSL
import Data.Schematic.Helpers
import Data.Schematic.JsonSchema
import Data.Schematic.Lens
import Data.Schematic.Migration
import Data.Schematic.Schema
import Data.Schematic.Validation
import Data.Singletons.Prelude hiding ((:.))
import Data.Tagged
import Data.Text as T


parseAndValidateTopVersionJson
  :: forall proxy (v :: Versioned)
  . ( SingI (TopVersion (AllVersions v))
    , FromJSON (JsonRepr (TopVersion (AllVersions v))) )
  => proxy v
  -> J.Value
  -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
parseAndValidateTopVersionJson _ v =
  case parseEither parseJSON v of
    Left s -> DecodingError $ T.pack s
    Right jsonRepr ->
      let
        validate =
          validateJsonRepr (sing :: Sing (TopVersion (AllVersions v))) [] jsonRepr
        res      = runIdentity . runValidationTEither $ validate
      in case res of
        Left em  -> ValidationError em
        Right () -> Valid jsonRepr

parseAndValidateWithMList
  :: Monad m
  => MList m revisions
  -> J.Value
  -> m (ParseResult (JsonRepr (Head revisions)))
parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v
parseAndValidateWithMList (Tagged f :&& tl) v =
  case parseAndValidateJson v of
    Valid a           -> pure $ Valid a
    _   -> do
      pr <- parseAndValidateWithMList tl v
      let pr' = f <$> pr
      sequence pr'

decodeAndValidateJson
  :: forall schema
  .  (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
  => BL.ByteString
  -> ParseResult (JsonRepr schema)
decodeAndValidateJson bs = case decode bs of
  Nothing -> DecodingError "malformed json"
  Just x  -> parseAndValidateJson x

decodeAndValidateVersionedWithMList
  :: Monad m
  => proxy versioned
  -> MList m (MapSnd (AllVersions versioned))
  -> BL.ByteString
  -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))))
decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
  Nothing -> pure $ DecodingError "malformed json"
  Just x  -> parseAndValidateWithMList mlist x

decodeAndValidateVersionedWithPureMList
  :: FromJSON (JsonRepr (Head (MapSnd (AllVersions versioned))))
  => proxy versioned
  -> MList F.Identity (MapSnd (AllVersions versioned))
  -> BL.ByteString
  -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
decodeAndValidateVersionedWithPureMList a b c =
  runIdentity $ decodeAndValidateVersionedWithMList a b c