{-# 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 (..), 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
..}