diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for jordan-servant-openapi + +## 0.1.0.0 -- 2022-07-04 + +* First version. Provides basic orphan instances. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2022 Anthony Super + +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/jordan-servant-openapi.cabal b/jordan-servant-openapi.cabal new file mode 100644 --- /dev/null +++ b/jordan-servant-openapi.cabal @@ -0,0 +1,62 @@ +cabal-version: 2.4 +name: jordan-servant-openapi +version: 0.1.0.0 +synopsis: OpenAPI schemas for Jordan-Powered Servant APIs + +-- A longer description of the package. +description: + Jordan Servant OpenAPI provides orphan instances to generate OpenAPI V3 documenation + for Jordan-Powered Servant APIs. + +homepage: https://github.com/AnthonySuper/jordan + +-- A URL where users can report bugs. +-- bug-reports: +license: MIT +license-file: LICENSE +author: Anthony Super +maintainer: anthony@noided.media +-- A copyright notice. +-- copyright: +category: Web +extra-source-files: CHANGELOG.md + +common build-deps + build-depends: + , attoparsec >= 0.14.1 && <0.15 + , bytestring >= 0.10.8.1 && <0.12 + , contravariant >= 1.5.5 && <1.6 + , jordan >= 0.2.0.0 && <0.3 + , servant >= 0.18 && <0.20 + , text >= 1.2.3.0 && <1.3 + , scientific >= 0.3.7 && <0.4 + , jordan-servant >= 0.1.0.0 && <0.2 + , servant-openapi3 >= 2.0 && <=2.1 + , jordan-openapi >= 0.2.0 && <= 0.3 + , http-types >= 0.12.2 && <0.13 + , http-media >= 0.7 && <0.9 + , lens >= 4.17 && <5.2 + , transformers >=0.5.5 && <= 0.7 + , openapi3 >= 3.1.0 && <3.3 + , base >= 4.14.1 && <4.17 + + +library + import: build-deps + exposed-modules: + Jordan.Servant.OpenApi + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + hs-source-dirs: lib + default-language: Haskell2010 + +test-suite jordan-servant-openapi-test + import: build-deps + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: MyLibTest.hs diff --git a/lib/Jordan/Servant/OpenApi.hs b/lib/Jordan/Servant/OpenApi.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/Servant/OpenApi.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Provides orphan instances for Jordan servant combinators that allow the generation of documentation. +module Jordan.Servant.OpenApi where + +import Control.Lens +import Data.OpenApi.Declare +import Data.OpenApi.Internal +import Data.OpenApi.Lens +import Data.OpenApi.Operation +import Data.OpenApi.ParamSchema +import Data.OpenApi.Schema +import Data.Proxy (Proxy (..)) +import qualified Data.Text as T +import Data.Typeable +import GHC.TypeLits +import Jordan +import Jordan.OpenAPI +import Jordan.Servant +import Jordan.Types.JSONError +import Network.HTTP.Media +import Servant.API +import Servant.API.ContentTypes +import Servant.API.Modifiers +import Servant.OpenApi.Internal + +instance (ToJSON a, Typeable a) => ToSchema (ViaJordan a) where + declareNamedSchema (Proxy :: Proxy (ViaJordan a)) = getToNamed (Proxy :: Proxy a) + +instance forall a sub baseKey mods. (HasOpenApi sub, FromJSON a, KnownSymbol baseKey, SBoolI (FoldRequired mods)) => HasOpenApi (JordanQuery' baseKey mods a :> sub) where + toOpenApi _ = + toOpenApi (Proxy :: Proxy sub) + & addParam parameter + & setResponseWith (<>) 400 queryErrorResponse + & components . schemas %~ (<> defs) + where + (defs, ref) = runDeclare (getFromRef (Proxy @a)) mempty + parameter :: Param + parameter = + mempty + & name .~ T.pack (symbolVal $ Proxy @baseKey) + & in_ .~ ParamQuery + & style ?~ StyleDeepObject + & explode ?~ True + & allowReserved ?~ False + & schema ?~ ref + & required ?~ isRequired + queryErrorResponse = + pure $ + mempty & content . at ("application" // "json+haskell-jordan-query-error") . non mempty . schema ?~ Inline s + s :: Schema + s = toParamSchema (Proxy :: Proxy String) + isRequired = case sbool @(FoldRequired mods) of + STrue -> True + SFalse -> False + +errorResponse :: Declare (Definitions Schema) Response +errorResponse = do + ref <- getToRef (Proxy :: Proxy JSONError) + pure $ mempty & content . at ("application" // "json+haskell-servant-body-error") . non mempty . schema ?~ ref + +instance forall a sub. (HasOpenApi sub, FromJSON a) => HasOpenApi (ReportingRequestBody a :> sub) where + toOpenApi _ = + toOpenApi (Proxy :: Proxy sub) + & addRequestBody reqBody + & addErrorResponse + & components . schemas %~ (<> defs) + where + (defs, ref) = runDeclare (getFromRef (Proxy :: Proxy a)) mempty + reqBody :: RequestBody = + mempty + { _requestBodyContent = [("application" // "json", mediaType)] + } + mediaType :: MediaTypeObject = + mempty + { _mediaTypeObjectSchema = Just ref + } + addErrorResponse = setResponseWith (<>) 400 errorResponse diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs new file mode 100644 --- /dev/null +++ b/test/MyLibTest.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."