highjson-swagger (empty) → 0.3.0.0
raw patch · 6 files changed
+257/−0 lines, 6 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, bytestring, highjson, highjson-swagger, hspec, hvect, insert-ordered-containers, lens, swagger2, text
Files
- Data/HighJson/Swagger.hs +107/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- highjson-swagger.cabal +54/−0
- test/Data/HighJson/SwaggerSpec.hs +65/−0
- test/Main.hs +9/−0
+ Data/HighJson/Swagger.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+module Data.HighJson.Swagger+ ( makeDeclareNamedSchema, makeDeclareNamedSchema', DeclM+ )+where++import Control.Lens+import Data.HVect (AllHave)+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import Data.HighJson+import Data.Monoid+import Data.Proxy+import Data.Swagger+import Data.Swagger.Declare+import qualified Data.HashMap.Strict.InsOrd as IOM+import qualified Data.Text as T++type DeclM = Declare (Definitions Schema)++-- | Automatically generate a 'NamedSchema' from a 'HighSpec'+makeDeclareNamedSchema ::+ (AllHave ToSchema ts, AllHave ToJSON ts)+ => HighSpec k ts+ -> f k+ -> DeclM NamedSchema+makeDeclareNamedSchema spec = makeDeclareNamedSchema' spec Nothing++-- | Automatically generate a 'NamedSchema' from a 'HighSpec' while optionally+-- providing an example value+makeDeclareNamedSchema' ::+ (AllHave ToSchema ts, AllHave ToJSON ts)+ => HighSpec k 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++computeSumProperties ::+ forall k ts. AllHave ToSchema ts+ => SumSpec k ts+ -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName])+computeSumProperties fs =+ go (ss_options fs) (mempty, mempty)+ where+ go ::+ forall qs. AllHave ToSchema qs+ => SumOptions k qs+ -> (InsOrdHashMap T.Text (Referenced Schema), [ParamName])+ -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName])+ go spec (props, reqs) =+ case spec of+ SOEmpty ->+ pure (props, reqs)+ (key :: SumOption k t) :|: rest ->+ do fieldSchema <- declareSchemaRef (Proxy :: Proxy t)+ let fld =+ IOM.singleton (so_jsonKey key) fieldSchema+ go rest (fld <> props, reqs)++computeRecProperties ::+ forall k ts. AllHave ToSchema ts+ => RecordSpec k ts+ -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName])+computeRecProperties fs =+ go (rs_fields fs) (mempty, mempty)+ where+ go ::+ forall qs. AllHave ToSchema qs+ => RecordFields k qs+ -> (InsOrdHashMap T.Text (Referenced Schema), [ParamName])+ -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName])+ go spec (props, reqs) =+ case spec of+ RFEmpty ->+ pure (props, reqs)+ (key :: RecordField k t) :+: rest ->+ do fieldSchema <- declareSchemaRef (Proxy :: Proxy t)+ let fld =+ IOM.singleton (rf_jsonKey key) fieldSchema+ reqs' =+ if not (rf_optional key)+ then (rf_jsonKey key : reqs)+ else reqs+ go rest (fld <> props, reqs')
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Alexander Thiemann <mail@athiemann.net>++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ highjson-swagger.cabal view
@@ -0,0 +1,54 @@+name: highjson-swagger+version: 0.3.0.0+synopsis: Derive swagger instances from highjson specs+description: Derive swagger instances from highjson specs+homepage: https://github.com/agrafix/highjson+bug-reports: https://github.com/agrafix/highjson/issues+license: MIT+license-file: LICENSE+author: Alexander Thiemann <mail@athiemann.net>+maintainer: Alexander Thiemann <mail@athiemann.net>+copyright: (c) 2017 Alexander Thiemann+category: Text, Web, JSON+build-type: Simple+stability: experimental+cabal-version: >=1.10+tested-with: GHC==8.0.1++library+ exposed-modules:+ Data.HighJson.Swagger+ build-depends:+ base >=4.8 && <5,+ highjson >= 0.3,+ swagger2 >= 2.1.3,+ text,+ lens,+ insert-ordered-containers >= 0.2,+ hvect+ hs-source-dirs: .+ default-language: Haskell2010++test-suite highjson-swagger-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ Data.HighJson.SwaggerSpec+ build-depends:+ QuickCheck >=2.8,+ base,+ highjson,+ highjson-swagger,+ aeson,+ hspec >= 2.0,+ text,+ lens,+ swagger2,+ bytestring+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans++source-repository head+ type: git+ location: git://github.com/agrafix/highjson.git
+ test/Data/HighJson/SwaggerSpec.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.HighJson.SwaggerSpec+ ( spec )+where++import Data.HighJson+import Data.HighJson.Swagger++import Data.Swagger+import Test.Hspec+import Test.QuickCheck hiding (Success)+import qualified Data.Text as T++data SomeDummy+ = SomeDummy+ { sd_int :: Int+ , sd_bool :: Bool+ , sd_text :: T.Text+ , sd_either :: Either Bool T.Text+ , sd_maybe :: Maybe Int+ } deriving (Show, Eq)++someDummySpec :: HighSpec 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++instance ToJSON SomeDummy where+ toJSON = jsonSerializer someDummySpec+ toEncoding = jsonEncoder someDummySpec++newtype SomeText = SomeText { unSomeText :: T.Text }++instance Arbitrary SomeText where+ arbitrary = SomeText . T.pack <$> listOf1 (choose ('A', 'Z'))++instance Arbitrary SomeDummy where+ arbitrary =+ SomeDummy+ <$> arbitrary+ <*> arbitrary+ <*> (unSomeText <$> arbitrary)+ <*> ebt+ <*> arbitrary+ where+ ebt =+ do v <- arbitrary+ case v of+ Left b -> pure (Left b)+ Right (SomeText t) -> pure (Right t)++instance ToSchema SomeDummy where+ declareNamedSchema p = makeDeclareNamedSchema someDummySpec p++spec :: Spec+spec =+ it "schema and serializer match" $ property $ \(t :: SomeDummy) ->+ validateToJSON t `shouldBe` []
+ test/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import qualified Data.HighJson.SwaggerSpec++import Test.Hspec++main :: IO ()+main = hspec $+ do Data.HighJson.SwaggerSpec.spec