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
data Method (t :: HTTP.StdMethod)
data MethodMismatch = MethodMismatch
{ expectedMethod :: HTTP.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 r =
let
expected = HTTP.renderStdMethod $ toStdMethod $ Proxy @t
actual = requestMethod r
in
pure $ if expected == actual
then Found ()
else NotFound $ MethodMismatch expected actual
class IsStdMethod t where
toStdMethod :: Proxy t -> HTTP.StdMethod
instance IsStdMethod HTTP.GET where
toStdMethod = const HTTP.GET
instance IsStdMethod HTTP.POST where
toStdMethod = const HTTP.POST
instance IsStdMethod HTTP.HEAD where
toStdMethod = const HTTP.HEAD
instance IsStdMethod HTTP.PUT where
toStdMethod = const HTTP.PUT
instance IsStdMethod HTTP.DELETE where
toStdMethod = const HTTP.DELETE
instance IsStdMethod HTTP.TRACE where
toStdMethod = const HTTP.TRACE
instance IsStdMethod HTTP.CONNECT where
toStdMethod = const HTTP.CONNECT
instance IsStdMethod HTTP.OPTIONS where
toStdMethod = const HTTP.OPTIONS
instance IsStdMethod HTTP.PATCH where
toStdMethod = const HTTP.PATCH
method :: forall t m req a. (IsStdMethod t, MonadRouter m)
=> RequestMiddleware' m req (Method t:req) a
method handler = Kleisli $ probe @(Method t) >=> either (const rejectRoute) (runKleisli handler)