diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# servant-side-loaded diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-zeppelin-swagger.cabal b/servant-zeppelin-swagger.cabal new file mode 100644 --- /dev/null +++ b/servant-zeppelin-swagger.cabal @@ -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 diff --git a/src/Servant/Zeppelin/Swagger.hs b/src/Servant/Zeppelin/Swagger.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Zeppelin/Swagger.hs @@ -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)) diff --git a/test/Servant/Zeppelin/SwaggerSpec.hs b/test/Servant/Zeppelin/SwaggerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Zeppelin/SwaggerSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +