servant-zeppelin-swagger (empty) → 0.1.0.0
raw patch · 7 files changed
+334/−0 lines, 7 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, hspec, insert-ordered-containers, lens, servant, servant-swagger, servant-zeppelin, servant-zeppelin-swagger, singletons, swagger2, text
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- servant-zeppelin-swagger.cabal +67/−0
- src/Servant/Zeppelin/Swagger.hs +100/−0
- test/Servant/Zeppelin/SwaggerSpec.hs +132/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# servant-side-loaded
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-zeppelin-swagger.cabal view
@@ -0,0 +1,67 @@+name: servant-zeppelin-swagger+version: 0.1.0.0+homepage: https://github.com/martyall/servant-zeppelin#readme+license: BSD3+license-file: LICENSE+author: Martin Allen, Ben Weitzman+maintainer: martin[dot]allen26[at]gmail.com+synopsis: Swagger instances for servant-zeppelin combinators.+copyright: 2017 Martin Allen, Ben Weitzman+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Servant.Zeppelin.Swagger+ build-depends: base >= 4.7 && < 5+ , aeson+ , insert-ordered-containers+ , lens+ , singletons+ , servant+ , servant-swagger >= 1.1.2.1+ , servant-zeppelin+ , swagger2+ , text+ default-language: Haskell2010+ default-extensions: GADTs+ , KindSignatures+ , FlexibleInstances+ , FlexibleContexts+ , OverloadedStrings+ , PolyKinds+ , DataKinds+ , TypeOperators+ , TypeFamilies+ , TypeApplications+ , TypeInType+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , ConstraintKinds+ + ghc-options: -Wall++test-suite servant-zeppelin-swagger-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , aeson+ , containers+ , hspec+ , insert-ordered-containers+ , lens+ , servant+ , servant-swagger+ , servant-zeppelin+ , servant-zeppelin-swagger+ , swagger2+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ other-modules: Servant.Zeppelin.SwaggerSpec++source-repository head+ type: git+ location: https://github.com/martyall/servant-zeppelin
+ src/Servant/Zeppelin/Swagger.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Zeppelin.Swagger+ (+ -- | The purpose of this package is provide the instance for 'servant-zepplin'+ -- combinators needed for 'servant-swagger' documentation generation.+ SideLoad+ ) where++import Control.Lens (mapped, (%~), (&), (.~), (?~))+import Control.Monad+import Data.Aeson (ToJSON (..))++import qualified Data.HashMap.Strict.InsOrd as O (empty, fromList, insert,+ member)+import Data.Kind+import Data.Monoid ((<>))+import Data.Promotion.Prelude hiding ((:>))+import Data.Singletons.TypeLits+import Data.Swagger+import Data.Swagger.Declare+import Data.Text as T+import Servant.API+import Servant.Swagger.Internal++import Servant.Zeppelin+import Servant.Zeppelin.Internal.Types++--------------------------------------------------------------------------------++-- | Helper type class for collecting the 'NamedSchema's of the dependencies.+class ToDependencySchema (deps :: [*]) where+ declareDependencySchema :: proxy deps -> Declare (Definitions Schema) NamedSchema++-- | Base case for induction.+instance ToDependencySchema '[] where+ declareDependencySchema _ =+ return $ NamedSchema Nothing+ ( mempty+ & type_ .~ SwaggerObject+ & properties .~ O.empty+ )++-- | Inductive step.+instance ( ToDependencySchema deps+ , KnownSymbol (NamedDependency d)+ , ToSchema d+ ) => ToDependencySchema (d : deps) where+ declareDependencySchema _ = do+ dRef <- declareSchemaRef $ Proxy @d+ let dText = T.pack . symbolVal $ Proxy @(NamedDependency d)+ declareDependencySchema (Proxy :: Proxy deps)+ & mapped.schema.properties %~ O.insert dText dRef++instance ( ToSchema a+ , ToDependencySchema deps+ ) => ToSchema (SideLoaded a deps) where+ declareNamedSchema _ = do+ aRef <- declareSchemaRef $ Proxy @a+ depsRef <- declareDependencySchemaRef $ Proxy @deps+ let aName = schemaName $ Proxy @a+ return $ NamedSchema (fmap ("side-loaded JSON: " <>) aName)+ ( mempty+ & type_ .~ SwaggerObject+ & properties .~ O.fromList [("data", aRef), ("dependencies", depsRef)]+ )++-- | PolyKinded version of declareSchemaRef.+declareDependencySchemaRef :: ToDependencySchema deps+ => proxy deps+ -> Declare (Definitions Schema) (Referenced Schema)+declareDependencySchemaRef deps =+ case undeclare . declareDependencySchema $ deps of+ NamedSchema (Just schmName) schm -> do+ known <- looks (O.member schmName)+ unless known $ do+ declare $ O.fromList [(schmName, schm)]+ void $ declareDependencySchema deps+ return $ Ref (Reference schmName)+ _ -> Inline . _namedSchemaSchema <$> declareDependencySchema deps++instance {-# OVERLAPPABLE #-}+ ( ToSchema a+ , ToDependencySchema deps+ , AllAccept cs+ , KnownNat status+ , SwaggerMethod method+ )+ => HasSwagger (Verb method status cs a :> SideLoad deps) where+ toSwagger _ =+ toSwagger (Proxy @(Verb method status cs (SideLoaded a deps)))+ & addParam param+ where+ param = mempty+ & name .~ "sideload"+ & schema .~ ParamOther (mempty+ & in_ .~ ParamQuery+ & allowEmptyValue ?~ True+ & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)+ & default_ ?~ toJSON False))
+ test/Servant/Zeppelin/SwaggerSpec.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Zeppelin.SwaggerSpec (spec) where++import Control.Lens (at, mapped, (&), (?~), (^?), _Just)+import Data.Aeson+import qualified Data.HashMap.Strict.InsOrd as O+import Data.Proxy+import qualified Data.Set as S+import Data.Swagger+import GHC.Generics (Generic)+import Servant.API+import Servant.Swagger+import Servant.Zeppelin+import Servant.Zeppelin.Swagger ()+import Servant.Zeppelin.Internal.Types+import Test.Hspec hiding (example)++spec :: Spec+spec = do+ swaggerSpec+ return ()+++swaggerSpec :: Spec+swaggerSpec = describe "Has Swagger instance" $ do++ let swag = toSwagger $ Proxy @API++ it "has properties of the main type" $ do+ let Just (Inline depSchema) = swag ^? definitions . at "side-loaded JSON: Album"+ . _Just . properties . at "dependencies" . _Just+ Just props = depSchema ^? properties+ (S.fromList . O.keys $ props) `shouldBe` S.fromList ["photos", "person"]+++--------------------------------------------------------------------------------+-- | api+--------------------------------------------------------------------------------++type API = "album" :> Get '[JSON] Album :> SideLoad [Person, [Photo]]++--------------------------------------------------------------------------------+-- | Data+--------------------------------------------------------------------------------+-- | Photo++newtype PhotoId = PhotoId Int+ deriving (Eq, Show, Num, Generic, ToJSON, FromJSON)++instance ToSchema PhotoId++type instance NamedDependency [Photo] = "photos"+type instance NamedDependency [PhotoId] = "photoIds"++data Photo =+ Photo { photoId :: PhotoId+ , photoCaption :: String+ , artistId :: PersonId+ } deriving (Eq, Show, Generic)++instance ToJSON Photo+instance FromJSON Photo++type instance NamedDependency [Photo] = "photos"++examplePhotos :: Photo+examplePhotos = Photo 1 "At the Beach." 1++instance ToSchema Photo where+ declareNamedSchema p = genericDeclareNamedSchema defaultSchemaOptions p+ & mapped.schema.example ?~ toJSON examplePhotos++-- | Person++newtype PersonId = PersonId Int+ deriving (Eq, Show, Num, Generic, ToJSON, FromJSON)++instance ToSchema PersonId++type instance NamedDependency Person = "person"++data Person =+ Person { personId :: PersonId+ , personName :: String+ } deriving (Eq, Show, Generic)++instance ToJSON Person+instance FromJSON Person++examplePerson :: Person+examplePerson = Person 1 "Alice"++type instance NamedDependency Person = "person"++instance ToSchema Person where+ declareNamedSchema p = genericDeclareNamedSchema defaultSchemaOptions p+ & mapped.schema.example ?~ toJSON examplePerson++-- | Albums++newtype AlbumId = AlbumId Int+ deriving (Eq, Show, Generic, Num, ToJSON, FromJSON)++instance ToSchema AlbumId++data Album =+ Album { albumId :: AlbumId+ , albumName :: String+ , albumOwner :: PersonId+ , albumPhotos :: [PhotoId]+ } deriving (Eq, Show, Generic)++instance ToJSON Album+instance FromJSON Album++exampleAlbum :: Album+exampleAlbum = Album 1 "Vacations" 1 [1]++instance ToSchema Album where+ declareNamedSchema p = genericDeclareNamedSchema defaultSchemaOptions p+ & mapped.schema.example ?~ toJSON exampleAlbum
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+