webgear-core 1.0.5 → 1.1.0

raw patch · 20 files changed

+838/−546 lines, 20 filesdep +binarydep +cookiedep +wai-extradep −safe-exceptionsdep −unordered-containersdep ~bytestringdep ~http-api-datadep ~text

Dependencies added: binary, cookie, wai-extra

Dependencies removed: safe-exceptions, unordered-containers

Dependency ranges changed: bytestring, http-api-data, text

Files

• CHANGELOG.md +12/−1
• src/WebGear/Core.hs +2/−0
• src/WebGear/Core/Handler.hs +49/−11
• src/WebGear/Core/Handler/Static.hs +29/−24
• src/WebGear/Core/MIMETypes.hs +98/−0
• src/WebGear/Core/Request.hs +17/−11
• src/WebGear/Core/Response.hs +25/−16
• src/WebGear/Core/Trait.hs +128/−68
• src/WebGear/Core/Trait/Auth/Basic.hs +18/−18
• src/WebGear/Core/Trait/Auth/Common.hs +23/−23
• src/WebGear/Core/Trait/Auth/JWT.hs +31/−31
• src/WebGear/Core/Trait/Body.hs +93/−195
• src/WebGear/Core/Trait/Cookie.hs +135/−0
• src/WebGear/Core/Trait/Header.hs +83/−65
• src/WebGear/Core/Trait/Method.hs +1/−1
• src/WebGear/Core/Trait/Path.hs +5/−5
• src/WebGear/Core/Trait/QueryParam.hs +15/−15
• src/WebGear/Core/Trait/Status.hs +50/−50
• src/WebGear/Core/Traits.hs +15/−6
• webgear-core.cabal +9/−6

@@ -2,6 +2,16 @@  ## [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)+ ## [1.0.5] - 2023-05-04  ### Changed@@ -34,7 +44,8 @@ - Extracted webgear-core from webgear-server - New arrow based API -[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

@@ -22,11 +22,13 @@   module WebGear.Core.Handler,   module WebGear.Core.Handler.Static,   module WebGear.Core.Traits,+  module WebGear.Core.MIMETypes, ) where  import Control.Arrow import Data.Text import qualified Network.Wai as Wai+import WebGear.Core.MIMETypes  import WebGear.Core.Handler import WebGear.Core.Handler.Static

