870bf5d · typeable/schematic

schematic.cabal+6−2

compare with master

unifiedsplit

@@ -16,6 +16,7 @@ library

16 exposed-modules: Data.Schematic

17 , Data.Schematic.Instances

18 , Data.Schematic.JsonSchema

19+ , Data.Schematic.Helpers

19 , Data.Schematic.Lens

20 , Data.Schematic.Lens

20 , Data.Schematic.Migration

21 , Data.Schematic.Migration

21 , Data.Schematic.Path

22 , Data.Schematic.Path

@@ -62,7 +63,8 @@ library

62 , containers

63 , containers

63 , hjsonschema

64 , hjsonschema

64 , mtl

65 , mtl

65− , regex-compat

66+ , regex-tdfa

67+ , regex-tdfa-text

66 , scientific

68 , scientific

67 , singletons >= 2.2

69 , singletons >= 2.2

68 , smallcheck

70 , smallcheck

@@ -118,7 +120,8 @@ test-suite spec

118 , hspec-discover

120 , hspec-discover

119 , hspec-smallcheck

121 , hspec-smallcheck

120 , lens

122 , lens

121− , regex-compat

123+ , regex-tdfa

124+ , regex-tdfa-text

122 , schematic

125 , schematic

123 , smallcheck

126 , smallcheck

124 , singletons

127 , singletons

@@ -128,5 +131,6 @@ test-suite spec

128 , validationt >= 0.1.0.1

131 , validationt >= 0.1.0.1

129 , vinyl

132 , vinyl

130 other-modules: SchemaSpec

133 other-modules: SchemaSpec

134+ , HelpersSpec

131 , LensSpec

135 , LensSpec

132 , JsonSchemaSpec

136 , JsonSchemaSpec

src/Data/Schematic.hs+3−1

@@ -3,9 +3,10 @@

3

4module Data.Schematic

5 ( module Data.Schematic.JsonSchema

6− , module Data.Schematic.Schema

6+ , module Data.Schematic.Helpers

7 , module Data.Schematic.Lens

8 , module Data.Schematic.Migration

9+ , module Data.Schematic.Schema

9 , module Data.Schematic.Utils

10 , module Data.Schematic.Utils

10 , decodeAndValidateJson

11 , decodeAndValidateJson

11 , parseAndValidateJson

12 , parseAndValidateJson

@@ -26,6 +27,7 @@ import Data.Aeson.Types as J

26import Data.ByteString.Lazy as BL

27import Data.ByteString.Lazy as BL

27import Data.Functor.Identity

28import Data.Functor.Identity

28import Data.Schematic.JsonSchema

29import Data.Schematic.JsonSchema

30+import Data.Schematic.Helpers

29import Data.Schematic.Lens

31import Data.Schematic.Lens

30import Data.Schematic.Migration

32import Data.Schematic.Migration

31import Data.Schematic.Schema

33import Data.Schematic.Schema

src/Data/Schematic/Helpers.hsnew file+13

@@ -0,0 +1,13 @@

1+module Data.Schematic.Helpers where

2+

3+import Data.Schematic.Schema

4+

5+type UUIDRegex =

6+ 'TRegex "[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}"

7+

8+type IsUUID = '[UUIDRegex]

9+

10+type ISO8601Regex =

11+ 'TRegex "(\\d{4}-[01]\\d-[0-3]\\dT[0-2]\\d:[0-5]\\d:[0-5]\\d\\.\\d+([+-][0-2]\\d:[0-5]\\d|Z))|(\\d{4}-[01]\\d-[0-3]\\dT[0-2]\\d:[0-5]\\d:[0-5]\\d([+-][0-2]\\d:[0-5]\\d|Z))|(\\d{4}-[01]\\d-[0-3]\\dT[0-2]\\d:[0-5]\\d([+-][0-2]\\d:[0-5]\\d|Z))"

12+

13+type IsDateTime = '[ISO8601Regex]

src/Data/Schematic/Validation.hs+4−4

@@ -16,7 +16,7 @@ import Data.Traversable

16import Data.Vector as V

17import Data.Vinyl

18import Prelude as P

19−import Text.Regex

19+import Text.Regex.TDFA

20

21

22type Validation a = ValidationT ErrorMap Identity a

@@ -84,9 +84,9 @@ validateTextConstraint (JSONPath path) t = \case

84 unless predicate warn

85 STRegex r -> do

86 let

87− regex = withKnownSymbol r $ symbolVal r

87+ regex = withKnownSymbol r $ fromSing r

88− predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)

88+ predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)

89− errMsg = path <> " must match " <> T.pack (show regex)

89+ errMsg = path <> " must match " <> regex

90 warn = vWarning $ mmSingleton path (pure errMsg)

91 unless predicate warn

92 STEnum ss -> do

test/HelpersSpec.hsnew file+62

@@ -0,0 +1,62 @@

1+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

2+

3+module HelpersSpec (spec, main) where

4+

5+import Control.Lens

6+import Data.Aeson

7+import Data.ByteString.Char8 as C8

8+import Data.ByteString.Lazy as BL

9+import Data.ByteString.Lazy.Lens

10+import Data.Foldable

11+import Data.Functor.Identity

12+import Data.Monoid

13+import Data.Proxy

14+import Data.Schematic

15+import Data.Text as T

16+import Data.Text.Lens

17+import Data.Vinyl

18+import Test.Hspec

19+

20+

21+type UUIDSchema = 'SchemaObject '[ '("uuid", 'SchemaText IsUUID) ]

22+

23+-- | Taken from UUID RFC 4122

24+uuid :: Text

25+uuid = "f81d4fae-7dec-11d0-a765-00a0c91e6bf6"

26+

27+type ISO8601Schema = 'SchemaObject '[ '("datetime", 'SchemaText IsDateTime) ]

28+

29+-- | Taken from ISO8601 RFC 3339

30+iso8601datetimes :: [Text]

31+iso8601datetimes =

32+ [ "1985-04-12T23:20:50.52Z"

33+ , "1996-12-19T16:39:57-08:00"

34+ , "1990-12-31T23:59:60Z"

35+ , "1990-12-31T15:59:60-08:00"

36+ , "1937-01-01T12:00:27.87+00:20"

37+ ]

38+

39+spec :: Spec

40+spec = do

41+ describe "UUID: " $ do

42+ it "validates correct UUID" $ do

43+ let

44+ uuidJson = "{\"uuid\": \"" <> (uuid ^. unpacked . packedChars) <> "\" }"

45+ (decodeAndValidateJson uuidJson :: ParseResult (JsonRepr UUIDSchema))

46+ `shouldSatisfy` isValid

47+

48+ it "fails to validate incorrect UUID" $ do

49+ let

50+ incorrectJson = "{\"uuid\": \"incorrect\" }"

51+ (decodeAndValidateJson incorrectJson :: ParseResult (JsonRepr UUIDSchema))

52+ `shouldSatisfy` isValidationError

53+

54+ describe "ISO8601 datetime: " $ do

55+ for_ iso8601datetimes $ \dt -> do

56+ it ("validates correct datetime - " <> dt ^. unpacked) $ do

57+ let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"

58+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601Schema))

59+ `shouldSatisfy` isValidationError

60+

61+main :: IO ()

62+main = hspec spec