-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Trait capturing the HTTP method in a request.
module WebGear.Trait.Method
  ( Method
  , IsStdMethod (..)
  , MethodMismatch (..)
  ) where

import Data.Proxy (Proxy (..))

import WebGear.Trait (CheckResult (..), Trait (..))
import WebGear.Types (Request, requestMethod)

import qualified Network.HTTP.Types as HTTP


-- | A 'Trait' for capturing the HTTP method of a request
data Method (t :: HTTP.StdMethod)

-- | Failure to match method against an expected value
data MethodMismatch = MethodMismatch
  { MethodMismatch -> Method
expectedMethod :: HTTP.Method
  , MethodMismatch -> Method
actualMethod   :: HTTP.Method
  }

instance (Monad m, IsStdMethod t) => Trait (Method t) Request m where
  type Val (Method t) Request = HTTP.Method
  type Fail (Method t) Request = MethodMismatch

  check :: Request -> m (CheckResult (Method t) Request)
  check :: Request -> m (CheckResult (Method t) Request)
check r :: Request
r =
    let
      expected :: Method
expected = StdMethod -> Method
HTTP.renderStdMethod (StdMethod -> Method) -> StdMethod -> Method
forall a b. (a -> b) -> a -> b
$ Proxy t -> StdMethod
forall k (t :: k). IsStdMethod t => Proxy t -> StdMethod
toStdMethod (Proxy t -> StdMethod) -> Proxy t -> StdMethod
forall a b. (a -> b) -> a -> b
$ Proxy t
forall k (t :: k). Proxy t
Proxy @t
      actual :: Method
actual = Request -> Method
requestMethod Request
r
    in
      CheckResult (Method t) Request
-> m (CheckResult (Method t) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckResult (Method t) Request
 -> m (CheckResult (Method t) Request))
-> CheckResult (Method t) Request
-> m (CheckResult (Method t) Request)
forall a b. (a -> b) -> a -> b
$ if Method
expected Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
actual
             then Request -> Val (Method t) Request -> CheckResult (Method t) Request
forall k (t :: k) a. a -> Val t a -> CheckResult t a
CheckSuccess Request
r Method
Val (Method t) Request
actual
             else Fail (Method t) Request -> CheckResult (Method t) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail (Fail (Method t) Request -> CheckResult (Method t) Request)
-> Fail (Method t) Request -> CheckResult (Method t) Request
forall a b. (a -> b) -> a -> b
$ Method -> Method -> MethodMismatch
MethodMismatch Method
expected Method
actual


-- | A typeclass implemented by all 'HTTP.StdMethod's to convert them
-- from type level to term level.
class IsStdMethod t where
  -- | Convert @t@ to term level.
  toStdMethod :: Proxy t -> HTTP.StdMethod

instance IsStdMethod HTTP.GET where
  toStdMethod :: Proxy 'GET -> StdMethod
toStdMethod = StdMethod -> Proxy 'GET -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.GET
instance IsStdMethod HTTP.POST where
  toStdMethod :: Proxy 'POST -> StdMethod
toStdMethod = StdMethod -> Proxy 'POST -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.POST
instance IsStdMethod HTTP.HEAD where
  toStdMethod :: Proxy 'HEAD -> StdMethod
toStdMethod = StdMethod -> Proxy 'HEAD -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.HEAD
instance IsStdMethod HTTP.PUT where
  toStdMethod :: Proxy 'PUT -> StdMethod
toStdMethod = StdMethod -> Proxy 'PUT -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.PUT
instance IsStdMethod HTTP.DELETE where
  toStdMethod :: Proxy 'DELETE -> StdMethod
toStdMethod = StdMethod -> Proxy 'DELETE -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.DELETE
instance IsStdMethod HTTP.TRACE where
  toStdMethod :: Proxy 'TRACE -> StdMethod
toStdMethod = StdMethod -> Proxy 'TRACE -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.TRACE
instance IsStdMethod HTTP.CONNECT where
  toStdMethod :: Proxy 'CONNECT -> StdMethod
toStdMethod = StdMethod -> Proxy 'CONNECT -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.CONNECT
instance IsStdMethod HTTP.OPTIONS where
  toStdMethod :: Proxy 'OPTIONS -> StdMethod
toStdMethod = StdMethod -> Proxy 'OPTIONS -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.OPTIONS
instance IsStdMethod HTTP.PATCH where
  toStdMethod :: Proxy 'PATCH -> StdMethod
toStdMethod = StdMethod -> Proxy 'PATCH -> StdMethod
forall a b. a -> b -> a
const StdMethod
HTTP.PATCH