solga-swagger 0.1.0.0 → 0.1.0.1
raw patch · 2 files changed
+46/−44 lines, 2 filesdep +insert-ordered-containersdep ~swagger2
Dependencies added: insert-ordered-containers
Dependency ranges changed: swagger2
Files
- solga-swagger.cabal +4/−3
- src/Solga/Swagger.hs +42/−41
solga-swagger.cabal view
@@ -1,5 +1,5 @@ name: solga-swagger-version: 0.1.0.0+version: 0.1.0.1 synopsis: Swagger generation for Solga description: Swagger generation for Solga license: MIT@@ -18,14 +18,15 @@ exposed-modules: Solga.Swagger build-depends: base >= 4.8 && < 5, solga,- swagger2,+ swagger2 >= 2.1, lens, text, unordered-containers, mtl, http-types, bytestring,- dlist+ dlist,+ insert-ordered-containers hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall
src/Solga/Swagger.hs view
@@ -30,6 +30,7 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.DList as DL import qualified Data.HashMap.Strict as HMS+import qualified Data.HashMap.Strict.InsOrd as OHMS import Data.Monoid import Data.Text (Text) import qualified Data.Text as T@@ -58,17 +59,17 @@ } type GenPathsM = ExceptT ( Text, Context ) (Declare (Definitions Schema))-type Paths = HMS.HashMap Text PathItem+type Paths = OHMS.InsOrdHashMap 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 ()))+ genPaths :: Proxy r -> Context -> GenPathsM Paths+ default genPaths :: (RouterSwagger (Rep r ())) => Proxy r -> Context -> GenPathsM Paths+ genPaths _ = genPaths (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)+passPaths p = genPaths (nextProxy p) -- | Produce no paths. noPaths :: Proxy r -> Context -> GenPathsM Paths@@ -76,11 +77,11 @@ -- | 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+genSwagger p = case runDeclare (runExceptT (genPaths 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+ fpPaths = OHMS.fromList $ map (\(k, v) -> ( T.unpack k, v )) $ OHMS.toList ps in Right (mempty & paths .~ fpPaths & definitions .~ defs) nextProxy :: Proxy (r next) -> Proxy next@@ -100,85 +101,85 @@ "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 resps = mempty & responses .~ OHMS.singleton 200 (Inline response) let operation = operationContext & responses .~ resps let pathItem = mempty & methodSetter ?~ operation- return $ HMS.singleton path pathItem+ return $ OHMS.singleton path pathItem instance RouterSwagger RawResponse where- genPathsFor _ = pathsFromContext mempty+ genPaths _ = pathsFromContext mempty instance ToSchema a => RouterSwagger (JSON a) where- genPathsFor p ctx = do+ genPaths 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+ genPaths p ctx = case ctx of Context { contextMethod = Just ctxMeth } | ctxMeth /= method -> throwError ( "Conflicting method specification.", ctx )- _ -> genPathsFor (nextProxy p) ctx { contextMethod = Just method }+ _ -> genPaths (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+ genPaths p ctx = do let seg = T.pack $ symbolVal (Proxy :: Proxy seg)- genPathsFor (nextProxy p) ctx { pathSegments = pathSegments ctx `DL.snoc` seg }+ genPaths (nextProxy p) ctx { pathSegments = pathSegments ctx `DL.snoc` seg } instance RouterSwagger next => RouterSwagger (WithIO next) where- genPathsFor = passPaths+ genPaths = passPaths instance RouterSwagger next => RouterSwagger (End next) where- genPathsFor = passPaths+ genPaths = passPaths instance RouterSwagger next => RouterSwagger (NoCache next) where- genPathsFor = passPaths+ genPaths = passPaths instance RouterSwagger next => RouterSwagger (ExtraHeaders next) where- genPathsFor = passPaths+ genPaths = passPaths instance RouterSwagger (ReqBodyMultipart a next) where- genPathsFor = noPaths+ genPaths = noPaths -instance RouterSwagger next => RouterSwagger (OneOfSegs '[] next) where- genPathsFor = noPaths+instance RouterSwagger (OneOfSegs '[] next) where+ genPaths = noPaths instance (KnownSymbol seg, RouterSwagger next, RouterSwagger (OneOfSegs segs next)) => RouterSwagger (OneOfSegs (seg ': segs) next) where- genPathsFor p ctx = do+ genPaths 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)+ nextPaths <- genPaths (nextProxy p) ctx { pathSegments = pathSegments ctx `DL.snoc` seg }+ nextSegPaths <- genPaths (Proxy :: Proxy (OneOfSegs segs next)) ctx+ return (nextPaths `OHMS.union` nextSegPaths) instance RouterSwagger Raw where- genPathsFor = noPaths+ genPaths = 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+ genPaths _ ctx =+ OHMS.unionWith mappend+ <$> genPaths (Proxy :: Proxy left) ctx+ <*> genPaths (Proxy :: Proxy right) ctx -- Generic paths instance RouterSwagger r => RouterSwagger (K1 i r p) where- genPathsFor _ = genPathsFor (Proxy :: Proxy r)+ genPaths _ = genPaths (Proxy :: Proxy r) instance RouterSwagger (f p) => RouterSwagger (M1 i c f p) where- genPathsFor _ = genPathsFor (Proxy :: Proxy (f p))+ genPaths _ = genPaths (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+ genPaths _ ctx =+ OHMS.unionWith mappend+ <$> genPaths (Proxy :: Proxy (left p)) ctx+ <*> genPaths (Proxy :: Proxy (right p)) ctx instance (ToSchema a, RouterSwagger next) => RouterSwagger (ReqBodyJSON a next) where- genPathsFor p ctx@Context { operationContext } = do+ genPaths 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 ] }+ genPaths (nextProxy p) ctx { operationContext = operationContext & parameters <>~ [ Inline param ] } newName :: Text -> Context -> ( Text, Context ) newName desiredName ctx@Context { paramScope } = case HMS.lookup desiredName paramScope of@@ -186,13 +187,13 @@ 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+ genPaths 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+ genPaths (nextProxy p) newCtx { pathSegments = pathSegments ctx `DL.snoc` paramName , operationContext = operationContext newCtx & parameters <>~ [ Inline param ] }