highjson-swagger 0.3.0.0 → 0.4.0.0

raw patch · 3 files changed

+161/−33 lines, 3 filesdep ~highjsondep ~hvectPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: highjson, hvect

API changes (from Hackage documentation)

Files

• Data/HighJson/Swagger.hs +61/−22
• highjson-swagger.cabal +3/−3
• test/Data/HighJson/SwaggerSpec.hs +97/−8

@@ -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

@@ -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 

@@ -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` []