diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/json-spec.cabal b/json-spec.cabal new file mode 100644 --- /dev/null +++ b/json-spec.cabal @@ -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 diff --git a/src/Data/JsonSpec.hs b/src/Data/JsonSpec.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec.hs @@ -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) + + diff --git a/src/Data/JsonSpec/Decode.hs b/src/Data/JsonSpec/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Decode.hs @@ -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 + + diff --git a/src/Data/JsonSpec/Encode.hs b/src/Data/JsonSpec/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Encode.hs @@ -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) + + diff --git a/src/Data/JsonSpec/Spec.hs b/src/Data/JsonSpec/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Spec.hs @@ -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) + + diff --git a/test/jsonspec.hs b/test/jsonspec.hs new file mode 100644 --- /dev/null +++ b/test/jsonspec.hs @@ -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 } + +