webgear-server 1.0.5 → 1.1.0

raw patch · 22 files changed

+560/−294 lines, 22 filesdep +binarydep +cookiedep +resourcetdep −unordered-containersdep ~aesondep ~bytestringdep ~http-api-dataPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, cookie, resourcet, text-conversions, wai-extra

Dependencies removed: unordered-containers

Dependency ranges changed: aeson, bytestring, http-api-data, tasty, text, webgear-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−1
• src/WebGear/Server/Handler.hs +94/−90
• src/WebGear/Server/MIMETypes.hs +146/−0
• src/WebGear/Server/Trait/Auth/Basic.hs +3/−3
• src/WebGear/Server/Trait/Auth/JWT.hs +5/−4
• src/WebGear/Server/Trait/Body.hs +42/−65
• src/WebGear/Server/Trait/Cookie.hs +100/−0
• src/WebGear/Server/Trait/Header.hs +41/−36
• src/WebGear/Server/Trait/Method.hs +4/−4
• src/WebGear/Server/Trait/Path.hs +32/−20
• src/WebGear/Server/Trait/QueryParam.hs +7/−7
• src/WebGear/Server/Trait/Status.hs +7/−8
• src/WebGear/Server/Traits.hs +1/−0
• test/Properties/Trait/Auth/Basic.hs +19/−17
• test/Properties/Trait/Body.hs +9/−8
• test/Properties/Trait/Header.hs +6/−6
• test/Properties/Trait/Method.hs +2/−2
• test/Properties/Trait/Path.hs +5/−5
• test/Properties/Trait/QueryParam.hs +3/−3
• test/Unit/Trait/Header.hs +4/−4
• test/Unit/Trait/Path.hs +3/−3
• webgear-server.cabal +14/−8

@@ -2,6 +2,17 @@  ## [Unreleased] +## [1.1.0] - 2023-12-29++### Added+- Streaming responses support (#26)+- Support for cookies (#29)+- Support file uploads (#32)++### Changed+- Redesign APIs for ease of use (breaking change) (#24)+- Switch ServerHandler to a standard monad transformer stack (breaking change) (#27)+ ## [1.0.5] - 2023-05-04  ### Changed@@ -57,7 +68,8 @@ - Automated tests - Documentation -[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.0.5...HEAD+[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.1.0...HEAD+[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 [1.0.4]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.4 [1.0.3]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.3

