verdict-json (empty) → 0.0.0.0
raw patch · 9 files changed
+450/−0 lines, 9 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, hspec, text, unordered-containers, vector, verdict, verdict-json
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/Example.hs +30/−0
- src/Verdict/JSON.hs +21/−0
- src/Verdict/JSON/Class.hs +64/−0
- src/Verdict/JSON/Types.hs +138/−0
- test/Spec.hs +1/−0
- test/Verdict/JSONSpec.hs +84/−0
- verdict-json.cabal +80/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Julian K. Arni++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Julian K. Arni nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Example.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+import qualified Data.Map as Map+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic)++import Verdict+import Verdict.JSON++type NameC = MinLength 1 :&& MaxLength 100+type Name = Validated NameC String+type AgeC = Minimum 0 :&& Maximum 200+type Age = Validated AgeC Integer++data Person = Person+ { name :: Name+ , age :: Age+ } deriving (Eq, Show, Read, Generic)++instance JsonSchema Person where+ jsonSchema _ = JsonSpec $ Map.fromList [ ("name", Left $ jsonVerdict namep)+ , ("age" , Left $ jsonVerdict agep )+ ]+ where namep = Proxy :: Proxy NameC+ agep = Proxy :: Proxy AgeC++main :: IO ()+main = print $ jsonSchema (Proxy :: Proxy Person)
+ src/Verdict/JSON.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Verdict.JSON+ ( JsonSchema(..)+ , ObjectSchema(..)+ , AnySchema(..)+ , Required(..)+ , mkAny+ , jsonSchema+ ) where++import Data.Aeson+import Verdict++import Verdict.JSON.Class+import Verdict.JSON.Types++instance (HaskVerdict c a, FromJSON a) => FromJSON (Validated c a) where+ parseJSON x = parseJSON x >>= either (fail . show) return . validate++instance (ToJSON a) => ToJSON (Validated c a) where+ toJSON = toJSON . getVal
+ src/Verdict/JSON/Class.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Verdict.JSON.Class where++import Data.Monoid+import Data.Proxy+import GHC.TypeLits+import Verdict+import Verdict.JSON.Types+++------------------------------------------------------------------------------+-- * JsonSchema+------------------------------------------------------------------------------++class (MkAny (JsonType a), Monoid (JsonType a)) => JsonSchema a where+ type JsonType a+ jsonSchema' :: proxy a -> JsonType a++instance (KnownNat n)+ => JsonSchema (Validated (Maximum n) i) where+ type JsonType (Validated (Maximum n) i) = NumericSchema+ jsonSchema' _ = mempty { maximum' = Just $ Max v }+ where v = fromInteger $ natVal (Proxy :: Proxy n)++instance (KnownNat n)+ => JsonSchema (Validated (Minimum n) i) where+ type JsonType (Validated (Minimum n) i) = NumericSchema+ jsonSchema' _ = mempty { minimum' = Just $ Min v }+ where v = fromInteger $ natVal (Proxy :: Proxy n)++instance ( JsonSchema (Validated c a), JsonSchema (Validated c' a)+ , JsonType (Validated c a) ~ JsonType (Validated c' a)+ ) => JsonSchema (Validated (c :&& c') a) where+ type JsonType (Validated (c :&& c') a) = JsonType (Validated c a)+ jsonSchema' _ = jsonSchema' pa <> jsonSchema' pb+ where pa = Proxy :: Proxy (Validated c a)+ pb = Proxy :: Proxy (Validated c' a)++instance ( KnownNat n+ ) => JsonSchema (Validated (MaxLength n) String) where+ type JsonType (Validated (MaxLength n) String) = StringSchema+ jsonSchema' _ = mempty { maxLength = Just $ Max v }+ where v = fromInteger $ natVal (Proxy :: Proxy n)++instance ( KnownNat n+ ) => JsonSchema (Validated (MinLength n) String) where+ type JsonType (Validated (MinLength n) String) = StringSchema+ jsonSchema' _ = mempty { minLength = Just $ Min v }+ where v = fromInteger $ natVal (Proxy :: Proxy n)++class MkAny a where+ mkAny :: a -> AnySchema++instance MkAny ObjectSchema where+ mkAny = ObjectS++instance MkAny NumericSchema where+ mkAny = NumericS++instance MkAny StringSchema where+ mkAny = StringS++jsonSchema :: JsonSchema a => proxy a -> AnySchema+jsonSchema = mkAny . jsonSchema'
+ src/Verdict/JSON/Types.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+module Verdict.JSON.Types where++import Data.Aeson+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import qualified Data.Text as Text+import Data.Vector (fromList)+import GHC.Generics (Generic)++data NumericT = JSONInteger | JSONNumeric+ deriving (Eq, Show, Read, Generic)++data AnySchema = ObjectS ObjectSchema+ | NumericS NumericSchema+ {-| ArrayS ArraySchema-}+ | StringS StringSchema+ | EmptyS+ deriving (Eq, Show, Read, Generic)++instance Monoid AnySchema where+ mempty = EmptyS+ (ObjectS a) `mappend` (ObjectS b) = ObjectS (a <> b)+ (NumericS a) `mappend` (NumericS b) = NumericS (a <> b)+ (StringS a) `mappend` (StringS b) = StringS (a <> b)+ EmptyS `mappend` x = x+ _ `mappend` _ = error "must be same constructor"++instance ToJSON AnySchema where+ toJSON (ObjectS os) = let (Object o) = toJSON os+ in Object $ HashMap.insert "type" (String "object") o+ toJSON (NumericS ns) = let (Object o) = toJSON ns+ in Object $ HashMap.insert "type" (String "number") o+ toJSON (StringS ss) = let (Object o) = toJSON ss+ in Object $ HashMap.insert "type" (String "string") o+ toJSON EmptyS = object []++data Either' a b = Left' a | Right' b+ deriving (Eq, Show, Read, Functor, Generic)++instance (ToJSON a, ToJSON b) => ToJSON (Either' a b) where+ toJSON (Left' a) = toJSON a+ toJSON (Right' b) = toJSON b++data ObjectSchema = ObjectSchema+ { properties :: Map.Map Text.Text (Required, AnySchema)+ , additionalProperties :: ()+ , patternProperties :: Map.Map Text.Text AnySchema+ } deriving (Eq, Show, Read, Generic)++instance Monoid ObjectSchema where+ mempty = ObjectSchema mempty mempty mempty+ a `mappend` b = ObjectSchema+ { properties = properties a <> properties b+ , additionalProperties = mempty+ , patternProperties = patternProperties a <> patternProperties b+ }++instance ToJSON ObjectSchema where+ toJSON os = object [+ "properties" .= toJSON (snd <$> properties os)+ , "required" .= Array (String <$> fromList reqs)+ {-, "additionalProperties" .= toJSON (additionalProperties os)-}+ {-, "patternProperties" .= toJSON (patternProperties os)-}+ ]+ where reqs = Map.keys $ Map.filter ((== Required) . fst) $ properties os++data NumericSchema = NumericSchema+ { multipleOf :: [Int]+ , maximum' :: Maybe Max+ , minimum' :: Maybe Min+ } deriving (Eq, Show, Read, Generic)++instance Monoid NumericSchema where+ mempty = NumericSchema mempty mempty mempty+ a `mappend` b = NumericSchema { multipleOf = multipleOf a <> multipleOf b+ , maximum' = maximum' a <> maximum' b+ , minimum' = minimum' a <> minimum' b+ }++instance ToJSON NumericSchema where+ toJSON ns = object $ catMaybes go+ where+ go = [ ("multipleOf" .=) <$> (toJSON <$> listToMaybe (multipleOf ns))+ , ("maximum" .=) <$> (toJSON . unMax <$> maximum' ns)+ , ("minimum" .=) <$> (toJSON . unMin <$> minimum' ns)+ ]++newtype Max = Max { unMax :: Int}+ deriving (Eq, Show, Bounded, Ord, Read, Generic)++instance Monoid Max where+ mempty = minBound+ mappend = max++newtype Min = Min { unMin :: Int }+ deriving (Eq, Show, Bounded, Ord, Read, Generic)++instance Monoid Min where+ mempty = maxBound+ mappend = min++data ArraySchema = ArraySchema+ { items :: [AnySchema]+ , additionalItems :: Either' Bool AnySchema+ } deriving (Eq, Show, Read, Generic)++data StringSchema = StringSchema+ { maxLength :: Maybe Max+ , minLength :: Maybe Min+ {-, pattern :: Maybe Regex-}+ } deriving (Eq, Show, Read, Generic)++instance Monoid StringSchema where+ mempty = StringSchema mempty mempty+ a `mappend` b = StringSchema { maxLength = maxLength a <> maxLength b+ , minLength = minLength a <> minLength b+ }++instance ToJSON StringSchema where+ toJSON ss = object $+ catMaybes [ ("maxLength" .=) <$> (toJSON . unMax <$> maxLength ss)+ , ("minLength" .=) <$> (toJSON . unMin <$> minLength ss)+ ]++data Metadata = Metadata+ { title :: Maybe Text.Text+ , description :: Maybe Text.Text+ } deriving (Eq, Show, Read, Generic)++data SchemaVersion = Draft4+ deriving (Eq, Show, Read, Generic)++data Required = Required | NotRequired+ deriving (Eq, Show, Read, Generic)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Verdict/JSONSpec.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+module Verdict.JSONSpec (spec) where++import Data.Aeson+import Data.Foldable (toList)+import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HashMap+import Data.Proxy+import Data.Vector (fromList)+import GHC.Generics (Generic)+import Test.Hspec (Spec, describe, it, shouldBe, shouldContain, context)+import Verdict++import Verdict.JSON++spec :: Spec+spec = describe "Verdict.JSON" $ do+ fromJSONSpec+ specSpec+++fromJSONSpec :: Spec+fromJSONSpec = describe "FromJSON instance" $ do++ it "does validation when parsing" $ do+ (decode "5" :: Maybe EvenInt) `shouldBe` Nothing++ it "gives a useful error message" $ do+ let Left e = eitherDecode "5" :: Either String EvenInt+ e `shouldContain` "Not a multiple of 2"++ it "parses valid values" $ do+ let (Right expected) = validate 4+ (decode "4" :: Maybe EvenInt) `shouldBe` Just expected++specSpec :: Spec+specSpec = describe "AnySchema" $ do++ context "ToJSON instance" $ do+ let (Object jspec) = toJSON $ jsonSchema (Proxy :: Proxy Person)+ (Just (Object props)) = HashMap.lookup "properties" jspec+ (Just (Array reqs)) = HashMap.lookup "required" jspec+ (Just (Object ageO)) = HashMap.lookup "age" props+ (Just (Object nameO)) = HashMap.lookup "name" props++ it "lists required properties " $ do+ toList reqs `shouldContain` [String "name"]+ toList reqs `shouldContain` [String "age"]++ it "contains the outermost type" $ do+ HashMap.lookup "type" jspec `shouldBe` Just (String "object")++ it "contains the nested types" $ do+ HashMap.lookup "type" nameO `shouldBe` Just (String "string")+ HashMap.lookup "type" ageO `shouldBe` Just (String "number")++ it "contains the nested constraints" $ do+ HashMap.lookup "minLength" nameO `shouldBe` Just (Number 1)+ HashMap.lookup "maxLength" nameO `shouldBe` Just (Number 100)+ HashMap.lookup "minimum" ageO `shouldBe` Just (Number 0)+ HashMap.lookup "maximum" ageO `shouldBe` Just (Number 200)++++type EvenInt = Validated (MultipleOf 2) Int++type Name = Validated (MinLength 1 :&& MaxLength 100) String+type Age = Validated (Minimum 0 :&& Maximum 200) Integer++data Person = Person+ { name :: Name+ , age :: Age+ } deriving (Eq, Show, Read, Generic, ToJSON)++instance JsonSchema Person where+ type JsonType Person = ObjectSchema+ jsonSchema' _ = mempty { properties = Map.fromList+ [ ("name", (Required, jsonSchema namep))+ , ("age" , (Required, jsonSchema agep ))+ ]+ }+ where namep = Proxy :: Proxy Name+ agep = Proxy :: Proxy Age
+ verdict-json.cabal view
@@ -0,0 +1,80 @@+name: verdict-json+version: 0.0.0.0+synopsis: JSON instances and JSON Schema for verdict+description:+ DO NOT USE! Unstable, not thoroughly tested.+license: BSD3+license-file: LICENSE+author: Julian K. Arni+maintainer: jkarni@gmail.com+copyright: (c) Julian K. Arni+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Verdict.JSON+ ghc-options: -Wall+ other-modules: Verdict.JSON.Class+ , Verdict.JSON.Types+ default-extensions: DeriveFunctor+ , DeriveGeneric+ , DeriveDataTypeable+ , TypeOperators+ , MultiParamTypeClasses+ , DataKinds+ , FunctionalDependencies+ , PolyKinds+ , ScopedTypeVariables+ , FlexibleInstances+ , FlexibleContexts+ , TypeFamilies+ build-depends: base >=4.8 && <4.9+ , aeson+ , verdict == 0.0.*+ , containers+ , text+ , unordered-containers+ , vector+ hs-source-dirs: src+ default-language: Haskell2010+++test-suite spec+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Verdict.JSONSpec+ default-extensions: DeriveAnyClass+ , DeriveFunctor+ , DeriveGeneric+ , TypeOperators+ , MultiParamTypeClasses+ , DataKinds+ , FunctionalDependencies+ , PolyKinds+ , ScopedTypeVariables+ , FlexibleInstances+ , FlexibleContexts+ , TypeFamilies+ build-depends: base == 4.*+ , aeson >= 0.10+ , containers+ , unordered-containers+ , vector+ , verdict+ , verdict-json+ , hspec == 2.*++executable Example+ buildable: False+ main-is: Example.hs+ hs-source-dirs: examples+ ghc-options: -Wall+ build-depends: base >=4.7 && <4.9+ , verdict+ , verdict-json+ , containers+ , aeson+ default-language: Haskell2010