-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Middlewares related to HTTP methods.
module WebGear.Middlewares.Method
  ( Method
  , IsStdMethod (..)
  , MethodMismatch (..)
  , method
  ) where

import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Data.Proxy (Proxy (..))

import WebGear.Trait (Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', 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 (IsStdMethod t, Monad m) => Trait (Method t) Request m where
  type Attribute (Method t) Request = ()
  type Absence (Method t) Request = MethodMismatch

  toAttribute :: Request -> m (Result (Method t) Request)
  toAttribute :: Request -> m (Result (Method t) Request)
toAttribute 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
      Result (Method t) Request -> m (Result (Method t) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Method t) Request -> m (Result (Method t) Request))
-> Result (Method t) Request -> m (Result (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 Attribute (Method t) Request -> Result (Method t) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found ()
             else Absence (Method t) Request -> Result (Method t) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (Method t) Request -> Result (Method t) Request)
-> Absence (Method t) Request -> Result (Method t) Request
forall a b. (a -> b) -> a -> b
$ Method -> Method -> MethodMismatch
MethodMismatch Method
expected Method
actual


-- | A typeclass to map a 'HTTP.StdMethod' 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

-- | A middleware to check whether the request has a specified HTTP
-- method.
--
-- Typically this would be used with a type application such as:
--
-- > method @GET handler
--
-- It is also idiomatic to use the template haskell quasiquoter
-- 'WebGear.Middlewares.Path.match' in cases where both HTTP method
-- and path needs to be matched.
method :: forall t m req a. (IsStdMethod t, MonadRouter m)
       => RequestMiddleware' m req (Method t:req) a
method :: RequestMiddleware' m req (Method t : req) a
method Handler' m (Method t : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$ forall (ts :: [*]) a (m :: * -> *).
Trait (Method t) a m =>
Linked ts a
-> m (Either (Absence (Method t) a) (Linked (Method t : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(Method t) (Linked req Request
 -> m (Either MethodMismatch (Linked (Method t : req) Request)))
-> (Either MethodMismatch (Linked (Method t : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (MethodMismatch -> m (Response a))
-> (Linked (Method t : req) Request -> m (Response a))
-> Either MethodMismatch (Linked (Method t : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Response a) -> MethodMismatch -> m (Response a)
forall a b. a -> b -> a
const m (Response a)
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler' m (Method t : req) a
-> Linked (Method t : req) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (Method t : req) a
handler)