@@ -9,111 +9,106 @@   transform, ) where -import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowPlus (..), ArrowZero (..))+import Control.Arrow (+  Arrow (..),+  ArrowChoice (..),+  ArrowPlus (..),+  ArrowZero (..),+  Kleisli (..),+ ) import Control.Arrow.Operations (ArrowError (..)) import qualified Control.Category as Cat+import Control.Monad.Except (+  ExceptT (..),+  MonadError (..),+  mapExceptT,+  runExceptT,+ )+import Control.Monad.State.Strict (+  MonadState (..),+  StateT (..),+  evalStateT,+  mapStateT,+ )+import Control.Monad.Trans (lift) import Data.ByteString (ByteString) import Data.Either (fromRight)-import qualified Data.HashMap.Strict as HM import Data.String (fromString) import Data.Version (showVersion) import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai import Paths_webgear_server (version)-import WebGear.Core.Handler (Description, Handler (..), RouteMismatch (..), RoutePath (..), Summary)+import WebGear.Core.Handler (+  Description,+  Handler (..),+  RouteMismatch (..),+  RoutePath (..),+  Summary,+ ) import WebGear.Core.Request (Request (..))-import WebGear.Core.Response (Response (..), toWaiResponse)-import WebGear.Core.Trait (Linked, linkzero)+import WebGear.Core.Response (Response (..), ResponseBody (..), toWaiResponse)+import WebGear.Core.Trait (With, wzero)  {- | An arrow implementing a WebGear server. - It can be thought of equivalent to the function arrow @a -> m b@- where @m@ is a monad. It also supports routing and possibly failing- the computation when the route does not match.+ A good first approximation is to consider ServerHandler to be+ equivalent to the function arrow @a -> m b@ where @m@ is a monad. It+ also supports routing and possibly failing the computation when the+ route does not match. -}-newtype ServerHandler m a b = ServerHandler {unServerHandler :: (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)}--instance Monad m => Cat.Category (ServerHandler m) where-  {-# INLINE id #-}-  id = ServerHandler $ \(a, s) -> pure (Right a, s)--  {-# INLINE (.) #-}-  ServerHandler f . ServerHandler g = ServerHandler $ \(a, s) ->-    g (a, s) >>= \case-      (Left e, s') -> pure (Left e, s')-      (Right b, s') -> f (b, s')--instance Monad m => Arrow (ServerHandler m) where-  arr f = ServerHandler (\(a, s) -> pure (Right (f a), s))--  {-# INLINE first #-}-  first (ServerHandler f) = ServerHandler $ \((a, c), s) ->-    f (a, s) >>= \case-      (Left e, s') -> pure (Left e, s')-      (Right b, s') -> pure (Right (b, c), s')--  {-# INLINE second #-}-  second (ServerHandler f) = ServerHandler $ \((c, a), s) ->-    f (a, s) >>= \case-      (Left e, s') -> pure (Left e, s')-      (Right b, s') -> pure (Right (c, b), s')--instance Monad m => ArrowZero (ServerHandler m) where-  {-# INLINE zeroArrow #-}-  zeroArrow = ServerHandler (\(_a, s) -> pure (Left mempty, s))--instance Monad m => ArrowPlus (ServerHandler m) where-  {-# INLINE (<+>) #-}-  ServerHandler f <+> ServerHandler g = ServerHandler $ \(a, s) ->-    f (a, s) >>= \case-      (Left _e, _s') -> g (a, s)-      (Right b, s') -> pure (Right b, s')--instance Monad m => ArrowChoice (ServerHandler m) where-  {-# INLINE left #-}-  left (ServerHandler f) = ServerHandler $ \(bd, s) ->-    case bd of-      Right d -> pure (Right (Right d), s)-      Left b ->-        f (b, s) >>= \case-          (Left e, s') -> pure (Left e, s')-          (Right c, s') -> pure (Right (Left c), s')--  {-# INLINE right #-}-  right (ServerHandler f) = ServerHandler $ \(db, s) ->-    case db of-      Left d -> pure (Right (Left d), s)-      Right b ->-        f (b, s) >>= \case-          (Left e, s') -> pure (Left e, s')-          (Right c, s') -> pure (Right (Right c), s')+newtype ServerHandler m a b = ServerHandler+  { unServerHandler :: a -> StateT RoutePath (ExceptT RouteMismatch m) b+  }+  deriving+    ( Cat.Category+    , Arrow+    , ArrowZero+    , ArrowPlus+    , ArrowChoice+    )+    via Kleisli (StateT RoutePath (ExceptT RouteMismatch m)) -instance Monad m => ArrowError RouteMismatch (ServerHandler m) where+instance (Monad m) => ArrowError RouteMismatch (ServerHandler m) where   {-# INLINE raise #-}-  raise = ServerHandler $ \(e, s) -> pure (Left e, s)+  raise :: ServerHandler m RouteMismatch b+  raise = ServerHandler throwError    {-# INLINE handle #-}-  (ServerHandler action) `handle` (ServerHandler errHandler) = ServerHandler $ \(a, s) ->-    action (a, s) >>= \case-      (Left e, s') -> errHandler ((a, e), s')-      (Right b, s') -> pure (Right b, s')+  handle ::+    ServerHandler m a b ->+    ServerHandler m (a, RouteMismatch) b ->+    ServerHandler m a b+  (ServerHandler action) `handle` (ServerHandler errHandler) =+    ServerHandler $ \a ->+      action a `catchError` \e -> errHandler (a, e)    {-# INLINE tryInUnless #-}+  tryInUnless ::+    ServerHandler m a b ->+    ServerHandler m (a, b) c ->+    ServerHandler m (a, RouteMismatch) c ->+    ServerHandler m a c   tryInUnless (ServerHandler action) (ServerHandler resHandler) (ServerHandler errHandler) =-    ServerHandler $ \(a, s) ->-      action (a, s) >>= \case-        (Left e, s') -> errHandler ((a, e), s')-        (Right b, s') -> resHandler ((a, b), s')+    ServerHandler $ \a ->+      f a `catchError` \e -> errHandler (a, e)+    where+      f a = do+        b <- action a+        resHandler (a, b) -instance Monad m => Handler (ServerHandler m) m where+instance (Monad m) => Handler (ServerHandler m) m where   {-# INLINE arrM #-}   arrM :: (a -> m b) -> ServerHandler m a b-  arrM f = ServerHandler $ \(a, s) -> f a >>= \b -> pure (Right b, s)+  arrM f = ServerHandler $ lift . lift . f    {-# INLINE consumeRoute #-}   consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a-  consumeRoute (ServerHandler h) = ServerHandler $-    \((), path) -> h (path, RoutePath [])+  consumeRoute (ServerHandler h) =+    ServerHandler+      $ \() -> do+        a <- get >>= h+        put (RoutePath [])+        pure a    {-# INLINE setDescription #-}   setDescription :: Description -> ServerHandler m a a@@ -125,7 +120,7 @@  -- | Run a ServerHandler to produce a result or a route mismatch error. runServerHandler ::-  Monad m =>+  (Monad m) =>   -- | The handler to run   ServerHandler m a b ->   -- | Path used for routing@@ -134,29 +129,38 @@   a ->   -- | The result of the arrow   m (Either RouteMismatch b)-runServerHandler (ServerHandler h) path a = fst <$> h (a, path)+runServerHandler (ServerHandler h) path a =+  runExceptT $ evalStateT (h a) path {-# INLINE runServerHandler #-}  -- | Convert a ServerHandler to a WAI application-toApplication :: ServerHandler IO (Linked '[] Request) Response -> Wai.Application+toApplication :: ServerHandler IO (Request `With` '[]) Response -> Wai.Application toApplication h rqt cont =   runServerHandler h path request-    >>= cont . toWaiResponse . addServerHeader . mkWebGearResponse+    >>= cont+    . toWaiResponse+    . addServerHeader+    . mkWebGearResponse   where-    request :: Linked '[] Request-    request = linkzero $ Request rqt+    request :: Request `With` '[]+    request = wzero $ Request rqt      path :: RoutePath     path = RoutePath $ Wai.pathInfo rqt      mkWebGearResponse :: Either RouteMismatch Response -> Response-    mkWebGearResponse = fromRight (Response HTTP.notFound404 [] mempty)+    mkWebGearResponse = fromRight $ Response HTTP.notFound404 [] $ ResponseBodyBuilder mempty      addServerHeader :: Response -> Response-    addServerHeader resp@Response{..} = resp{responseHeaders = responseHeaders <> webGearServerHeader}+    addServerHeader resp@Response{..} = resp{responseHeaders = foldr insertServerHeader [] responseHeaders} -    webGearServerHeader :: HM.HashMap HTTP.HeaderName ByteString-    webGearServerHeader = HM.singleton HTTP.hServer (fromString $ "WebGear/" ++ showVersion version)+    insertServerHeader :: HTTP.Header -> HTTP.ResponseHeaders -> HTTP.ResponseHeaders+    insertServerHeader hdr@(name, _) hdrs+      | name == HTTP.hServer = (HTTP.hServer, webGearServerHeader) : hdrs+      | otherwise = hdr : hdrs++    webGearServerHeader :: ByteString+    webGearServerHeader = fromString $ "WebGear/" ++ showVersion version {-# INLINE toApplication #-}  {- | Transform a `ServerHandler` running in one monad to another monad.@@ -170,7 +174,7 @@ @  `toApplication` (transform f server)    where-     server :: `ServerHandler` (ReaderT r IO) (`Linked` '[] `Request`) `Response`+     server :: `ServerHandler` (ReaderT r IO) (`Request` \``With`\` '[]) `Response`      server = ....       f :: ReaderT r IO a -> IO a@@ -182,5 +186,5 @@   ServerHandler m a b ->   ServerHandler n a b transform f (ServerHandler g) =-  ServerHandler $ f . g+  ServerHandler $ mapStateT (mapExceptT f) . g {-# INLINE transform #-}

@@ -0,0 +1,146 @@+module WebGear.Server.MIMETypes (+  -- * Parsing and rendering MIME types+  BodyUnrender (..),+  BodyRender (..),++  -- * FormData utils+  inMemoryBackend,+  tempFileBackend,+) where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Resource (MonadResource, getInternalState, liftResourceT)+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.Lazy as LBS+import Data.Text (Text, pack)+import Data.Text.Conversions (FromText (..), ToText (..))+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Encoding as LText+import qualified Network.HTTP.Media as HTTP+import Network.Wai.Parse (BackEnd, lbsBackEnd, parseRequestBodyEx, tempFileBackEnd)+import Web.FormUrlEncoded (+  FromForm (..),+  ToForm (..),+  urlDecodeForm,+  urlEncodeFormStable,+ )+import WebGear.Core.MIMETypes (+  FormData (..),+  FormDataResult (..),+  FormURLEncoded (..),+  HTML,+  JSON,+  MIMEType (..),+  OctetStream,+  PlainText,+ )+import WebGear.Core.Request (Request (..), getRequestBody)+import WebGear.Core.Response (Response, ResponseBody (..))++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)++class (MIMEType mt) => BodyRender m mt a where+  -- | Render a value in the format specified by the media type.+  --+  -- Returns the response body and the media type to be used in the+  -- "Content-Type" header. This could be a variant of the original+  -- media type with additional parameters.+  bodyRender :: mt -> Response -> a -> m (HTTP.MediaType, ResponseBody)++--------------------------------------------------------------------------------++instance (MonadIO m, FromForm a) => BodyUnrender m FormURLEncoded a where+  bodyUnrender :: FormURLEncoded -> Request -> m (Either Text a)+  bodyUnrender FormURLEncoded request = do+    body <- liftIO $ getRequestBody request+    pure $ urlDecodeForm body >>= fromForm++instance (Monad m, ToForm a) => BodyRender m FormURLEncoded a where+  bodyRender :: FormURLEncoded -> Response -> a -> m (HTTP.MediaType, ResponseBody)+  bodyRender FormURLEncoded _response a = do+    let body = ResponseBodyBuilder $ B.fromLazyByteString $ urlEncodeFormStable $ toForm a+    pure (mimeType FormURLEncoded, body)++--------------------------------------------------------------------------------++instance (MonadIO m, FromByteString a) => BodyUnrender m HTML a where+  bodyUnrender :: HTML -> Request -> m (Either Text a)+  bodyUnrender _ request = do+    body <- liftIO $ getRequestBody request+    pure $ first pack $ runParser' parser body++instance (Monad m, ToByteString a) => BodyRender m HTML a where+  bodyRender :: HTML -> Response -> a -> m (HTTP.MediaType, ResponseBody)+  bodyRender html _response a = do+    let body = ResponseBodyBuilder $ builder a+    pure (mimeType html, body)++--------------------------------------------------------------------------------++instance (MonadIO m, Aeson.FromJSON a) => BodyUnrender m JSON a where+  bodyUnrender :: JSON -> Request -> m (Either Text a)+  bodyUnrender _ request = do+    s <- liftIO $ getRequestBody request+    pure $ first pack $ Aeson.eitherDecode s++instance (Monad m, Aeson.ToJSON a) => BodyRender m JSON a where+  bodyRender :: JSON -> Response -> a -> m (HTTP.MediaType, ResponseBody)+  bodyRender json _response a = do+    let body = ResponseBodyBuilder $ Aeson.fromEncoding $ Aeson.toEncoding a+    pure (mimeType json, body)++--------------------------------------------------------------------------------++-- | A backend that stores all files in memory+inMemoryBackend :: BackEnd LBS.ByteString+inMemoryBackend = lbsBackEnd++-- | A backend that stores files in a temp directory.+tempFileBackend :: (MonadResource m) => m (BackEnd FilePath)+tempFileBackend = do+  st <- liftResourceT getInternalState+  pure $ tempFileBackEnd st++instance (MonadIO m) => BodyUnrender m (FormData a) (FormDataResult a) where+  bodyUnrender :: FormData a -> Request -> m (Either Text (FormDataResult a))+  bodyUnrender FormData{parseOptions, backendOptions} request = do+    (formDataParams, formDataFiles) <-+      liftIO $ parseRequestBodyEx parseOptions backendOptions $ toWaiRequest request+    pure $ Right FormDataResult{formDataParams, formDataFiles}++--------------------------------------------------------------------------------++instance (MonadIO m, FromByteString a) => BodyUnrender m OctetStream a where+  bodyUnrender :: OctetStream -> Request -> m (Either Text a)+  bodyUnrender _ request = do+    body <- liftIO $ getRequestBody request+    pure $ first pack $ runParser' parser body++instance (Monad m, ToByteString a) => BodyRender m OctetStream a where+  bodyRender :: OctetStream -> Response -> a -> m (HTTP.MediaType, ResponseBody)+  bodyRender os _response a = do+    let body = ResponseBodyBuilder $ builder a+    pure (mimeType os, body)++--------------------------------------------------------------------------------++instance (MonadIO m, FromText a) => BodyUnrender m PlainText a where+  bodyUnrender :: PlainText -> Request -> m (Either Text a)+  bodyUnrender _ request = do+    body <- liftIO $ getRequestBody request+    pure $ case LText.decodeUtf8' body of+      Left e -> Left $ pack $ show e+      Right t -> Right $ fromText $ LText.toStrict t++instance (Monad m, ToText a) => BodyRender m PlainText a where+  bodyRender :: PlainText -> Response -> a -> m (HTTP.MediaType, ResponseBody)+  bodyRender txt _response a = do+    let body = ResponseBodyBuilder $ Text.encodeUtf8Builder $ toText a+    pure (mimeType txt, body)

