minion-openapi3 (empty) → 0.1.0.0

raw patch · 6 files changed

+605/−0 lines, 6 filesdep +aesondep +basedep +blaze-html

Dependencies added: aeson, base, blaze-html, blaze-markup, bytestring, case-insensitive, directory, file-embed-lzma, filepath, http-api-data, http-types, insert-ordered-containers, lens, minion, minion-wai-extra, openapi3, template-haskell, text

Files

• LICENSE +20/−0
• README.md +45/−0
• minion-openapi3.cabal +80/−0
• src/Web/Minion/Embed.hs +24/−0
• src/Web/Minion/Files.hs +11/−0
• src/Web/Minion/OpenApi3.hs +425/−0

@@ -0,0 +1,20 @@+Copyright (c) 2024 Danil Berestov++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.

@@ -0,0 +1,45 @@+# Minion++Minion is Haskell library for developing web applications. It stands between [Scotty](https://hackage.haskell.org/package/scotty) and [Servant](https://hackage.haskell.org/package/servant-server)  ++|                  | Scotty | Minion | Servant |+| ---------------- | ------ | ------ | ------- |+| As simple as ABC | Yes    | No     | No      |+| At term level    | Yes    | Yes    | No      |+| Typesafe         | No     | Yes    | Yes     |+| Introspectable   | No     | Yes    | Yes     |+| Generated client | No     | No     | Yes     |++  +Since Minion defines servers at the term level, it's easier to start and without excess verbosity.++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+module Main where++import Web.Minion+import Network.Wai.Handler.Warp qualified as Warp++main :: IO ()+main = Warp.run 9001 app++app :: ApplicationM IO+app = serve api ++api :: Router Void IO+api = "api" /> +    [ "about" /> handlePlainText @String GET (pure "Hello-World Minion server")+    , "hello" /> capture @String "name" +              .> handlePlainText @String GET (\name -> pure $ "Hello, " <> name <> "!")+    ]+```++Documentation and examples can be found on [Hackage](https://hackage.haskell.org/package/minion)  ++Minion ecosystem also contains following libraries:+* [minion-conduit](https://hackage.haskell.org/package/minion-conduit) +* [minion-htmx](https://hackage.haskell.org/package/minion-htmx) +* [minion-jwt](https://hackage.haskell.org/package/minion-jwt) +* [minion-wai-extra](https://hackage.haskell.org/package/minion-wai-extra) +* [minion-openapi3](https://hackage.haskell.org/package/minion-openapi3) 

@@ -0,0 +1,80 @@+cabal-version:      3.0+name:               minion-openapi3+version:            0.1.0.0+license:            MIT+license-file:       LICENSE+author:             Danil Berestov+maintainer:         goosedb@yandex.ru+synopsis:           Minion openapi3 support+category:           Web+build-type:         Simple+extra-source-files: README.md++common common+  ghc-options:        -Wall+  default-extensions:+    AllowAmbiguousTypes+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveGeneric+    DerivingStrategies+    DerivingStrategies+    DuplicateRecordFields+    DuplicateRecordFields+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    LambdaCase+    MultiParamTypeClasses+    NamedFieldPuns+    OverloadedLists+    OverloadedRecordDot+    OverloadedRecordDot+    OverloadedStrings+    PolyKinds+    RankNTypes+    RecordWildCards+    RoleAnnotations+    ScopedTypeVariables+    TemplateHaskell+    TypeApplications+    TypeFamilies+    TypeOperators+    UndecidableInstances+    ViewPatterns++library+  import:           common+  exposed-modules:  Web.Minion.OpenApi3+  other-modules:+    Web.Minion.Embed+    Web.Minion.Files++  build-depends:+    , aeson+    , base >= 4.16 && < 5+    , blaze-html+    , blaze-markup+    , bytestring+    , case-insensitive+    , directory+    , file-embed-lzma+    , filepath+    , http-api-data+    , http-types+    , insert-ordered-containers+    , lens+    , minion+    , minion-wai-extra+    , openapi3+    , template-haskell+    , text++  hs-source-dirs:   src+  default-language: Haskell2010

