module WebGear.Core.Trait.Method (
Method (..),
MethodMismatch (..),
method,
) where
import Control.Arrow (ArrowChoice (..), (>>>))
import Control.Arrow.Operations (ArrowError)
import qualified Network.HTTP.Types as HTTP
import WebGear.Core.Handler (Middleware, RouteMismatch, routeMismatch)
import WebGear.Core.Request (Request)
import WebGear.Core.Trait (Get (..), Prerequisite, Trait (..), TraitAbsence (..), probe)
newtype Method = Method HTTP.StdMethod
data MethodMismatch = MethodMismatch
{ MethodMismatch -> Method
expectedMethod :: HTTP.Method
, MethodMismatch -> Method
actualMethod :: HTTP.Method
}
instance Trait Method Request where
type Attribute Method Request = HTTP.StdMethod
instance TraitAbsence Method Request where
type Absence Method Request = MethodMismatch
type instance Prerequisite Method ts Request = ()
method ::
(Get h Method Request, ArrowChoice h, ArrowError RouteMismatch h) =>
HTTP.StdMethod ->
Middleware h ts (Method : ts)
method :: forall (h :: * -> * -> *) (ts :: [*]).
(Get h Method Request, ArrowChoice h,
ArrowError RouteMismatch h) =>
StdMethod -> Middleware h ts (Method : ts)
method StdMethod
m RequestHandler h (Method : ts)
nextHandler = Method
-> h (With Request ts)
(Either (Absence Method Request) (With Request (Method : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe (StdMethod -> Method
Method StdMethod
m) h (With Request ts)
(Either MethodMismatch (With Request (Method : ts)))
-> h (Either MethodMismatch (With Request (Method : ts))) Response
-> h (With Request ts) Response
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> h MethodMismatch Response
forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch h MethodMismatch Response
-> RequestHandler h (Method : ts)
-> h (Either MethodMismatch (With Request (Method : ts))) Response
forall b d c. h b d -> h c d -> h (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (Method : ts)
nextHandler
{-# INLINE method #-}