@@ -10,17 +10,19 @@   RequestHandler,   Middleware,   routeMismatch,-  unlinkA,+  unwitnessA,+  (>->),+  (<-<), ) where -import Control.Arrow (ArrowChoice, ArrowPlus, arr)+import Control.Arrow (Arrow, ArrowChoice, ArrowPlus, arr) import Control.Arrow.Operations (ArrowError (..)) import Data.String (IsString) import Data.Text (Text) import GHC.Exts (IsList (..)) import WebGear.Core.Request (Request) import WebGear.Core.Response (Response (..))-import WebGear.Core.Trait (Linked (unlink))+import WebGear.Core.Trait (With (unwitness))  -- | Parts of the request path used by the routing machinery newtype RoutePath = RoutePath [Text]@@ -53,11 +55,11 @@   -- | Set a summary of a part of an API   setSummary :: Summary -> h a a --- | A handler arrow from a linked request to response.-type RequestHandler h req = h (Linked req Request) Response+-- | A handler arrow from a witnessed request to response.+type RequestHandler h ts = h (Request `With` ts) Response  -- | A middleware enhances a `RequestHandler` and produces another handler.-type Middleware h reqOut reqIn = RequestHandler h reqIn -> RequestHandler h reqOut+type Middleware h tsOut tsIn = RequestHandler h tsIn -> RequestHandler h tsOut  -- | Description associated with part of an API newtype Description = Description {getDescription :: Text}@@ -80,11 +82,47 @@   mempty = RouteMismatch  -- | Indicates that the request does not match the current handler.-routeMismatch :: ArrowError RouteMismatch h => h a b+routeMismatch :: (ArrowError RouteMismatch h) => h a b routeMismatch = proc _a -> raise -< RouteMismatch {-# INLINE routeMismatch #-} --- | Lifts `unlink` into a handler arrow.-unlinkA :: Handler h m => h (Linked ts Response) Response-unlinkA = arr unlink-{-# INLINE unlinkA #-}+-- | Lifts `unwitness` into a handler arrow.+unwitnessA :: (Handler h m) => h (Response `With` ts) Response+unwitnessA = arr unwitness+{-# INLINE unwitnessA #-}++infixr 1 >->, <-<++{- | Thread a response through commands from left to right.++ For example, an HTTP 200 response with a body and Content-Type header+ can be generated with:++@+ (ok200 -< ())+   >-> (\resp -> setBody "text/plain" -< (resp, "Hello World"))+   >-> (\resp -> unwitnessA -< resp)+@+-}+(>->) :: (Arrow h) => h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b+f >-> g = proc (env, stack) -> do+  a <- f -< (env, stack)+  g -< (env, (a, stack))+{-# INLINE (>->) #-}++{- | Thread a response through commands from right to left.++ For example, an HTTP 200 response with a body and Content-Type header+ can be generated with:++@+ (\resp -> unwitnessA -< resp)+   <-< (\resp -> setBody "text/plain" -< (resp, "Hello World"))+   <-< (ok200 -< ())+@+-}+(<-<) :: (Arrow h) => h (env, (a, stack)) b -> h (env, stack) a -> h (env, stack) b+f <-< g = proc (env, stack) -> do+  a <- g -< (env, stack)+  f -< (env, (a, stack))+{-# INLINE (<-<) #-}

@@ -7,26 +7,28 @@ ) where  import Control.Arrow ((<<<))-import Control.Exception.Safe (catchIO)-import Control.Monad.IO.Class (MonadIO (..))-import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text import qualified Network.Mime as Mime import System.FilePath (joinPath, takeFileName, (</>))-import WebGear.Core.Handler (Handler (..), RoutePath (..), unlinkA)+import WebGear.Core.Handler (Handler (..), RoutePath (..), unwitnessA, (>->)) import WebGear.Core.Request (Request (..))-import WebGear.Core.Response (Response)-import WebGear.Core.Trait (Linked (..), Sets)-import WebGear.Core.Trait.Body (Body, setBodyWithoutContentType)-import WebGear.Core.Trait.Header (RequiredHeader, setHeader)+import WebGear.Core.Response (Response, ResponseBody (..))+import WebGear.Core.Trait (Sets, With)+import WebGear.Core.Trait.Body (UnknownContentBody, setBodyWithoutContentType)+import WebGear.Core.Trait.Header (RequiredResponseHeader, setHeader) import WebGear.Core.Trait.Status (Status, notFound404, ok200) import Prelude hiding (readFile)  -- | Serve files under the specified directory. serveDir ::-  ( MonadIO m-  , Handler h m-  , Sets h [Status, RequiredHeader "Content-Type" Mime.MimeType, Body LBS.ByteString] Response+  ( Handler h m+  , Sets+      h+      [ Status+      , RequiredResponseHeader "Content-Type" Mime.MimeType+      , UnknownContentBody+      ]+      Response   ) =>   -- | The directory to serve   FilePath ->@@ -34,28 +36,31 @@   -- response will be returned for requests to the root path if this   -- is set to @Nothing@.   Maybe FilePath ->-  h (Linked req Request) Response+  h (Request `With` ts) Response serveDir root index = proc _request -> consumeRoute go -< ()   where     go = proc path -> do       case (path, index) of-        (RoutePath [], Nothing) -> unlinkA <<< notFound404 -< ()+        (RoutePath [], Nothing) -> unwitnessA <<< notFound404 -< ()         (RoutePath [], Just f) -> serveFile -< root </> f         (RoutePath ps, _) -> serveFile -< root </> joinPath (Text.unpack <$> ps)  -- | Serve a file specified by the input filepath. serveFile ::-  ( MonadIO m-  , Handler h m-  , Sets h [Status, RequiredHeader "Content-Type" Mime.MimeType, Body LBS.ByteString] Response+  ( Handler h m+  , Sets+      h+      [ Status+      , RequiredResponseHeader "Content-Type" Mime.MimeType+      , UnknownContentBody+      ]+      Response   ) =>   h FilePath Response serveFile = proc file -> do-  maybeContents <- readFile -< file-  case maybeContents of-    Nothing -> unlinkA <<< notFound404 -< ()-    Just contents -> do-      let contentType = Mime.defaultMimeLookup $ Text.pack $ takeFileName file-      unlinkA <<< setHeader @"Content-Type" (setBodyWithoutContentType ok200) -< (contentType, (contents, ()))-  where-    readFile = arrM $ \f -> liftIO $ (Just <$> LBS.readFile f) `catchIO` const (pure Nothing)+  let contents = ResponseBodyFile file Nothing+      contentType = Mime.defaultMimeLookup $ Text.pack $ takeFileName file+  (ok200 -< ())+    >-> (\resp -> setBodyWithoutContentType -< (resp, contents))+    >-> (\resp -> setHeader @"Content-Type" -< (resp, contentType))+    >-> (\resp -> unwitnessA -< resp)

@@ -0,0 +1,98 @@+-- | MIME types for HTTP bodies+module WebGear.Core.MIMETypes (+  MIMEType (..),+  FormURLEncoded (..),+  HTML (..),+  JSON (..),+  FormData (..),+  FormDataResult (..),+  OctetStream (..),+  PlainText (..),+) where++import Data.String (IsString (fromString))+import Data.Text (Text, unpack)+import qualified Network.HTTP.Media as HTTP+import qualified Network.Wai.Parse as Wai.Parse++-- | MIME types used in the Accept and Content-Type headers+class MIMEType mt where+  mimeType :: mt -> HTTP.MediaType++--------------------------------------------------------------------------------++-- | The application/x-www-form-urlencoded MIME type+data FormURLEncoded = FormURLEncoded++instance MIMEType FormURLEncoded where+  mimeType :: FormURLEncoded -> HTTP.MediaType+  mimeType FormURLEncoded = "application/x-www-form-urlencoded"+  {-# INLINE mimeType #-}++--------------------------------------------------------------------------------++-- | The text/html MIME type+data HTML = HTML++instance MIMEType HTML where+  mimeType :: HTML -> HTTP.MediaType+  mimeType HTML = "text/html"+  {-# INLINE mimeType #-}++--------------------------------------------------------------------------------++-- | A JSON MIME type with customizable media type+data JSON+  = -- | JSON with a specific media type+    JSONMedia Text+  | -- | application/json media type+    JSON++instance MIMEType JSON where+  mimeType :: JSON -> HTTP.MediaType+  mimeType =+    \case+      JSONMedia mt -> fromString (unpack mt)+      JSON -> "application/json"+  {-# INLINE mimeType #-}++--------------------------------------------------------------------------------++-- | The multipart/form-data MIME type+data FormData a = FormData+  { parseOptions :: Wai.Parse.ParseRequestBodyOptions+  , backendOptions :: Wai.Parse.BackEnd a+  }++{- | Result of parsing a multipart/form-data body from a request.+The body can contain both parameters and files.+-}+data FormDataResult a = FormDataResult+  { formDataParams :: [Wai.Parse.Param]+  , formDataFiles :: [Wai.Parse.File a]+  }++instance MIMEType (FormData a) where+  mimeType :: FormData a -> HTTP.MediaType+  mimeType _ = "multipart/form-data"+  {-# INLINE mimeType #-}++--------------------------------------------------------------------------------++-- | The application/octet-stream MIME type+data OctetStream = OctetStream++instance MIMEType OctetStream where+  mimeType :: OctetStream -> HTTP.MediaType+  mimeType OctetStream = "application/octet-stream"+  {-# INLINE mimeType #-}++--------------------------------------------------------------------------------++-- | The text/plain MIME type+data PlainText = PlainText++instance MIMEType PlainText where+  mimeType :: PlainText -> HTTP.MediaType+  mimeType PlainText = "text/plain"+  {-# INLINE mimeType #-}

@@ -14,9 +14,11 @@   requestHeaders,   requestBodyLength,   getRequestBodyChunk,+  getRequestBody, ) where  import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS import Data.List (find) import Data.Text (Text) import qualified Network.HTTP.Types as HTTP@@ -25,8 +27,8 @@  -- | A request processed by a handler newtype Request = Request-  { -- | underlying WAI request-    waiRequest :: Wai.Request+  { toWaiRequest :: Wai.Request+  -- ^ underlying WAI request   }  -- | Get the value of a request header@@ -35,36 +37,40 @@  -- | See 'Wai.getRequestBodyChunk' getRequestBodyChunk :: Request -> IO ByteString-getRequestBodyChunk = Wai.getRequestBodyChunk . waiRequest+getRequestBodyChunk = Wai.getRequestBodyChunk . toWaiRequest +-- | Returns the entire request body as a lazy bytestring+getRequestBody :: Request -> IO LBS.ByteString+getRequestBody = Wai.lazyRequestBody . toWaiRequest+ -- | See 'Wai.httpVersion' httpVersion :: Request -> HTTP.HttpVersion-httpVersion = Wai.httpVersion . waiRequest+httpVersion = Wai.httpVersion . toWaiRequest  -- | See 'Wai.isSecure' isSecure :: Request -> Bool-isSecure = Wai.isSecure . waiRequest+isSecure = Wai.isSecure . toWaiRequest  -- | See 'Wai.pathInfo' pathInfo :: Request -> [Text]-pathInfo = Wai.pathInfo . waiRequest+pathInfo = Wai.pathInfo . toWaiRequest  -- | See 'Wai.queryString' queryString :: Request -> HTTP.Query-queryString = Wai.queryString . waiRequest+queryString = Wai.queryString . toWaiRequest  -- | See 'Wai.remoteHost' remoteHost :: Request -> SockAddr-remoteHost = Wai.remoteHost . waiRequest+remoteHost = Wai.remoteHost . toWaiRequest  -- | See 'Wai.requestBodyLength' requestBodyLength :: Request -> Wai.RequestBodyLength-requestBodyLength = Wai.requestBodyLength . waiRequest+requestBodyLength = Wai.requestBodyLength . toWaiRequest  -- | See 'Wai.requestHeaders' requestHeaders :: Request -> HTTP.RequestHeaders-requestHeaders = Wai.requestHeaders . waiRequest+requestHeaders = Wai.requestHeaders . toWaiRequest  -- | See 'Wai.requestMethod' requestMethod :: Request -> HTTP.Method-requestMethod = Wai.requestMethod . waiRequest+requestMethod = Wai.requestMethod . toWaiRequest

@@ -4,31 +4,40 @@ module WebGear.Core.Response (   -- * Basic Types   Response (..),+  ResponseBody (..),   toWaiResponse, ) where -import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as LBS-import qualified Data.HashMap.Strict as HM-import Data.Maybe (fromMaybe)+import qualified Data.Binary.Builder as B import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai --- | An HTTP response sent from the server to the client.------ The response contains a status, optional headers and an optional--- body payload.+{- | An HTTP response sent from the server to the client.++The response contains a status, optional headers and an optional+body payload.+-} data Response = Response-  { -- | Response status code-    responseStatus :: HTTP.Status-  , -- | Response headers-    responseHeaders :: HM.HashMap HTTP.HeaderName ByteString-  , -- | Optional response body-    responseBody :: Maybe LBS.ByteString+  { responseStatus :: HTTP.Status+  -- ^ Response status code+  , responseHeaders :: HTTP.ResponseHeaders+  -- ^ Response headers+  , responseBody :: ResponseBody+  -- ^ The response body   }-  deriving stock (Eq, Ord, Show) +data ResponseBody+  = ResponseBodyFile FilePath (Maybe Wai.FilePart)+  | ResponseBodyBuilder B.Builder+  | ResponseBodyStream Wai.StreamingBody+ -- | Generate a WAI response toWaiResponse :: Response -> Wai.Response toWaiResponse Response{..} =-  Wai.responseLBS responseStatus (HM.toList responseHeaders) (fromMaybe "" responseBody)+  case responseBody of+    ResponseBodyFile fpath fpart ->+      Wai.responseFile responseStatus responseHeaders fpath fpart+    ResponseBodyBuilder builder ->+      Wai.responseBuilder responseStatus responseHeaders builder+    ResponseBodyStream stream ->+      Wai.responseStream responseStatus responseHeaders stream

@@ -3,15 +3,45 @@ {- | Traits are optional attributes associated with a value. For  example, a list containing totally ordered values might have a  @Maximum@ trait where the associated attribute is the maximum- value. This trait exists only if the list is non-empty. The `Trait`+ value. This trait exists only if the list is non-empty. The 'Trait'  typeclass provides an interface to extract such trait attributes. - Traits help to link attributes with values in a type-safe manner.+ Traits help to associate attributes with values in a type-safe+ manner.   Traits are somewhat similar to [refinement  types](https://hackage.haskell.org/package/refined), but allow- arbitrary attributes to be associated with a value instead of only- a predicate.+ arbitrary attributes to be associated with a value instead of only a+ predicate.++ A value @a@ associated with traits @ts@ is referred to as a witnessed+ value, represented by the type @a \`'With'\` ts@ where @ts@ is a+ type-level list. You can extract a trait attribute from a witnessed+ value with:++ @+ `pick` \@t (`from` witnessedValue)+ @++ The above expression will result in a compile-time error if @t@ is+ not present in the type-level list of the witnessed value's type.++ You can create a witnessed value in a number of ways:++ First, you can use 'wzero' to lift a regular value to a witnessed+ value with no associated traits.++ Second, you can use 'probe' to search for the presence of a trait and+ add it to the witnessed value; this will adjust the type-level list+ accordingly. This is used in cases where the regular value already+ contains the trait attribute which can be extracted using the 'Get'+ typeclass.++ Third, you can use 'plant' to add a trait attribute to a witnessed+ value, thereby extending its type-level list with one more+ trait. This is used in cases where you want to modify the witnessed+ value. This operation requires an implementation of the 'Set'+ typeclass. -} module WebGear.Core.Trait (   -- * Core Types@@ -19,18 +49,18 @@   TraitAbsence (..),   Get (..),   Gets,-  Linked,   Set (..),   Sets,+  With, -  -- * Linking values with attributes-  linkzero,-  linkminus,-  unlink,+  -- * Associating values with attributes+  wzero,+  wminus,+  unwitness,   probe,   plant, -  -- * Retrive trait attributes from linked values+  -- * Retrieve trait attributes from witnessed values   HasTrait (..),   HaveTraits,   pick,@@ -49,33 +79,34 @@   type Attribute t a :: Type  -- | A trait @t@ that can be retrieved from @a@ but could be absent.-class Trait t a => TraitAbsence t a where+class (Trait t a) => TraitAbsence t a where   -- | Type that indicates that the trait does not exist for a   -- value. This could be an error message, exception etc.   type Absence t a :: Type  -- | Extract trait attributes from a value. class (Arrow h, TraitAbsence t a) => Get h t a where-  -- | Attempt to deduce the trait attribute from the value @a@.+  -- | Attempt to witness the trait attribute from the value @a@.   getTrait ::-    -- | The trait to extract+    -- | The trait to witness     t ->-    -- | Arrow that extracts the trait and can possibly fail-    h (Linked ts a) (Either (Absence t a) (Attribute t a))+    -- | Arrow that attemtps to witness the trait and can possibly+    -- fail+    h (a `With` ts) (Either (Absence t a) (Attribute t a)) --- | Set a trait attribute on a value+-- | Associate a trait attribute on a value class (Arrow h, Trait t a) => Set h (t :: Type) a where-  -- | Set a trait attribute @t@ on the value @a@.+  -- | Set a trait attribute @t@ on the value @a \`With\` ts@.   setTrait ::     -- | The trait to set     t ->-    -- | A function to generate a linked value. This function must be-    -- called by the `setTrait` implementation to generate a linked+    -- | A function to generate a witnessed value. This function must+    -- be called by the `setTrait` implementation to generate a+    -- witnessed value.+    (a `With` ts -> a -> Attribute t a -> a `With` (t : ts)) ->+    -- | An arrow that attaches a new trait attribute to a witnessed     -- value.-    (Linked ts a -> a -> Attribute t a -> Linked (t : ts) a) ->-    -- | An arrow that attches a new trait attribute to a value linked-    -- with other traits-    h (Linked ts a, Attribute t a) (Linked (t : ts) a)+    h (a `With` ts, Attribute t a) (a `With` (t : ts))  {- | @Gets h ts a@ is equivalent to @(Get h t1 a, Get h t2 a, ..., Get  h tn a)@ where @ts = [t1, t2, ..., tn]@.@@ -91,96 +122,125 @@   Sets h '[] a = ()   Sets h (t : ts) a = (Set h t a, Sets h ts a) --- | A value linked with a type-level list of traits.-data Linked (ts :: [Type]) a = Linked-  { linkAttribute :: !(LinkedAttributes ts a)-  , unlink :: !a-  -- ^ Retrive the value from a linked value+{- | A value associated with a list of traits, referred to as a+witnessed value. Typically, this is used as an infix type constructor:++@+a \`With\` ts+@++where @a@ is a value and @ts@ is a list of traits associated with+that value.++If @t@ is a type present in the list of types @ts@, it is possible to+extract its attribute from a witnessed value:++@+let witnessedValue :: a \`With\` ts+    witnessedValue = ...++let attr :: `Attribute` t a+    attr = `pick` \@t (`from` witnessedValue)+@+-}+data With a (ts :: [Type]) = With+  { attribute :: !(WitnessedAttribute ts a)+  , unwitness :: !a+  -- ^ Retrieve the value   } -type family LinkedAttributes (ts :: [Type]) (a :: Type) where-  LinkedAttributes '[] a = ()-  LinkedAttributes (t : ts) a = (Attribute t a, LinkedAttributes ts a)+type family WitnessedAttribute (ts :: [Type]) (a :: Type) where+  WitnessedAttribute '[] a = ()+  WitnessedAttribute (t : ts) a = (Attribute t a, WitnessedAttribute ts a) --- | Wrap a value with an empty list of traits.-linkzero :: a -> Linked '[] a-linkzero = Linked ()-{-# INLINE linkzero #-}+-- | Lift a value to a witnessed value having no associated traits.+wzero :: a -> a `With` '[]+wzero = With ()+{-# INLINE wzero #-}  -- | Forget the head trait-linkminus :: Linked (t : ts) a -> Linked ts a-linkminus (Linked (_, rv) a) = Linked rv a-{-# INLINE linkminus #-}+wminus :: a `With` (t : ts) -> a `With` ts+wminus (With (_, rv) a) = With rv a+{-# INLINE wminus #-} -{- | Attempt to link an additional trait with an already linked- value. This can fail indicating an 'Absence' of the trait.+{- | Attempt to witness an additional trait with a witnessed value. This+ can fail indicating an 'Absence' of the trait. -} probe ::   forall t ts h a.-  Get h t a =>+  (Get h t a) =>   t ->-  h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))+  h (a `With` ts) (Either (Absence t a) (a `With` (t : ts))) probe t = proc l -> do   res <- getTrait t -< l-  arr link -< (l, res)+  arr add -< (l, res)   where-    link :: (Linked ts a, Either e (Attribute t a)) -> Either e (Linked (t : ts) a)-    link (_, Left e) = Left e-    link (Linked{..}, Right attr) = Right $ Linked{linkAttribute = (attr, linkAttribute), ..}+    add :: (a `With` ts, Either e (Attribute t a)) -> Either e (a `With` (t : ts))+    add (_, Left e) = Left e+    add (With{..}, Right attr) = Right $ With{attribute = (attr, attribute), ..} {-# INLINE probe #-} -{- | Set a trait attribute on linked value to produce another linked- value+{- | Set a trait attribute on witnessed value to produce another+   witnessed value with the additional trait attached to it. -}-plant :: forall t ts h a. Set h t a => t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)+plant ::+  forall t ts h a.+  (Set h t a) =>+  t ->+  h (a `With` ts, Attribute t a) (a `With` (t : ts)) plant t = proc (l, attr) -> do-  setTrait t link -< (l, attr)+  setTrait t add -< (l, attr)   where-    link :: Linked ts a -> a -> Attribute t a -> Linked (t : ts) a-    link Linked{..} a' attr = Linked{linkAttribute = (attr, linkAttribute), unlink = a'}+    add :: a `With` ts -> a -> Attribute t a -> a `With` (t : ts)+    add With{..} a' attr = With{attribute = (attr, attribute), unwitness = a'} {-# INLINE plant #-}  {- | Constraint that proves that the trait @t@ is present in the list  of traits @ts@. -} class HasTrait t ts where-  -- | Get the attribute associated with @t@ from a linked value. See also: 'pick'.-  from :: Linked ts a -> Tagged t (Attribute t a)+  -- | Get the attribute associated with @t@ from a witnessed+  -- value. See also: 'pick'.+  from :: a `With` ts -> Tagged t (Attribute t a)  instance HasTrait t (t : ts) where-  from :: Linked (t : ts) a -> Tagged t (Attribute t a)-  from (Linked (lv, _) _) = Tagged lv+  from :: a `With` (t : ts) -> Tagged t (Attribute t a)+  from (With (lv, _) _) = Tagged lv   {-# INLINE from #-} -instance {-# OVERLAPPABLE #-} HasTrait t ts => HasTrait t (t' : ts) where-  from :: Linked (t' : ts) a -> Tagged t (Attribute t a)-  from l = from $ linkminus l+instance {-# OVERLAPPABLE #-} (HasTrait t ts) => HasTrait t (t' : ts) where+  from :: a `With` (t' : ts) -> Tagged t (Attribute t a)+  from l = from $ wminus l   {-# INLINE from #-}  {- | Retrieve a trait. - @pick@ is used along with `from` to retrieve an attribute from a- linked value:+ @pick@ is used along with 'from' to retrieve an attribute from a+ witnessed value: - > pick @t $ from val+ @+ pick @t (`from` val)+ @ -} pick :: Tagged t a -> a pick = untag {-# INLINE pick #-}  -- For better type errors-instance TypeError (MissingTrait t) => HasTrait t '[] where+instance (TypeError (MissingTrait t)) => HasTrait t '[] where   from = undefined  -- | Type error for nicer UX of missing traits type MissingTrait t =-  Text "The request doesn't have the trait ‘" :<>: ShowType t :<>: Text "’."+  Text "The value doesn't have the ‘"+    :<>: ShowType t+    :<>: Text "’ trait."     :$$: Text ""-    :$$: Text "Did you use a wrong trait type?"-    :$$: Text "For e.g., ‘QueryParam \"foo\" Int’ instead of ‘QueryParam \"foo\" String’?"+    :$$: Text "Did you forget to apply an appropriate middleware?"+    :$$: Text "For e.g. The trait ‘Body JSON t’ requires ‘requestBody @t JSON’ middleware."     :$$: Text ""-    :$$: Text "Or did you forget to apply an appropriate middleware?"-    :$$: Text "For e.g. The trait ‘JSONBody t’ can be used with ‘jsonRequestBody @t’ middleware."+    :$$: Text "or did you use a wrong trait type?"+    :$$: Text "For e.g., ‘RequiredQueryParam \"foo\" Int’ instead of ‘RequiredQueryParam \"foo\" String’?"     :$$: Text ""  {- | Constraint that proves that all the traits in the list @ts@ are

@@ -22,7 +22,7 @@  For example, given this handler:   @- myHandler :: ('Handler' h IO, 'HasTrait' ('BasicAuth' IO () 'Credentials') req) => 'RequestHandler' h req+ myHandler :: ('Handler' h IO, 'HasTrait' ('BasicAuth' IO () 'Credentials') ts) => 'RequestHandler' h ts  myHandler = ....  @ @@ -32,10 +32,10 @@  authConfig :: 'BasicAuth' IO () 'Credentials'  authConfig = 'BasicAuth'' { toBasicAttribute = pure . Right } - type ErrorTraits = [Status, RequiredHeader \"Content-Type\" Text, RequiredHeader \"WWW-Authenticate\" Text, Body Text]+ type ErrorTraits = [Status, RequiredRequestHeader \"Content-Type\" Text, RequiredRequestHeader \"WWW-Authenticate\" Text, Body Text]   errorHandler :: ('Handler' h IO, Sets h ErrorTraits Response)-              => h (Linked req Request, 'BasicAuthError' e) Response+              => h (Request \`With\` ts, 'BasicAuthError' e) Response  errorHandler = 'respondUnauthorized' \"Basic\" \"MyRealm\"  @ @@ -43,7 +43,7 @@   @  myHandlerWithAuth :: ('Handler' h IO, Get h ('BasicAuth' IO () 'Credentials') Request, Sets h ErrorTraits Response)-                   => 'RequestHandler' h req+                   => 'RequestHandler' h ts  myHandlerWithAuth = 'basicAuth' authConfig errorHandler myHandler  @ @@ -92,8 +92,8 @@  -- | Trait for HTTP basic authentication: https://tools.ietf.org/html/rfc7617 newtype BasicAuth' (x :: Existence) (scheme :: Symbol) m e a = BasicAuth'-  { -- | Convert the credentials to the trait attribute or an error-    toBasicAttribute :: Credentials -> m (Either e a)+  { toBasicAttribute :: Credentials -> m (Either e a)+  -- ^ Convert the credentials to the trait attribute or an error   }  -- | Trait for HTTP basic authentication with the "Basic" scheme.@@ -139,8 +139,8 @@ basicAuthMiddleware ::   (Get h (BasicAuth' x scheme m e t) Request, ArrowChoice h) =>   BasicAuth' x scheme m e t ->-  h (Linked req Request, Absence (BasicAuth' x scheme m e t) Request) Response ->-  Middleware h req (BasicAuth' x scheme m e t : req)+  h (Request `With` ts, Absence (BasicAuth' x scheme m e t) Request) Response ->+  Middleware h ts (BasicAuth' x scheme m e t : ts) basicAuthMiddleware authCfg errorHandler nextHandler =   proc request -> do     result <- probe authCfg -< request@@ -160,13 +160,13 @@  retrieved successfully. -} basicAuth ::-  forall m e t h req.+  forall m e t h ts.   (Get h (BasicAuth' Required "Basic" m e t) Request, ArrowChoice h) =>   -- | Authentication configuration   BasicAuth m e t ->   -- | Error handler-  h (Linked req Request, BasicAuthError e) Response ->-  Middleware h req (BasicAuth m e t : req)+  h (Request `With` ts, BasicAuthError e) Response ->+  Middleware h ts (BasicAuth m e t : ts) basicAuth = basicAuth' {-# INLINE basicAuth #-} @@ -177,13 +177,13 @@  > basicAuth' @"scheme" cfg errorHandler nextHandler -} basicAuth' ::-  forall scheme m e t h req.+  forall scheme m e t h ts.   (Get h (BasicAuth' Required scheme m e t) Request, ArrowChoice h) =>   -- | Authentication configuration   BasicAuth' Required scheme m e t ->   -- | Error handler-  h (Linked req Request, BasicAuthError e) Response ->-  Middleware h req (BasicAuth' Required scheme m e t : req)+  h (Request `With` ts, BasicAuthError e) Response ->+  Middleware h ts (BasicAuth' Required scheme m e t : ts) basicAuth' = basicAuthMiddleware {-# INLINE basicAuth' #-} @@ -199,11 +199,11 @@  authentication error appropriately. -} optionalBasicAuth ::-  forall m e t h req.+  forall m e t h ts.   (Get h (BasicAuth' Optional "Basic" m e t) Request, ArrowChoice h) =>   -- | Authentication configuration   BasicAuth' Optional "Basic" m e t ->-  Middleware h req (BasicAuth' Optional "Basic" m e t : req)+  Middleware h ts (BasicAuth' Optional "Basic" m e t : ts) optionalBasicAuth = optionalBasicAuth' {-# INLINE optionalBasicAuth #-} @@ -215,10 +215,10 @@  > optionalBasicAuth' @"scheme" cfg nextHandler -} optionalBasicAuth' ::-  forall scheme m e t h req.+  forall scheme m e t h ts.   (Get h (BasicAuth' Optional scheme m e t) Request, ArrowChoice h) =>   -- | Authentication configuration   BasicAuth' Optional scheme m e t ->-  Middleware h req (BasicAuth' Optional scheme m e t : req)+  Middleware h ts (BasicAuth' Optional scheme m e t : ts) optionalBasicAuth' cfg = basicAuthMiddleware cfg $ arr (absurd . snd) {-# INLINE optionalBasicAuth' #-}

@@ -9,7 +9,7 @@   respondUnauthorized, ) where -import Control.Arrow (returnA, (<<<))+import Control.Arrow (returnA) import Data.ByteString (ByteString, drop) import Data.ByteString.Char8 (break) import Data.CaseInsensitive (CI, mk, original)@@ -19,20 +19,20 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Void (absurd) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)-import qualified Network.HTTP.Types as HTTP import Web.HttpApiData (FromHttpApiData (..))-import WebGear.Core.Handler (Handler, unlinkA)+import WebGear.Core.Handler (Handler, unwitnessA, (>->))+import WebGear.Core.MIMETypes (PlainText (..)) import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) import WebGear.Core.Request (Request) import WebGear.Core.Response (Response)-import WebGear.Core.Trait (Get (..), Linked, Sets)-import WebGear.Core.Trait.Body (Body, respondA)-import WebGear.Core.Trait.Header (Header (..), RequiredHeader, setHeader)-import WebGear.Core.Trait.Status (Status)+import WebGear.Core.Trait (Get (..), Sets, With)+import WebGear.Core.Trait.Body (Body, setBody)+import WebGear.Core.Trait.Header (RequestHeader (..), RequiredResponseHeader, setHeader)+import WebGear.Core.Trait.Status (Status, unauthorized401) import Prelude hiding (break, drop)  -- | Trait for \"Authorization\" header-type AuthorizationHeader scheme = Header Optional Lenient "Authorization" (AuthToken scheme)+type AuthorizationHeader scheme = RequestHeader Optional Lenient "Authorization" (AuthToken scheme)  {- | Extract the \"Authorization\" header from a request by specifying    an authentication scheme.@@ -41,10 +41,10 @@ -} getAuthorizationHeaderTrait ::   forall scheme h ts.-  Get h (AuthorizationHeader scheme) Request =>-  h (Linked ts Request) (Maybe (Either Text (AuthToken scheme)))+  (Get h (AuthorizationHeader scheme) Request) =>+  h (Request `With` ts) (Maybe (Either Text (AuthToken scheme))) getAuthorizationHeaderTrait = proc request -> do-  result <- getTrait (Header :: Header Optional Lenient "Authorization" (AuthToken scheme)) -< request+  result <- getTrait (RequestHeader :: RequestHeader Optional Lenient "Authorization" (AuthToken scheme)) -< request   returnA -< either absurd id result {-# INLINE getAuthorizationHeaderTrait #-} @@ -54,13 +54,13 @@  -- | The components of Authorization request header data AuthToken (scheme :: Symbol) = AuthToken-  { -- | Authentication scheme-    authScheme :: CI ByteString-  , -- | Authentication token-    authToken :: ByteString+  { authScheme :: CI ByteString+  -- ^ Authentication scheme+  , authToken :: ByteString+  -- ^ Authentication token   } -instance KnownSymbol scheme => FromHttpApiData (AuthToken scheme) where+instance (KnownSymbol scheme) => FromHttpApiData (AuthToken scheme) where   parseUrlPiece = parseHeader . encodeUtf8    {-# INLINE parseHeader #-}@@ -83,9 +83,9 @@   , Sets       h       [ Status-      , RequiredHeader "Content-Type" Text-      , RequiredHeader "WWW-Authenticate" Text-      , Body Text+      , RequiredResponseHeader "Content-Type" Text+      , RequiredResponseHeader "WWW-Authenticate" Text+      , Body PlainText Text       ]       Response   ) =>@@ -96,8 +96,8 @@   h a Response respondUnauthorized scheme (Realm realm) = proc _ -> do   let headerVal = decodeUtf8 $ original scheme <> " realm=\"" <> realm <> "\""-  unlinkA-    <<< setHeader @"WWW-Authenticate" (respondA HTTP.unauthorized401 "text/plain")-    -<-      (headerVal, "Unauthorized" :: Text)+  (unauthorized401 -< ())+    >-> (\resp -> setBody PlainText -< (resp, "Unauthorized" :: Text))+    >-> (\resp -> setHeader @"WWW-Authenticate" -< (resp, headerVal))+    >-> (\resp -> unwitnessA -< resp) {-# INLINE respondUnauthorized #-}

@@ -22,7 +22,7 @@  For example, given this handler:   @- myHandler :: ('Handler' h IO, 'HasTrait' ('JWTAuth' IO () 'JWT.ClaimsSet') req) => 'RequestHandler' h req+ myHandler :: ('Handler' h IO, 'HasTrait' ('JWTAuth' IO () 'JWT.ClaimsSet') ts) => 'RequestHandler' h ts  myHandler = ....  @ @@ -36,10 +36,10 @@    , toJWTAttribute = pure . Right    } - type ErrorTraits = [Status, RequiredHeader \"Content-Type\" Text, RequiredHeader \"WWW-Authenticate\" Text, Body Text]+ type ErrorTraits = [Status, RequiredRequestHeader \"Content-Type\" Text, RequiredRequestHeader \"WWW-Authenticate\" Text, Body Text]   errorHandler :: ('Handler' h IO, Sets h ErrorTraits Response)-              => h (Linked req Request, 'JWTAuthError' e) Response+              => h (Request \`With\` ts, 'JWTAuthError' e) Response  errorHandler = 'respondUnauthorized' \"Bearer\" \"MyRealm\"  @ @@ -47,7 +47,7 @@   @  myHandlerWithAuth :: ('Handler' h IO, Get h ('JWTAuth' IO () 'JWT.ClaimsSet') Request, Sets h ErrorTraits Response)-                   => 'RequestHandler' h req+                   => 'RequestHandler' h ts  myHandlerWithAuth = 'jwtAuth' authConfig errorHandler myHandler  @ @@ -97,12 +97,12 @@  \"Bearer\" scheme. -} data JWTAuth' (x :: Existence) (scheme :: Symbol) m e a = JWTAuth'-  { -- | Settings to validate the JWT-    jwtValidationSettings :: JWT.JWTValidationSettings-  , -- | JWK to validate the JWT-    jwkSet :: JWT.JWKSet-  , -- | Convert the claims set to the trait attribute or an error-    toJWTAttribute :: JWT.ClaimsSet -> m (Either e a)+  { jwtValidationSettings :: JWT.JWTValidationSettings+  -- ^ Settings to validate the JWT+  , jwkSet :: JWT.JWKSet+  -- ^ JWK to validate the JWT+  , toJWTAttribute :: JWT.ClaimsSet -> m (Either e a)+  -- ^ Convert the claims set to the trait attribute or an error   }  -- | Trait for JWT authentication with the \"Bearer\" scheme@@ -116,16 +116,16 @@   | JWTAuthAttributeError e   deriving stock (Eq, Show) -instance WebGear.Core.Trait.Trait (JWTAuth' Required scheme m e a) Request where+instance Trait (JWTAuth' Required scheme m e a) Request where   type Attribute (JWTAuth' Required scheme m e a) Request = a -instance WebGear.Core.Trait.TraitAbsence (JWTAuth' Required scheme m e a) Request where+instance TraitAbsence (JWTAuth' Required scheme m e a) Request where   type Absence (JWTAuth' Required scheme m e a) Request = JWTAuthError e -instance WebGear.Core.Trait.Trait (JWTAuth' Optional scheme m e a) Request where+instance Trait (JWTAuth' Optional scheme m e a) Request where   type Attribute (JWTAuth' Optional scheme m e a) Request = Either (JWTAuthError e) a -instance WebGear.Core.Trait.TraitAbsence (JWTAuth' Optional scheme m e a) Request where+instance TraitAbsence (JWTAuth' Optional scheme m e a) Request where   type Absence (JWTAuth' Optional scheme m e a) Request = Void  {- | Middleware to add JWT authentication protection for a@@ -143,14 +143,14 @@  retrieved successfully. -} jwtAuth ::-  ( WebGear.Core.Trait.Get h (JWTAuth m e t) Request+  ( Get h (JWTAuth m e t) Request   , ArrowChoice h   ) =>   -- | Authentication configuration   JWTAuth m e t ->   -- | Error handler-  h (WebGear.Core.Trait.Linked req Request, JWTAuthError e) Response ->-  Middleware h req (JWTAuth m e t : req)+  h (Request `With` ts, JWTAuthError e) Response ->+  Middleware h ts (JWTAuth m e t : ts) jwtAuth = jwtAuth' @"Bearer" {-# INLINE jwtAuth #-} @@ -170,26 +170,26 @@  authentication error appropriately. -} optionalJWTAuth ::-  ( WebGear.Core.Trait.Get h (JWTAuth' Optional "Bearer" m e t) Request+  ( Get h (JWTAuth' Optional "Bearer" m e t) Request   , ArrowChoice h   ) =>   -- | Authentication configuration   JWTAuth' Optional "Bearer" m e t ->-  Middleware h req (JWTAuth' Optional "Bearer" m e t : req)+  Middleware h ts (JWTAuth' Optional "Bearer" m e t : ts) optionalJWTAuth = optionalJWTAuth' @"Bearer" {-# INLINE optionalJWTAuth #-}  jwtAuthMiddleware ::-  forall s e t x h m req.-  ( WebGear.Core.Trait.Get h (JWTAuth' x s m e t) Request+  forall s e t x h m ts.+  ( Get h (JWTAuth' x s m e t) Request   , ArrowChoice h   ) =>   JWTAuth' x s m e t ->-  h (WebGear.Core.Trait.Linked req Request, WebGear.Core.Trait.Absence (JWTAuth' x s m e t) Request) Response ->-  Middleware h req (JWTAuth' x s m e t : req)+  h (Request `With` ts, Absence (JWTAuth' x s m e t) Request) Response ->+  Middleware h ts (JWTAuth' x s m e t : ts) jwtAuthMiddleware authCfg errorHandler nextHandler =   proc request -> do-    result <- WebGear.Core.Trait.probe authCfg -< request+    result <- probe authCfg -< request     case result of       Left err -> errorHandler -< (request, err)       Right val -> nextHandler -< val@@ -210,15 +210,15 @@  retrieved successfully. -} jwtAuth' ::-  forall s e t h m req.-  ( WebGear.Core.Trait.Get h (JWTAuth' Required s m e t) Request+  forall s e t h m ts.+  ( Get h (JWTAuth' Required s m e t) Request   , ArrowChoice h   ) =>   -- | Authentication configuration   JWTAuth' Required s m e t ->   -- | Error handler-  h (WebGear.Core.Trait.Linked req Request, JWTAuthError e) Response ->-  Middleware h req (JWTAuth' Required s m e t : req)+  h (Request `With` ts, JWTAuthError e) Response ->+  Middleware h ts (JWTAuth' Required s m e t : ts) jwtAuth' = jwtAuthMiddleware {-# INLINE jwtAuth' #-} @@ -238,12 +238,12 @@  authentication error appropriately. -} optionalJWTAuth' ::-  forall s e t h m req.-  ( WebGear.Core.Trait.Get h (JWTAuth' Optional s m e t) Request+  forall s e t h m ts.+  ( Get h (JWTAuth' Optional s m e t) Request   , ArrowChoice h   ) =>   -- | Authentication configuration   JWTAuth' Optional s m e t ->-  Middleware h req (JWTAuth' Optional s m e t : req)+  Middleware h ts (JWTAuth' Optional s m e t : ts) optionalJWTAuth' cfg = jwtAuthMiddleware cfg $ arr (absurd . snd) {-# INLINE optionalJWTAuth' #-}

@@ -1,86 +1,70 @@ {- | Traits and middlewares to handle request and response body    payloads. - There are a number of ways to extract a body from a request:-  The 'requestBody' middleware attempts to convert the body to a  Haskell value or invoke an error handler if that fails. - The 'jsonRequestBody' middleware attempts to convert a JSON- formatted body to a Haskell value or invoke an error handler if that- fails. It uses the standard "application/json" media type.-- The 'jsonRequestBody'' middleware is similar but supports custom- media types.-- Similarly, there are a number of ways to set a response body:-- The easiest option is to use one of 'respondA', 'respondJsonA', or- 'respondJsonA'' middlewares. These middlewares generate a response- from an HTTP status and a response body.+ The 'respondA' middleware generates a response from an HTTP status+ and a response body. - If you need finer control over setting the body, use one of- 'setBody', 'setBodyWithoutContentType', 'setJSONBody',- 'setJSONBodyWithoutContentType', or 'setJSONBody''. These arrows- accept a linked response and a body and sets the body in the- response. You can generate an input response object using functions- from "WebGear.Core.Trait.Status" module.+ If you need finer control over setting the body, use 'setBody' or+ 'setBodyWithoutContentType'. These arrows accept a witnessed response+ and a body and sets the body in the response. You can generate an+ input response object using functions from+ "WebGear.Core.Trait.Status" module. -} module WebGear.Core.Trait.Body (   -- * Traits   Body (..),-  JSONBody (..),+  UnknownContentBody (..),    -- * Middlewares   requestBody,-  jsonRequestBody',-  jsonRequestBody,   respondA,-  respondJsonA,-  respondJsonA',   setBody,   setBodyWithoutContentType,-  setJSONBody,-  setJSONBodyWithoutContentType,-  setJSONBody', ) where -import Control.Arrow (ArrowChoice)+import Control.Arrow ((<<<)) import Data.Kind (Type) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) import qualified Network.HTTP.Media as HTTP import qualified Network.HTTP.Types as HTTP-import WebGear.Core.Handler (Middleware)+import WebGear.Core.Handler (Handler (..), Middleware, unwitnessA)+import WebGear.Core.MIMETypes (MIMEType (..)) import WebGear.Core.Request (Request)-import WebGear.Core.Response (Response)-import WebGear.Core.Trait (Get, Linked, Set, Sets, Trait (..), TraitAbsence (..), plant, probe)-import WebGear.Core.Trait.Header (Header (..), RequiredHeader)+import WebGear.Core.Response (Response, ResponseBody)+import WebGear.Core.Trait (+  Get,+  Set,+  Sets,+  Trait (..),+  TraitAbsence (..),+  With (..),+  plant,+  probe,+ )+import WebGear.Core.Trait.Header (RequiredResponseHeader, ResponseHeader (..)) import WebGear.Core.Trait.Status (Status, mkResponse) --- | Request or response body with a type @t@.-newtype Body (t :: Type) = Body (Maybe HTTP.MediaType)--instance Trait (Body t) Request where-  type Attribute (Body t) Request = t--instance TraitAbsence (Body t) Request where-  type Absence (Body t) Request = Text+-- | Request or response body with MIME types @mimeTypes@ and type @t@.+newtype Body (mimeType :: Type) (t :: Type) = Body mimeType -instance Trait (Body t) Response where-  type Attribute (Body t) Response = t+instance Trait (Body mt t) Request where+  type Attribute (Body mt t) Request = t --- | A 'Trait' for converting a JSON formatted body into a value.-newtype JSONBody (t :: Type) = JSONBody (Maybe HTTP.MediaType)+instance TraitAbsence (Body mt t) Request where+  type Absence (Body mt t) Request = Text -instance Trait (JSONBody t) Request where-  type Attribute (JSONBody t) Request = t+instance Trait (Body mt t) Response where+  type Attribute (Body mt t) Response = t -instance TraitAbsence (JSONBody t) Request where-  type Absence (JSONBody t) Request = Text+-- | Type representing responses without a statically known MIME type+data UnknownContentBody = UnknownContentBody -instance Trait (JSONBody t) Response where-  type Attribute (JSONBody t) Response = t+instance Trait UnknownContentBody Response where+  type Attribute UnknownContentBody Response = ResponseBody  {- | Middleware to extract a request body. @@ -89,175 +73,89 @@   Usage: - > requestBody @t (Just "text/plain") errorHandler nextHandler+@+ requestBody \@'Text' 'PlainText' errorHandler nextHandler+@ -} requestBody ::-  forall t h req.-  (Get h (Body t) Request, ArrowChoice h) =>-  -- | Optional media type of the body-  Maybe HTTP.MediaType ->+  forall t mt h m ts.+  ( Handler h m+  , Get h (Body mt t) Request+  ) =>+  mt ->   -- | Error handler in case body cannot be retrieved-  h (Linked req Request, Text) Response ->-  Middleware h req (Body t : req)-requestBody mediaType errorHandler nextHandler = proc request -> do-  result <- probe (Body mediaType) -< request+  h (Request `With` ts, Text) Response ->+  Middleware h ts (Body mt t : ts)+requestBody mt errorHandler nextHandler = proc request -> do+  result <- probe (Body mt) -< request   case result of     Left err -> errorHandler -< (request, err)     Right t -> nextHandler -< t {-# INLINE requestBody #-} -{- | Parse the request body as JSON and convert it to a value of type-   @t@.+{- | Set the response body along with a media type. - The @nextHandler@ is invoked when the body is parsed successfully and- the @errorHandler@ is invoked when there is a parsing failure.+ The MIME type @mt@ is used to set the "Content-Type" header in the+ response.   Usage: - > jsonRequestBody @t errorHandler nextHandler--}-jsonRequestBody' ::-  forall t h req.-  (Get h (JSONBody t) Request, ArrowChoice h) =>-  -- | Optional media type of the body-  Maybe HTTP.MediaType ->-  -- | Error handler in case body cannot be retrieved-  h (Linked req Request, Text) Response ->-  Middleware h req (JSONBody t : req)-jsonRequestBody' mediaType errorHandler nextHandler = proc request -> do-  result <- probe (JSONBody mediaType) -< request-  case result of-    Left err -> errorHandler -< (request, err)-    Right t -> nextHandler -< t-{-# INLINE jsonRequestBody' #-}---- | Same as 'jsonRequestBody'' but with a media type @application/json@.-jsonRequestBody ::-  forall t h req.-  (Get h (JSONBody t) Request, ArrowChoice h) =>-  -- | error handler-  h (Linked req Request, Text) Response ->-  Middleware h req (JSONBody t : req)-jsonRequestBody = jsonRequestBody' (Just "application/json")-{-# INLINE jsonRequestBody #-}--{- | Set the response body along with a media type.--  The media type value is used to set the "Content-Type" header in the response.+@+ let body :: SomeJSONType = ...+ response' <- setBody 'JSON' -< (response, body)+@ -} setBody ::-  forall body a h ts.-  Sets h [Body body, RequiredHeader "Content-Type" Text] Response =>-  -- | The media type of the response body-  HTTP.MediaType ->-  h a (Linked ts Response) ->-  h (body, a) (Linked (RequiredHeader "Content-Type" Text : Body body : ts) Response)-setBody mediaType prevHandler = proc (body, a) -> do-  r <- prevHandler -< a-  r' <- plant (Body (Just mediaType)) -< (r, body)-  let mt = decodeUtf8 $ HTTP.renderHeader mediaType-  plant Header -< (r', mt)+  forall body mt h ts.+  ( Sets h [Body mt body, RequiredResponseHeader "Content-Type" Text] Response+  , MIMEType mt+  ) =>+  mt ->+  h (Response `With` ts, body) (Response `With` (Body mt body : RequiredResponseHeader "Content-Type" Text : ts))+setBody mt = proc (response, body) -> do+  let ct = mimeType mt+  response' <- plant ResponseHeader -< (response, decodeUtf8 $ HTTP.renderHeader ct)+  plant (Body mt) -< (response', body) {-# INLINE setBody #-} --- | Set the response body without specifying any media type.-setBodyWithoutContentType ::-  forall body a h ts.-  Set h (Body body) Response =>-  h a (Linked ts Response) ->-  h (body, a) (Linked (Body body : ts) Response)-setBodyWithoutContentType prevHandler = proc (body, a) -> do-  r <- prevHandler -< a-  plant (Body Nothing) -< (r, body)-{-# INLINE setBodyWithoutContentType #-}+{- | Set the response body without specifying any media type. -{- | Set the response body to a JSON value along with a media type.+Usage: -  The media type value is used to set the "Content-Type" header in the response.+@+ let body :: ResponseBody = ...+ response' <- setBodyWithoutContentType -< (response, body)+@ -}-setJSONBody' ::-  forall body a h ts.-  Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response =>-  -- | The media type of the response body-  HTTP.MediaType ->-  h a (Linked ts Response) ->-  h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)-setJSONBody' mediaType prevHandler = proc (body, a) -> do-  r <- prevHandler -< a-  r' <- plant (JSONBody (Just mediaType)) -< (r, body)-  let mt = decodeUtf8 $ HTTP.renderHeader mediaType-  plant Header -< (r', mt)-{-# INLINE setJSONBody' #-}--{- | Set the response body to a JSON value.+setBodyWithoutContentType ::+  forall h ts.+  (Set h UnknownContentBody Response) =>+  h (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts))+setBodyWithoutContentType = plant UnknownContentBody+{-# INLINE setBodyWithoutContentType #-} -  The "Content-Type" header will be set to "application/json".--}-setJSONBody ::-  forall body a h ts.-  Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response =>-  h a (Linked ts Response) ->-  h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response)-setJSONBody = setJSONBody' "application/json"-{-# INLINE setJSONBody #-}+{- | A convenience arrow to generate a response specifying a status and body. -{- | Set the response body to a JSON value without specifying any- media type.--}-setJSONBodyWithoutContentType ::-  forall body a h ts.-  Set h (JSONBody body) Response =>-  h a (Linked ts Response) ->-  h (body, a) (Linked (JSONBody body : ts) Response)-setJSONBodyWithoutContentType prevHandler = proc (body, a) -> do-  r <- prevHandler -< a-  plant (JSONBody Nothing) -< (r, body)-{-# INLINE setJSONBodyWithoutContentType #-}+ The "Content-Type" header will be set to the value specified by @mt@. -{- | A convenience arrow to generate a response specifying a status and body.+ Usage: - The "Content-Type" header will be set to the specified media type- value.+@+ let body :: SomeJSONType = ...+ respondA 'HTTP.ok200' 'JSON' -< body+@ -} respondA ::-  forall body h.-  Sets h [Status, Body body, RequiredHeader "Content-Type" Text] Response =>+  forall body mt h m.+  ( Handler h m+  , Sets h [Status, Body mt body, RequiredResponseHeader "Content-Type" Text] Response+  , MIMEType mt+  ) =>   -- | Response status   HTTP.Status ->-  -- | Media type of the response body-  HTTP.MediaType ->-  h body (Linked [RequiredHeader "Content-Type" Text, Body body, Status] Response)-respondA status mediaType = proc body ->-  setBody mediaType (mkResponse status) -< (body, ())+  mt ->+  h body Response+respondA status mt = proc body -> do+  response <- mkResponse status -< ()+  unwitnessA <<< setBody mt -< (response, body) {-# INLINE respondA #-}--{- | A convenience arrow to generate a response specifying a status and-   JSON body.-- The "Content-Type" header will be set to "application/json".--}-respondJsonA ::-  forall body h.-  Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response =>-  -- | Response status-  HTTP.Status ->-  h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response)-respondJsonA status = respondJsonA' status "application/json"-{-# INLINE respondJsonA #-}--{- | A convenience arrow to generate a response specifying a status and-   JSON body.-- The "Content-Type" header will be set to the specified media type- value.--}-respondJsonA' ::-  forall body h.-  Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response =>-  -- | Response status-  HTTP.Status ->-  -- | Media type of the response body-  HTTP.MediaType ->-  h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response)-respondJsonA' status mediaType = proc body ->-  setJSONBody' mediaType (mkResponse status) -< (body, ())-{-# INLINE respondJsonA' #-}

@@ -0,0 +1,135 @@+-- | Traits and middlewares to handle cookies in requests and responses.+module WebGear.Core.Trait.Cookie (+  -- * Traits+  Cookie (..),+  CookieNotFound (..),+  CookieParseError (..),+  SetCookie (..),++  -- * Middlewares+  cookie,+  optionalCookie,+  setCookie,+  setOptionalCookie,+) where++import Control.Arrow (ArrowChoice)+import Data.Kind (Type)+import Data.Text (Text)+import GHC.TypeLits (Symbol)+import qualified Web.Cookie as Cookie+import WebGear.Core.Handler (Middleware)+import WebGear.Core.Modifiers (Existence (..))+import WebGear.Core.Request (Request)+import WebGear.Core.Response (Response)+import WebGear.Core.Trait (Get, Set, Trait (..), TraitAbsence (..), With, plant, probe)++-- | Indicates a missing cookie+data CookieNotFound = CookieNotFound+  deriving stock (Read, Show, Eq)++-- | Error in converting a cookie to the expected type+newtype CookieParseError = CookieParseError Text+  deriving stock (Read, Show, Eq)++-- | Trait for a cookie in HTTP requests+data Cookie (e :: Existence) (name :: Symbol) (val :: Type) = Cookie++instance Trait (Cookie Required name val) Request where+  type Attribute (Cookie Required name val) Request = val++instance TraitAbsence (Cookie Required name val) Request where+  type Absence (Cookie Required name val) Request = Either CookieNotFound CookieParseError++instance Trait (Cookie Optional name val) Request where+  type Attribute (Cookie Optional name val) Request = Maybe val++instance TraitAbsence (Cookie Optional name val) Request where+  type Absence (Cookie Optional name val) Request = CookieParseError++cookieHandler ::+  forall name val e h ts.+  (Get h (Cookie e name val) Request, ArrowChoice h) =>+  -- | error handler+  h (Request `With` ts, Absence (Cookie e name val) Request) Response ->+  Middleware h ts (Cookie e name val : ts)+cookieHandler errorHandler nextHandler = proc request -> do+  result <- probe Cookie -< request+  case result of+    Left err -> errorHandler -< (request, err)+    Right val -> nextHandler -< val+{-# INLINE cookieHandler #-}++{- | Extract a cookie and convert it to a value of type @val@.++ The associated trait attribute has type @val@.++ Example usage:++ > cookie @"name" @Integer errorHandler okHandler+-}+cookie ::+  forall name val h ts.+  (Get h (Cookie Required name val) Request, ArrowChoice h) =>+  -- | Error handler+  h (Request `With` ts, Either CookieNotFound CookieParseError) Response ->+  Middleware h ts (Cookie Required name val : ts)+cookie = cookieHandler+{-# INLINE cookie #-}++{- | Extract an optional cookie and convert it to a value of type @val@.++ The associated trait attribute has type @Maybe val@; a @Nothing@+ value indicates that the cookie is missing from the request.++ Example usage:++ > optionalCookie @"name" @Integer errorHandler okHandler+-}+optionalCookie ::+  forall name val h ts.+  (Get h (Cookie Optional name val) Request, ArrowChoice h) =>+  -- | Error handler+  h (Request `With` ts, CookieParseError) Response ->+  Middleware h ts (Cookie Optional name val : ts)+optionalCookie = cookieHandler+{-# INLINE optionalCookie #-}++-- | Trait for a cookie in HTTP responses+data SetCookie (e :: Existence) (name :: Symbol) = SetCookie++instance Trait (SetCookie Required name) Response where+  type Attribute (SetCookie Required name) Response = Cookie.SetCookie++instance Trait (SetCookie Optional name) Response where+  type Attribute (SetCookie Optional name) Response = Maybe Cookie.SetCookie++{- | Set a cookie value in a response.++ Example usage:++ > response' <- setCookie @"name" -< (response, cookie)+-}+setCookie ::+  forall name h ts.+  (Set h (SetCookie Required name) Response) =>+  h (Response `With` ts, Cookie.SetCookie) (Response `With` (SetCookie Required name : ts))+setCookie = plant SetCookie+{-# INLINE setCookie #-}++{- | Set an optional cookie value in a response.++ Setting the cookie to 'Nothing' will remove it from the response if+ it was previously set. The cookie will be considered as optional in+ all relevant places (such as documentation).++ Example usage:++ > response' <- setOptionalCookie @"name" -< (response, cookie)+-}+setOptionalCookie ::+  forall name h ts.+  (Set h (SetCookie Optional name) Response) =>+  h (Response `With` ts, Maybe Cookie.SetCookie) (Response `With` (SetCookie Optional name : ts))+setOptionalCookie = plant SetCookie+{-# INLINE setOptionalCookie #-}

@@ -21,17 +21,20 @@  indicated in the trait attribute passed to next handler.   A response header can be set using `setHeader` or `setOptionalHeader`- arrows. They accept a linked response and a header value and sets the- header in the response. You can generate an input response object+ arrows. They accept a witnessed response and a header value and sets+ the header in the response. You can generate an input response object  using functions from "WebGear.Core.Trait.Status" module. -} module WebGear.Core.Trait.Header (   -- * Traits-  Header (..),+  RequestHeader (..),   HeaderNotFound (..),   HeaderParseError (..),-  RequiredHeader,-  OptionalHeader,+  RequiredRequestHeader,+  OptionalRequestHeader,+  ResponseHeader (..),+  RequiredResponseHeader,+  OptionalResponseHeader,    -- * Middlewares   header,@@ -51,7 +54,15 @@ import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) import WebGear.Core.Request (Request) import WebGear.Core.Response (Response)-import WebGear.Core.Trait (Get (..), Linked, Set, Trait (..), TraitAbsence (..), plant, probe)+import WebGear.Core.Trait (+  Get (..),+  Set,+  Trait (..),+  TraitAbsence (..),+  With,+  plant,+  probe,+ )  -- | Indicates a missing header data HeaderNotFound = HeaderNotFound@@ -66,46 +77,46 @@  how missing headers and parsing errors are handled. The header name  is compared case-insensitively. -}-data Header (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type) = Header+data RequestHeader (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type) = RequestHeader --- | A `Header` that is required and parsed strictly-type RequiredHeader = Header Required Strict+-- | A `Header` that is required in the request and parsed strictly+type RequiredRequestHeader = RequestHeader Required Strict --- | A `Header` that is optional and parsed strictly-type OptionalHeader = Header Optional Strict+-- | A `Header` that is optional in the request and parsed strictly+type OptionalRequestHeader = RequestHeader Optional Strict -instance Trait (Header Required Strict name val) Request where-  type Attribute (Header Required Strict name val) Request = val+instance Trait (RequestHeader Required Strict name val) Request where+  type Attribute (RequestHeader Required Strict name val) Request = val -instance TraitAbsence (Header Required Strict name val) Request where-  type Absence (Header Required Strict name val) Request = Either HeaderNotFound HeaderParseError+instance TraitAbsence (RequestHeader Required Strict name val) Request where+  type Absence (RequestHeader Required Strict name val) Request = Either HeaderNotFound HeaderParseError -instance Trait (Header Optional Strict name val) Request where-  type Attribute (Header Optional Strict name val) Request = Maybe val+instance Trait (RequestHeader Optional Strict name val) Request where+  type Attribute (RequestHeader Optional Strict name val) Request = Maybe val -instance TraitAbsence (Header Optional Strict name val) Request where-  type Absence (Header Optional Strict name val) Request = HeaderParseError+instance TraitAbsence (RequestHeader Optional Strict name val) Request where+  type Absence (RequestHeader Optional Strict name val) Request = HeaderParseError -instance Trait (Header Required Lenient name val) Request where-  type Attribute (Header Required Lenient name val) Request = Either Text val+instance Trait (RequestHeader Required Lenient name val) Request where+  type Attribute (RequestHeader Required Lenient name val) Request = Either Text val -instance TraitAbsence (Header Required Lenient name val) Request where-  type Absence (Header Required Lenient name val) Request = HeaderNotFound+instance TraitAbsence (RequestHeader Required Lenient name val) Request where+  type Absence (RequestHeader Required Lenient name val) Request = HeaderNotFound -instance Trait (Header Optional Lenient name val) Request where-  type Attribute (Header Optional Lenient name val) Request = Maybe (Either Text val)+instance Trait (RequestHeader Optional Lenient name val) Request where+  type Attribute (RequestHeader Optional Lenient name val) Request = Maybe (Either Text val) -instance TraitAbsence (Header Optional Lenient name val) Request where-  type Absence (Header Optional Lenient name val) Request = Void+instance TraitAbsence (RequestHeader Optional Lenient name val) Request where+  type Absence (RequestHeader Optional Lenient name val) Request = Void  headerHandler ::-  forall name val e p h req.-  (Get h (Header e p name val) Request, ArrowChoice h) =>+  forall name val e p h ts.+  (Get h (RequestHeader e p name val) Request, ArrowChoice h) =>   -- | error handler-  h (Linked req Request, Absence (Header e p name val) Request) Response ->-  Middleware h req (Header e p name val : req)+  h (Request `With` ts, Absence (RequestHeader e p name val) Request) Response ->+  Middleware h ts (RequestHeader e p name val : ts) headerHandler errorHandler nextHandler = proc request -> do-  result <- probe Header -< request+  result <- probe RequestHeader -< request   case result of     Left err -> errorHandler -< (request, err)     Right val -> nextHandler -< val@@ -120,11 +131,11 @@  > header @"Content-Length" @Integer errorHandler okHandler -} header ::-  forall name val h req.-  (Get h (Header Required Strict name val) Request, ArrowChoice h) =>+  forall name val h ts.+  (Get h (RequestHeader Required Strict name val) Request, ArrowChoice h) =>   -- | Error handler-  h (Linked req Request, Either HeaderNotFound HeaderParseError) Response ->-  Middleware h req (Header Required Strict name val : req)+  h (Request `With` ts, Either HeaderNotFound HeaderParseError) Response ->+  Middleware h ts (RequestHeader Required Strict name val : ts) header = headerHandler {-# INLINE header #-} @@ -139,11 +150,11 @@  > optionalHeader @"Content-Length" @Integer errorHandler okHandler -} optionalHeader ::-  forall name val h req.-  (Get h (Header Optional Strict name val) Request, ArrowChoice h) =>+  forall name val h ts.+  (Get h (RequestHeader Optional Strict name val) Request, ArrowChoice h) =>   -- | Error handler-  h (Linked req Request, HeaderParseError) Response ->-  Middleware h req (Header Optional Strict name val : req)+  h (Request `With` ts, HeaderParseError) Response ->+  Middleware h ts (RequestHeader Optional Strict name val : ts) optionalHeader = headerHandler {-# INLINE optionalHeader #-} @@ -158,11 +169,11 @@  > lenientHeader @"Content-Length" @Integer errorHandler okHandler -} lenientHeader ::-  forall name val h req.-  (Get h (Header Required Lenient name val) Request, ArrowChoice h) =>+  forall name val h ts.+  (Get h (RequestHeader Required Lenient name val) Request, ArrowChoice h) =>   -- | Error handler-  h (Linked req Request, HeaderNotFound) Response ->-  Middleware h req (Header Required Lenient name val : req)+  h (Request `With` ts, HeaderNotFound) Response ->+  Middleware h ts (RequestHeader Required Lenient name val : ts) lenientHeader = headerHandler {-# INLINE lenientHeader #-} @@ -177,18 +188,31 @@  > optionalLenientHeader @"Content-Length" @Integer handler -} optionalLenientHeader ::-  forall name val h req.-  (Get h (Header Optional Lenient name val) Request, ArrowChoice h) =>-  Middleware h req (Header Optional Lenient name val : req)+  forall name val h ts.+  (Get h (RequestHeader Optional Lenient name val) Request, ArrowChoice h) =>+  Middleware h ts (RequestHeader Optional Lenient name val : ts) optionalLenientHeader = headerHandler $ arr (absurd . snd) {-# INLINE optionalLenientHeader #-} -instance Trait (Header Required Strict name val) Response where-  type Attribute (Header Required Strict name val) Response = val+{- | A 'Trait' for setting a header in the HTTP response. It has a+ specified @name@ and a value of type @val@ which can be converted to+ a 'ByteString'. The header name is compared case-insensitively. The+ modifier @e@ determines whether the header is mandatory or optional.+-}+data ResponseHeader (e :: Existence) (name :: Symbol) (val :: Type) = ResponseHeader -instance Trait (Header Optional Strict name val) Response where-  type Attribute (Header Optional Strict name val) Response = Maybe val+-- | A `Header` that is required in the response+type RequiredResponseHeader = ResponseHeader Required +-- | A `Header` that is optional in the response+type OptionalResponseHeader = ResponseHeader Optional++instance Trait (ResponseHeader Required name val) Response where+  type Attribute (ResponseHeader Required name val) Response = val++instance Trait (ResponseHeader Optional name val) Response where+  type Attribute (ResponseHeader Optional name val) Response = Maybe val+ {- | Set a header value in a response.   Example usage:@@ -196,13 +220,10 @@  > response' <- setHeader @"Content-Length" -< (response, 42) -} setHeader ::-  forall name val a h res.-  Set h (Header Required Strict name val) Response =>-  h a (Linked res Response) ->-  h (val, a) (Linked (Header Required Strict name val : res) Response)-setHeader prevHandler = proc (val, a) -> do-  r <- prevHandler -< a-  plant Header -< (r, val)+  forall name val h ts.+  (Set h (ResponseHeader Required name val) Response) =>+  h (Response `With` ts, val) (Response `With` (ResponseHeader Required name val : ts))+setHeader = plant ResponseHeader {-# INLINE setHeader #-}  {- | Set an optional header value in a response.@@ -216,11 +237,8 @@  > response' <- setOptionalHeader @"Content-Length" -< (response, Just 42) -} setOptionalHeader ::-  forall name val a h res.-  Set h (Header Optional Strict name val) Response =>-  h a (Linked res Response) ->-  h (Maybe val, a) (Linked (Header Optional Strict name val : res) Response)-setOptionalHeader prevHandler = proc (val, a) -> do-  r <- prevHandler -< a-  plant Header -< (r, val)+  forall name val h ts.+  (Set h (ResponseHeader Optional name val) Response) =>+  h (Response `With` ts, Maybe val) (Response `With` (ResponseHeader Optional name val : ts))+setOptionalHeader = plant ResponseHeader {-# INLINE setOptionalHeader #-}

@@ -43,6 +43,6 @@ method ::   (Get h Method Request, ArrowChoice h, ArrowError RouteMismatch h) =>   HTTP.StdMethod ->-  Middleware h req (Method : req)+  Middleware h ts (Method : ts) method m nextHandler = probe (Method m) >>> routeMismatch ||| nextHandler {-# INLINE method #-}

@@ -83,7 +83,7 @@ path ::   (Get h Path Request, ArrowChoice h, ArrowError RouteMismatch h) =>   Text ->-  Middleware h req (Path : req)+  Middleware h ts (Path : ts) path s nextHandler = probe (Path s) >>> routeMismatch ||| nextHandler {-# INLINE path #-} @@ -100,16 +100,16 @@  > pathVar @"objId" @Int handler -} pathVar ::-  forall tag val h req.+  forall tag val h ts.   (Get h (PathVar tag val) Request, ArrowChoice h, ArrowError RouteMismatch h) =>-  Middleware h req (PathVar tag val : req)+  Middleware h ts (PathVar tag val : ts) pathVar nextHandler = probe PathVar >>> routeMismatch ||| nextHandler {-# INLINE pathVar #-}  -- | A middleware that verifies that end of path is reached. pathEnd ::   (Get h PathEnd Request, ArrowChoice h, ArrowError RouteMismatch h) =>-  Middleware h req (PathEnd : req)+  Middleware h ts (PathEnd : ts) pathEnd nextHandler = probe PathEnd >>> routeMismatch ||| nextHandler {-# INLINE pathEnd #-} @@ -212,7 +212,7 @@ compose :: Exp -> Exp -> Exp compose l = UInfixE l (VarE $ mkName ".") -splitOn :: Eq a => a -> [a] -> NonEmpty [a]+splitOn :: (Eq a) => a -> [a] -> NonEmpty [a] splitOn sep = foldr f ([] :| [])   where     f x acc | x == sep = [] :| toList acc

@@ -43,7 +43,7 @@ import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) import WebGear.Core.Request (Request) import WebGear.Core.Response (Response)-import WebGear.Core.Trait (Get, Linked, Trait (..), TraitAbsence (..), probe)+import WebGear.Core.Trait (Get, Trait (..), TraitAbsence (..), With, probe)  {- | Capture a query parameter with a specified @name@ and convert it to  a value of type @val@. The type parameter @e@ denotes whether the@@ -92,10 +92,10 @@   type Absence (QueryParam Optional Lenient name val) Request = Void  queryParamHandler ::-  forall name val e p h req.+  forall name val e p h ts.   (Get h (QueryParam e p name val) Request, ArrowChoice h) =>-  h (Linked req Request, Absence (QueryParam e p name val) Request) Response ->-  Middleware h req (QueryParam e p name val : req)+  h (Request `With` ts, Absence (QueryParam e p name val) Request) Response ->+  Middleware h ts (QueryParam e p name val : ts) queryParamHandler errorHandler nextHandler = proc request -> do   result <- probe QueryParam -< request   case result of@@ -113,10 +113,10 @@  > queryParam @"limit" @Integer errorHandler okHandler -} queryParam ::-  forall name val h req.+  forall name val h ts.   (Get h (QueryParam Required Strict name val) Request, ArrowChoice h) =>-  h (Linked req Request, Either ParamNotFound ParamParseError) Response ->-  Middleware h req (QueryParam Required Strict name val : req)+  h (Request `With` ts, Either ParamNotFound ParamParseError) Response ->+  Middleware h ts (QueryParam Required Strict name val : ts) queryParam = queryParamHandler {-# INLINE queryParam #-} @@ -131,10 +131,10 @@  > optionalQueryParam @"limit" @Integer errorHandler okHandler -} optionalQueryParam ::-  forall name val h req.+  forall name val h ts.   (Get h (QueryParam Optional Strict name val) Request, ArrowChoice h) =>-  h (Linked req Request, ParamParseError) Response ->-  Middleware h req (QueryParam Optional Strict name val : req)+  h (Request `With` ts, ParamParseError) Response ->+  Middleware h ts (QueryParam Optional Strict name val : ts) optionalQueryParam = queryParamHandler {-# INLINE optionalQueryParam #-} @@ -149,10 +149,10 @@  > lenientQueryParam @"limit" @Integer errorHandler okHandler -} lenientQueryParam ::-  forall name val h req.+  forall name val h ts.   (Get h (QueryParam Required Lenient name val) Request, ArrowChoice h) =>-  h (Linked req Request, ParamNotFound) Response ->-  Middleware h req (QueryParam Required Lenient name val : req)+  h (Request `With` ts, ParamNotFound) Response ->+  Middleware h ts (QueryParam Required Lenient name val : ts) lenientQueryParam = queryParamHandler {-# INLINE lenientQueryParam #-} @@ -167,8 +167,8 @@  missing query parameters are reported in the trait attribute. -} optionalLenientQueryParam ::-  forall name val h req.+  forall name val h ts.   (Get h (QueryParam Optional Lenient name val) Request, ArrowChoice h) =>-  Middleware h req (QueryParam Optional Lenient name val : req)+  Middleware h ts (QueryParam Optional Lenient name val : ts) optionalLenientQueryParam = queryParamHandler $ arr (absurd . snd) {-# INLINE optionalLenientQueryParam #-}

@@ -53,8 +53,8 @@ ) where  import qualified Network.HTTP.Types as HTTP-import WebGear.Core.Response (Response (..))-import WebGear.Core.Trait (Linked, Set, Trait (..), linkzero, plant)+import WebGear.Core.Response (Response (..), ResponseBody (ResponseBodyBuilder))+import WebGear.Core.Trait (Set, Trait (..), With, plant, wzero)  -- | HTTP response status newtype Status = Status HTTP.Status@@ -63,238 +63,238 @@   type Attribute Status Response = HTTP.Status  -- | Generate a response with the specified status-mkResponse :: Set h Status Response => HTTP.Status -> h () (Linked '[Status] Response)+mkResponse :: (Set h Status Response) => HTTP.Status -> h () (Response `With` '[Status]) mkResponse status = proc () -> do-  let response = linkzero $ Response status [] Nothing+  let response = wzero $ Response status [] (ResponseBodyBuilder mempty)   plant (Status status) -< (response, status) {-# INLINE mkResponse #-}  -- | Continue 100 response-continue100 :: Set h Status Response => h () (Linked '[Status] Response)+continue100 :: (Set h Status Response) => h () (Response `With` '[Status]) continue100 = mkResponse HTTP.continue100 {-# INLINE continue100 #-}  -- | Switching Protocols 101 response-switchingProtocols101 :: Set h Status Response => h () (Linked '[Status] Response)+switchingProtocols101 :: (Set h Status Response) => h () (Response `With` '[Status]) switchingProtocols101 = mkResponse HTTP.switchingProtocols101 {-# INLINE switchingProtocols101 #-}  -- | OK 200 response-ok200 :: Set h Status Response => h () (Linked '[Status] Response)+ok200 :: (Set h Status Response) => h () (Response `With` '[Status]) ok200 = mkResponse HTTP.ok200 {-# INLINE ok200 #-}  -- | Created 201 response-created201 :: Set h Status Response => h () (Linked '[Status] Response)+created201 :: (Set h Status Response) => h () (Response `With` '[Status]) created201 = mkResponse HTTP.created201 {-# INLINE created201 #-}  -- | Accepted 202 response-accepted202 :: Set h Status Response => h () (Linked '[Status] Response)+accepted202 :: (Set h Status Response) => h () (Response `With` '[Status]) accepted202 = mkResponse HTTP.accepted202 {-# INLINE accepted202 #-}  -- | Non-Authoritative 203 response-nonAuthoritative203 :: Set h Status Response => h () (Linked '[Status] Response)+nonAuthoritative203 :: (Set h Status Response) => h () (Response `With` '[Status]) nonAuthoritative203 = mkResponse HTTP.nonAuthoritative203 {-# INLINE nonAuthoritative203 #-}  -- | No Content 204 response-noContent204 :: Set h Status Response => h () (Linked '[Status] Response)+noContent204 :: (Set h Status Response) => h () (Response `With` '[Status]) noContent204 = mkResponse HTTP.noContent204 {-# INLINE noContent204 #-}  -- | Reset Content 205 response-resetContent205 :: Set h Status Response => h () (Linked '[Status] Response)+resetContent205 :: (Set h Status Response) => h () (Response `With` '[Status]) resetContent205 = mkResponse HTTP.resetContent205 {-# INLINE resetContent205 #-}  -- | Partial Content 206 response-partialContent206 :: Set h Status Response => h () (Linked '[Status] Response)+partialContent206 :: (Set h Status Response) => h () (Response `With` '[Status]) partialContent206 = mkResponse HTTP.partialContent206 {-# INLINE partialContent206 #-}  -- | Multiple Choices 300 response-multipleChoices300 :: Set h Status Response => h () (Linked '[Status] Response)+multipleChoices300 :: (Set h Status Response) => h () (Response `With` '[Status]) multipleChoices300 = mkResponse HTTP.multipleChoices300 {-# INLINE multipleChoices300 #-}  -- | Moved Permanently 301 response-movedPermanently301 :: Set h Status Response => h () (Linked '[Status] Response)+movedPermanently301 :: (Set h Status Response) => h () (Response `With` '[Status]) movedPermanently301 = mkResponse HTTP.movedPermanently301 {-# INLINE movedPermanently301 #-}  -- | Found 302 response-found302 :: Set h Status Response => h () (Linked '[Status] Response)+found302 :: (Set h Status Response) => h () (Response `With` '[Status]) found302 = mkResponse HTTP.found302 {-# INLINE found302 #-}  -- | See Other 303 response-seeOther303 :: Set h Status Response => h () (Linked '[Status] Response)+seeOther303 :: (Set h Status Response) => h () (Response `With` '[Status]) seeOther303 = mkResponse HTTP.seeOther303 {-# INLINE seeOther303 #-}  -- | Not Modified 304 response-notModified304 :: Set h Status Response => h () (Linked '[Status] Response)+notModified304 :: (Set h Status Response) => h () (Response `With` '[Status]) notModified304 = mkResponse HTTP.notModified304 {-# INLINE notModified304 #-}  -- | Temporary Redirect 307 response-temporaryRedirect307 :: Set h Status Response => h () (Linked '[Status] Response)+temporaryRedirect307 :: (Set h Status Response) => h () (Response `With` '[Status]) temporaryRedirect307 = mkResponse HTTP.temporaryRedirect307 {-# INLINE temporaryRedirect307 #-}  -- | Permanent Redirect 308 response-permanentRedirect308 :: Set h Status Response => h () (Linked '[Status] Response)+permanentRedirect308 :: (Set h Status Response) => h () (Response `With` '[Status]) permanentRedirect308 = mkResponse HTTP.permanentRedirect308 {-# INLINE permanentRedirect308 #-}  -- | Bad Request 400 response-badRequest400 :: Set h Status Response => h () (Linked '[Status] Response)+badRequest400 :: (Set h Status Response) => h () (Response `With` '[Status]) badRequest400 = mkResponse HTTP.badRequest400 {-# INLINE badRequest400 #-}  -- | Unauthorized 401 response-unauthorized401 :: Set h Status Response => h () (Linked '[Status] Response)+unauthorized401 :: (Set h Status Response) => h () (Response `With` '[Status]) unauthorized401 = mkResponse HTTP.unauthorized401 {-# INLINE unauthorized401 #-}  -- | Payment Required 402 response-paymentRequired402 :: Set h Status Response => h () (Linked '[Status] Response)+paymentRequired402 :: (Set h Status Response) => h () (Response `With` '[Status]) paymentRequired402 = mkResponse HTTP.paymentRequired402 {-# INLINE paymentRequired402 #-}  -- | Forbidden 403 response-forbidden403 :: Set h Status Response => h () (Linked '[Status] Response)+forbidden403 :: (Set h Status Response) => h () (Response `With` '[Status]) forbidden403 = mkResponse HTTP.forbidden403 {-# INLINE forbidden403 #-}  -- | Not Found 404 response-notFound404 :: Set h Status Response => h () (Linked '[Status] Response)+notFound404 :: (Set h Status Response) => h () (Response `With` '[Status]) notFound404 = mkResponse HTTP.notFound404 {-# INLINE notFound404 #-}  -- | Method Not Allowed 405 response-methodNotAllowed405 :: Set h Status Response => h () (Linked '[Status] Response)+methodNotAllowed405 :: (Set h Status Response) => h () (Response `With` '[Status]) methodNotAllowed405 = mkResponse HTTP.methodNotAllowed405 {-# INLINE methodNotAllowed405 #-}  -- | Not Acceptable 406 response-notAcceptable406 :: Set h Status Response => h () (Linked '[Status] Response)+notAcceptable406 :: (Set h Status Response) => h () (Response `With` '[Status]) notAcceptable406 = mkResponse HTTP.notAcceptable406 {-# INLINE notAcceptable406 #-}  -- | Proxy Authentication Required 407 response-proxyAuthenticationRequired407 :: Set h Status Response => h () (Linked '[Status] Response)+proxyAuthenticationRequired407 :: (Set h Status Response) => h () (Response `With` '[Status]) proxyAuthenticationRequired407 = mkResponse HTTP.proxyAuthenticationRequired407 {-# INLINE proxyAuthenticationRequired407 #-}  -- | Request Timeout 408 response-requestTimeout408 :: Set h Status Response => h () (Linked '[Status] Response)+requestTimeout408 :: (Set h Status Response) => h () (Response `With` '[Status]) requestTimeout408 = mkResponse HTTP.requestTimeout408 {-# INLINE requestTimeout408 #-}  -- | Conflict 409 response-conflict409 :: Set h Status Response => h () (Linked '[Status] Response)+conflict409 :: (Set h Status Response) => h () (Response `With` '[Status]) conflict409 = mkResponse HTTP.conflict409 {-# INLINE conflict409 #-}  -- | Gone 410 response-gone410 :: Set h Status Response => h () (Linked '[Status] Response)+gone410 :: (Set h Status Response) => h () (Response `With` '[Status]) gone410 = mkResponse HTTP.gone410 {-# INLINE gone410 #-}  -- | Length Required 411 response-lengthRequired411 :: Set h Status Response => h () (Linked '[Status] Response)+lengthRequired411 :: (Set h Status Response) => h () (Response `With` '[Status]) lengthRequired411 = mkResponse HTTP.lengthRequired411 {-# INLINE lengthRequired411 #-}  -- | Precondition Failed 412 response-preconditionFailed412 :: Set h Status Response => h () (Linked '[Status] Response)+preconditionFailed412 :: (Set h Status Response) => h () (Response `With` '[Status]) preconditionFailed412 = mkResponse HTTP.preconditionFailed412 {-# INLINE preconditionFailed412 #-}  -- | Request Entity Too Large 413 response-requestEntityTooLarge413 :: Set h Status Response => h () (Linked '[Status] Response)+requestEntityTooLarge413 :: (Set h Status Response) => h () (Response `With` '[Status]) requestEntityTooLarge413 = mkResponse HTTP.requestEntityTooLarge413 {-# INLINE requestEntityTooLarge413 #-}  -- | Request URI Too Long 414 response-requestURITooLong414 :: Set h Status Response => h () (Linked '[Status] Response)+requestURITooLong414 :: (Set h Status Response) => h () (Response `With` '[Status]) requestURITooLong414 = mkResponse HTTP.requestURITooLong414 {-# INLINE requestURITooLong414 #-}  -- | Unsupported Media Type 415 response-unsupportedMediaType415 :: Set h Status Response => h () (Linked '[Status] Response)+unsupportedMediaType415 :: (Set h Status Response) => h () (Response `With` '[Status]) unsupportedMediaType415 = mkResponse HTTP.unsupportedMediaType415 {-# INLINE unsupportedMediaType415 #-}  -- | Requested Range Not Satisfiable 416 response-requestedRangeNotSatisfiable416 :: Set h Status Response => h () (Linked '[Status] Response)+requestedRangeNotSatisfiable416 :: (Set h Status Response) => h () (Response `With` '[Status]) requestedRangeNotSatisfiable416 = mkResponse HTTP.requestedRangeNotSatisfiable416 {-# INLINE requestedRangeNotSatisfiable416 #-}  -- | Expectation Failed 417 response-expectationFailed417 :: Set h Status Response => h () (Linked '[Status] Response)+expectationFailed417 :: (Set h Status Response) => h () (Response `With` '[Status]) expectationFailed417 = mkResponse HTTP.expectationFailed417 {-# INLINE expectationFailed417 #-}  -- | I'm A Teapot 418 response-imATeapot418 :: Set h Status Response => h () (Linked '[Status] Response)+imATeapot418 :: (Set h Status Response) => h () (Response `With` '[Status]) imATeapot418 = mkResponse HTTP.imATeapot418 {-# INLINE imATeapot418 #-}  -- | Unprocessable Entity 422 response-unprocessableEntity422 :: Set h Status Response => h () (Linked '[Status] Response)+unprocessableEntity422 :: (Set h Status Response) => h () (Response `With` '[Status]) unprocessableEntity422 = mkResponse HTTP.unprocessableEntity422 {-# INLINE unprocessableEntity422 #-}  -- | Precondition Required 428 response-preconditionRequired428 :: Set h Status Response => h () (Linked '[Status] Response)+preconditionRequired428 :: (Set h Status Response) => h () (Response `With` '[Status]) preconditionRequired428 = mkResponse HTTP.preconditionRequired428 {-# INLINE preconditionRequired428 #-}  -- | Too Many Requests 429 response-tooManyRequests429 :: Set h Status Response => h () (Linked '[Status] Response)+tooManyRequests429 :: (Set h Status Response) => h () (Response `With` '[Status]) tooManyRequests429 = mkResponse HTTP.tooManyRequests429 {-# INLINE tooManyRequests429 #-}  -- | Request Header Fields Too Large 431 response-requestHeaderFieldsTooLarge431 :: Set h Status Response => h () (Linked '[Status] Response)+requestHeaderFieldsTooLarge431 :: (Set h Status Response) => h () (Response `With` '[Status]) requestHeaderFieldsTooLarge431 = mkResponse HTTP.requestHeaderFieldsTooLarge431 {-# INLINE requestHeaderFieldsTooLarge431 #-}  -- | Internal Server Error 500 response-internalServerError500 :: Set h Status Response => h () (Linked '[Status] Response)+internalServerError500 :: (Set h Status Response) => h () (Response `With` '[Status]) internalServerError500 = mkResponse HTTP.internalServerError500 {-# INLINE internalServerError500 #-}  -- | Not Implemented 501 response-notImplemented501 :: Set h Status Response => h () (Linked '[Status] Response)+notImplemented501 :: (Set h Status Response) => h () (Response `With` '[Status]) notImplemented501 = mkResponse HTTP.notImplemented501 {-# INLINE notImplemented501 #-}  -- | Bad Gateway 502 response-badGateway502 :: Set h Status Response => h () (Linked '[Status] Response)+badGateway502 :: (Set h Status Response) => h () (Response `With` '[Status]) badGateway502 = mkResponse HTTP.badGateway502 {-# INLINE badGateway502 #-}  -- | Service Unavailable 503 response-serviceUnavailable503 :: Set h Status Response => h () (Linked '[Status] Response)+serviceUnavailable503 :: (Set h Status Response) => h () (Response `With` '[Status]) serviceUnavailable503 = mkResponse HTTP.serviceUnavailable503 {-# INLINE serviceUnavailable503 #-}  -- | Gateway Timeout 504 response-gatewayTimeout504 :: Set h Status Response => h () (Linked '[Status] Response)+gatewayTimeout504 :: (Set h Status Response) => h () (Response `With` '[Status]) gatewayTimeout504 = mkResponse HTTP.gatewayTimeout504 {-# INLINE gatewayTimeout504 #-}  -- | HTTP Version Not Supported 505 response-httpVersionNotSupported505 :: Set h Status Response => h () (Linked '[Status] Response)+httpVersionNotSupported505 :: (Set h Status Response) => h () (Response `With` '[Status]) httpVersionNotSupported505 = mkResponse HTTP.httpVersionNotSupported505 {-# INLINE httpVersionNotSupported505 #-}  -- | Network Authentication Required 511 response-networkAuthenticationRequired511 :: Set h Status Response => h () (Linked '[Status] Response)+networkAuthenticationRequired511 :: (Set h Status Response) => h () (Response `With` '[Status]) networkAuthenticationRequired511 = mkResponse HTTP.networkAuthenticationRequired511 {-# INLINE networkAuthenticationRequired511 #-}

@@ -4,6 +4,7 @@   module WebGear.Core.Trait.Auth.JWT,   module WebGear.Core.Trait.Auth.Common,   module WebGear.Core.Trait.Body,+  module WebGear.Core.Trait.Cookie,   module WebGear.Core.Trait.Header,   module WebGear.Core.Trait.Method,   module WebGear.Core.Trait.Path,@@ -12,7 +13,10 @@   StdHandler, ) where +import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText import WebGear.Core.Handler (Handler)+import WebGear.Core.MIMETypes (PlainText) import WebGear.Core.Request (Request) import WebGear.Core.Response (Response) import WebGear.Core.Trait (Gets, Sets)@@ -20,24 +24,29 @@ import WebGear.Core.Trait.Auth.Common import WebGear.Core.Trait.Auth.JWT import WebGear.Core.Trait.Body+import WebGear.Core.Trait.Cookie import WebGear.Core.Trait.Header import WebGear.Core.Trait.Method import WebGear.Core.Trait.Path import WebGear.Core.Trait.QueryParam import WebGear.Core.Trait.Status -{- | Constraints that include all common traits.+{- | Constraints that include a set of common traits for handlers.   The type variables are:   * @h@ - The handler arrow  * @m@ - The underlying monad of the handler- * @req@ - List of traits the handler `Gets` from the request- * @res@ - List of traits the handler `Sets` on the response -}-type StdHandler h m req res =+type StdHandler h m =   ( Handler h m   , Gets h [Method, Path, PathEnd] Request-  , Gets h req Request-  , Sets h (Status : res) Response+  , Sets+      h+      '[ Status+       , Body PlainText String+       , Body PlainText Text.Text+       , Body PlainText LText.Text+       ]+      Response   )

@@ -1,7 +1,7 @@ cabal-version:       2.4  name:                webgear-core-version:             1.0.5+version:             1.1.0 synopsis:            Composable, type-safe library to build HTTP APIs description:         WebGear is a library to for building composable, type-safe HTTP APIs.@@ -54,19 +54,20 @@                       TypeFamilies                       TypeOperators   build-depends:      base >=4.13.0.0 && <4.19-                    , bytestring >=0.10.10.1 && <0.12+                    , binary >= 0.8.0.0 && <0.9+                    , bytestring >=0.10.10.1 && <0.13                     , case-insensitive ==1.2.*+                    , cookie >=0.4.5 && <0.5                     , filepath ==1.4.*-                    , http-api-data >=0.4.2 && <0.6+                    , http-api-data >=0.4.2 && <0.7                     , http-media ==0.8.*                     , http-types ==0.12.*                     , network ==3.1.*-                    , safe-exceptions ==0.1.*                     , tagged ==0.8.*                     , template-haskell >=2.15.0.0 && <2.21-                    , text >=1.2.0.0 && <2.1-                    , unordered-containers ==0.2.*+                    , text >=1.2.0.0 && <2.2                     , wai ==3.2.*+                    , wai-extra ==3.1.*   ghc-options:        -Wall                       -Wno-unticked-promoted-constructors                       -Wcompat@@ -91,11 +92,13 @@                     , WebGear.Core.Request                     , WebGear.Core.Response                     , WebGear.Core.Handler+                    , WebGear.Core.MIMETypes                     , WebGear.Core.Traits                     , WebGear.Core.Trait.Auth.Basic                     , WebGear.Core.Trait.Auth.JWT                     , WebGear.Core.Trait.Auth.Common                     , WebGear.Core.Trait.Body+                    , WebGear.Core.Trait.Cookie                     , WebGear.Core.Trait.Header                     , WebGear.Core.Trait.Method                     , WebGear.Core.Trait.Path