{-# 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 (..), Linked, unlink)
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 (Linked ts Request) (Either MethodMismatch HTTP.StdMethod)
getTrait :: forall (ts :: [*]).
Method
-> ServerHandler
m (Linked ts Request) (Either MethodMismatch StdMethod)
getTrait (Method StdMethod
method) = proc Linked ts Request
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 (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Request
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
..}