diff --git a/Data/HighJson/Swagger.hs b/Data/HighJson/Swagger.hs --- a/Data/HighJson/Swagger.hs +++ b/Data/HighJson/Swagger.hs @@ -1,10 +1,15 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Data.HighJson.Swagger ( makeDeclareNamedSchema, makeDeclareNamedSchema', DeclM + , IsValidSwaggerType, AllAre, NoneAre ) where @@ -12,6 +17,7 @@ import Data.HVect (AllHave) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.HighJson +import Data.Kind import Data.Monoid import Data.Proxy import Data.Swagger @@ -21,10 +27,27 @@ type DeclM = Declare (Definitions Schema) +type family AllAre x (xs :: [*]) :: Bool where + AllAre x (x ': xs) = AllAre x xs + AllAre x '[] = 'True + +type family NoneAre x (xs :: [*]) :: Bool where + NoneAre x (x ': xs) = 'False + NoneAre x (y ': xs) = NoneAre x xs + NoneAre x '[] = 'True + +-- | Not all valid Haskell types have a valid swagger mapping. Simple records +-- are fine, but sum types should be either "real" Enums or every option must +-- contain a value. For more information see the swagger2 haskell package. +type family IsValidSwaggerType ty (ts :: [*]) :: Constraint where + IsValidSwaggerType 'SpecRecord xs = 'True ~ 'True + IsValidSwaggerType 'SpecSum xs = NoneAre () xs ~ 'True + IsValidSwaggerType 'SpecEnum xs = AllAre () xs ~ 'True + -- | Automatically generate a 'NamedSchema' from a 'HighSpec' makeDeclareNamedSchema :: - (AllHave ToSchema ts, AllHave ToJSON ts) - => HighSpec k ts + (AllHave ToSchema ts, AllHave ToJSON ts, IsValidSwaggerType ty ts) + => HighSpec k ty ts -> f k -> DeclM NamedSchema makeDeclareNamedSchema spec = makeDeclareNamedSchema' spec Nothing @@ -32,31 +55,47 @@ -- | Automatically generate a 'NamedSchema' from a 'HighSpec' while optionally -- providing an example value makeDeclareNamedSchema' :: - (AllHave ToSchema ts, AllHave ToJSON ts) - => HighSpec k ts + (AllHave ToSchema ts, AllHave ToJSON ts, IsValidSwaggerType ty ts) + => HighSpec k ty ts -> Maybe k -- ^ example value -> f k -> DeclM NamedSchema makeDeclareNamedSchema' spec exVal _ = - do (props, reqs) <- - case hs_bodySpec spec of - BodySpecRecord r -> computeRecProperties r - BodySpecSum r -> computeSumProperties r - let (minProps, maxProps) = - case hs_bodySpec spec of - BodySpecSum _ -> (Just 1, Just 1) - BodySpecRecord _ -> - (Just (fromIntegral $ length reqs), Just (fromIntegral $ length props)) - pure $ NamedSchema (Just $ hs_name spec) $ - mempty - & type_ .~ SwaggerObject - & description .~ hs_description spec - & properties .~ props - & required .~ reqs - & maxProperties .~ maxProps - & minProperties .~ minProps - & example .~ fmap (jsonSerializer spec) exVal + case hs_bodySpec spec of + BodySpecRecord r -> + do (props, reqs) <- computeRecProperties r + pure $ NamedSchema (Just $ hs_name spec) $ + mempty + & type_ .~ SwaggerObject + & description .~ hs_description spec + & properties .~ props + & required .~ reqs + & maxProperties .~ Just (fromIntegral $ length props) + & minProperties .~ Just (fromIntegral $ length reqs) + & example .~ fmap (jsonSerializer spec) exVal + BodySpecSum r -> + do (props, reqs) <- computeSumProperties r + pure $ NamedSchema (Just $ hs_name spec) $ + mempty + & type_ .~ SwaggerObject + & description .~ hs_description spec + & properties .~ props + & required .~ reqs + & maxProperties .~ Just 1 + & minProperties .~ Just 1 + & example .~ fmap (jsonSerializer spec) exVal + BodySpecEnum r -> + let ps = + mempty + & type_ .~ SwaggerString + & enum_ .~ Just (map (toJSON . eo_jsonKey) (es_options r)) + in pure $ NamedSchema (Just $ hs_name spec) $ + mempty + & type_ .~ SwaggerString + & description .~ hs_description spec + & example .~ fmap (jsonSerializer spec) exVal + & paramSchema .~ ps computeSumProperties :: forall k ts. AllHave ToSchema ts diff --git a/highjson-swagger.cabal b/highjson-swagger.cabal --- a/highjson-swagger.cabal +++ b/highjson-swagger.cabal @@ -1,5 +1,5 @@ name: highjson-swagger -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Derive swagger instances from highjson specs description: Derive swagger instances from highjson specs homepage: https://github.com/agrafix/highjson @@ -20,12 +20,12 @@ Data.HighJson.Swagger build-depends: base >=4.8 && <5, - highjson >= 0.3, + highjson >= 0.4, swagger2 >= 2.1.3, text, lens, insert-ordered-containers >= 0.2, - hvect + hvect >= 0.4 hs-source-dirs: . default-language: Haskell2010 diff --git a/test/Data/HighJson/SwaggerSpec.hs b/test/Data/HighJson/SwaggerSpec.hs --- a/test/Data/HighJson/SwaggerSpec.hs +++ b/test/Data/HighJson/SwaggerSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Data.HighJson.SwaggerSpec ( spec ) where @@ -8,6 +9,8 @@ import Data.HighJson import Data.HighJson.Swagger +import Control.Lens.TH +import Data.Proxy import Data.Swagger import Test.Hspec import Test.QuickCheck hiding (Success) @@ -22,15 +25,14 @@ , sd_maybe :: Maybe Int } deriving (Show, Eq) -someDummySpec :: HighSpec SomeDummy '[Int, Bool, T.Text, Either Bool T.Text, Maybe Int] +someDummySpec :: RecordTypeSpec SomeDummy '[Int, Bool, T.Text, Either Bool T.Text, Maybe Int] someDummySpec = recSpec "Some Dummy" Nothing SomeDummy $ "int" .= sd_int - :+: "bool" .= sd_bool - :+: "text" .= sd_text - :+: "either" .= sd_either - :+: "maybe" .=? sd_maybe - :+: RFEmpty + :& "bool" .= sd_bool + :& "text" .= sd_text + :& "either" .= sd_either + :& "maybe" .=? sd_maybe instance ToJSON SomeDummy where toJSON = jsonSerializer someDummySpec @@ -59,7 +61,94 @@ instance ToSchema SomeDummy where declareNamedSchema p = makeDeclareNamedSchema someDummySpec p +data SomeSum + = SomeSumInt Int + | SomeSumDummy SomeDummy + deriving (Show, Eq) + +makePrisms ''SomeSum + +someSumSpec :: SumTypeSpec SomeSum '[Int, SomeDummy] +someSumSpec = + sumSpec "some sum" Nothing $ + "int" .-> _SomeSumInt + :& "dummy" .-> _SomeSumDummy + +instance ToJSON SomeSum where + toJSON = jsonSerializer someSumSpec + toEncoding = jsonEncoder someSumSpec + +instance ToSchema SomeSum where + declareNamedSchema p = makeDeclareNamedSchema someSumSpec p + +instance Arbitrary SomeSum where + arbitrary = + oneof + [ SomeSumInt <$> arbitrary + , SomeSumDummy <$> arbitrary + ] + +data SomeEnum + = SomeEnumA + | SomeEnumB + deriving (Show, Eq) + +makePrisms ''SomeEnum + +someEnumSpec :: EnumTypeSpec SomeEnum '[(), ()] +someEnumSpec = + enumSpec "some enum" Nothing $ + "a" @-> _SomeEnumA + :& "b" @-> _SomeEnumB + +instance ToJSON SomeEnum where + toJSON = jsonSerializer someEnumSpec + toEncoding = jsonEncoder someEnumSpec + +instance ToSchema SomeEnum where + declareNamedSchema p = makeDeclareNamedSchema someEnumSpec p + +instance Arbitrary SomeEnum where + arbitrary = + oneof + [ pure SomeEnumA + , pure SomeEnumB + ] + +data BrokenEnum + = BEnumX + | BEnumY + deriving (Show, Eq) + +makePrisms ''BrokenEnum + +brokenEnumSpec :: EnumTypeSpec BrokenEnum '[(), ()] +brokenEnumSpec = + enumSpec "broken enum" Nothing $ + "x" @-> _BEnumX + :& "y" @-> _BEnumY + +instance ToJSON BrokenEnum where + toJSON = jsonSerializer brokenEnumSpec + toEncoding = jsonEncoder brokenEnumSpec + +instance ToSchema BrokenEnum where + declareNamedSchema _ = makeDeclareNamedSchema someEnumSpec (Proxy :: Proxy SomeEnum) + +instance Arbitrary BrokenEnum where + arbitrary = + oneof + [ pure BEnumX + , pure BEnumY + ] + spec :: Spec spec = - it "schema and serializer match" $ property $ \(t :: SomeDummy) -> - validateToJSON t `shouldBe` [] + do it "should work for records" $ + property $ \(t :: SomeDummy) -> validateToJSON t `shouldBe` [] + it "should work for sum types" $ + property $ \(t :: SomeSum) -> validateToJSON t `shouldBe` [] + it "should work for enum types" $ + property $ \(t :: SomeEnum) -> validateToJSON t `shouldBe` [] + it "should not work for bad schemas" $ + property $ \(t :: BrokenEnum) -> validateToJSON t `shouldNotBe` []