{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the `Method` trait.
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
  {-# INLINEABLE getTrait #-}
  getTrait :: Method -> ServerHandler m (Linked ts Request) (Either MethodMismatch HTTP.StdMethod)
  getTrait :: 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 (Request -> Method) -> Request -> Method
forall a b. (a -> b) -> a -> b
$ Linked ts Request -> Request
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Request
request
    if Method
actualMethod Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
expectedMethod
      then ServerHandler
  m
  (Either MethodMismatch StdMethod)
  (Either MethodMismatch StdMethod)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< StdMethod -> Either MethodMismatch StdMethod
forall a b. b -> Either a b
Right StdMethod
method
      else ServerHandler
  m
  (Either MethodMismatch StdMethod)
  (Either MethodMismatch StdMethod)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< MethodMismatch -> Either MethodMismatch StdMethod
forall a b. a -> Either a b
Left (MethodMismatch -> Either MethodMismatch StdMethod)
-> MethodMismatch -> Either MethodMismatch StdMethod
forall a b. (a -> b) -> a -> b
$ MethodMismatch :: Method -> Method -> MethodMismatch
MethodMismatch{Method
expectedMethod :: Method
actualMethod :: Method
actualMethod :: Method
expectedMethod :: Method
..}