{-# OPTIONS_GHC -Wno-orphans #-}
module WebGear.Server.Trait.Method where
import Control.Arrow (returnA)
import qualified Network.HTTP.Types as HTTP
import WebGear.Core.Request (Request, requestMethod)
import WebGear.Core.Trait (Get (..), With (unwitness), unwitness)
import WebGear.Core.Trait.Method (Method (..), MethodMismatch (..))
import WebGear.Server.Handler (ServerHandler)
instance (Monad m) => Get (ServerHandler m) Method Request where
{-# INLINE getTrait #-}
getTrait :: Method -> ServerHandler m (Request `With` ts) (Either MethodMismatch HTTP.StdMethod)
getTrait :: forall (ts :: [*]).
Method
-> ServerHandler
m (With Request ts) (Either MethodMismatch StdMethod)
getTrait (Method StdMethod
method) = proc With Request ts
request -> do
let expectedMethod :: Method
expectedMethod = StdMethod -> Method
HTTP.renderStdMethod StdMethod
method
actualMethod :: Method
actualMethod = Request -> Method
requestMethod forall a b. (a -> b) -> a -> b
$ forall a (ts :: [*]). With a ts -> a
unwitness With Request ts
request
if Method
actualMethod forall a. Eq a => a -> a -> Bool
== Method
expectedMethod
then forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a b. b -> Either a b
Right StdMethod
method
else forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ MethodMismatch{Method
expectedMethod :: Method
actualMethod :: Method
actualMethod :: Method
expectedMethod :: Method
..}