webgear-server 1.1.1 → 1.2.0
raw patch · 10 files changed
+139/−78 lines, 10 filesdep −bytestring-conversiondep ~basedep ~cookiedep ~webgear-core
Dependencies removed: bytestring-conversion
Dependency ranges changed: base, cookie, webgear-core
Files
- CHANGELOG.md +11/−1
- src/WebGear/Server/Handler.hs +21/−8
- src/WebGear/Server/MIMETypes.hs +44/−13
- src/WebGear/Server/Trait/Auth/Basic.hs +6/−15
- src/WebGear/Server/Trait/Auth/JWT.hs +4/−3
- src/WebGear/Server/Trait/Body.hs +10/−12
- src/WebGear/Server/Trait/Cookie.hs +16/−8
- src/WebGear/Server/Trait/Header.hs +16/−9
- src/WebGear/Server/Trait/Status.hs +7/−4
- webgear-server.cabal +4/−5
CHANGELOG.md view
@@ -2,6 +2,15 @@ ## [Unreleased] +## [1.2.0] - 2024-03-18++### Added+- Prerequisite traits (#37)++### Changed+- Removed the dependency on bytestring-conversion package (#38)+- Support for embedding WAI applications in handlers (#36)+ ## [1.1.1] - 2024-01-01 ### Changed@@ -73,7 +82,8 @@ - Automated tests - Documentation -[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.1.1...HEAD+[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.2.0...HEAD+[1.2.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.2.0 [1.1.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.1 [1.1.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.0 [1.0.5]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.5
src/WebGear/Server/Handler.hs view
@@ -46,7 +46,7 @@ Summary, ) import WebGear.Core.Request (Request (..))-import WebGear.Core.Response (Response (..), ResponseBody (..), toWaiResponse)+import WebGear.Core.Response (Response (..), ResponseBody (..)) import WebGear.Core.Trait (With, wzero) {- | An arrow implementing a WebGear server.@@ -104,8 +104,8 @@ {-# INLINE consumeRoute #-} consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a consumeRoute (ServerHandler h) =- ServerHandler- $ \() -> do+ ServerHandler $+ \() -> do a <- get >>= h put (RoutePath []) pure a@@ -137,10 +137,9 @@ toApplication :: ServerHandler IO (Request `With` '[]) Response -> Wai.Application toApplication h rqt cont = runServerHandler h path request- >>= cont- . toWaiResponse- . addServerHeader- . mkWebGearResponse+ >>= processResponse+ . addServerHeader+ . mkWebGearResponse where request :: Request `With` '[] request = wzero $ Request rqt@@ -152,7 +151,9 @@ mkWebGearResponse = fromRight $ Response HTTP.notFound404 [] $ ResponseBodyBuilder mempty addServerHeader :: Response -> Response- addServerHeader resp@Response{..} = resp{responseHeaders = foldr insertServerHeader [] responseHeaders}+ addServerHeader = \case+ Response status hdrs body -> Response status (foldr insertServerHeader [] hdrs) body+ resp -> resp insertServerHeader :: HTTP.Header -> HTTP.ResponseHeaders -> HTTP.ResponseHeaders insertServerHeader hdr@(name, _) hdrs@@ -161,6 +162,18 @@ webGearServerHeader :: ByteString webGearServerHeader = fromString $ "WebGear/" ++ showVersion version++ processResponse :: Response -> IO Wai.ResponseReceived+ processResponse resp =+ case resp of+ ResponseCont f -> f cont+ ResponseRaw raw fallback -> cont $ Wai.responseRaw raw fallback+ Response status hdrs body ->+ cont $+ case body of+ ResponseBodyFile fpath fpart -> Wai.responseFile status hdrs fpath fpart+ ResponseBodyBuilder b -> Wai.responseBuilder status hdrs b+ ResponseBodyStream sb -> Wai.responseStream status hdrs sb {-# INLINE toApplication #-} {- | Transform a `ServerHandler` running in one monad to another monad.
src/WebGear/Server/MIMETypes.hs view
@@ -1,3 +1,4 @@+-- | Parsing and rendering of MIME types module WebGear.Server.MIMETypes ( -- * Parsing and rendering MIME types BodyUnrender (..),@@ -13,7 +14,7 @@ import qualified Data.Aeson as Aeson import Data.Bifunctor (Bifunctor (first)) import qualified Data.Binary.Builder as B-import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), runParser')+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Text (Text, pack) import Data.Text.Conversions (FromText (..), ToText (..))@@ -41,11 +42,17 @@ import WebGear.Core.Request (Request (..), getRequestBody) import WebGear.Core.Response (Response, ResponseBody (..)) +{- | Instances of this class are used to parse the body of a request+as specified by a MIME type.+-} class (MIMEType mt) => BodyUnrender m mt a where -- | Parse a request body. Return a 'Left' value with error messages -- in case of failure. bodyUnrender :: mt -> Request -> m (Either Text a) +{- | Instances of this class serializes a value to a response body as+specified by a MIME type.+-} class (MIMEType mt) => BodyRender m mt a where -- | Render a value in the format specified by the media type. --@@ -70,18 +77,30 @@ -------------------------------------------------------------------------------- -instance (MonadIO m, FromByteString a) => BodyUnrender m HTML a where- bodyUnrender :: HTML -> Request -> m (Either Text a)+instance (MonadIO m) => BodyUnrender m HTML BS.ByteString where+ bodyUnrender :: HTML -> Request -> m (Either Text BS.ByteString) bodyUnrender _ request = do body <- liftIO $ getRequestBody request- pure $ first pack $ runParser' parser body+ pure $ Right $ LBS.toStrict body -instance (Monad m, ToByteString a) => BodyRender m HTML a where- bodyRender :: HTML -> Response -> a -> m (HTTP.MediaType, ResponseBody)+instance (Monad m) => BodyRender m HTML BS.ByteString where+ bodyRender :: HTML -> Response -> BS.ByteString -> m (HTTP.MediaType, ResponseBody) bodyRender html _response a = do- let body = ResponseBodyBuilder $ builder a+ let body = ResponseBodyBuilder $ B.fromByteString a pure (mimeType html, body) +instance (MonadIO m) => BodyUnrender m HTML LBS.ByteString where+ bodyUnrender :: HTML -> Request -> m (Either Text LBS.ByteString)+ bodyUnrender _ request = do+ body <- liftIO $ getRequestBody request+ pure $ Right body++instance (Monad m) => BodyRender m HTML LBS.ByteString where+ bodyRender :: HTML -> Response -> LBS.ByteString -> m (HTTP.MediaType, ResponseBody)+ bodyRender html _response a = do+ let body = ResponseBodyBuilder $ B.fromLazyByteString a+ pure (mimeType html, body)+ -------------------------------------------------------------------------------- instance (MonadIO m, Aeson.FromJSON a) => BodyUnrender m JSON a where@@ -117,16 +136,28 @@ -------------------------------------------------------------------------------- -instance (MonadIO m, FromByteString a) => BodyUnrender m OctetStream a where- bodyUnrender :: OctetStream -> Request -> m (Either Text a)+instance (MonadIO m) => BodyUnrender m OctetStream BS.ByteString where+ bodyUnrender :: OctetStream -> Request -> m (Either Text BS.ByteString) bodyUnrender _ request = do body <- liftIO $ getRequestBody request- pure $ first pack $ runParser' parser body+ pure $ Right $ LBS.toStrict body -instance (Monad m, ToByteString a) => BodyRender m OctetStream a where- bodyRender :: OctetStream -> Response -> a -> m (HTTP.MediaType, ResponseBody)+instance (Monad m) => BodyRender m OctetStream BS.ByteString where+ bodyRender :: OctetStream -> Response -> BS.ByteString -> m (HTTP.MediaType, ResponseBody) bodyRender os _response a = do- let body = ResponseBodyBuilder $ builder a+ let body = ResponseBodyBuilder $ B.fromByteString a+ pure (mimeType os, body)++instance (MonadIO m) => BodyUnrender m OctetStream LBS.ByteString where+ bodyUnrender :: OctetStream -> Request -> m (Either Text LBS.ByteString)+ bodyUnrender _ request = do+ body <- liftIO $ getRequestBody request+ pure $ Right body++instance (Monad m) => BodyRender m OctetStream LBS.ByteString where+ bodyRender :: OctetStream -> Response -> LBS.ByteString -> m (HTTP.MediaType, ResponseBody)+ bodyRender os _response a = do+ let body = ResponseBodyBuilder $ B.fromLazyByteString a pure (mimeType os, body) --------------------------------------------------------------------------------
src/WebGear/Server/Trait/Auth/Basic.hs view
@@ -12,7 +12,7 @@ import WebGear.Core.Handler (arrM) import WebGear.Core.Modifiers import WebGear.Core.Request (Request)-import WebGear.Core.Trait (Get (..), With)+import WebGear.Core.Trait (Get (..), HasTrait, With, from, pick) import WebGear.Core.Trait.Auth.Basic ( BasicAuth' (..), BasicAuthError (..),@@ -23,22 +23,17 @@ import WebGear.Core.Trait.Auth.Common ( AuthToken (..), AuthorizationHeader,- getAuthorizationHeaderTrait, ) import WebGear.Server.Handler (ServerHandler) -instance- ( Monad m- , Get (ServerHandler m) (AuthorizationHeader scheme) Request- ) =>- Get (ServerHandler m) (BasicAuth' Required scheme m e a) Request- where+instance (Monad m) => Get (ServerHandler m) (BasicAuth' Required scheme m e a) Request where {-# INLINE getTrait #-} getTrait ::+ (HasTrait (AuthorizationHeader scheme) ts) => BasicAuth' Required scheme m e a -> ServerHandler m (Request `With` ts) (Either (BasicAuthError e) a) getTrait BasicAuth'{..} = proc request -> do- result <- getAuthorizationHeaderTrait @scheme -< request+ let result = pick @(AuthorizationHeader scheme) $ from request case result of Nothing -> returnA -< Left BasicAuthHeaderMissing (Just (Left _)) -> returnA -< Left BasicAuthSchemeMismatch@@ -58,14 +53,10 @@ res <- toBasicAttribute creds pure $ first BasicAuthAttributeError res -instance- ( Monad m- , Get (ServerHandler m) (AuthorizationHeader scheme) Request- ) =>- Get (ServerHandler m) (BasicAuth' Optional scheme m e a) Request- where+instance (Monad m) => Get (ServerHandler m) (BasicAuth' Optional scheme m e a) Request where {-# INLINE getTrait #-} getTrait ::+ (HasTrait (AuthorizationHeader scheme) ts) => BasicAuth' Optional scheme m e a -> ServerHandler m (Request `With` ts) (Either Void (Either (BasicAuthError e) a)) getTrait BasicAuth'{..} = getTrait (BasicAuth'{..} :: BasicAuth' Required scheme m e a) >>> arr Right
src/WebGear/Server/Trait/Auth/JWT.hs view
@@ -14,11 +14,10 @@ import WebGear.Core.Handler (arrM) import WebGear.Core.Modifiers import WebGear.Core.Request (Request)-import WebGear.Core.Trait (Get (..), With)+import WebGear.Core.Trait (Get (..), HasTrait, With, from, pick) import WebGear.Core.Trait.Auth.Common ( AuthToken (..), AuthorizationHeader,- getAuthorizationHeaderTrait, ) import WebGear.Core.Trait.Auth.JWT (JWTAuth' (..), JWTAuthError (..)) import WebGear.Server.Handler (ServerHandler)@@ -26,10 +25,11 @@ instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme) Request) => Get (ServerHandler m) (JWTAuth' Required scheme m e a) Request where {-# INLINE getTrait #-} getTrait ::+ (HasTrait (AuthorizationHeader scheme) ts) => JWTAuth' Required scheme m e a -> ServerHandler m (Request `With` ts) (Either (JWTAuthError e) a) getTrait JWTAuth'{..} = proc request -> do- result <- getAuthorizationHeaderTrait @scheme -< request+ let result = pick @(AuthorizationHeader scheme) $ from request case result of Nothing -> returnA -< Left JWTAuthHeaderMissing (Just (Left _)) -> returnA -< Left JWTAuthSchemeMismatch@@ -49,6 +49,7 @@ instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme) Request) => Get (ServerHandler m) (JWTAuth' Optional scheme m e a) Request where {-# INLINE getTrait #-} getTrait ::+ (HasTrait (AuthorizationHeader scheme) ts) => JWTAuth' Optional scheme m e a -> ServerHandler m (Request `With` ts) (Either Void (Either (JWTAuthError e) a)) getTrait JWTAuth'{..} = getTrait (JWTAuth'{..} :: JWTAuth' Required scheme m e a) >>> arr Right
src/WebGear/Server/Trait/Body.hs view
@@ -29,15 +29,12 @@ ServerHandler m (Response `With` ts, val) (Response `With` (Body mt val : ts)) setTrait (Body mt) f = ServerHandler $ \(wResponse, val) -> do let response = unwitness wResponse- (mediaType, responseBody) <- lift $ lift $ bodyRender mt response val-- let response' =- response- { responseBody- , responseHeaders = alterContentType mediaType (responseHeaders response)- }-- pure $ f wResponse response' val+ case response of+ Response status hdrs _ -> do+ (mediaType, body') <- lift $ lift $ bodyRender mt response val+ let response' = Response status (alterContentType mediaType hdrs) body'+ pure $ f wResponse response' val+ _ -> pure $ f wResponse response val alterContentType :: HTTP.MediaType -> HTTP.ResponseHeaders -> HTTP.ResponseHeaders alterContentType mt = go@@ -54,6 +51,7 @@ UnknownContentBody -> (Response `With` ts -> Response -> ResponseBody -> Response `With` (UnknownContentBody : ts)) -> ServerHandler m (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts))- setTrait UnknownContentBody f = ServerHandler $ \(wResponse, responseBody) -> do- let response' = (unwitness wResponse){responseBody}- pure $ f wResponse response' responseBody+ setTrait UnknownContentBody f = ServerHandler $ \(wResponse, body') ->+ case unwitness wResponse of+ Response status hdrs _ -> pure $ f wResponse (Response status hdrs body') body'+ response -> pure $ f wResponse response body'
src/WebGear/Server/Trait/Cookie.hs view
@@ -4,8 +4,9 @@ module WebGear.Server.Trait.Cookie () where import Control.Arrow (arr, returnA, (>>>))+import Data.Binary.Builder (toLazyByteString) import Data.ByteString (ByteString)-import Data.ByteString.Conversion (toByteString')+import Data.ByteString.Lazy (toStrict) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.Text (Text)@@ -67,8 +68,11 @@ ServerHandler m (Response `With` ts, Cookie.SetCookie) (Response `With` (SetCookie Required name : ts)) setTrait SetCookie f = proc (l, cookie) -> do let cookieName :: ByteString = fromString $ symbolVal $ Proxy @name- response@Response{..} = unwitness l- response' = response{responseHeaders = ("Set-Cookie", cookieToBS cookieName cookie) : responseHeaders}+ response = unwitness l+ response' =+ case response of+ Response status hdrs body -> Response status (("Set-Cookie", cookieToBS cookieName cookie) : hdrs) body+ _ -> response returnA -< f l response' cookie instance (Monad m, KnownSymbol name) => Set (ServerHandler m) (SetCookie Optional name) Response where@@ -80,8 +84,11 @@ ServerHandler m (Response `With` ts, Maybe Cookie.SetCookie) (Response `With` (SetCookie Optional name : ts)) setTrait SetCookie f = proc (l, maybeCookie) -> do let cookieName :: ByteString = fromString $ symbolVal $ Proxy @name- response@Response{..} = unwitness l- response' = response{responseHeaders = alterCookie cookieName maybeCookie responseHeaders}+ response = unwitness l+ response' =+ case response of+ Response status hdrs body -> Response status (alterCookie cookieName maybeCookie hdrs) body+ _ -> response returnA -< f l response' maybeCookie alterCookie :: ByteString -> Maybe Cookie.SetCookie -> ResponseHeaders -> ResponseHeaders@@ -95,6 +102,7 @@ cookieToBS :: ByteString -> Cookie.SetCookie -> ByteString cookieToBS name cookie =- toByteString'- $ Cookie.renderSetCookie- $ cookie{Cookie.setCookieName = name}+ toStrict $+ toLazyByteString $+ Cookie.renderSetCookie $+ cookie{Cookie.setCookieName = name}
src/WebGear/Server/Trait/Header.hs view
@@ -1,18 +1,19 @@ {-# OPTIONS_GHC -Wno-orphans #-} --- | Server implementation of the `Header` trait.+{- | Server implementation of the `RequestHeader` and `ResponseHeader`+traits.+-} module WebGear.Server.Trait.Header () where import Control.Arrow (arr, returnA, (>>>)) import Data.ByteString (ByteString)-import Data.ByteString.Conversion (ToByteString, toByteString') import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.Text (Text) import Data.Void (Void) import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types (HeaderName, ResponseHeaders)-import Web.HttpApiData (FromHttpApiData, parseHeader)+import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) import WebGear.Core.Modifiers import WebGear.Core.Request (Request, requestHeader) import WebGear.Core.Response (Response (..))@@ -76,7 +77,7 @@ Just (Left e) -> Right $ Just $ Left e Just (Right x) -> Right $ Just $ Right x -instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (ResponseHeader Required name val) Response where+instance (Monad m, KnownSymbol name, ToHttpApiData val) => Set (ServerHandler m) (ResponseHeader Required name val) Response where {-# INLINE setTrait #-} setTrait :: ResponseHeader Required name val ->@@ -84,11 +85,14 @@ ServerHandler m (Response `With` ts, val) (Response `With` (ResponseHeader Required name val : ts)) setTrait ResponseHeader f = proc (l, val) -> do let headerName :: HeaderName = fromString $ symbolVal $ Proxy @name- response@Response{..} = unwitness l- response' = response{responseHeaders = (headerName, toByteString' val) : responseHeaders}+ response = unwitness l+ response' =+ case response of+ Response status hdrs body -> Response status ((headerName, toHeader val) : hdrs) body+ _ -> response returnA -< f l response' val -instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (ResponseHeader Optional name val) Response where+instance (Monad m, KnownSymbol name, ToHttpApiData val) => Set (ServerHandler m) (ResponseHeader Optional name val) Response where {-# INLINE setTrait #-} -- If the optional value is 'Nothing', the header is removed from the response setTrait ::@@ -97,8 +101,11 @@ ServerHandler m (Response `With` ts, Maybe val) (Response `With` (ResponseHeader Optional name val : ts)) setTrait ResponseHeader f = proc (l, maybeVal) -> do let headerName :: HeaderName = fromString $ symbolVal $ Proxy @name- response@Response{..} = unwitness l- response' = response{responseHeaders = alterHeader headerName (toByteString' <$> maybeVal) responseHeaders}+ response = unwitness l+ response' =+ case response of+ Response status hdrs body -> Response status (alterHeader headerName (toHeader <$> maybeVal) hdrs) body+ _ -> response returnA -< f l response' maybeVal alterHeader :: HeaderName -> Maybe ByteString -> ResponseHeaders -> ResponseHeaders
src/WebGear/Server/Trait/Status.hs view
@@ -5,7 +5,7 @@ import Control.Arrow (returnA) import qualified Network.HTTP.Types.Status as HTTP-import WebGear.Core.Response (Response (responseStatus))+import WebGear.Core.Response (Response (..)) import WebGear.Core.Trait (Set, With, setTrait, unwitness) import WebGear.Core.Trait.Status (Status (..)) import WebGear.Server.Handler (ServerHandler)@@ -16,6 +16,9 @@ Status -> (Response `With` ts -> Response -> HTTP.Status -> Response `With` (Status : ts)) -> ServerHandler m (Response `With` ts, HTTP.Status) (Response `With` (Status : ts))- setTrait (Status status) f = proc (response, _) -> do- let response' = (unwitness response){responseStatus = status}- returnA -< f response response' status+ setTrait (Status status) f = proc (wResponse, _) -> do+ let response' =+ case unwitness wResponse of+ Response _ hdrs body -> Response status hdrs body+ response -> response+ returnA -< f wResponse response' status
webgear-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: webgear-server-version: 1.1.1+version: 1.2.0 synopsis: Composable, type-safe library to build HTTP API servers description: WebGear is a library to for building composable, type-safe HTTP API servers.@@ -53,13 +53,13 @@ TypeApplications TypeFamilies TypeOperators- build-depends: base >=4.13.0.0 && <4.19+ build-depends: base >=4.13.0.0 && <4.20 , base64-bytestring >=1.0.0.3 && <1.3 , bytestring >=0.10.10.1 && <0.13 , http-types ==0.12.* , text >=1.2.0.0 && <2.2 , wai ==3.2.*- , webgear-core ^>=1.1.1+ , webgear-core ^>=1.2.0 ghc-options: -Wall -Wno-unticked-promoted-constructors -Wcompat@@ -97,8 +97,7 @@ build-depends: aeson >=1.4 && <1.6 || >=2.0 && <2.3 , arrows ==0.4.* , binary >= 0.8.0.0 && <0.9- , bytestring-conversion ==0.3.*- , cookie >=0.4.5 && <0.5+ , cookie >=0.4.5 && <0.6 , http-api-data >=0.4.2 && <0.7 , http-media ==0.8.* , jose >=0.8.3.1 && <0.12