mirror of
https://github.com/OpenAPITools/openapi-generator.git
synced 2025-05-12 12:40:53 +00:00
0820edee5d
* Add bytestring package to dependencies of generated haskell code This broke in https://github.com/OpenAPITools/openapi-generator/pull/18047 where tvh introduced an import of Data.ByteString.Lazy. The added bytestring package was available in some but not all cases. * update workflow to test haskell servant ping * update samples --------- Co-authored-by: Bastian Senst <senst@cp-med.com>
246 lines
10 KiB
Haskell
246 lines
10 KiB
Haskell
{-# 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
|