diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Patrick Chilton + +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. diff --git a/solga-swagger.cabal b/solga-swagger.cabal new file mode 100644 --- /dev/null +++ b/solga-swagger.cabal @@ -0,0 +1,31 @@ +name: solga-swagger +version: 0.1.0.0 +synopsis: Swagger generation for Solga +description: Swagger generation for Solga +license: MIT +license-file: LICENSE +author: Patrick Chilton +maintainer: chpatrick@gmail.com +copyright: Copyright (C) 2016 Patrick Chilton +category: Web +build-type: Simple +homepage: https://github.com/chpatrick/solga +bug-reports: https://github.com/chpatrick/solga/issues +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Solga.Swagger + build-depends: base >= 4.8 && < 5, + solga, + swagger2, + lens, + text, + unordered-containers, + mtl, + http-types, + bytestring, + dlist + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Solga/Swagger.hs b/src/Solga/Swagger.hs new file mode 100644 --- /dev/null +++ b/src/Solga/Swagger.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} + +module Solga.Swagger + ( genSwagger + , RouterSwagger(..) + -- * Implementation + , GenPathsM + , Paths + , Context(..) + , passPaths + , noPaths + ) where + +import Control.Monad.State +import Control.Monad.Except +import qualified Network.HTTP.Types as HTTP + +import Control.Lens hiding (Context) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.DList as DL +import qualified Data.HashMap.Strict as HMS +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Typeable +import GHC.Generics +import GHC.TypeLits +import Data.Swagger as Swagger +import Data.Swagger.Declare + +import Solga + +data Context = Context + { contextMethod :: Maybe HTTP.Method -- ^ Any method currently set. + , pathSegments :: DL.DList Text -- ^ The current path. + , operationContext :: Operation -- ^ The current template operation. + , paramScope :: HMS.HashMap Text Int -- ^ The parameter names in use. + } deriving (Show) + +noContext :: Context +noContext = Context + { contextMethod = mempty + , pathSegments = mempty + , operationContext = mempty + , paramScope = mempty + } + +type GenPathsM = ExceptT ( Text, Context ) (Declare (Definitions Schema)) +type Paths = HMS.HashMap Text PathItem + +-- | A type for which we can generate a Swagger specification. +class RouterSwagger r where + genPathsFor :: Proxy r -> Context -> GenPathsM Paths + default genPathsFor :: (Generic r, RouterSwagger (Rep r ())) => Proxy r -> Context -> GenPathsM Paths + genPathsFor _ = genPathsFor (Proxy :: Proxy (Rep r ())) + +-- | For a Router @f next@, produce the same paths as @next@ without modification. +passPaths :: (r ~ f next, RouterSwagger next) => Proxy r -> Context -> GenPathsM Paths +passPaths p = genPathsFor (nextProxy p) + +-- | Produce no paths. +noPaths :: Proxy r -> Context -> GenPathsM Paths +noPaths _ _ = return mempty + +-- | Generate a Swagger specification for a given type. +genSwagger :: RouterSwagger r => Proxy r -> Either ( Text, Context ) Swagger +genSwagger p = case runDeclare (runExceptT (genPathsFor p noContext)) mempty of + ( _, Left err ) -> Left err + ( defs, Right ps ) -> + let + fpPaths = HMS.fromList $ map (\(k, v) -> ( T.unpack k, v )) $ HMS.toList ps + in Right (mempty & paths .~ fpPaths & definitions .~ defs) + +nextProxy :: Proxy (r next) -> Proxy next +nextProxy _ = Proxy + +pathsFromContext :: Response -> Context -> GenPathsM Paths +pathsFromContext response ctx@Context { contextMethod, pathSegments, operationContext } = do + let path = foldMap (\seg -> "/" <> seg) (DL.toList pathSegments) + methodSetter <- case contextMethod of + Just m -> case m of + "GET" -> return Swagger.get + "PUT" -> return Swagger.put + "POST" -> return Swagger.post + "DELETE" -> return Swagger.delete + "OPTIONS" -> return Swagger.options + "HEAD" -> return Swagger.head_ + "PATCH" -> return Swagger.patch + _ -> throwError ( "Unsupported method " <> decodeUtf8 m, ctx ) + _ -> throwError ( "Missing method in context.", ctx ) + let resps = mempty & responses .~ HMS.singleton 200 (Inline response) + let operation = operationContext & responses .~ resps + let pathItem = mempty & methodSetter ?~ operation + return $ HMS.singleton path pathItem + +instance RouterSwagger RawResponse where + genPathsFor _ = pathsFromContext mempty + +instance ToSchema a => RouterSwagger (JSON a) where + genPathsFor p ctx = do + respSchemaRef <- lift $ declareSchemaRef (nextProxy p) + let resp = mempty & schema ?~ respSchemaRef + pathsFromContext resp ctx + +instance (KnownSymbol m, RouterSwagger next) => RouterSwagger (Method m next) where + genPathsFor p ctx = case ctx of + Context { contextMethod = Just ctxMeth } | ctxMeth /= method -> throwError ( "Conflicting method specification.", ctx ) + _ -> genPathsFor (nextProxy p) ctx { contextMethod = Just method } + where + method = BSC.pack (symbolVal (Proxy :: Proxy m)) + +instance (KnownSymbol seg, RouterSwagger next) => RouterSwagger (Seg seg next) where + genPathsFor p ctx = do + let seg = T.pack $ symbolVal (Proxy :: Proxy seg) + genPathsFor (nextProxy p) ctx { pathSegments = pathSegments ctx `DL.snoc` seg } + +instance RouterSwagger next => RouterSwagger (WithIO next) where + genPathsFor = passPaths +instance RouterSwagger next => RouterSwagger (End next) where + genPathsFor = passPaths +instance RouterSwagger next => RouterSwagger (NoCache next) where + genPathsFor = passPaths +instance RouterSwagger next => RouterSwagger (ExtraHeaders next) where + genPathsFor = passPaths + +instance RouterSwagger (ReqBodyMultipart a next) where + genPathsFor = noPaths + +instance RouterSwagger next => RouterSwagger (OneOfSegs '[] next) where + genPathsFor = noPaths + +instance (KnownSymbol seg, RouterSwagger next, RouterSwagger (OneOfSegs segs next)) => RouterSwagger (OneOfSegs (seg ': segs) next) where + genPathsFor p ctx = do + let seg = T.pack $ symbolVal (Proxy :: Proxy seg) + nextPaths <- genPathsFor (nextProxy p) ctx { pathSegments = pathSegments ctx `DL.snoc` seg } + nextSegPaths <- genPathsFor (Proxy :: Proxy (OneOfSegs segs next)) ctx + return (nextPaths `HMS.union` nextSegPaths) + +instance RouterSwagger Raw where + genPathsFor = noPaths + +instance (RouterSwagger left, RouterSwagger right) => RouterSwagger (left :<|> right) where + genPathsFor _ ctx = + HMS.unionWith mappend + <$> genPathsFor (Proxy :: Proxy left) ctx + <*> genPathsFor (Proxy :: Proxy right) ctx + +-- Generic paths +instance RouterSwagger r => RouterSwagger (K1 i r p) where + genPathsFor _ = genPathsFor (Proxy :: Proxy r) + +instance RouterSwagger (f p) => RouterSwagger (M1 i c f p) where + genPathsFor _ = genPathsFor (Proxy :: Proxy (f p)) + +instance (RouterSwagger (left p), RouterSwagger (right p)) => RouterSwagger ((left :*: right) p) where + genPathsFor _ ctx = + HMS.unionWith mappend + <$> genPathsFor (Proxy :: Proxy (left p)) ctx + <*> genPathsFor (Proxy :: Proxy (right p)) ctx + +instance (ToSchema a, RouterSwagger next) => RouterSwagger (ReqBodyJSON a next) where + genPathsFor p ctx@Context { operationContext } = do + let hasOtherBody = notNullOf (parameters . folded . _Inline . schema . _ParamBody) operationContext + if hasOtherBody + then throwError ( "Conflicting request body schemas.", ctx ) + else do + bodySchemaRef <- lift $ declareSchemaRef (Proxy :: Proxy a) + let param = mempty & name .~ "requestBody" & required .~ Just True & schema .~ (ParamBody bodySchemaRef) + genPathsFor (nextProxy p) ctx { operationContext = operationContext & parameters <>~ [ Inline param ] } + +newName :: Text -> Context -> ( Text, Context ) +newName desiredName ctx@Context { paramScope } = case HMS.lookup desiredName paramScope of + Nothing -> ( desiredName, ctx { paramScope = HMS.insert desiredName 1 paramScope } ) + Just count -> let newCount = count + 1 in ( desiredName <> T.pack (show newCount), ctx { paramScope = HMS.insert desiredName newCount paramScope } ) + +instance (Typeable a, ToParamSchema a, RouterSwagger next) => RouterSwagger (Capture a next) where + genPathsFor p ctx = do + let desiredName = T.pack $ tyConName $ typeRepTyCon $ typeRep (Proxy :: Proxy a) + let ( paramName, newCtx ) = newName desiredName ctx + let pSchema = toParamSchema (Proxy :: Proxy a) + let pOtherSchema = mempty & in_ .~ ParamPath & paramSchema .~ pSchema + let param = mempty & name .~ paramName & required .~ Just True & schema .~ ParamOther pOtherSchema + genPathsFor (nextProxy p) newCtx + { pathSegments = pathSegments ctx `DL.snoc` paramName + , operationContext = operationContext newCtx & parameters <>~ [ Inline param ] + }