schematic 0.3.0.0 → 0.3.1.0
raw patch · 8 files changed
+294/−24 lines, 8 filesdep +regex-tdfadep +regex-tdfa-textdep −regex-compat
Dependencies added: regex-tdfa, regex-tdfa-text
Dependencies removed: regex-compat
Files
- ChangeLog.md +5/−0
- schematic.cabal +9/−3
- src/Data/Schematic.hs +3/−1
- src/Data/Schematic/Helpers.hs +59/−0
- src/Data/Schematic/JsonSchema.hs +33/−16
- src/Data/Schematic/Lens.hs +57/−0
- src/Data/Schematic/Validation.hs +4/−4
- test/HelpersSpec.hs +124/−0
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for schematic +## 0.3.1.0 -- 2017-09-28++Add UUID and ISO8601 helpers, json schema constraint export, fsubset lens+combinator.+ ## 0.3.0.0 -- 2017-09-28 Updated to GHC 8.2.1 and singletons 2.3.1
schematic.cabal view
@@ -1,10 +1,12 @@ name: schematic-version: 0.3.0.0+version: 0.3.1.0 synopsis: JSON-biased spec and validation tool license: BSD3 license-file: LICENSE author: Denis Redozubov maintainer: denis.redozubov@gmail.com+homepage: http://github.com/typeable/schematic+Bug-reports: http://github.com/typeable/schematic/issues/ category: Data build-type: Simple extra-source-files: ChangeLog.md@@ -14,6 +16,7 @@ exposed-modules: Data.Schematic , Data.Schematic.Instances , Data.Schematic.JsonSchema+ , Data.Schematic.Helpers , Data.Schematic.Lens , Data.Schematic.Migration , Data.Schematic.Path@@ -60,7 +63,8 @@ , containers , hjsonschema , mtl- , regex-compat+ , regex-tdfa+ , regex-tdfa-text , scientific , singletons >= 2.2 , smallcheck@@ -116,7 +120,8 @@ , hspec-discover , hspec-smallcheck , lens- , regex-compat+ , regex-tdfa+ , regex-tdfa-text , schematic , smallcheck , singletons@@ -126,5 +131,6 @@ , validationt >= 0.1.0.1 , vinyl other-modules: SchemaSpec+ , HelpersSpec , LensSpec , JsonSchemaSpec
src/Data/Schematic.hs view
@@ -3,9 +3,10 @@ module Data.Schematic ( module Data.Schematic.JsonSchema- , module Data.Schematic.Schema+ , module Data.Schematic.Helpers , module Data.Schematic.Lens , module Data.Schematic.Migration+ , module Data.Schematic.Schema , module Data.Schematic.Utils , decodeAndValidateJson , parseAndValidateJson@@ -26,6 +27,7 @@ import Data.ByteString.Lazy as BL import Data.Functor.Identity import Data.Schematic.JsonSchema+import Data.Schematic.Helpers import Data.Schematic.Lens import Data.Schematic.Migration import Data.Schematic.Schema
+ src/Data/Schematic/Helpers.hs view
@@ -0,0 +1,59 @@+module Data.Schematic.Helpers where++import Data.Schematic.Schema+import GHC.TypeLits+++type UUIDRegex =+ 'TRegex "[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}"++type IsUUID = '[UUIDRegex]++-- [ "1985-04-12T23:20:50.52Z"+-- , "1996-12-19T16:39:57-08:00"+-- , "1990-12-31T23:59:60Z"+-- , "1990-12-31T15:59:60-08:00"+-- , "1937-01-01T12:00:27.87+00:20"+-- ]++-- components+type ISO8601Date = "[1-9][0-9]{3}-(0[1-9]|1[0-2])-([0-2][0-9]|3[0-1])"++type ISO8601Time = "([0-1][0-9]|2[0-3]):[0-5][0-9]:[0-5][0-9]"++type ISO8601DateTime =+ AppendSymbol+ ISO8601Date+ (AppendSymbol "(T" (AppendSymbol ISO8601Time ")?"))++type ISO8601UTC = "(Z|\\+00:00)"++type ISO8601DateTimeUTC =+ AppendSymbol ISO8601Date (AppendSymbol "T" (AppendSymbol ISO8601Time ISO8601UTC))++type ISO8601TZ = "\\+[0-1][0-9]:[0-6][0-9]"++type ISO8601DateTimeZoned =+ AppendSymbol ISO8601Date (AppendSymbol "T" (AppendSymbol ISO8601Time ISO8601TZ))++-- regexes+type ISO8601DateRegex = 'TRegex ISO8601Date++type ISO8601TimeRegex = 'TRegex ISO8601Time++type ISO8601DateTimeRegex = 'TRegex ISO8601DateTime++type ISO8601DateTimeRegexUTC = 'TRegex ISO8601DateTimeUTC++type ISO8601DateTimeRegexZoned = 'TRegex ISO8601DateTimeZoned++-- constraints+type IsDate = '[ISO8601DateRegex]++type IsTime = '[ISO8601TimeRegex]++type IsDateTime = '[ISO8601DateTimeRegex]++type IsZonedDateTime = '[ISO8601DateTimeRegexZoned]++type IsUTCDateTime = '[ISO8601DateTimeRegexUTC]
src/Data/Schematic/JsonSchema.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-} module Data.Schematic.JsonSchema ( toJsonSchema@@ -8,9 +9,10 @@ ) where import Control.Monad.State.Strict-import Data.Foldable+import Data.Aeson as J+import Data.Foldable as F import Data.HashMap.Strict as H-import Data.List.NonEmpty+import Data.List.NonEmpty as NE import Data.Schematic.Schema as S import Data.Singletons import Data.Text@@ -19,24 +21,39 @@ draft4 :: Text-draft4 = "http://Jason-schema.org/draft-04/schema#"+draft4 = "http://json-schema.org/draft-04/schema#" --- FIXME: implement all this later textConstraint :: DemotedTextConstraint -> State D4.Schema ()-textConstraint (DTEq _) = pure ()-textConstraint (DTLt _) = pure ()-textConstraint (DTLe _) = pure ()-textConstraint (DTGt _) = pure ()-textConstraint (DTGe _) = pure ()-textConstraint (DTRegex _) = pure ()-textConstraint (DTEnum _) = pure ()+textConstraint (DTEq n) = modify $ \s -> s+ { _schemaMinLength = pure $ fromIntegral n+ , _schemaMaxLength = pure $ fromIntegral n }+textConstraint (DTLt n) = modify $ \s -> s+ { _schemaMaxLength = pure . fromIntegral $ n + 1 }+textConstraint (DTLe n) = modify $ \s -> s+ { _schemaMaxLength = pure . fromIntegral $ n }+textConstraint (DTGt n) =+ let n' = if n == 0 then 0 else n - 1+ in modify $ \s -> s { _schemaMinLength = pure . fromIntegral $ n' }+textConstraint (DTGe n) = modify $ \s -> s+ { _schemaMinLength = pure . fromIntegral $ n }+textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }+textConstraint (DTEnum ss) =+ let ss' = if F.length ss == 0 then [] else NE.fromList $ J.String <$> ss+ in modify $ \s -> s { _schemaEnum = pure ss' } numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()-numberConstraint (DNLe _) = pure ()-numberConstraint (DNLt _) = pure ()-numberConstraint (DNGt _) = pure ()-numberConstraint (DNGe _) = pure ()-numberConstraint (DNEq _) = pure ()+numberConstraint (DNLe n) = modify $ \s -> s+ { _schemaMaximum = pure . fromIntegral $ n }+numberConstraint (DNLt n) = modify $ \s -> s+ { _schemaMaximum = pure . fromIntegral $ n + 1 }+numberConstraint (DNGt n) = modify $ \s -> s+ { _schemaMinimum = pure . fromIntegral $ n }+numberConstraint (DNGe n) =+ let n' = if n == 0 then 0 else n - 1+ in modify $ \s -> s { _schemaMinimum = pure . fromIntegral $ n' }+numberConstraint (DNEq n) = modify $ \s -> s+ { _schemaMinimum = pure $ fromIntegral n+ , _schemaMaximum = pure $ fromIntegral n } arrayConstraint :: DemotedArrayConstraint -> State D4.Schema () arrayConstraint (DAEq _) = pure ()
src/Data/Schematic/Lens.hs view
@@ -64,3 +64,60 @@ fput y = getIdentity . flens Proxy (\_ -> Identity y) {-# INLINE fput #-}++-- This is an internal convenience stolen from the @lens@ library.+lens+ :: Functor f+ => (t -> s)+ -> (t -> a -> b)+ -> (s -> f a)+ -> t+ -> f b+lens sa sbt afb s = fmap (sbt s) $ afb (sa s)+{-# INLINE lens #-}++-- | A partial relation that gives the indices of a sublist in a larger list.+type family FImage (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) :: [Nat] where+ FImage '[] ss = '[]+ FImage ('(fn,s) ': rs) ss = FIndex fn ss ': FImage rs ss++class is ~ FImage rs ss+ => FSubset (rs :: [(Symbol, Schema)]) (ss :: [(Symbol, Schema)]) is where+ -- | This is a lens into a slice of the larger record. Morally, we have:+ --+ -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)+ fsubset+ :: Functor g+ => (Rec FieldRepr rs -> g (Rec FieldRepr rs))+ -> Rec FieldRepr ss+ -> g (Rec FieldRepr ss)++ -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record+ -- to a smaller one by forgetting fields.+ fcast+ :: Rec FieldRepr ss+ -> Rec FieldRepr rs+ fcast = getConst . fsubset Const+ {-# INLINE fcast #-}++ -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of+ -- a record to be replaced with different values.+ freplace+ :: Rec FieldRepr rs+ -> Rec FieldRepr ss+ -> Rec FieldRepr ss+ freplace rs = getIdentity . fsubset (\_ -> Identity rs)+ {-# INLINE freplace #-}++instance FSubset '[] ss '[] where+ fsubset = lens (const RNil) const++instance+ ( ByRevision fn ss i ~ s+ , FElem fn ss i+ , FSubset rs ss is+ ) => FSubset ( '(fn,s) ': rs) ss (i ': is) where+ fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set+ where+ set :: Rec FieldRepr ss -> Rec FieldRepr ( '(fn,s) ': rs) -> Rec FieldRepr ss+ set ss (r :& rs) = fput r $ freplace rs ss
src/Data/Schematic/Validation.hs view
@@ -16,7 +16,7 @@ import Data.Vector as V import Data.Vinyl import Prelude as P-import Text.Regex+import Text.Regex.TDFA type Validation a = ValidationT ErrorMap Identity a@@ -84,9 +84,9 @@ unless predicate warn STRegex r -> do let- regex = withKnownSymbol r $ symbolVal r- predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)- errMsg = path <> " must match " <> T.pack (show regex)+ regex = withKnownSymbol r $ fromSing r+ predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)+ errMsg = path <> " must match " <> regex warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STEnum ss -> do
+ test/HelpersSpec.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}++module HelpersSpec (spec, main) where++import Control.Lens+import Data.Aeson+import Data.ByteString.Char8 as C8+import Data.ByteString.Lazy as BL+import Data.ByteString.Lazy.Lens+import Data.Foldable+import Data.Functor.Identity+import Data.Monoid+import Data.Proxy+import Data.Schematic+import Data.Text as T+import Data.Text.Lens+import Data.Vinyl+import Test.Hspec+++type UUIDSchema = 'SchemaObject '[ '("uuid", 'SchemaText IsUUID) ]++-- | Taken from UUID RFC 4122+uuid :: Text+uuid = "f81d4fae-7dec-11d0-a765-00a0c91e6bf6"++type ISO8601DateSchema = 'SchemaObject '[ '("date", 'SchemaText IsDate) ]++iso8601dates :: [Text]+iso8601dates = [ "1985-04-12" ]++invalidIso8601dates :: [Text]+invalidIso8601dates = [ "1999-13-12" ]++type ISO8601TimeSchema = 'SchemaObject '[ '("time", 'SchemaText IsTime) ]++iso8601times :: [Text]+iso8601times =+ [ "19:23:00"+ , "00:00:00"+ , "23:47:12" ]++invalidIso8601times :: [Text]+invalidIso8601times =+ [ "00:60:00"+ , "24:01:02" ]++type ISO8601DateTimeSchema = 'SchemaObject '[ '("datetime", 'SchemaText IsDateTime) ]++-- | Taken from ISO8601 RFC 3339+iso8601datetimes :: [Text]+iso8601datetimes =+ iso8601dates <>+ [ "1985-04-12T23:20:50.52Z"+ , "1996-12-19T16:39:57-08:00"+ , "1990-12-31T23:59:60Z"+ , "1990-12-31T15:59:60-08:00"+ , "1937-01-01T12:00:27.87+00:20"+ ]++invalidIso8601datetimes :: [Text]+invalidIso8601datetimes =+ [ "1996-13-129T16:39:57-08:00"+ , "1990-2-31T23:59:60Z"+ , "1990-12-32T15:59:70"+ , "1937-01-1T12::27.87+24:20"+ ]++spec :: Spec+spec = do+ describe "UUID: " $ do+ it "validates correct UUID" $ do+ let+ uuidJson = "{\"uuid\": \"" <> (uuid ^. unpacked . packedChars) <> "\" }"+ (decodeAndValidateJson uuidJson :: ParseResult (JsonRepr UUIDSchema))+ `shouldSatisfy` isValid++ it "fails to validate incorrect UUID" $ do+ let+ incorrectJson = "{\"uuid\": \"incorrect\" }"+ (decodeAndValidateJson incorrectJson :: ParseResult (JsonRepr UUIDSchema))+ `shouldSatisfy` isValidationError++ describe "ISO8601 date: " $ do+ for_ iso8601dates $ \dt -> do+ it ("validates correct date - " <> dt ^. unpacked) $ do+ let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))+ `shouldSatisfy` isValid++ for_ invalidIso8601dates $ \dt -> do+ it ("fails to validate incorrect date - " <> dt ^. unpacked) $ do+ let json = "{\"date\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateSchema))+ `shouldSatisfy` isValidationError++ describe "ISO8601 time: " $ do+ for_ iso8601times $ \dt -> do+ it ("validates correct time - " <> dt ^. unpacked) $ do+ let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))+ `shouldSatisfy` isValid++ for_ invalidIso8601times $ \dt -> do+ it ("fails to validate incorrect time - " <> dt ^. unpacked) $ do+ let json = "{\"time\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601TimeSchema))+ `shouldSatisfy` isValidationError++ describe "ISO8601 datetime: " $ do+ for_ iso8601datetimes $ \dt -> do+ it ("validates correct datetime - " <> dt ^. unpacked) $ do+ let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))+ `shouldSatisfy` isValid++ for_ invalidIso8601datetimes $ \dt -> do+ it ("fails to validate incorrect datetime - " <> dt ^. unpacked) $ do+ let json = "{\"datetime\": \"" <> (dt ^. unpacked . packedChars) <> "\" }"+ (decodeAndValidateJson json :: ParseResult (JsonRepr ISO8601DateTimeSchema))+ `shouldSatisfy` isValidationError++main :: IO ()+main = hspec spec