@@ -12,7 +12,7 @@ import WebGear.Core.Handler (arrM) import WebGear.Core.Modifiers import WebGear.Core.Request (Request)-import WebGear.Core.Trait (Get (..), Linked)+import WebGear.Core.Trait (Get (..), With) import WebGear.Core.Trait.Auth.Basic (   BasicAuth' (..),   BasicAuthError (..),@@ -36,7 +36,7 @@   {-# INLINE getTrait #-}   getTrait ::     BasicAuth' Required scheme m e a ->-    ServerHandler m (Linked ts Request) (Either (BasicAuthError e) a)+    ServerHandler m (Request `With` ts) (Either (BasicAuthError e) a)   getTrait BasicAuth'{..} = proc request -> do     result <- getAuthorizationHeaderTrait @scheme -< request     case result of@@ -67,5 +67,5 @@   {-# INLINE getTrait #-}   getTrait ::     BasicAuth' Optional scheme m e a ->-    ServerHandler m (Linked ts Request) (Either Void (Either (BasicAuthError 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

@@ -5,15 +5,16 @@ module WebGear.Server.Trait.Auth.JWT where  import Control.Arrow (arr, returnA, (>>>))-import Control.Monad.Except (MonadError (throwError), lift, runExceptT, withExceptT)+import Control.Monad.Except (MonadError (throwError), runExceptT, withExceptT) import Control.Monad.Time (MonadTime)+import Control.Monad.Trans (lift) import qualified Crypto.JWT as JWT import Data.ByteString.Lazy (fromStrict) import Data.Void (Void) import WebGear.Core.Handler (arrM) import WebGear.Core.Modifiers import WebGear.Core.Request (Request)-import WebGear.Core.Trait (Get (..), Linked)+import WebGear.Core.Trait (Get (..), With) import WebGear.Core.Trait.Auth.Common (   AuthToken (..),   AuthorizationHeader,@@ -26,7 +27,7 @@   {-# INLINE getTrait #-}   getTrait ::     JWTAuth' Required scheme m e a ->-    ServerHandler m (Linked ts Request) (Either (JWTAuthError e) a)+    ServerHandler m (Request `With` ts) (Either (JWTAuthError e) a)   getTrait JWTAuth'{..} = proc request -> do     result <- getAuthorizationHeaderTrait @scheme -< request     case result of@@ -49,5 +50,5 @@   {-# INLINE getTrait #-}   getTrait ::     JWTAuth' Optional scheme m e a ->-    ServerHandler m (Linked ts Request) (Either Void (Either (JWTAuthError 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

@@ -1,82 +1,59 @@+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- | Server implementation of the `Body` trait. module WebGear.Server.Trait.Body () where -import Control.Arrow (returnA)-import Control.Monad.IO.Class (MonadIO (..))-import qualified Data.Aeson as Aeson-import Data.ByteString.Conversion (FromByteString, ToByteString, parser, runParser', toByteString)-import Data.ByteString.Lazy (fromChunks)-import Data.Text (Text, pack)-import Network.HTTP.Media.RenderHeader (RenderHeader (renderHeader))-import Network.HTTP.Types (hContentType)+import Control.Monad.Trans (lift)+import Data.Text (Text)+import qualified Network.HTTP.Media as HTTP+import qualified Network.HTTP.Types as HTTP import WebGear.Core.Handler (Handler (..))-import WebGear.Core.Request (Request, getRequestBodyChunk)-import WebGear.Core.Response (Response (..))-import WebGear.Core.Trait (Get (..), Linked, Set (..), unlink)-import WebGear.Core.Trait.Body (Body (..), JSONBody (..))-import WebGear.Server.Handler (ServerHandler)+import WebGear.Core.Request (Request (..))+import WebGear.Core.Response (Response (..), ResponseBody)+import WebGear.Core.Trait (Get (..), Set (..), With, unwitness)+import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..))+import WebGear.Server.Handler (ServerHandler (..))+import WebGear.Server.MIMETypes (BodyRender (..), BodyUnrender (..)) -instance (MonadIO m, FromByteString val) => Get (ServerHandler m) (Body val) Request where+instance (Monad m, BodyUnrender m mt val) => Get (ServerHandler m) (Body mt val) Request where   {-# INLINE getTrait #-}-  getTrait :: Body val -> ServerHandler m (Linked ts Request) (Either Text val)-  getTrait (Body _) = arrM $ \request -> do-    chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk $ unlink request-    pure $ case runParser' parser (fromChunks chunks) of-      Left e -> Left $ pack e-      Right t -> Right t+  getTrait :: Body mt val -> ServerHandler m (Request `With` ts) (Either Text val)+  getTrait (Body mt) = arrM $ bodyUnrender mt . unwitness -instance (Monad m, ToByteString val) => Set (ServerHandler m) (Body val) Response where+instance (Monad m, BodyRender m mt val) => Set (ServerHandler m) (Body mt val) Response where   {-# INLINE setTrait #-}   setTrait ::-    Body val ->-    (Linked ts Response -> Response -> val -> Linked (Body val : ts) Response) ->-    ServerHandler m (Linked ts Response, val) (Linked (Body val : ts) Response)-  setTrait (Body mediaType) f = proc (linkedResponse, val) -> do-    let response = (unlink linkedResponse)-        response' =+    Body mt val ->+    (Response `With` ts -> Response -> val -> Response `With` (Body mt val : ts)) ->+    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 = Just (toByteString val)-            , responseHeaders =-                responseHeaders response-                  <> case mediaType of-                    Just mt -> [(hContentType, renderHeader mt)]-                    Nothing -> []+            { responseBody+            , responseHeaders = alterContentType mediaType (responseHeaders response)             }-    returnA -< f linkedResponse response' val -instance (MonadIO m, Aeson.FromJSON val) => Get (ServerHandler m) (JSONBody val) Request where-  {-# INLINE getTrait #-}-  getTrait :: JSONBody val -> ServerHandler m (Linked ts Request) (Either Text val)-  getTrait (JSONBody _) = arrM $ \request -> do-    chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk $ unlink request-    pure $ case Aeson.eitherDecode' (fromChunks chunks) of-      Left e -> Left $ pack e-      Right t -> Right t+    pure $ f wResponse response' val -instance (Monad m, Aeson.ToJSON val) => Set (ServerHandler m) (JSONBody val) Response where+alterContentType :: HTTP.MediaType -> HTTP.ResponseHeaders -> HTTP.ResponseHeaders+alterContentType mt = go+  where+    mtStr = HTTP.renderHeader mt+    go [] = [(HTTP.hContentType, mtStr)]+    go ((n, v) : hdrs)+      | n == HTTP.hContentType = (HTTP.hContentType, mtStr) : hdrs+      | otherwise = (n, v) : go hdrs++instance (Monad m) => Set (ServerHandler m) UnknownContentBody Response where   {-# INLINE setTrait #-}   setTrait ::-    JSONBody val ->-    (Linked ts Response -> Response -> val -> Linked (JSONBody val : ts) Response) ->-    ServerHandler m (Linked ts Response, val) (Linked (JSONBody val : ts) Response)-  setTrait (JSONBody mediaType) f = proc (linkedResponse, val) -> do-    let response = unlink linkedResponse-        ctype = maybe "application/json" renderHeader mediaType-        response' =-          response-            { responseBody = Just (Aeson.encode val)-            , responseHeaders =-                responseHeaders response-                  <> [(hContentType, ctype)]-            }-    returnA -< f linkedResponse response' val--takeWhileM :: Monad m => (a -> Bool) -> [m a] -> m [a]-takeWhileM _ [] = pure []-takeWhileM p (mx : mxs) = do-  x <- mx-  if p x-    then (x :) <$> takeWhileM p mxs-    else pure []+    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

@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the `Cookie` and `SetCookie` traits.+module WebGear.Server.Trait.Cookie () where++import Control.Arrow (arr, returnA, (>>>))+import Data.ByteString (ByteString)+import Data.ByteString.Conversion (toByteString')+import Data.Proxy (Proxy (Proxy))+import Data.String (fromString)+import Data.Text (Text)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Network.HTTP.Types (Header, ResponseHeaders)+import qualified Web.Cookie as Cookie+import Web.HttpApiData (FromHttpApiData, parseHeader)+import WebGear.Core.Modifiers+import WebGear.Core.Request (Request, requestHeader)+import WebGear.Core.Response (Response (..))+import WebGear.Core.Trait (Get (..), Set (..), With, unwitness)+import WebGear.Core.Trait.Cookie (Cookie (..), CookieNotFound (..), CookieParseError (..), SetCookie (..))+import WebGear.Server.Handler (ServerHandler)++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Cookie Required name val) Request where+  {-# INLINE getTrait #-}+  getTrait ::+    Cookie Required name val ->+    ServerHandler m (Request `With` ts) (Either (Either CookieNotFound CookieParseError) val)+  getTrait Cookie = extractCookie (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Left $ Left CookieNotFound+        Just (Left e) -> Left $ Right $ CookieParseError e+        Just (Right x) -> Right x++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Cookie Optional name val) Request where+  {-# INLINE getTrait #-}+  getTrait ::+    Cookie Optional name val ->+    ServerHandler m (Request `With` ts) (Either CookieParseError (Maybe val))+  getTrait Cookie = extractCookie (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Right Nothing+        Just (Left e) -> Left $ CookieParseError e+        Just (Right x) -> Right $ Just x++extractCookie ::+  (Monad m, KnownSymbol name, FromHttpApiData val) =>+  Proxy name ->+  ServerHandler m (Request `With` ts) (Maybe (Either Text val))+extractCookie proxy = proc req -> do+  let cookieName :: ByteString = fromString $ symbolVal proxy++      lookupCookie :: Maybe ByteString+      lookupCookie = do+        hdr <- requestHeader "Cookie" (unwitness req)+        let cookies :: Cookie.Cookies = Cookie.parseCookies hdr+        lookup cookieName cookies++  returnA -< parseHeader <$> lookupCookie++instance (Monad m, KnownSymbol name) => Set (ServerHandler m) (SetCookie Required name) Response where+  {-# INLINE setTrait #-}+  setTrait ::+    SetCookie Required name ->+    (Response `With` ts -> Response -> Cookie.SetCookie -> Response `With` (SetCookie Required name : ts)) ->+    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}+    returnA -< f l response' cookie++instance (Monad m, KnownSymbol name) => Set (ServerHandler m) (SetCookie Optional name) Response where+  {-# INLINE setTrait #-}+  -- If the optional value is 'Nothing', the cookie is removed from the response+  setTrait ::+    SetCookie Optional name ->+    (Response `With` ts -> Response -> Maybe Cookie.SetCookie -> Response `With` (SetCookie Optional name : ts)) ->+    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}+    returnA -< f l response' maybeCookie++alterCookie :: ByteString -> Maybe Cookie.SetCookie -> ResponseHeaders -> ResponseHeaders+alterCookie name (Just cookie) hdrs = ("Set-Cookie", cookieToBS name cookie) : hdrs+alterCookie name Nothing hdrs = filter (not . isMatchingCookie) hdrs+  where+    isMatchingCookie :: Header -> Bool+    isMatchingCookie (hdrName, hdrVal) =+      (hdrName == "Set-Cookie")+        && (name == Cookie.setCookieName (Cookie.parseSetCookie hdrVal))++cookieToBS :: ByteString -> Cookie.SetCookie -> ByteString+cookieToBS name cookie =+  toByteString'+    $ Cookie.renderSetCookie+    $ cookie{Cookie.setCookieName = name}

@@ -4,98 +4,103 @@ module WebGear.Server.Trait.Header () where  import Control.Arrow (arr, returnA, (>>>))+import Data.ByteString (ByteString) import Data.ByteString.Conversion (ToByteString, toByteString')-import qualified Data.HashMap.Strict as HM 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)+import Network.HTTP.Types (HeaderName, ResponseHeaders) import Web.HttpApiData (FromHttpApiData, parseHeader) import WebGear.Core.Modifiers import WebGear.Core.Request (Request, requestHeader) import WebGear.Core.Response (Response (..))-import WebGear.Core.Trait (Get (..), Linked, Set (..), unlink)-import WebGear.Core.Trait.Header (Header (..), HeaderNotFound (..), HeaderParseError (..))+import WebGear.Core.Trait (Get (..), Set (..), With, unwitness)+import WebGear.Core.Trait.Header (HeaderNotFound (..), HeaderParseError (..), RequestHeader (..), ResponseHeader (..)) import WebGear.Server.Handler (ServerHandler)  extractRequestHeader ::   (Monad m, KnownSymbol name, FromHttpApiData val) =>   Proxy name ->-  ServerHandler m (Linked ts Request) (Maybe (Either Text val))+  ServerHandler m (Request `With` ts) (Maybe (Either Text val)) extractRequestHeader proxy = proc req -> do   let headerName :: HeaderName = fromString $ symbolVal proxy-  returnA -< parseHeader <$> requestHeader headerName (unlink req)+  returnA -< parseHeader <$> requestHeader headerName (unwitness req) -instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Required Strict name val) Request where+instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Required Strict name val) Request where   {-# INLINE getTrait #-}   getTrait ::-    Header Required Strict name val ->-    ServerHandler m (Linked ts Request) (Either (Either HeaderNotFound HeaderParseError) val)-  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    RequestHeader Required Strict name val ->+    ServerHandler m (Request `With` ts) (Either (Either HeaderNotFound HeaderParseError) val)+  getTrait RequestHeader = extractRequestHeader (Proxy @name) >>> arr f     where       f = \case         Nothing -> Left $ Left HeaderNotFound         Just (Left e) -> Left $ Right $ HeaderParseError e         Just (Right x) -> Right x -instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Optional Strict name val) Request where+instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Optional Strict name val) Request where   {-# INLINE getTrait #-}   getTrait ::-    Header Optional Strict name val ->-    ServerHandler m (Linked ts Request) (Either HeaderParseError (Maybe val))-  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    RequestHeader Optional Strict name val ->+    ServerHandler m (Request `With` ts) (Either HeaderParseError (Maybe val))+  getTrait RequestHeader = extractRequestHeader (Proxy @name) >>> arr f     where       f = \case         Nothing -> Right Nothing         Just (Left e) -> Left $ HeaderParseError e         Just (Right x) -> Right $ Just x -instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Required Lenient name val) Request where+instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Required Lenient name val) Request where   {-# INLINE getTrait #-}   getTrait ::-    Header Required Lenient name val ->-    ServerHandler m (Linked ts Request) (Either HeaderNotFound (Either Text val))-  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    RequestHeader Required Lenient name val ->+    ServerHandler m (Request `With` ts) (Either HeaderNotFound (Either Text val))+  getTrait RequestHeader = extractRequestHeader (Proxy @name) >>> arr f     where       f = \case         Nothing -> Left HeaderNotFound         Just (Left e) -> Right $ Left e         Just (Right x) -> Right $ Right x -instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Optional Lenient name val) Request where+instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Optional Lenient name val) Request where   {-# INLINE getTrait #-}   getTrait ::-    Header Optional Lenient name val ->-    ServerHandler m (Linked ts Request) (Either Void (Maybe (Either Text val)))-  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    RequestHeader Optional Lenient name val ->+    ServerHandler m (Request `With` ts) (Either Void (Maybe (Either Text val)))+  getTrait RequestHeader = extractRequestHeader (Proxy @name) >>> arr f     where       f = \case         Nothing -> Right Nothing         Just (Left e) -> Right $ Just $ Left e         Just (Right x) -> Right $ Just $ Right x -instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (Header Required Strict name val) Response where+instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (ResponseHeader Required name val) Response where   {-# INLINE setTrait #-}   setTrait ::-    Header Required Strict name val ->-    (Linked ts Response -> Response -> val -> Linked (Header Required Strict name val : ts) Response) ->-    ServerHandler m (Linked ts Response, val) (Linked (Header Required Strict name val : ts) Response)-  setTrait Header f = proc (l, val) -> do+    ResponseHeader Required name val ->+    (Response `With` ts -> Response -> val -> Response `With` (ResponseHeader Required name val : ts)) ->+    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{..} = unlink l-        response' = response{responseHeaders = HM.insert headerName (toByteString' val) responseHeaders}+        response@Response{..} = unwitness l+        response' = response{responseHeaders = (headerName, toByteString' val) : responseHeaders}     returnA -< f l response' val -instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (Header Optional Strict name val) Response where+instance (Monad m, KnownSymbol name, ToByteString 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 ::-    Header Optional Strict name val ->-    (Linked ts Response -> Response -> Maybe val -> Linked (Header Optional Strict name val : ts) Response) ->-    ServerHandler m (Linked ts Response, Maybe val) (Linked (Header Optional Strict name val : ts) Response)-  setTrait Header f = proc (l, maybeVal) -> do+    ResponseHeader Optional name val ->+    (Response `With` ts -> Response -> Maybe val -> Response `With` (ResponseHeader Optional name val : ts)) ->+    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{..} = unlink l-        response' = response{responseHeaders = HM.alter (const $ toByteString' <$> maybeVal) headerName responseHeaders}+        response@Response{..} = unwitness l+        response' = response{responseHeaders = alterHeader headerName (toByteString' <$> maybeVal) responseHeaders}     returnA -< f l response' maybeVal++alterHeader :: HeaderName -> Maybe ByteString -> ResponseHeaders -> ResponseHeaders+alterHeader name Nothing hdrs = filter (\(n, _) -> name /= n) hdrs+alterHeader name (Just val) hdrs = (name, val) : hdrs

@@ -6,16 +6,16 @@ import Control.Arrow (returnA) import qualified Network.HTTP.Types as HTTP import WebGear.Core.Request (Request, requestMethod)-import WebGear.Core.Trait (Get (..), Linked, unlink)+import WebGear.Core.Trait (Get (..), With (unwitness), unwitness) import WebGear.Core.Trait.Method (Method (..), MethodMismatch (..)) import WebGear.Server.Handler (ServerHandler) -instance Monad m => Get (ServerHandler m) Method Request where+instance (Monad m) => Get (ServerHandler m) Method Request where   {-# INLINE getTrait #-}-  getTrait :: Method -> ServerHandler m (Linked ts Request) (Either MethodMismatch HTTP.StdMethod)+  getTrait :: Method -> ServerHandler m (Request `With` ts) (Either MethodMismatch HTTP.StdMethod)   getTrait (Method method) = proc request -> do     let expectedMethod = HTTP.renderStdMethod method-        actualMethod = requestMethod $ unlink request+        actualMethod = requestMethod $ unwitness request     if actualMethod == expectedMethod       then returnA -< Right method       else returnA -< Left $ MethodMismatch{..}

@@ -3,39 +3,51 @@ -- | Server implementation of the path traits. module WebGear.Server.Trait.Path where +import Control.Monad.State (get, gets, put) import qualified Data.List as List import qualified Data.Text as Text import Web.HttpApiData (FromHttpApiData (..)) import WebGear.Core.Handler (RoutePath (..)) import WebGear.Core.Request (Request)-import WebGear.Core.Trait (Get (..), Linked)-import WebGear.Core.Trait.Path (Path (..), PathEnd (..), PathVar (..), PathVarError (..))+import WebGear.Core.Trait (Get (..), With)+import WebGear.Core.Trait.Path (+  Path (..),+  PathEnd (..),+  PathVar (..),+  PathVarError (..),+ ) import WebGear.Server.Handler (ServerHandler (..)) -instance Monad m => Get (ServerHandler m) Path Request where+instance (Monad m) => Get (ServerHandler m) Path Request where   {-# INLINE getTrait #-}-  getTrait :: Path -> ServerHandler m (Linked ts Request) (Either () ())-  getTrait (Path p) = ServerHandler $ \(_, path@(RoutePath remaining)) -> do+  getTrait :: Path -> ServerHandler m (Request `With` ts) (Either () ())+  getTrait (Path p) = ServerHandler $ const $ do+    RoutePath remaining <- get     let expected = filter (/= "") $ Text.splitOn "/" p-    pure $ case List.stripPrefix expected remaining of-      Just ps -> (Right (Right ()), RoutePath ps)-      Nothing -> (Right (Left ()), path)+    case List.stripPrefix expected remaining of+      Just ps -> put (RoutePath ps) >> pure (Right ())+      Nothing -> pure (Left ())  instance (Monad m, FromHttpApiData val) => Get (ServerHandler m) (PathVar tag val) Request where   {-# INLINE getTrait #-}-  getTrait :: PathVar tag val -> ServerHandler m (Linked ts Request) (Either PathVarError val)-  getTrait PathVar = ServerHandler $ \(_, path@(RoutePath remaining)) -> do-    pure $ case remaining of-      [] -> (Right (Left PathVarNotFound), path)+  getTrait :: PathVar tag val -> ServerHandler m (Request `With` ts) (Either PathVarError val)+  getTrait PathVar = ServerHandler $ const $ do+    RoutePath remaining <- get+    case remaining of+      [] -> pure (Left PathVarNotFound)       (p : ps) ->         case parseUrlPiece p of-          Left e -> (Right (Left $ PathVarParseError e), path)-          Right val -> (Right (Right val), RoutePath ps)+          Left e -> pure (Left $ PathVarParseError e)+          Right val -> put (RoutePath ps) >> pure (Right val) -instance Monad m => Get (ServerHandler m) PathEnd Request where+instance (Monad m) => Get (ServerHandler m) PathEnd Request where   {-# INLINE getTrait #-}-  getTrait :: PathEnd -> ServerHandler m (Linked ts Request) (Either () ())-  getTrait PathEnd = ServerHandler f-    where-      f (_, p@(RoutePath [])) = pure (Right $ Right (), p)-      f (_, p) = pure (Right $ Left (), p)+  getTrait :: PathEnd -> ServerHandler m (Request `With` ts) (Either () ())+  getTrait PathEnd =+    ServerHandler+      $ const+      $ gets+        ( \case+            RoutePath [] -> Right ()+            _ -> Left ()+        )

@@ -14,7 +14,7 @@ import Web.HttpApiData (FromHttpApiData (..)) import WebGear.Core.Modifiers import WebGear.Core.Request (Request, queryString)-import WebGear.Core.Trait (Get (..), Linked, unlink)+import WebGear.Core.Trait (Get (..), With, unwitness) import WebGear.Core.Trait.QueryParam (   ParamNotFound (..),   ParamParseError (..),@@ -25,17 +25,17 @@ extractQueryParam ::   (Monad m, KnownSymbol name, FromHttpApiData val) =>   Proxy name ->-  ServerHandler m (Linked ts Request) (Maybe (Either Text val))+  ServerHandler m (Request `With` ts) (Maybe (Either Text val)) extractQueryParam proxy = proc req -> do   let name = fromString $ symbolVal proxy-      params = queryToQueryText $ queryString $ unlink req+      params = queryToQueryText $ queryString $ unwitness req   returnA -< parseQueryParam <$> (find ((== name) . fst) params >>= snd)  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Required Strict name val) Request where   {-# INLINE getTrait #-}   getTrait ::     QueryParam Required Strict name val ->-    ServerHandler m (Linked ts Request) (Either (Either ParamNotFound ParamParseError) val)+    ServerHandler m (Request `With` ts) (Either (Either ParamNotFound ParamParseError) val)   getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f     where       f = \case@@ -47,7 +47,7 @@   {-# INLINE getTrait #-}   getTrait ::     QueryParam Optional Strict name val ->-    ServerHandler m (Linked ts Request) (Either ParamParseError (Maybe val))+    ServerHandler m (Request `With` ts) (Either ParamParseError (Maybe val))   getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f     where       f = \case@@ -59,7 +59,7 @@   {-# INLINE getTrait #-}   getTrait ::     QueryParam Required Lenient name val ->-    ServerHandler m (Linked ts Request) (Either ParamNotFound (Either Text val))+    ServerHandler m (Request `With` ts) (Either ParamNotFound (Either Text val))   getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f     where       f = \case@@ -71,7 +71,7 @@   {-# INLINE getTrait #-}   getTrait ::     QueryParam Optional Lenient name val ->-    ServerHandler m (Linked ts Request) (Either Void (Maybe (Either Text val)))+    ServerHandler m (Request `With` ts) (Either Void (Maybe (Either Text val)))   getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f     where       f = \case

@@ -6,17 +6,16 @@ import Control.Arrow (returnA) import qualified Network.HTTP.Types.Status as HTTP import WebGear.Core.Response (Response (responseStatus))-import WebGear.Core.Trait (Linked, Set, setTrait, unlink)+import WebGear.Core.Trait (Set, With, setTrait, unwitness) import WebGear.Core.Trait.Status (Status (..)) import WebGear.Server.Handler (ServerHandler) -instance Monad m => Set (ServerHandler m) Status Response where+instance (Monad m) => Set (ServerHandler m) Status Response where   {-# INLINE setTrait #-}   setTrait ::     Status ->-    (Linked ts Response -> Response -> HTTP.Status -> Linked (Status : ts) Response) ->-    ServerHandler m (Linked ts Response, HTTP.Status) (Linked (Status : ts) Response)-  setTrait (Status status) f = proc (linkedResponse, _) -> do-    let response = unlink linkedResponse-        response' = response{responseStatus = status}-    returnA -< f linkedResponse response' 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

@@ -8,6 +8,7 @@ import WebGear.Server.Trait.Auth.Basic () import WebGear.Server.Trait.Auth.JWT () import WebGear.Server.Trait.Body ()+import WebGear.Server.Trait.Cookie () import WebGear.Server.Trait.Header () import WebGear.Server.Trait.Method () import WebGear.Server.Trait.Path ()

@@ -21,7 +21,7 @@ import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (Linked, getTrait, linkzero, probe)+import WebGear.Core.Trait (With, getTrait, probe, wzero) import WebGear.Core.Trait.Auth.Basic (   BasicAuth,   BasicAuth' (..),@@ -30,7 +30,7 @@   Username (..),  ) import WebGear.Core.Trait.Auth.Common (AuthorizationHeader)-import WebGear.Core.Trait.Header (Header (..))+import WebGear.Core.Trait.Header (RequestHeader (..)) import WebGear.Server.Handler (ServerHandler, runServerHandler) import WebGear.Server.Trait.Auth.Basic () import WebGear.Server.Trait.Header ()@@ -42,23 +42,25 @@     f (username, password)       | ':' `elem` username = property Discard       | otherwise =-        let hval = "Basic " <> encode (username <> ":" <> password)+          let hval = "Basic " <> encode (username <> ":" <> password) -            mkRequest :: ServerHandler Identity () (Linked '[AuthorizationHeader "Basic"] Request)-            mkRequest = proc () -> do-              let req = Request $ defaultRequest{requestHeaders = [("Authorization", hval)]}-              r <- probe Header -< linkzero req-              returnA -< fromRight undefined r+              mkRequest :: ServerHandler Identity () (Request `With` '[AuthorizationHeader "Basic"])+              mkRequest = proc () -> do+                let req = Request $ defaultRequest{requestHeaders = [("Authorization", hval)]}+                r <- probe RequestHeader -< wzero req+                returnA -< fromRight undefined r -            authCfg :: BasicAuth Identity () Credentials-            authCfg = BasicAuth'{toBasicAttribute = pure . Right}-         in runIdentity $ do-              res <- runServerHandler (mkRequest >>> getTrait authCfg) [""] ()-              pure $ case res of-                Right (Right creds) ->-                  credentialsUsername creds === Username username-                    .&&. credentialsPassword creds === Password password-                e -> counterexample ("Unexpected failure: " <> show e) (property False)+              authCfg :: BasicAuth Identity () Credentials+              authCfg = BasicAuth'{toBasicAttribute = pure . Right}+           in runIdentity $ do+                res <- runServerHandler (mkRequest >>> getTrait authCfg) [""] ()+                pure $ case res of+                  Right (Right creds) ->+                    credentialsUsername creds+                      === Username username+                      .&&. credentialsPassword creds+                      === Password password+                  e -> counterexample ("Unexpected failure: " <> show e) (property False)  -- Hack for TH splicing return []

@@ -13,25 +13,26 @@ import Test.QuickCheck.Monadic (assert, monadicIO, monitor) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties)+import WebGear.Core.MIMETypes (JSON (..)) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (Linked, getTrait, linkzero)-import WebGear.Core.Trait.Body (JSONBody (..))+import WebGear.Core.Trait (With, getTrait, wzero)+import WebGear.Core.Trait.Body (Body (..)) import WebGear.Server.Handler (runServerHandler) import WebGear.Server.Trait.Body () -jsonBody :: JSONBody t-jsonBody = JSONBody (Just "application/json")+jsonBody :: Body JSON t+jsonBody = Body JSON -bodyToRequest :: (MonadIO m, Show a) => a -> m (Linked '[] Request)+bodyToRequest :: (MonadIO m, Show a) => a -> m (Request `With` '[]) bodyToRequest x = do   body <- liftIO $ newIORef $ Just $ fromString $ show x   let f = readIORef body >>= maybe (pure "") (\s -> writeIORef body Nothing >> pure s)-  return $ linkzero $ Request $ defaultRequest{requestBody = f}+  return $ wzero $ Request $ defaultRequest{requestBody = f}  prop_emptyRequestBodyFails :: Property prop_emptyRequestBodyFails = monadicIO $ do   req <- bodyToRequest ("" :: String)-  runServerHandler (getTrait (jsonBody :: JSONBody Int)) [""] req >>= \case+  runServerHandler (getTrait (jsonBody @Int)) [""] req >>= \case     Right (Left _) -> assert True     e -> monitor (counterexample $ "Unexpected " <> show e) >> assert False @@ -45,7 +46,7 @@ prop_invalidBodyTypeFails :: Property prop_invalidBodyTypeFails = property $ \n -> monadicIO $ do   req <- bodyToRequest (n :: Integer)-  runServerHandler (getTrait (jsonBody :: JSONBody String)) [""] req >>= \case+  runServerHandler (getTrait (jsonBody @String)) [""] req >>= \case     Right (Left _) -> assert True     _ -> assert False 

@@ -11,17 +11,17 @@ import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (getTrait, linkzero)-import WebGear.Core.Trait.Header (Header (..), HeaderParseError (..), RequiredHeader)+import WebGear.Core.Trait (getTrait, wzero)+import WebGear.Core.Trait.Header (HeaderParseError (..), RequestHeader (..), RequiredRequestHeader) import WebGear.Server.Handler (runServerHandler) import WebGear.Server.Trait.Header ()  prop_headerParseError :: Property prop_headerParseError = property $ \hval ->   let hval' = "test-" <> hval-      req = linkzero $ Request $ defaultRequest{requestHeaders = [("foo", encodeUtf8 hval')]}+      req = wzero $ Request $ defaultRequest{requestHeaders = [("foo", encodeUtf8 hval')]}    in runIdentity $ do-        res <- runServerHandler (getTrait (Header :: RequiredHeader "foo" Int)) [""] req+        res <- runServerHandler (getTrait (RequestHeader :: RequiredRequestHeader "foo" Int)) [""] req         pure $ case res of           Right (Left e) ->             e === Right (HeaderParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)")@@ -29,9 +29,9 @@  prop_headerParseSuccess :: Property prop_headerParseSuccess = property $ \(n :: Int) ->-  let req = linkzero $ Request $ defaultRequest{requestHeaders = [("foo", fromString $ show n)]}+  let req = wzero $ Request $ defaultRequest{requestHeaders = [("foo", fromString $ show n)]}    in runIdentity $ do-        res <- runServerHandler (getTrait (Header :: RequiredHeader "foo" Int)) [""] req+        res <- runServerHandler (getTrait (RequestHeader :: RequiredRequestHeader "foo" Int)) [""] req         pure $ case res of           Right (Right n') -> n === n'           e -> counterexample ("Unexpected result: " <> show e) (property False)

@@ -18,7 +18,7 @@ import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait (getTrait, wzero) import WebGear.Core.Trait.Method (Method (..), MethodMismatch (..)) import WebGear.Server.Handler (runServerHandler) import WebGear.Server.Trait.Method ()@@ -31,7 +31,7 @@  prop_methodMatch :: Property prop_methodMatch = property $ \(MethodWrapper v) ->-  let req = linkzero $ Request $ defaultRequest{requestMethod = renderStdMethod v}+  let req = wzero $ Request $ defaultRequest{requestMethod = renderStdMethod v}    in runIdentity $ do         res <- runServerHandler (getTrait (Method GET)) [""] req         pure $ case res of

@@ -9,16 +9,16 @@ import Test.QuickCheck.Instances () import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties)-import WebGear.Core.Trait.Path (Path (..), PathVar (..), PathVarError (..)) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait (getTrait, wzero)+import WebGear.Core.Trait.Path (Path (..), PathVar (..), PathVarError (..)) import WebGear.Server.Handler (RoutePath (..), runServerHandler) import WebGear.Server.Trait.Path ()  prop_pathMatch :: Property prop_pathMatch = property $ \h ->   let rest = ["foo", "bar"]-      req = linkzero $ Request $ defaultRequest{pathInfo = h : rest}+      req = wzero $ Request $ defaultRequest{pathInfo = h : rest}    in runIdentity $ do         res <- runServerHandler (getTrait $ Path "a") (RoutePath $ h : rest) req         pure $ case res of@@ -30,7 +30,7 @@ prop_pathVarMatch = property $ \(n :: Int) ->   let rest = ["foo", "bar"]       p = fromString (show n) : rest-      req = linkzero $ Request $ defaultRequest{pathInfo = p}+      req = wzero $ Request $ defaultRequest{pathInfo = p}    in runIdentity $ do         res <- runServerHandler (getTrait (PathVar @"tag" @Int)) (RoutePath p) req         pure $ case res of@@ -40,7 +40,7 @@ prop_pathVarParseError :: Property prop_pathVarParseError = property $ \(p, ps) ->   let p' = "test-" <> p-      req = linkzero $ Request $ defaultRequest{pathInfo = p' : ps}+      req = wzero $ Request $ defaultRequest{pathInfo = p' : ps}    in runIdentity $ do         res <- runServerHandler (getTrait (PathVar @"tag" @Int)) (RoutePath $ p' : ps) req         pure $ case res of

@@ -12,7 +12,7 @@ import Test.Tasty.QuickCheck (testProperties) import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait (getTrait, wzero) import WebGear.Core.Trait.QueryParam (ParamParseError (..), QueryParam (..)) import WebGear.Server.Handler (runServerHandler) import WebGear.Server.Trait.QueryParam ()@@ -20,7 +20,7 @@ prop_paramParseError :: Property prop_paramParseError = property $ \hval ->   let hval' = "test-" <> hval-      req = linkzero $ Request $ defaultRequest{queryString = [("foo", Just $ encodeUtf8 hval')]}+      req = wzero $ Request $ defaultRequest{queryString = [("foo", Just $ encodeUtf8 hval')]}    in runIdentity $ do         res <- runServerHandler (getTrait (QueryParam :: QueryParam Required Strict "foo" Int)) [""] req         pure $ case res of@@ -30,7 +30,7 @@  prop_paramParseSuccess :: Property prop_paramParseSuccess = property $ \(n :: Int) ->-  let req = linkzero $ Request $ defaultRequest{queryString = [("foo", Just $ fromString $ show n)]}+  let req = wzero $ Request $ defaultRequest{queryString = [("foo", Just $ fromString $ show n)]}    in runIdentity $ do         res <- runServerHandler (getTrait (QueryParam :: QueryParam Required Strict "foo" Int)) [""] req         pure $ case res of

@@ -7,16 +7,16 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (getTrait, linkzero)-import WebGear.Core.Trait.Header (Header (..), HeaderNotFound (..), RequiredHeader)+import WebGear.Core.Trait (getTrait, wzero)+import WebGear.Core.Trait.Header (HeaderNotFound (..), RequestHeader (..), RequiredRequestHeader) import WebGear.Server.Handler (runServerHandler) import WebGear.Server.Trait.Header ()  testMissingHeaderFails :: TestTree testMissingHeaderFails = testCase "Missing header fails Header trait" $ do-  let req = linkzero $ Request $ defaultRequest{requestHeaders = []}+  let req = wzero $ Request $ defaultRequest{requestHeaders = []}   runIdentity $ do-    res <- runServerHandler (getTrait (Header :: RequiredHeader "foo" Int)) [""] req+    res <- runServerHandler (getTrait (RequestHeader :: RequiredRequestHeader "foo" Int)) [""] req     pure $ case res of       Right (Left e) -> e @?= Left HeaderNotFound       _ -> assertFailure "unexpected success"

@@ -6,15 +6,15 @@ import Network.Wai (defaultRequest, pathInfo) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=))-import WebGear.Core.Trait.Path (PathVar (..), PathVarError (..)) import WebGear.Core.Request (Request (..))-import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait (getTrait, wzero)+import WebGear.Core.Trait.Path (PathVar (..), PathVarError (..)) import WebGear.Server.Handler (runServerHandler) import WebGear.Server.Trait.Path ()  testMissingPathVar :: TestTree testMissingPathVar = testCase "PathVar match: missing variable" $ do-  let req = linkzero $ Request $ defaultRequest{pathInfo = []}+  let req = wzero $ Request $ defaultRequest{pathInfo = []}   runIdentity $ do     res <- runServerHandler (getTrait (PathVar @"tag" @Int)) [] req     pure $ case res of

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                webgear-server-version:             1.0.5+version:             1.1.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.@@ -55,11 +55,11 @@                       TypeOperators   build-depends:      base >=4.13.0.0 && <4.19                     , base64-bytestring >=1.0.0.3 && <1.3-                    , bytestring >=0.10.10.1 && <0.12+                    , bytestring >=0.10.10.1 && <0.13                     , http-types ==0.12.*-                    , text >=1.2.0.0 && <2.1+                    , text >=1.2.0.0 && <2.2                     , wai ==3.2.*-                    , webgear-core ==1.0.5+                    , webgear-core ==1.1.0   ghc-options:        -Wall                       -Wno-unticked-promoted-constructors                       -Wcompat@@ -80,10 +80,12 @@   import:             webgear-common   exposed-modules:    WebGear.Server                     , WebGear.Server.Handler+                    , WebGear.Server.MIMETypes                     , WebGear.Server.Traits                     , WebGear.Server.Trait.Auth.Basic                     , WebGear.Server.Trait.Auth.JWT                     , WebGear.Server.Trait.Body+                    , WebGear.Server.Trait.Cookie                     , WebGear.Server.Trait.Header                     , WebGear.Server.Trait.Method                     , WebGear.Server.Trait.Path@@ -92,15 +94,19 @@   other-modules:      Paths_webgear_server   autogen-modules:    Paths_webgear_server   hs-source-dirs:     src-  build-depends:      aeson >=1.4 && <1.6 || >=2.0 && <2.2+  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.*-                    , http-api-data >=0.4.2 && <0.6+                    , cookie >=0.4.5 && <0.5+                    , http-api-data >=0.4.2 && <0.7                     , http-media ==0.8.*                     , jose >=0.8.3.1 && <0.11                     , monad-time >=0.3.0.0 && <0.5                     , mtl >=2.2 && <2.4-                    , unordered-containers ==0.2.*+                    , resourcet >=1.2 && <1.4+                    , text-conversions ==0.3.*+                    , wai-extra ==3.1.*  test-suite webgear-server-test   import:             webgear-common@@ -123,7 +129,7 @@                       -with-rtsopts=-N   build-depends:      QuickCheck >=2.13 && <2.15                     , quickcheck-instances ==0.3.*-                    , tasty >=1.2 && <1.5+                    , tasty >=1.2 && <1.6                     , tasty-hunit ==0.10.*                     , tasty-quickcheck ==0.10.*                     , webgear-server