{-# 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 :: 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
..}