solga-swagger (empty) → 0.1.0.0

raw patch · 3 files changed

+249/−0 lines, 3 filesdep +basedep +bytestringdep +dlist

Dependencies added: base, bytestring, dlist, http-types, lens, mtl, solga, swagger2, text, unordered-containers

Files

LICENSE +20/−0
solga-swagger.cabal +31/−0
src/Solga/Swagger.hs +198/−0

+ LICENSE view

@@ -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.cabal view

@@ -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

+ src/Solga/Swagger.hs view

@@ -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 ]+      }