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
{ 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
class IsStdMethod t where
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
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)