-- | Traits and middlewares to handle HTTP methods.
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 (..), Trait (..), TraitAbsence (..), probe)

-- | A 'Trait' for capturing the HTTP method of a request
newtype Method = Method HTTP.StdMethod

-- | Failure to match method against an expected value
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

{- | Check whether the request has a specified HTTP method.

 Example usage:

 > method @GET handler

 If the request does not have the specified method, another handler
 will be tried.

 It is also idiomatic to use the template haskell quasiquoter
 'WebGear.Core.Trait.Path.match' or 'WebGear.Core.Trait.Path.route' in
 cases where both an HTTP method and a path need to be matched.
-}
method ::
  (Get h Method Request, ArrowChoice h, ArrowError RouteMismatch h) =>
  HTTP.StdMethod ->
  Middleware h req (Method : req)
method :: StdMethod -> Middleware h req (Method : req)
method StdMethod
m RequestHandler h (Method : req)
nextHandler = Method
-> h (Linked req Request)
     (Either (Absence Method Request) (Linked (Method : req) Request))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe (StdMethod -> Method
Method StdMethod
m) h (Linked req Request)
  (Either MethodMismatch (Linked (Method : req) Request))
-> h (Either MethodMismatch (Linked (Method : req) Request))
     Response
-> h (Linked req Request) 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 : req)
-> h (Either MethodMismatch (Linked (Method : req) Request))
     Response
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (Method : req)
nextHandler