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
data Method (t :: HTTP.StdMethod)
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
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