packages feed

composite-swagger (empty) → 0.5.4.0

raw patch · 8 files changed

+225/−0 lines, 8 filesdep +QuickCheckdep +basedep +composite-aesonsetup-changed

Dependencies added: QuickCheck, base, composite-aeson, composite-base, composite-swagger, hspec, insert-ordered-containers, lens, swagger2, template-haskell, text, vinyl

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ composite-swagger.cabal view
@@ -0,0 +1,66 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: e7ec678d5b3717c82d20aa9880dfddf8946c7be6daa1d10b3fd6b6e366a31bbf++name:           composite-swagger+version:        0.5.4.0+synopsis:       Swagger for Vinyl/Frames records+description:    Integration between Swagger and Vinyl/Frames records allowing easily derivable/explicit Swagger definitions for records.+category:       Records+homepage:       https://github.com/ConferHealth/composite#readme+author:         Confer Health, Inc+maintainer:     oss@confer.health+copyright:      2017 Confer Health, Inc.+license:        BSD3+build-type:     Simple+cabal-version:  >= 1.10++library+  hs-source-dirs:+      src+  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PolyKinds ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+  ghc-options: -Wall -O2+  build-depends:+      base >=4.7 && <5+    , composite-base >=0.5.3.0 && <0.6+    , insert-ordered-containers >=0.2.1.0 && <0.3+    , lens >=4.15.4 && <4.17+    , swagger2 >=2.1.6 && <2.3+    , template-haskell >=2.11.1.0 && <2.13+    , text >=1.2.2.2 && <1.3+    , vinyl >=0.5.3 && <0.8+  exposed-modules:+      Composite.Swagger+      Composite.Swagger.Base+      Composite.Swagger.OrphanInstances+      Composite.Swagger.TH+  other-modules:+      Paths_composite_swagger+  default-language: Haskell2010++test-suite composite-swagger-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      test+  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PolyKinds ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , composite-aeson+    , composite-base+    , composite-swagger+    , hspec+    , insert-ordered-containers >=0.2.1.0 && <0.3+    , lens >=4.15.4 && <4.17+    , swagger2 >=2.1.6 && <2.3+    , template-haskell >=2.11.1.0 && <2.13+    , text >=1.2.2.2 && <1.3+    , vinyl >=0.5.3 && <0.8+  other-modules:+      THSpec+      Paths_composite_swagger+  default-language: Haskell2010
+ src/Composite/Swagger.hs view
@@ -0,0 +1,5 @@+module Composite.Swagger+  ( module Composite.Swagger.Base+  ) where++import Composite.Swagger.Base
+ src/Composite/Swagger/Base.hs view
@@ -0,0 +1,18 @@+module Composite.Swagger.Base where++import Control.Lens (Unwrapped, Wrapped, (&), (.~))+import Composite.Swagger.OrphanInstances ()+import Data.Proxy (Proxy (Proxy))+import Data.Swagger+  ( Definitions, NamedSchema(NamedSchema), Schema, SwaggerType(SwaggerObject), ToSchema+  , declareSchema, type_ )+import Data.Swagger.Declare (Declare)+import qualified Data.Text as Text++-- |Given a 'Control.Lens.Wrapped' and an underlying 'Data.Swagger.ToSchema' instance, create a+-- Schema with the given name surrounding the underlying instance.+wrappedSchema :: (Wrapped wrap, ToSchema (Unwrapped wrap)) => Proxy wrap -> String -> Declare (Definitions Schema) NamedSchema+wrappedSchema (Proxy :: Proxy wrap) name = do+  s <- declareSchema (Proxy :: Proxy (Unwrapped wrap))+  pure $ NamedSchema (Just $ Text.pack name) s+    & type_ .~ SwaggerObject
+ src/Composite/Swagger/OrphanInstances.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+module Composite.Swagger.OrphanInstances where++import Composite ((:->), Record)+import Control.Lens ((%~), (&))+import qualified Data.HashMap.Strict.InsOrd as I+import Data.Proxy (Proxy (Proxy))+import Data.Swagger+  ( NamedSchema (NamedSchema), ToSchema+  , declareNamedSchema, declareSchemaRef, properties, schema )+import qualified Data.Text as Text+import GHC.TypeLits (KnownSymbol, symbolVal)++-- Orphan instances for 'Data.Vinyl.Record' that stuff a name/parameter schema into a+-- 'Data.Swagger.Schema' object.++instance ToSchema (Record '[]) where+  declareNamedSchema _ = pure $ NamedSchema Nothing mempty++instance forall a s rs. (ToSchema a, ToSchema (Record rs), KnownSymbol s) => ToSchema (Record ((s :-> a) ': rs)) where+  declareNamedSchema _ = do+    xs <- declareNamedSchema (Proxy :: Proxy (Record rs))+    x <- declareSchemaRef (Proxy :: Proxy a)+    let name = Text.pack $ symbolVal (Proxy :: Proxy s)+    pure $ xs+      & schema.properties %~ I.insert name x
+ src/Composite/Swagger/TH.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}+module Composite.Swagger.TH where++import Composite.CoRecord (Field)+import Composite.Swagger.Base (wrappedSchema)+import Data.Monoid ((<>))+import Data.Proxy (Proxy (Proxy))+import Data.Swagger (ToSchema, declareNamedSchema)+import Language.Haskell.TH+  ( Dec, Name, Q, mkName+  , bang, bangType, clause, conT, cxt, funD, instanceD, newtypeD, normalB, recC, varBangType , wildP+  , noSourceStrictness, noSourceUnpackedness )++-- |TH splice which makes it more convenient to define 'ToSchema' instance for 'Record' types.+--+-- For example:+--+-- @+--   type MyRecord = '[FFoo, FBar]+--   newtype MyRecordWrapper = MyRecordWrapper { unMyRecordWrapper :: Record MyRecord }+--   makeToSchema "MyRecordWrapper" ''MyRecordWrapper+-- @+--+-- is equivalent to:+--+-- @+--   instance ToSchema MyRecordWrapper where+--     declareNamedSchema = wrappedSchema (Proxy :: Proxy MyRecordWrapper) "MyRecordWrapper"+-- @+makeToSchema :: String -> Name -> Q [Dec]+makeToSchema schemaName wrapperName =+  sequence+    [ instanceD+        (cxt [])+        [t| ToSchema $(conT wrapperName) |]+        [ funD+            'declareNamedSchema+            [ clause [wildP] (normalB [| wrappedSchema (Proxy :: Proxy $(conT wrapperName)) schemaName |]) [] ]+        ]+    ]++-- |TH splice which makes it more convenient to define 'ToSchema' instance for 'Record' types.+--+-- For example:+--+-- @+--   type MyRecord = '[FFoo, FBar]+--   makeToSchemaWrapper "MyRecordWrapper" ''MyRecord+-- @+--+-- is equivalent to:+--+-- @+--   newtype MyRecordWrapper = MyRecordWrapper { unMyRecordWrapper :: Record MyRecord }+--   instance ToSchema MyRecordWrapper where+--     declareNamedSchema = wrappedSchema (Proxy :: Proxy MyRecordWrapper) "MyRecordWrapper"+-- @+makeToSchemaWrapper :: String -> Name -> Q [Dec]+makeToSchemaWrapper wrapperNameStr fieldsTyName = do+  let wrapperName = mkName wrapperNameStr+      extractorName = mkName $ "un" <> wrapperNameStr+      fieldTy = [t| Field $(conT fieldsTyName) |]+  wrapperNewtype <- newtypeD+    (cxt [])+    wrapperName+    [] -- TyVarBndrs+    Nothing -- kind+    (recC wrapperName [varBangType extractorName (bangType (bang noSourceUnpackedness noSourceStrictness) fieldTy)])+#if MIN_VERSION_template_haskell(2,12,0)+    [] -- deriving context+#else+    (cxt [])+#endif+  wrapperInstances <- makeToSchema wrapperNameStr wrapperName+  pure $ wrapperNewtype:wrapperInstances
+ test/Main.hs view
@@ -0,0 +1,6 @@+import THSpec (thSuite)+import Test.Hspec (hspec)++main :: IO ()+main = hspec $ do+  thSuite
+ test/THSpec.hs view
@@ -0,0 +1,26 @@+module THSpec where++import Composite+import Composite.Aeson.TH (makeRecordJsonWrapper)+import Composite.Swagger.TH (makeToSchema)+import Composite.TH (withLensesAndProxies)+import Control.Lens.TH (makeWrapped)+import Data.Swagger (validateToJSON)+import Test.Hspec (Spec, describe, it, shouldBe)++withLensesAndProxies [d|+  type FFoo = "foo" :-> Int+  type FBar = "bar" :-> String+  |]+type TestRec = '["foo" :-> Int, "bar" :-> String]++makeRecordJsonWrapper "TestRecJson" ''TestRec+makeWrapped ''TestRecJson+makeToSchema "TestRecJson" ''TestRecJson++thSuite :: Spec+thSuite = do+  describe "Swagger Record Support" $ do+    it "encodes all fields" $ do+      let x = TestRecJson $ 1 :*: "a" :*: RNil+      validateToJSON x `shouldBe` mempty