diff --git a/.github/workflows/samples-haskell.yaml b/.github/workflows/samples-haskell.yaml index a1d7d3940fc3..16f8e1ffa76e 100644 --- a/.github/workflows/samples-haskell.yaml +++ b/.github/workflows/samples-haskell.yaml @@ -5,11 +5,13 @@ on: paths: - samples/server/petstore/haskell-yesod/** - samples/server/petstore/haskell-servant/** + - samples/server/others/haskell-servant-ping/** - samples/client/petstore/haskell-http-client/** pull_request: paths: - samples/server/petstore/haskell-yesod/** - samples/server/petstore/haskell-servant/** + - samples/server/others/haskell-servant-ping/** - samples/client/petstore/haskell-http-client/** jobs: build: @@ -22,6 +24,7 @@ jobs: # servers - samples/server/petstore/haskell-yesod/ - samples/server/petstore/haskell-servant/ + - samples/server/others/haskell-servant-ping/ - samples/client/petstore/haskell-http-client/ steps: - uses: actions/checkout@v4 diff --git a/bin/configs/haskell-servant-ping.yaml b/bin/configs/haskell-servant-ping.yaml new file mode 100644 index 000000000000..11bc935b1880 --- /dev/null +++ b/bin/configs/haskell-servant-ping.yaml @@ -0,0 +1,4 @@ +generatorName: haskell +outputDir: samples/server/others/haskell-servant-ping +inputSpec: modules/openapi-generator/src/test/resources/3_0/ping.yaml +templateDir: modules/openapi-generator/src/main/resources/haskell-servant diff --git a/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache b/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache index a55ed07ed2c7..910fcf094e71 100644 --- a/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache +++ b/modules/openapi-generator/src/main/resources/haskell-servant/haskell-servant-codegen.mustache @@ -38,12 +38,9 @@ library , http-types , swagger2 , uuid -{{#authMethods}} -{{#isApiKey}} , bytestring -{{/isApiKey}} +{{#authMethods}} {{#isBasicBearer}} - , bytestring , wai-extra {{/isBasicBearer}} {{#isBasicBasic}} diff --git a/samples/server/others/haskell-servant-ping/.openapi-generator-ignore b/samples/server/others/haskell-servant-ping/.openapi-generator-ignore new file mode 100644 index 000000000000..7484ee590a38 --- /dev/null +++ b/samples/server/others/haskell-servant-ping/.openapi-generator-ignore @@ -0,0 +1,23 @@ +# OpenAPI Generator Ignore +# Generated by openapi-generator https://github.com/openapitools/openapi-generator + +# Use this file to prevent files from being overwritten by the generator. +# The patterns follow closely to .gitignore or .dockerignore. + +# As an example, the C# client generator defines ApiClient.cs. +# You can make changes and tell OpenAPI Generator to ignore just this file by uncommenting the following line: +#ApiClient.cs + +# You can match any string of characters against a directory, file or extension with a single asterisk (*): +#foo/*/qux +# The above matches foo/bar/qux and foo/baz/qux, but not foo/bar/baz/qux + +# You can recursively match patterns against a directory, file or extension with a double asterisk (**): +#foo/**/qux +# This matches foo/bar/qux, foo/baz/qux, and foo/bar/baz/qux + +# You can also negate patterns with an exclamation (!). +# For example, you can ignore all files in a docs folder with the file extension .md: +#docs/*.md +# Then explicitly reverse the ignore rule for a single file: +#!docs/README.md diff --git a/samples/server/others/haskell-servant-ping/.openapi-generator/FILES b/samples/server/others/haskell-servant-ping/.openapi-generator/FILES new file mode 100644 index 000000000000..1814b863420e --- /dev/null +++ b/samples/server/others/haskell-servant-ping/.openapi-generator/FILES @@ -0,0 +1,6 @@ +README.md +Setup.hs +lib/PingTest/API.hs +lib/PingTest/Types.hs +ping-test.cabal +stack.yaml diff --git a/samples/server/others/haskell-servant-ping/.openapi-generator/VERSION b/samples/server/others/haskell-servant-ping/.openapi-generator/VERSION new file mode 100644 index 000000000000..6116b14d2c59 --- /dev/null +++ b/samples/server/others/haskell-servant-ping/.openapi-generator/VERSION @@ -0,0 +1 @@ +7.8.0-SNAPSHOT diff --git a/samples/server/others/haskell-servant-ping/README.md b/samples/server/others/haskell-servant-ping/README.md new file mode 100644 index 000000000000..56539768e863 --- /dev/null +++ b/samples/server/others/haskell-servant-ping/README.md @@ -0,0 +1,128 @@ +# Auto-Generated OpenAPI Bindings to `PingTest` + +The library in `lib` provides auto-generated-from-OpenAPI bindings to the PingTest API. + +## Installation + +Installation follows the standard approach to installing Stack-based projects. + +1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README). +2. Run `stack install` to install this package. + +Otherwise, if you already have a Stack project, you can include this package under the `packages` key in your `stack.yaml`: +```yaml +packages: +- location: + git: https://github.com/yourGitOrg/yourGitRepo + commit: somecommit +``` + +## Main Interface + +The main interface to this library is in the `PingTest.API` module, which exports the PingTestBackend type. The PingTestBackend +type can be used to create and define servers and clients for the API. + +## Creating a Client + +A client can be created via the `createPingTestClient` function, which will generate a function for every endpoint of the API. +Then these functions can be invoked with `runPingTestClientWithManager` or more conveniently with `callPingTestClient` +(depending if you want an `Either` back or you want to catch) to access the API endpoint they refer to, if the API is served +at the `url` you specified. + +For example, if `localhost:8080` is serving the PingTest API, you can write: + +```haskell +{-# LANGUAGE RecordWildCards #-} + +import PingTest.API as API + +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Servant.Client (ClientEnv, mkClientEnv, parseBaseUrl) + + +main :: IO () +main = do + -- Configure the BaseUrl for the client + url <- parseBaseUrl "http://localhost:8080/" + + -- You probably want to reuse the Manager across calls, for performance reasons + manager <- newManager tlsManagerSettings + + -- Create the client (all endpoint functions will be available) + let PingTestBackend{..} = API.createPingTestClient + + -- Any PingTest API call can go here, e.g. here we call `getSomeEndpoint` + API.callPingTest (mkClientEnv manager url) getSomeEndpoint +``` + +## Creating a Server + +In order to create a server, you must use the `runPingTestMiddlewareServer` function. However, you unlike the client, in which case you *got* a `PingTestBackend` +from the library, you must instead *provide* a `PingTestBackend`. For example, if you have defined handler functions for all the +functions in `PingTest.Handlers`, you can write: + +```haskell +{-# LANGUAGE RecordWildCards #-} + +import PingTest.API +-- required dependency: wai +import Network.Wai (Middleware) +-- required dependency: wai-extra +import Network.Wai.Middleware.RequestLogger (logStdout) + +-- A module you wrote yourself, containing all handlers needed for the PingTestBackend type. +import PingTest.Handlers + +-- If you would like to not use any middlewares you could use runPingTestServer instead + +-- Combined middlewares +requestMiddlewares :: Middleware +requestMiddlewares = logStdout + +-- Run a PingTest server on localhost:8080 +main :: IO () +main = do + let server = PingTestBackend{..} + config = Config "http://localhost:8080/" + runPingTestMiddlewareServer config requestMiddlewares server +``` + +## Authentication + +Currently basic, bearer and API key authentication is supported. The API key must be provided +in the request header. + +For clients authentication the function `clientAuth` is generated automatically. For basic +authentication the argument is of type `BasicAuthData` provided by `Servant.API.BasicAuth`. +For bearer and API key authentication the argument is the key/token and is of type `Text`. +Protected endpoints on the client will receive an extra argument. The value returned by +`clientAuth keyTokenOrBasic` can then be used to make authenticated requests. + +For the server you are free to choose a custom data type. After you specified an instance of +`AuthServerData` it is automatically added as a first argument to protected endpoints: + +``` +newtype Account = Account {unAccount :: Text} +type instance AuthServerData Protected = Account +``` + +Additionally, you have to provide value for the `PingTestAuth` type provided by the +`PingTest.API` module: + +``` +auth :: PingTestAuth +auth = + PingTestAuth + { lookupUser = lookupAccount, + authError = \request -> err401 {errBody = "Missing header"} + } +``` + +`lookupAccount` is a user defined function used to verify the key, token or basic auth data. +`authError` takes a `Request` and returns a `ServerError`. The value is used by the server +functions: + +``` +runPingTestMiddlewareServer config requestMiddlewares auth server +``` diff --git a/samples/server/others/haskell-servant-ping/Setup.hs b/samples/server/others/haskell-servant-ping/Setup.hs new file mode 100644 index 000000000000..9a994af677b0 --- /dev/null +++ b/samples/server/others/haskell-servant-ping/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/samples/server/others/haskell-servant-ping/lib/PingTest/API.hs b/samples/server/others/haskell-servant-ping/lib/PingTest/API.hs new file mode 100644 index 000000000000..85e9515d3226 --- /dev/null +++ b/samples/server/others/haskell-servant-ping/lib/PingTest/API.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC +-fno-warn-unused-binds -fno-warn-unused-imports -freduction-depth=328 #-} + +module PingTest.API + ( -- * Client and Server + Config(..) + , PingTestBackend(..) + , createPingTestClient + , runPingTestServer + , runPingTestMiddlewareServer + , runPingTestClient + , runPingTestClientWithManager + , callPingTest + , PingTestClient + , PingTestClientError(..) + -- ** Servant + , PingTestAPI + -- ** Plain WAI Application + , serverWaiApplicationPingTest + ) where + +import PingTest.Types + +import Control.Monad.Catch (Exception, MonadThrow, throwM) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Coerce (coerce) +import Data.Data (Data) +import Data.Function ((&)) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time +import Data.UUID (UUID) +import GHC.Exts (IsString (..)) +import GHC.Generics (Generic) +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types.Method (methodOptions) +import Network.Wai (Middleware) +import qualified Network.Wai.Handler.Warp as Warp +import Servant (ServerError, serveWithContextT) +import Servant.API hiding (addHeader) +import Servant.API.Verbs (StdMethod (..), Verb) +import Servant.Client (ClientEnv, Scheme (Http), ClientError, client, + mkClientEnv, parseBaseUrl) +import Servant.Client.Core (baseUrlPort, baseUrlHost) +import Servant.Client.Internal.HttpClient (ClientM (..)) +import Servant.Server (Handler (..), Application, Context (EmptyContext)) +import Servant.Server.StaticFiles (serveDirectoryFileServer) +import Web.FormUrlEncoded +import Web.HttpApiData + + + + +-- | List of elements parsed from a query. +newtype QueryList (p :: CollectionFormat) a = QueryList + { fromQueryList :: [a] + } deriving (Functor, Applicative, Monad, Foldable, Traversable) + +-- | Formats in which a list can be encoded into a HTTP path. +data CollectionFormat + = CommaSeparated -- ^ CSV format for multiple parameters. + | SpaceSeparated -- ^ Also called "SSV" + | TabSeparated -- ^ Also called "TSV" + | PipeSeparated -- ^ `value1|value2|value2` + | MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. Only for GET params. + +instance FromHttpApiData a => FromHttpApiData (QueryList 'CommaSeparated a) where + parseQueryParam = parseSeparatedQueryList ',' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'TabSeparated a) where + parseQueryParam = parseSeparatedQueryList '\t' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'SpaceSeparated a) where + parseQueryParam = parseSeparatedQueryList ' ' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'PipeSeparated a) where + parseQueryParam = parseSeparatedQueryList '|' + +instance FromHttpApiData a => FromHttpApiData (QueryList 'MultiParamArray a) where + parseQueryParam = error "unimplemented FromHttpApiData for MultiParamArray collection format" + +parseSeparatedQueryList :: FromHttpApiData a => Char -> Text -> Either Text (QueryList p a) +parseSeparatedQueryList char = fmap QueryList . mapM parseQueryParam . T.split (== char) + +instance ToHttpApiData a => ToHttpApiData (QueryList 'CommaSeparated a) where + toQueryParam = formatSeparatedQueryList ',' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'TabSeparated a) where + toQueryParam = formatSeparatedQueryList '\t' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'SpaceSeparated a) where + toQueryParam = formatSeparatedQueryList ' ' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'PipeSeparated a) where + toQueryParam = formatSeparatedQueryList '|' + +instance ToHttpApiData a => ToHttpApiData (QueryList 'MultiParamArray a) where + toQueryParam = error "unimplemented ToHttpApiData for MultiParamArray collection format" + +formatSeparatedQueryList :: ToHttpApiData a => Char -> QueryList p a -> Text +formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList + +newtype JSONQueryParam a = JSONQueryParam + { fromJsonQueryParam :: a + } deriving (Functor, Foldable, Traversable) + +instance Aeson.ToJSON a => ToHttpApiData (JSONQueryParam a) where + toQueryParam = T.decodeUtf8 . BSL.toStrict . Aeson.encode . fromJsonQueryParam + +instance Aeson.FromJSON a => FromHttpApiData (JSONQueryParam a) where + parseQueryParam = either (Left . T.pack) (Right . JSONQueryParam) . Aeson.eitherDecodeStrict . T.encodeUtf8 + + +-- | Servant type-level API, generated from the OpenAPI spec for PingTest. +type PingTestAPI + = "ping" :> Verb 'GET 201 '[JSON] NoContent -- 'pingGet' route + :<|> Raw + + +-- | Server or client configuration, specifying the host and port to query or serve on. +data Config = Config + { configUrl :: String -- ^ scheme://hostname:port/path, e.g. "http://localhost:8080/" + } deriving (Eq, Ord, Show, Read) + + +-- | Custom exception type for our errors. +newtype PingTestClientError = PingTestClientError ClientError + deriving (Show, Exception) +-- | Configuration, specifying the full url of the service. + + +-- | Backend for PingTest. +-- The backend can be used both for the client and the server. The client generated from the PingTest OpenAPI spec +-- is a backend that executes actions by sending HTTP requests (see @createPingTestClient@). Alternatively, provided +-- a backend, the API can be served using @runPingTestMiddlewareServer@. +data PingTestBackend m = PingTestBackend + { pingGet :: m NoContent{- ^ -} + } + + +newtype PingTestClient a = PingTestClient + { runClient :: ClientEnv -> ExceptT ClientError IO a + } deriving Functor + +instance Applicative PingTestClient where + pure x = PingTestClient (\_ -> pure x) + (PingTestClient f) <*> (PingTestClient x) = + PingTestClient (\env -> f env <*> x env) + +instance Monad PingTestClient where + (PingTestClient a) >>= f = + PingTestClient (\env -> do + value <- a env + runClient (f value) env) + +instance MonadIO PingTestClient where + liftIO io = PingTestClient (\_ -> liftIO io) + +createPingTestClient :: PingTestBackend PingTestClient +createPingTestClient = PingTestBackend{..} + where + ((coerce -> pingGet) :<|> + _) = client (Proxy :: Proxy PingTestAPI) + +-- | Run requests in the PingTestClient monad. +runPingTestClient :: Config -> PingTestClient a -> ExceptT ClientError IO a +runPingTestClient clientConfig cl = do + manager <- liftIO $ newManager tlsManagerSettings + runPingTestClientWithManager manager clientConfig cl + +-- | Run requests in the PingTestClient monad using a custom manager. +runPingTestClientWithManager :: Manager -> Config -> PingTestClient a -> ExceptT ClientError IO a +runPingTestClientWithManager manager Config{..} cl = do + url <- parseBaseUrl configUrl + runClient cl $ mkClientEnv manager url + +-- | Like @runClient@, but returns the response or throws +-- a PingTestClientError +callPingTest + :: (MonadIO m, MonadThrow m) + => ClientEnv -> PingTestClient a -> m a +callPingTest env f = do + res <- liftIO $ runExceptT $ runClient f env + case res of + Left err -> throwM (PingTestClientError err) + Right response -> pure response + + +requestMiddlewareId :: Application -> Application +requestMiddlewareId a = a + +-- | Run the PingTest server at the provided host and port. +runPingTestServer + :: (MonadIO m, MonadThrow m) + => Config -> PingTestBackend (ExceptT ServerError IO) -> m () +runPingTestServer config backend = runPingTestMiddlewareServer config requestMiddlewareId backend + +-- | Run the PingTest server at the provided host and port. +runPingTestMiddlewareServer + :: (MonadIO m, MonadThrow m) + => Config -> Middleware -> PingTestBackend (ExceptT ServerError IO) -> m () +runPingTestMiddlewareServer Config{..} middleware backend = do + url <- parseBaseUrl configUrl + let warpSettings = Warp.defaultSettings + & Warp.setPort (baseUrlPort url) + & Warp.setHost (fromString $ baseUrlHost url) + liftIO $ Warp.runSettings warpSettings $ middleware $ serverWaiApplicationPingTest backend + +-- | Plain "Network.Wai" Application for the PingTest server. +-- +-- Can be used to implement e.g. tests that call the API without a full webserver. +serverWaiApplicationPingTest :: PingTestBackend (ExceptT ServerError IO) -> Application +serverWaiApplicationPingTest backend = serveWithContextT (Proxy :: Proxy PingTestAPI) context id (serverFromBackend backend) + where + context = serverContext + serverFromBackend PingTestBackend{..} = + (coerce pingGet :<|> + serveDirectoryFileServer "static") + + +serverContext :: Context ('[]) +serverContext = EmptyContext diff --git a/samples/server/others/haskell-servant-ping/lib/PingTest/Types.hs b/samples/server/others/haskell-servant-ping/lib/PingTest/Types.hs new file mode 100644 index 000000000000..5e6c493209ed --- /dev/null +++ b/samples/server/others/haskell-servant-ping/lib/PingTest/Types.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} + +module PingTest.Types ( + ) where + +import Data.Data (Data) +import Data.UUID (UUID) +import Data.List (lookup) +import Data.Maybe (fromMaybe) +import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON) +import Data.Aeson.Types (Options(..), defaultOptions) +import Data.Set (Set) +import Data.Text (Text) +import Data.Time +import Data.Swagger (ToSchema, declareNamedSchema) +import qualified Data.Swagger as Swagger +import qualified Data.Char as Char +import qualified Data.Text as T +import qualified Data.Map as Map +import GHC.Generics (Generic) + diff --git a/samples/server/others/haskell-servant-ping/ping-test.cabal b/samples/server/others/haskell-servant-ping/ping-test.cabal new file mode 100644 index 000000000000..00b148c9a8dc --- /dev/null +++ b/samples/server/others/haskell-servant-ping/ping-test.cabal @@ -0,0 +1,42 @@ +name: ping-test +version: 0.1.0.0 +synopsis: Auto-generated API bindings for ping-test +description: Please see README.md +homepage: https://openapi-generator.tech +author: Author Name Here +maintainer: author.name@email.com +copyright: YEAR - AUTHOR +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: lib + exposed-modules: PingTest.API + , PingTest.Types + ghc-options: -Wall + build-depends: base + , aeson + , text + , containers + , exceptions + , network-uri + , servant + , http-api-data + , servant + , servant-client + , servant-client-core + , servant-server + , servant + , wai + , warp + , transformers + , mtl + , time + , http-client + , http-client-tls + , http-types + , swagger2 + , uuid + , bytestring + default-language: Haskell2010 diff --git a/samples/server/others/haskell-servant-ping/stack.yaml b/samples/server/others/haskell-servant-ping/stack.yaml new file mode 100644 index 000000000000..7b4767b0ebff --- /dev/null +++ b/samples/server/others/haskell-servant-ping/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-22.12 +extra-deps: [] +packages: +- '.' +nix: + enable: false + packages: + - zlib