json-spec (empty) → 0.1.0.0
raw patch · 8 files changed
+1089/−0 lines, 8 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, hspec, json-spec, lens, openapi3, scientific, text, time, vector
Files
- LICENSE +21/−0
- README.md +86/−0
- json-spec.cabal +157/−0
- src/Data/JsonSpec.hs +136/−0
- src/Data/JsonSpec/Decode.hs +107/−0
- src/Data/JsonSpec/Encode.hs +96/−0
- src/Data/JsonSpec/Spec.hs +171/−0
- test/jsonspec.hs +315/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2023 Rick Owens++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,86 @@+# json-spec++## Motivation+This package provides a way to specify the shape of your JSON data at+the type level. The particular use cases we focus on are enabling (but+not providing in this package):++1. Auto-generating documentation to ensure it is correct.+2. Auto-generating client code in front-end languages to ensure it is correct.++There are already tools available to achieve this, but they all have one+major drawback: they rely on generically derived Aeson instances. Some+people strongly object to using generically derived Aeson instances for+encoding/decoding http api data because of how brittle it is. It can be+surprisingly easy accidentally break your API without noticing because+you don't realize that a small change to some type somewhere affects+the API representation. Avoiding this requires very strict discipline+about how you organize and maintain your code. E.g. you will see a lot+of comments like++> --| BEWARE, Changing any of the types in this file will change the API+> -- representation!!+> module My.API (...) where++But then the types in this api might reference types in in other modules+where it isn't as obvious that you might be changing the api when you+make an update.++I have even seen people go so far as to mandate that _every_ type+appearing on the API must be in some similar "API" module. This usually+ends badly because you end up with a bunch of seemingly spurious (and+quite tedious) translations between between "business" types and almost+identical "API" types.++The other option is to simply not use generically derived instances and+code all or some of your 'ToJSON'/'FromJSON' instances by hand. That+(sometimes) helps solve the problem of making it a little more obvious+when you are making a breaking api change. And it definitely helps with+the ability to update the haskell type for some business purpose while+keeping the encoding backwards compatible.++The problem now though is that you can't take advantage of any of the+above tooling without writing every instance by hand. Writing all the+individual instances by hand defeat's the purpose because you are back+to being unsure whether they are all in sync!++The approach this library takes is to take a cue from `servant` and+provide a way to specify the JSON encoding at the type level. You+must manually specify the encoding, but you only have to do so once+(at the type level). Other tools can then inspect the type using either+type families or type classes to generate the appropriate artifacts or+behavior. Aeson integration (provided by this package) works by using a+type family to transform the spec into a new Haskell type whose structure+is analogous to the specification. You are then required to transform+your regular business value into a value of this "structural type"+(I strongly recommend using type holes to make this easier). Values of+the structural type will always encode into specification-complient JSON.++## Example++> data User = User+> { name :: Text+> , lastLogin :: UTCTime+> }+> deriving stock (Show, Eq)+> deriving (ToJSON, FromJSON) via (SpecJSON User)+> instance HasJsonEncodingSpec User where+> type EncodingSpec User =+> JsonObject+> '[ '("name", JsonString)+> , '("last-login", JsonDateTime)+> ]+> toJSONStructure user =+> (Field @"name" (name user),+> (Field @"last-login" (lastLogin user),+> ()))+> instance HasJsonDecodingSpec User where+> type DecodingSpec User = EncodingSpec User+> fromJSONStructure+> (Field @"name" name,+> (Field @"last-login" lastLogin,+> ()))+> =+> pure User { name , lastLogin }++For more examples, take a look at the test suite.
+ json-spec.cabal view
@@ -0,0 +1,157 @@+cabal-version: 3.0+name: json-spec+version: 0.1.0.0+synopsis: Type-level JSON specification+maintainer: rick@owensmurray.com+description: = Motivation+ This package provides a way to specify the shape of+ your JSON data at the type level. The particular use+ cases we focus on are enabling (but not providing+ in this package):++ 1. Auto-generating documentation to ensure it+ is correct.+ 2. Auto-generating client code in front-end languages+ to ensure it is correct.++ There are already tools available to achieve this,+ but they all have one major drawback: they rely on+ generically derived Aeson instances. Some people+ strongly object to using generically derived Aeson+ instances for encoding/decoding http api data because+ of how brittle it is. It can be surprisingly easy+ accidentally break your API without noticing because+ you don't realize that a small change to some type+ somewhere affects the API representation. Avoiding+ this requires very strict discipline about how you+ organize and maintain your code. E.g. you will see+ a lot of comments like++ > --| BEWARE, Changing any of the types in this file will change the API+ > -- representation!!+ > module My.API (...) where++ But then the types in this api might reference+ types in in other modules where it isn't as obvious+ that you might be changing the api when you make+ an update.++ I have even seen people go so far as to mandate+ that /every/ type appearing on the API must be+ in some similar \"API\" module. This usually ends+ badly because you end up with a bunch of seemingly+ spurious (and quite tedious) translations between+ between \"business\" types and almost identical+ \"API\" types.++ The other option is to simply not use generically+ derived instances and code all or some of your+ 'ToJSON'/'FromJSON' instances by hand. That+ (sometimes) helps solve the problem of making it a+ little more obvious when you are making a breaking+ api change. And it definitely helps with the ability+ to update the haskell type for some business purpose+ while keeping the encoding backwards compatible.++ The problem now though is that you can't take+ advantage of any of the above tooling without+ writing every instance by hand. Writing all the+ individual instances by hand defeat's the purpose+ because you are back to being unsure whether they+ are all in sync!++ The approach this library takes is to take a cue+ from `servant` and provide a way to specify the+ JSON encoding at the type level. You must manually+ specify the encoding, but you only have to do so+ once (at the type level). Other tools can then+ inspect the type using either type families or+ type classes to generate the appropriate artifacts+ or behavior. Aeson integration (provided by this+ package) works by using a type family to transform+ the spec into a new Haskell type whose structure+ is analogous to the specification. You are then+ required to transform your regular business+ value into a value of this \"structural type\"+ (I strongly recommend using type holes to make this+ easier). Values of the structural type will always+ encode into specification-complient JSON.++ = Example++ > data User = User+ > { name :: Text+ > , lastLogin :: UTCTime+ > }+ > deriving stock (Show, Eq)+ > deriving (ToJSON, FromJSON) via (SpecJSON User)+ > instance HasJsonEncodingSpec User where+ > type EncodingSpec User =+ > JsonObject+ > '[ '("name", JsonString)+ > , '("last-login", JsonDateTime)+ > ]+ > toJSONStructure user =+ > (Field @"name" (name user),+ > (Field @"last-login" (lastLogin user),+ > ()))+ > instance HasJsonDecodingSpec User where+ > type DecodingSpec User = EncodingSpec User+ > fromJSONStructure+ > (Field @"name" name,+ > (Field @"last-login" lastLogin,+ > ()))+ > =+ > pure User { name , lastLogin }++homepage: https://github.com/owensmurray/json-spec+license: MIT+license-file: LICENSE+author: Rick Owens+category: JSON+build-type: Simple+extra-source-files:+ README.md+ LICENSE++common dependencies+ build-depends:+ , aeson >= 2.1.2.1 && < 2.2+ , base >= 4.17.1.0 && < 4.18+ , bytestring >= 0.11.4.0 && < 0.12+ , lens >= 5.2.2 && < 5.3+ , openapi3 >= 3.2.3 && < 3.3+ , scientific >= 0.3.7.0 && < 0.4+ , text >= 2.0.2 && < 2.1+ , time >= 1.12.2 && < 1.13+ , vector >= 0.13.0.0 && < 0.14++common warnings+ ghc-options:+ -Wmissing-deriving-strategies+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wredundant-constraints+ -Wall++library+ import: dependencies, warnings+ exposed-modules:+ Data.JsonSpec+ other-modules: + Data.JsonSpec.Encode+ Data.JsonSpec.Decode+ Data.JsonSpec.Spec+ -- other-extensions: + hs-source-dirs: src+ default-language: Haskell2010++test-suite jsonspec+ import: dependencies, warnings+ main-is: jsonspec.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends:+ , json-spec+ , hspec >= 2.11.1 && < 2.12
+ src/Data/JsonSpec.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+ This module provides a way to specify the shape of your JSON data at+ the type level.++ = Example++ > data User = User+ > { name :: Text+ > , lastLogin :: UTCTime+ > }+ > deriving stock (Show, Eq)+ > deriving (ToJSON, FromJSON) via (SpecJSON User)+ > instance HasJsonEncodingSpec User where+ > type EncodingSpec User =+ > JsonObject+ > '[ '("name", JsonString)+ > , '("last-login", JsonDateTime)+ > ]+ > toJSONStructure user =+ > (Field @"name" (name user),+ > (Field @"last-login" (lastLogin user),+ > ()))+ > instance HasJsonDecodingSpec User where+ > type DecodingSpec User = EncodingSpec User+ > fromJSONStructure+ > (Field @"name" name,+ > (Field @"last-login" lastLogin,+ > ()))+ > =+ > pure User { name , lastLogin }+ + = Motivation++ The particular use cases we focus on are enabling (but not providing+ in this package):++ 1. Auto-generating documentation to ensure it is correct.+ 2. Auto-generating client code in front-end languages to ensure it is correct.++ There are already tools available to achieve this, but they all have one+ major drawback: they rely on generically derived Aeson instances. Some+ people strongly object to using generically derived Aeson instances+ for encoding/decoding http api data because of how brittle it is. It+ can be surprisingly easy accidentally break your API without noticing+ because you don't realize that a small change to some type somewhere+ affects the API representation. Avoiding this requires very strict+ discipline about how you organize and maintain your code. E.g. you+ will see a lot of comments like++ > --| BEWARE, Changing any of the types in this file will change the API+ > -- representation!!+ > module My.API (...) where++ But then the types in this api might reference types in in other modules+ where it isn't as obvious that you might be changing the api when you+ make an update.++ I have even seen people go so far as to mandate that /every/ type+ appearing on the API must be in some similar \"API\" module. This+ usually ends badly because you end up with a bunch of seemingly spurious+ (and quite tedious) translations between between \"business\" types and+ almost identical \"API\" types.++ The other option is to simply not use generically derived instances+ and code all or some of your 'ToJSON'/'FromJSON' instances by hand. That+ (sometimes) helps solve the problem of making it a little more obvious+ when you are making a breaking api change. And it definitely helps+ with the ability to update the haskell type for some business purpose+ while keeping the encoding backwards compatible.++ The problem now though is that you can't take advantage of any of the+ above tooling without writing every instance by hand. Writing all the+ individual instances by hand defeat's the purpose because you are back+ to being unsure whether they are all in sync!++ The approach this library takes is to take a cue from `servant` and+ provide a way to specify the JSON encoding at the type level. You+ must manually specify the encoding, but you only have to do so once+ (at the type level). Other tools can then inspect the type using+ either type families or type classes to generate the appropriate+ artifacts or behavior. Aeson integration (provided by this package)+ works by using a type family to transform the spec into a new Haskell+ type whose structure is analogous to the specification. You are then+ required to transform your regular business value into a value of+ this \"structural type\" (I strongly recommend using type holes to+ make this easier). Values of the structural type will always encode+ into specification-complient JSON.+-}+module Data.JsonSpec (+ Specification(..),+ HasJsonEncodingSpec(..),+ HasJsonDecodingSpec(..),+ SpecJSON(..),+ Tag(..),+ Field(..),+ JSONStructure,+) where+++import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))+import Data.JsonSpec.Decode (HasJsonDecodingSpec(DecodingSpec,+ fromJSONStructure), StructureFromJSON(reprParseJSON))+import Data.JsonSpec.Encode (HasJsonEncodingSpec(EncodingSpec,+ toJSONStructure), StructureToJSON(reprToJSON))+import Data.JsonSpec.Spec (Field(Field), Specification(JsonArray,+ JsonBool, JsonDateTime, JsonEither, JsonInt, JsonNullable, JsonNum,+ JsonObject, JsonString, JsonTag), Tag(Tag), JSONStructure)+++{- |+ Helper for defining 'ToJSON' and 'FromJSON' instances based on+ 'HasEncodingJsonSpec'.++ Use with -XDerivingVia like:++ > data MyObj = MyObj+ > { foo :: Int+ > , bar :: Text+ > }+ > deriving (ToJSON, FromJSON) via (SpecJSON MyObj)+ > instance HasEncodingSpec MyObj where ...+ > instance HasDecodingSpec MyObj where ...+-}+newtype SpecJSON a = SpecJSON {unSpecJson :: a}+instance (StructureToJSON (JSONStructure (EncodingSpec a)), HasJsonEncodingSpec a) => ToJSON (SpecJSON a) where+ toJSON = reprToJSON . toJSONStructure . unSpecJson+instance (StructureFromJSON (JSONStructure (DecodingSpec a)), HasJsonDecodingSpec a) => FromJSON (SpecJSON a) where+ parseJSON v =+ SpecJSON <$>+ (fromJSONStructure =<< reprParseJSON v)++
+ src/Data/JsonSpec/Decode.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Decoding using specs. -}+module Data.JsonSpec.Decode (+ StructureFromJSON(..),+ HasJsonDecodingSpec(..),+) where+++import Control.Applicative (Alternative((<|>)))+import Data.Aeson (Value(Null, Object), parseJSON, withArray, withObject,+ withScientific, withText)+import Data.Aeson.Types (Parser)+import Data.JsonSpec.Spec (Field(Field), Tag(Tag), JSONStructure,+ Specification, sym)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.TypeLits (KnownSymbol)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Vector as Vector+++{- |+ Types of this class can be JSON decoded according to a type-level+ 'Specification'.+-}+class HasJsonDecodingSpec a where+ {- | The decoding 'Specification'. -}+ type DecodingSpec a :: Specification++ {- |+ Given the structural encoding of the JSON data, parse the structure+ into the final type. The reason this returns a @'Parser' a@ instead of+ just a plain @a@ is because there may still be some invariants of the+ JSON data that the 'Specification' language is not able to express,+ and so you may need to fail parsing in those cases. For instance,+ 'Specification' is not powerful enough to express "this field must+ contain only prime numbers".+ -}+ fromJSONStructure :: JSONStructure (DecodingSpec a) -> Parser a+++{- |+ Analog of 'Data.Aeson.FromJSON', but specialized for decoding our+ "json representations", and closed to the user because the haskell+ representation scheme is fixed and not extensible by the user.++ We can't just use 'Data.Aeson.FromJSON' because the types we are using+ to represent "json data" (i.e. the 'JSONStructure' type family) already+ have 'ToJSON' instances. Even if we were to make a bunch of newtypes+ or whatever to act as the json representation (and therefor also force+ the user to do a lot of wrapping and unwrapping), that still wouldn't+ be sufficient because someone could always write an overlapping (or+ incoherent) 'ToJSON' instance of our newtype! This way we don't have+ to worry about any of that, and the types that the user must deal with+ when implementing 'fromJSONRepr' can be simple tuples and such.+-}+class StructureFromJSON a where+ reprParseJSON :: Value -> Parser a+instance StructureFromJSON Text where+ reprParseJSON = withText "string" pure+instance StructureFromJSON Scientific where+ reprParseJSON = withScientific "number" pure+instance StructureFromJSON Int where+ reprParseJSON = parseJSON+instance StructureFromJSON () where+ reprParseJSON =+ withObject "empty object" $ \_ -> pure ()+instance (KnownSymbol key, StructureFromJSON val, StructureFromJSON more) => StructureFromJSON (Field key val, more) where+ reprParseJSON =+ withObject "object" $ \o -> do+ more <- reprParseJSON (Object o)+ case KM.lookup (sym @key) o of+ Nothing -> fail $ "could not find key: " <> sym @key+ Just rawVal -> do+ val <- reprParseJSON rawVal+ pure (Field val, more)+instance (StructureFromJSON left, StructureFromJSON right) => StructureFromJSON (Either left right) where+ reprParseJSON v =+ (Left <$> reprParseJSON v)+ <|> (Right <$> reprParseJSON v)+instance (KnownSymbol const) => StructureFromJSON (Tag const) where+ reprParseJSON =+ withText "constant" $ \c ->+ if c == sym @const then pure Tag+ else fail "unexpected constant value"+instance (StructureFromJSON a) => StructureFromJSON [a] where+ reprParseJSON =+ withArray+ "list"+ (fmap Vector.toList . traverse reprParseJSON)+instance StructureFromJSON UTCTime where+ reprParseJSON = parseJSON+instance (StructureFromJSON a) => StructureFromJSON (Maybe a) where+ reprParseJSON val = do+ case val of+ Null -> pure Nothing+ _ -> Just <$> reprParseJSON val++
+ src/Data/JsonSpec/Encode.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.JsonSpec.Encode (+ HasJsonEncodingSpec(..),+ StructureToJSON(..),+) where+++import Data.Aeson (ToJSON(toJSON), Value)+import Data.JsonSpec.Spec (Field(Field), JSONStructure, Specification,+ Tag, sym)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.TypeLits (KnownSymbol)+import qualified Data.Aeson as A+import qualified Data.Aeson.KeyMap as KM+++{- |+ Types of this class can be encoded to JSON according to a type-level+ 'Specification'.+-}+class HasJsonEncodingSpec a where+ {- | The encoding specification. -}+ type EncodingSpec a :: Specification++ {- | Encode the value into the structure appropriate for the specification. -}+ toJSONStructure :: a -> JSONStructure (EncodingSpec a)+++{- |+ This is like 'ToJSON', but specialized for our custom "json+ representation" types (i.e. the 'JSONStructure' type family). It is+ also closed (i.e. not exported, so the user can't add instances),+ because our json representation is closed.++ see 'StructureFromJSON' for an explaination about why we don't just use+ 'ToJSON'.+-}+class StructureToJSON a where+ reprToJSON :: a -> Value+instance StructureToJSON () where+ reprToJSON () = A.object []+instance StructureToJSON Text where+ reprToJSON = toJSON+instance StructureToJSON Scientific where+ reprToJSON = toJSON+instance StructureToJSON Int where+ reprToJSON = toJSON+instance (ToJSONObject (a, b)) => StructureToJSON (a, b) where+ reprToJSON = A.Object . toJSONObject +instance (StructureToJSON left, StructureToJSON right) => StructureToJSON (Either left right) where+ reprToJSON = \case+ Left val -> reprToJSON val+ Right val -> reprToJSON val+instance (KnownSymbol const) => StructureToJSON (Tag const) where+ reprToJSON _proxy = toJSON (sym @const @Text)+instance (StructureToJSON a) => StructureToJSON [a] where+ reprToJSON = toJSON . fmap reprToJSON+instance StructureToJSON UTCTime where+ reprToJSON = toJSON+instance (StructureToJSON a) => StructureToJSON (Maybe a) where+ reprToJSON = maybe A.Null reprToJSON+++{- |+ This class is to help 'StructureToJSON' recursively encode objects, and+ is mutually recursive with 'StructureToJSON'. If we tried to "recurse+ on the rest of the object" directly in 'StructureToJSON' we would end+ up with a partial function, because 'reprToJSON' returns a 'Value'+ not an 'Object'. We would therefore have to pattern match on 'Value'+ to get the 'Object' back out, but we would have to call 'error' if the+ 'Value' mysteriously somehow wasn't an 'Object' after all. Instead of+ calling error because "it can't ever happen", we use this helper so+ the compiler can prove it never happens.+-}+class ToJSONObject a where+ toJSONObject :: a -> A.Object+instance ToJSONObject () where+ toJSONObject _ = mempty+instance (KnownSymbol key, StructureToJSON val, ToJSONObject more) => ToJSONObject (Field key val, more) where+ toJSONObject (Field val, more) =+ KM.insert+ (sym @key)+ (reprToJSON val)+ (toJSONObject more)++
+ src/Data/JsonSpec/Spec.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.JsonSpec.Spec (+ Specification(..),+ JSONStructure,+ sym,+ Tag(..),+ Field(..),+) where+++import Data.Proxy (Proxy(Proxy))+import Data.Scientific (Scientific)+import Data.String (IsString(fromString))+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+++{-|+ Simple DSL for defining type level "specifications" for JSON+ data. Similar in spirit to (but not isomorphic with) JSON Schema.+ + Intended to be used at the type level using @-XDataKinds@++ See 'JSONStructure' for how these map into Haskell representations.+-}+data Specification+ = JsonObject [(Symbol, Specification)]+ {-^+ An object with the specified properties, each having its own+ specification. This does not yet support optional properties,+ although a property can be specified as "nullable" using+ `JsonNullable`+ -}+ | JsonString+ {-^ An arbitrary JSON string. -}+ | JsonNum+ {-^ An arbitrary (floating point) JSON number. -}+ | JsonInt+ {-^ A JSON integer. -}+ | JsonArray Specification+ {-^ A JSON array of values which conform to the given spec. -}+ | JsonBool+ {-^ A JSON boolean value. -}+ | JsonNullable Specification+ {-^+ A value that can either be `null`, or else a value conforming to+ the specification.++ E.g.:++ > type SpecWithNullableField =+ > JsonObject+ > '[ '("nullableProperty", JsonNullable JsonString)+ > ]+ -}+ | JsonEither Specification Specification+ {-^+ One of two different specifications. Corresponds to json-schema+ "oneOf". Useful for encoding sum types. E.g:++ > data MyType+ > = Foo Text+ > | Bar Int+ > | Baz UTCTime+ > instance HasJsonEncodingSpec MyType where+ > type EncodingSpec MyType =+ > JsonEither+ > (+ > JsonObject+ > '[ '("tag", JsonTag "foo")+ > , '("content", JsonString)+ > ]+ > )+ > (+ > JsonEither+ > (+ > JsonObject+ > '[ '("tag", JsonTag "bar")+ > , '("content", JsonInt)+ > ]+ > )+ > (+ > JsonObject+ > '[ '("tag", JsonTag "baz")+ > , '("content", JsonDateTime)+ > ]+ > )+ > )+ -}+ | JsonTag Symbol {-^ A constant string value -}+ | JsonDateTime+ {-^+ A JSON string formatted as an ISO-8601 string. In Haskell this+ corresponds to `Data.Time.UTCTime`, and in json-schema it corresponds+ to the "date-time" format.+ -}+++{- |+ @'JSONStructure' spec@ is the Haskell type used to contain the JSON data+ that will be encoded or decoded according to the provided @spec@.++ Basically, we represent JSON objects as "list-like" nested tuples of+ the form:++ > (Field @key1 valueType,+ > (Field @key2 valueType,+ > (Field @key3 valueType,+ > ())))++ Arrays, booleans, numbers, and strings are just Lists, 'Bool's,+ 'Scientific's, and 'Text's respectively.++ If the user can convert their normal business logic type to/from this+ tuple type, then they get a JSON encoding to/from their type that is+ guaranteed to be compliant with the 'Specification'+-}+type family JSONStructure (spec :: Specification) where+ JSONStructure (JsonObject '[]) = ()+ JSONStructure (JsonObject ( '(key, s) : more )) =+ (+ Field key (JSONStructure s),+ JSONStructure (JsonObject more)+ )+ JSONStructure JsonString = Text+ JSONStructure JsonNum = Scientific+ JSONStructure JsonInt = Int+ JSONStructure (JsonArray spec) = [JSONStructure spec]+ JSONStructure JsonBool = Bool+ JSONStructure (JsonEither left right) =+ Either (JSONStructure left) (JSONStructure right)+ JSONStructure (JsonTag tag) = Tag tag+ JSONStructure JsonDateTime = UTCTime+ JSONStructure (JsonNullable spec) = Maybe (JSONStructure spec)+++{-| Structural representation of 'JsonTag'. (I.e. a constant string value.) -}+data Tag (a :: Symbol) = Tag+++{-| Structural representation of an object field. -}+newtype Field (key :: Symbol) t = Field t+++{- |+ Shorthand for demoting type-level strings.+ Use with -XTypeApplication, e.g.:++ This function doesn't really "go" in this module, it is only here because+ this module happens to be at the bottom of the dependency tree and so it is+ easy to stuff "reusable" things here, and I don't feel like creating a whole+ new module just for this function (although maybe I should).++ > sym @var+-}+sym+ :: forall a b.+ ( IsString b+ , KnownSymbol a+ )+ => b+sym = fromString $ symbolVal (Proxy @a)++
+ test/jsonspec.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Main (main) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson.Types (Parser)+import Data.ByteString.Lazy (ByteString)+import Data.JsonSpec (Field(Field), HasJsonDecodingSpec(DecodingSpec,+ fromJSONStructure), HasJsonEncodingSpec(EncodingSpec, toJSONStructure),+ SpecJSON(SpecJSON), Specification(JsonDateTime, JsonEither, JsonInt,+ JsonNullable, JsonNum, JsonObject, JsonString, JsonTag), Tag(Tag))+import Data.Proxy (Proxy(Proxy))+import Data.Scientific (Scientific, floatingOrInteger)+import Data.Text (Text)+import Data.Time (UTCTime(UTCTime))+import GHC.TypeLits (KnownSymbol, symbolVal)+import Test.Hspec (describe, hspec, it, shouldBe)+import qualified Data.Aeson as A+++main :: IO ()+main =+ hspec $ do+ describe "json" $ do+ it "encodes product" $+ let+ actual :: ByteString+ actual = A.encode $ sampleTestObject+ expected :: ByteString+ expected = "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":100}"+ in+ actual `shouldBe` expected++ it "decodes product" $+ let+ actual :: Either String TestObj+ actual =+ A.eitherDecode+ "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":100}"+ expected :: Either String TestObj+ expected = Right sampleTestObject+ in+ actual `shouldBe` expected++ it "encodes sum1" $+ let+ actual :: ByteString+ actual = A.encode $ TestA 0 "bar"+ expected :: ByteString+ expected = "{\"content\":{\"int-field\":0,\"txt-field\":\"bar\"},\"tag\":\"a\"}"+ in+ actual `shouldBe` expected++ it "encodes sum2" $+ let+ actual :: ByteString+ actual = A.encode $ TestB+ expected :: ByteString+ expected = "{\"tag\":\"b\"}"+ in+ actual `shouldBe` expected++ it "decodes sum1" $+ let+ actual :: Either String TestSum+ actual =+ A.eitherDecode+ "{\"content\":{\"int-field\":0,\"txt-field\":\"bar\"},\"tag\":\"a\"}"+ expected :: Either String TestSum+ expected = Right (TestA 0 "bar")+ in+ actual `shouldBe` expected++ it "decodes sum2" $+ let+ actual :: Either String TestSum+ actual = A.eitherDecode "{\"tag\":\"b\"}"+ expected :: Either String TestSum+ expected = Right TestB+ in+ actual `shouldBe` expected++ it "decodes UTCTime" $+ let+ actual :: Either String User+ actual =+ A.eitherDecode+ "{ \"name\": \"foo\", \"last-login\": \"1858-11-17T00:00:00Z\" }"+ + expected :: Either String User+ expected =+ Right+ User+ { name = "foo"+ , lastLogin =+ UTCTime (toEnum 0) 0+ }+ in+ actual `shouldBe` expected++ describe "nullable" $ do+ it "encodes product" $+ let+ actual :: ByteString+ actual = A.encode $ sampleTestObjectWithNull+ expected :: ByteString+ expected = "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":null}"+ in+ actual `shouldBe` expected++ it "decodes product" $+ let+ actual :: Either String TestObj+ actual =+ A.eitherDecode+ "{\"bar\":1,\"baz\":{\"bar\":0,\"foo\":\"foo2\"},\"foo\":\"foo\",\"qux\":null}"+ expected :: Either String TestObj+ expected = Right sampleTestObjectWithNull+ in+ actual `shouldBe` expected++ it "Bad tag does not decode" $+ let+ actual :: Either String TestSum+ actual = A.eitherDecode "{\"tag\":\"c\"}"+ expected :: Either String TestSum+ expected = Left "Error in $: unexpected constant value"+ in+ actual `shouldBe` expected+++sampleTestObject :: TestObj+sampleTestObject =+ TestObj+ { foo = "foo"+ , bar = 1+ , baz = + TestSubObj+ { foo2 = "foo2"+ , bar2 = 0+ }++ , qux = Just 100+ }+++sampleTestObjectWithNull:: TestObj+sampleTestObjectWithNull=+ TestObj+ { foo = "foo"+ , bar = 1+ , baz = + TestSubObj+ { foo2 = "foo2"+ , bar2 = 0+ }++ , qux = Nothing+ }+++data TestSum+ = TestA Int Text+ | TestB+ deriving stock (Eq, Show)+ deriving ToJSON via (SpecJSON TestSum)+ deriving FromJSON via (SpecJSON TestSum)+instance HasJsonEncodingSpec TestSum where+ type EncodingSpec TestSum =+ JsonEither+ (JsonObject '[+ '("tag", JsonTag "a"),+ '("content", JsonObject [+ '("int-field", JsonNum),+ '("txt-field", JsonString)+ ])+ ])+ (JsonObject '[+ '("tag", JsonTag "b")+ ])+ toJSONStructure = \case+ TestA i t ->+ Left+ (Field @"tag" (Tag @"a"),+ (Field @"content"+ ( (Field @"int-field" (realToFrac i)+ , (Field @"txt-field" t+ , ()+ )+ )),+ ()))+ TestB ->+ Right+ ( Field @"tag" (Tag @"b")+ , ()+ )+instance HasJsonDecodingSpec TestSum where+ type DecodingSpec TestSum = EncodingSpec TestSum+ fromJSONStructure = \case+ Left (Field Tag, (Field (rawInt, (Field txt, ())), ())) -> do+ int <- parseInt rawInt+ pure (TestA int txt)+ Right _ ->+ pure TestB+++data TestObj = TestObj+ { foo :: Text+ , bar :: Scientific+ , baz :: TestSubObj+ , qux :: Maybe Int+ }+ deriving stock (Show, Eq)+ deriving ToJSON via (SpecJSON TestObj)+ deriving FromJSON via (SpecJSON TestObj)+instance HasJsonEncodingSpec TestObj where+ type EncodingSpec TestObj =+ JsonObject+ '[+ '("foo", JsonString),+ '("bar", JsonNum),+ '("baz", EncodingSpec TestSubObj),+ '("qux", JsonNullable JsonInt)+ ]+ toJSONStructure TestObj { foo , bar , baz, qux } =+ (Field @"foo" foo,+ (Field @"bar" (realToFrac bar),+ (Field @"baz" (toJSONStructure baz),+ (Field @"qux" qux,+ ()))))+instance HasJsonDecodingSpec TestObj where+ type DecodingSpec TestObj = EncodingSpec TestObj+ fromJSONStructure+ (Field @"foo" foo,+ (Field @"bar" bar,+ (Field @"baz" rawBaz,+ (Field @"qux" qux,+ ()))))+ = do+ baz <- fromJSONStructure rawBaz+ pure $ TestObj { foo, bar, baz, qux }+++data TestSubObj = TestSubObj+ { foo2 :: Text+ , bar2 :: Int+ }+ deriving stock (Show, Eq)+instance HasJsonEncodingSpec TestSubObj where+ type EncodingSpec TestSubObj =+ JsonObject+ '[+ '("foo", JsonString),+ '("bar", JsonNum)+ ]+ toJSONStructure TestSubObj { foo2 , bar2 } =+ (Field @"foo" foo2,+ (Field @"bar" (realToFrac bar2),+ ()))+instance HasJsonDecodingSpec TestSubObj where+ type DecodingSpec TestSubObj = EncodingSpec TestSubObj+ fromJSONStructure ((Field foo2), (rawBar, ())) = do+ bar2 <- parseInt rawBar+ pure TestSubObj {foo2 , bar2}+++parseInt+ :: forall key.+ (KnownSymbol key)+ => Field key Scientific+ -> Parser Int+parseInt (Field val) =+ case floatingOrInteger val of+ Left (_ :: Float) ->+ fail $+ "Bad integer for property: "+ <> symbolVal (Proxy @key)+ Right i -> pure i+++data User = User+ { name :: Text+ , lastLogin :: UTCTime+ }+ deriving stock (Show, Eq)+ deriving (ToJSON, FromJSON) via (SpecJSON User)+instance HasJsonEncodingSpec User where+ type EncodingSpec User =+ JsonObject+ '[ '("name", JsonString)+ , '("last-login", JsonDateTime)+ ]+ toJSONStructure user =+ (Field @"name" (name user),+ (Field @"last-login" (lastLogin user),+ ()))+instance HasJsonDecodingSpec User where+ type DecodingSpec User = EncodingSpec User+ fromJSONStructure+ (Field @"name" name,+ (Field @"last-login" lastLogin,+ ()))+ =+ pure User { name , lastLogin }++