@@ -0,0 +1,24 @@+module Web.Minion.Embed where++import Control.Monad.IO.Class (MonadIO (..))+import FileEmbedLzma.Untyped+import Language.Haskell.TH+import System.Directory++indexName :: FilePath+indexName = "index.html.tmpl"++fixPath :: (MonadIO m) => FilePath -> m FilePath+fixPath path = liftIO do+  currDirectory <- getCurrentDirectory+  curDirectoryContents <- getDirectoryContents currDirectory+  pure+    if indexName `elem` curDirectoryContents+      then currDirectory <> "/" <> path+      else currDirectory <> "/minion-openapi3/" <> path++embedIndex :: Q Exp+embedIndex = fixPath indexName >>= embedText++embedUi :: Q Exp+embedUi = fixPath "ui" >>= embedRecursiveDir

@@ -0,0 +1,11 @@+module Web.Minion.Files where++import Data.ByteString qualified as Bytes+import Data.Text (Text)+import Web.Minion.Embed++indexTemplate :: Text+indexTemplate = $(embedIndex)++ui :: [(FilePath, Bytes.ByteString)]+ui = $(embedUi)

@@ -0,0 +1,425 @@+module Web.Minion.OpenApi3 (+  OpenApi3Config (..),+  OpenApi3,+  AttachRequestSchema (..),+  IsOpenApi3Description (..),+  OpenApi3Description (..),+  ToResponses (..),+  openapi3,+  -- | Use these newtypes to implement instances for according auths/response bodies/request bodies+  -- We do not implement it for concrete types to avoid extra dependencies+  AsCookieJwt (..),+  AsJwt (..),+  AsHtml (..),+  AsSSE (..),+  AsBinary (..),+  AsMultipart (..),+  AttachSecuritySchema (..),+  AttachSecuritySchemas (..),+) where++import Data.OpenApi hiding (Header (..))+import Web.Minion hiding (description)+import Web.Minion.Router++import Control.Applicative ((<|>))+import Control.Arrow ((>>>))+import Control.Lens hiding (index)+import Control.Monad.IO.Class (MonadIO)+import Data.Bifunctor (Bifunctor (..))+import Data.ByteString qualified as Bytes+import Data.CaseInsensitive qualified as CI+import Data.Data (Proxy (..))+import Data.Foldable (Foldable (..))+import Data.HashMap.Strict.InsOrd qualified as HM+import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap+import Data.Maybe (listToMaybe)+import Data.OpenApi.Declare (runDeclare)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Network.HTTP.Types (Status (..))+import Network.HTTP.Types qualified as Http+import Text.Blaze+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Web.HttpApiData (ToHttpApiData (..))+import Web.Minion.Auth.Basic (Basic)+import Web.Minion.Files (indexTemplate, ui)+import Web.Minion.Introspect qualified as I+import Web.Minion.Media+import Web.Minion.Response.Header qualified as Header+import Web.Minion.Response.Status+import Web.Minion.Response.Union+import Web.Minion.Static++data OpenApi3Config = OpenApi3Config+  { openapi3File :: !FilePath+  , staticDir :: !FilePath+  }++data OpenApi3++class AttachRequestSchema a where+  attachRequestSchema :: OpenApi -> OpenApi++type instance I.Introspection OpenApi3 I.QueryParam = ToParamSchema+type instance I.Introspection OpenApi3 I.Capture = ToParamSchema+type instance I.Introspection OpenApi3 I.Captures = ToParamSchema+type instance I.Introspection OpenApi3 I.Header = ToParamSchema+type instance I.Introspection OpenApi3 I.Request = AttachRequestSchema+type instance I.Introspection OpenApi3 I.Response = ToResponses+type instance I.Introspection OpenApi3 I.Description = IsOpenApi3Description++class IsOpenApi3Description a where+  toOpenApi3Description :: a -> OpenApi3Description++instance IsOpenApi3Description OpenApi3Description where+  toOpenApi3Description = id++data OpenApi3Description = DescriptionText Text | SummaryText Text++instance (AttachSecuritySchemas as) => AttachRequestSchema (Auth as a) where+  attachRequestSchema = attachSecuritySchemas @as++class AttachSecuritySchemas as where+  attachSecuritySchemas :: OpenApi -> OpenApi++instance AttachSecuritySchemas '[] where+  attachSecuritySchemas = id++instance (AttachSecuritySchema a, AttachSecuritySchemas as) => AttachSecuritySchemas (a ': as) where+  attachSecuritySchemas = attachSecuritySchemas @as . attachSecuritySchema @a++class AttachSecuritySchema a where+  attachSecuritySchema :: OpenApi -> OpenApi++instance AttachSecuritySchema Basic where+  attachSecuritySchema = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme+   where+    identifier = "BasicAuth"+    securityScheme =+      SecurityScheme+        { _securitySchemeType = SecuritySchemeHttp HttpSchemeBasic+        , _securitySchemeDescription = Just "Basic Authentication"+        }++newtype AsJwt a = AsJwt a+instance AttachSecuritySchema (AsJwt a) where+  attachSecuritySchema = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme+   where+    identifier = "JWT"+    securityScheme =+      SecurityScheme+        { _securitySchemeType = SecuritySchemeHttp $ HttpSchemeBearer $ Just "JWT"+        , _securitySchemeDescription = Just "Bearer Authentication"+        }++newtype AsCookieJwt a = AsCookieJwt a++instance AttachSecuritySchema (AsCookieJwt a) where+  attachSecuritySchema = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme+   where+    identifier = "Cookie"+    securityScheme =+      SecurityScheme+        { _securitySchemeType = SecuritySchemeHttp $ HttpSchemeBearer $ Just "JWT"+        , _securitySchemeDescription = Just "Cookie Authentication"+        }++addSecurityScheme :: Text -> SecurityScheme -> OpenApi -> OpenApi+addSecurityScheme securityIdentifier securityScheme openApi =+  openApi+    { _openApiComponents =+        (_openApiComponents openApi)+          { _componentsSecuritySchemes =+              _componentsSecuritySchemes (_openApiComponents openApi)+                <> SecurityDefinitions (HM.singleton securityIdentifier securityScheme)+          }+    }++addSecurityRequirement :: Text -> OpenApi -> OpenApi+addSecurityRequirement securityRequirement =+  allOperations+    . security+    %~ ((SecurityRequirement $ HM.singleton securityRequirement []) :)++instance (ToSchema a, AllContentTypes cts) => AttachRequestSchema (ReqBody cts a) where+  attachRequestSchema =+    addRequestBody reqB+      >>> addDefaultResponse400 tname+      >>> components . schemas %~ (<> defs)+   where+    addRequestBody rb = allOperations . requestBody ?~ Inline rb+    tname = "body"+    (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty+    reqB =+      (mempty :: RequestBody)+        & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- allContentTypes @cts]++newtype AsHtml a = AsHtml a+instance ToResponses (AsHtml a) where+  toResponses = (resps, [])+   where+    resps =+      Responses+        { _responsesResponses = mempty & at 200 ?~ resp+        , _responsesDefault = Nothing+        }+    resp =+      Inline+        ( mempty+            & content+              .~ InsOrdHashMap.fromList+                [("text/html", mempty)]+        )++newtype AsBinary a = AsBinary a+instance ToResponses (AsBinary a) where+  toResponses = (resps, [])+   where+    resps =+      Responses+        { _responsesResponses = mempty & at 200 ?~ resp+        , _responsesDefault = Nothing+        }+    resp =+      Inline+        ( mempty+            & content+              .~ InsOrdHashMap.fromList+                [("octet/stream", mempty)]+        )++newtype AsSSE a = AsSSE a++-- | It's just a stub for now+instance ToResponses (AsSSE a) where+  toResponses = (resps, [])+   where+    resps =+      Responses+        { _responsesResponses = mempty & at 200 ?~ resp+        , _responsesDefault = Nothing+        }+    resp =+      Inline+        ( mempty+            & content+              .~ InsOrdHashMap.fromList+                [("text/event-stream", mempty)]+        )++newtype AsMultipart a = AsMultipart a++instance AttachRequestSchema (AsMultipart a) where+  attachRequestSchema =+    addRequestBody reqB+      >>> addDefaultResponse400 tname+   where+    addRequestBody rb = allOperations . requestBody ?~ Inline rb+    tname = "body"+    reqB =+      (mempty :: RequestBody)+        & content .~ InsOrdHashMap.fromList [("multipart/form-data", mempty)]++instance (ToSchema a, AllContentTypes cts) => ToResponses (RespBody cts a) where+  toResponses = (resps, defs)+   where+    (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty+    resps =+      Responses+        { _responsesResponses = mempty & at 200 ?~ resp+        , _responsesDefault = Nothing+        }+    resp =+      Inline+        ( mempty+            & content+              .~ InsOrdHashMap.fromList+                [(t, mempty & schema ?~ ref) | t <- responseContentTypes]+        )++    responseContentTypes = allContentTypes @cts++instance ToResponses NoBody where+  toResponses = (resps, mempty)+   where+    resps =+      Responses+        { _responsesResponses = mempty & at 200 ?~ resp+        , _responsesDefault = Nothing+        }+    resp = Inline mempty++instance ToResponses LazyBytes where+  toResponses = (resps, mempty)+   where+    resps =+      Responses+        { _responsesResponses = mempty & at 200 ?~ resp+        , _responsesDefault = Nothing+        }+    resp =+      Inline+        ( mempty+            & content+              .~ InsOrdHashMap.fromList+                [("application/octet-stream", mempty)]+        )++instance ToResponses Chunks where+  toResponses = toResponses @LazyBytes++instance (ToResponses a, ToResponses (Union as)) => ToResponses (Union (a ': as)) where+  toResponses =+    let (resp, def) = toResponses @a+        (resps, defs) = toResponses @(Union as)+     in (resp <> resps, def <> defs)++instance (ToResponses a, IsStatus status) => ToResponses (WithStatus status a) where+  toResponses =+    let (Responses{..}, def) = toResponses @a+        Status code _ = status @status+     in ( Responses+            { _responsesDefault = Nothing+            , _responsesResponses =+                mempty+                  & at code+                    .~ ( _responsesResponses ^. at code+                          <|> listToMaybe (toList _responsesResponses)+                          <|> _responsesDefault+                       )+            }+        , def+        )++class ToResponses a where+  toResponses :: (Responses, Definitions Schema)++openapi3 ::+  forall m ts st.+  (HandleArgs ts st m, MonadIO m) =>+  OpenApi3Config ->+  Router' OpenApi3 ts m ->+  Router' Void Void m+openapi3 OpenApi3Config{..} r =+  [ Piece (Text.pack openapi3File) /> handleJson GET (pure $ generateOpenApi3 r)+  , Piece (Text.pack staticDir)+      /> [ "index.html" /> getIndex+         , staticFiles defaultExtsMap ui'+         , getIndex+         ]+  ]+ where+  ui' = map (first (dropWhile (== '/'))) ui+  getIndex = handle GET do+    pure $+      Header.AddHeaders+        { headers = Header.AddHeader @"Content-Type" (Header.RawHeaderValue "text/html") :# HNil+        , body = LazyBytes index+        }++  index =+    indexTemplate+      & Text.replace "SWAGGER_UI_SCHEMA" (toUrlPiece openapi3File)+      & Text.replace "SWAGGER_UI_DIR" (toUrlPiece staticDir)+      & preEscapedToMarkup+      & renderHtml++generateOpenApi3 :: forall m ts. Router' OpenApi3 ts m -> OpenApi+generateOpenApi3 = \case+  Capture @a _ pname r ->+    generateOpenApi3 r & openapi3Capture @a pname+  Captures @a _ pname r ->+    generateOpenApi3 r & openapi3Capture @a pname+  Header @a @presence hname _ r ->+    generateOpenApi3 r & opeanapi3Header @presence @a hname+  Request @r _ r -> generateOpenApi3 r & attachRequestSchema @r+  HideIntrospection _ -> mempty+  Piece path r -> prependPath (Text.unpack path) (generateOpenApi3 r)+  Middleware _ r -> generateOpenApi3 r+  Alt rs -> foldMap generateOpenApi3 rs+  MapArgs _ r -> generateOpenApi3 r+  Description (toOpenApi3Description -> desc) r -> case desc of+    DescriptionText txt -> generateOpenApi3 r & allOperations . description %~ (Just txt <>)+    SummaryText txt -> generateOpenApi3 r & allOperations . summary %~ (Just txt <>)+  QueryParam @a @presence bname _ r -> generateOpenApi3 r & openapi3QueryParam @presence @a bname+  Handle @o httpMethod _ ->+    let+      method :: Lens' PathItem (Maybe Operation)+      method = case httpMethod of+        "GET" -> get+        "POST" -> post+        "PATCH" -> patch+        "DELETE" -> delete+        "PUT" -> put+        "TRACE" -> trace+        "OPTIONS" -> options+        "HEAD" -> head_+        _ -> lens (const Nothing) const+      (resp, defs) = toResponses @o+     in+      mempty+        & paths . at "/" ?~ (mempty & method ?~ (mempty{_operationResponses = resp}))+        & components . schemas .~ defs++openapi3QueryParam :: forall presence a. (IsRequired presence, ToParamSchema a) => Bytes.ByteString -> OpenApi -> OpenApi+openapi3QueryParam bname = addParam param >>> addDefaultResponse400 tname+ where+  tname = Text.decodeUtf8 bname+  param =+    mempty+      & name .~ tname+      & required ?~ isRequired @presence+      & in_ .~ ParamQuery+      & schema ?~ Inline (toParamSchema (Proxy @a))++openapi3Capture :: forall a. (ToParamSchema a) => Text -> OpenApi -> OpenApi+openapi3Capture tname =+  addParam param+    >>> prependPath capture_+    >>> addDefaultResponse404 tname+ where+  sname = Text.unpack tname+  capture_ = "{" <> sname <> "}"+  param =+    mempty+      & name .~ tname+      & required ?~ True+      & in_ .~ ParamPath+      & schema ?~ Inline (toParamSchema (Proxy :: Proxy a))++opeanapi3Header :: forall presence a. (IsRequired presence, ToParamSchema a) => Http.HeaderName -> OpenApi -> OpenApi+opeanapi3Header hname =+  addParam param+    >>> addDefaultResponse400 tname+ where+  tname = Text.decodeUtf8 $ CI.original hname+  param =+    mempty+      & name .~ tname+      & required ?~ isRequired @presence+      & in_ .~ ParamHeader+      & schema ?~ Inline (toParamSchema (Proxy :: Proxy a))++addParam :: Param -> OpenApi -> OpenApi+addParam param = allOperations . parameters %~ (Inline param :)++addDefaultResponse404 :: ParamName -> OpenApi -> OpenApi+addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (return response404)+ where+  sname = markdownCode pname+  description404 = sname <> " not found"+  alter404 = description %~ ((sname <> " or ") <>)+  response404 = mempty & description .~ description404++addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)+ where+  sname = markdownCode pname+  description400 = "Invalid " <> sname+  alter400 = description %~ (<> (" or " <> sname))+  response400 = mempty & description .~ description400++markdownCode :: Text -> Text+markdownCode s = "`" <> s <> "`"