Add experimental Swagger spec generation.

solga-swagger/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.

solga-swagger/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:          [email protected]
+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

solga-swagger/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 ]
+      }

stack.yaml

@@ -6,6 +6,7 @@ resolver: lts-6.6
 # Local packages, usually specified by relative directory name
 packages:
 - 'solga'
+- 'solga-swagger'
 
 # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
 extra-deps: []