module Web.Respond.Method where
import Network.Wai
import Network.HTTP.Types.Method
import qualified Data.Map.Lazy as Map
import Control.Lens (at, (^.), (<&>), to)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Function (on)
import Web.Respond.Monad
import Web.Respond.Response
newtype MethodMatcher a = MethodMatcher {
getMethodMatcher :: Map.Map StdMethod a
}
instance Monoid (MethodMatcher a) where
mempty = MethodMatcher mempty
mappend = (MethodMatcher .) . on mappend getMethodMatcher
matchMethod :: MonadRespond m => MethodMatcher (m ResponseReceived) -> m ResponseReceived
matchMethod dispatcher = getRequest <&> (parseMethod . requestMethod) >>= either (handleUnsupportedMethod supported) selectMethod
where
supported = Map.keys (getMethodMatcher dispatcher)
selectMethod mth = fromMaybe (handleUnsupportedMethod supported (renderStdMethod mth)) $ dispatcher ^. to getMethodMatcher . at mth
onMethod :: StdMethod -> a -> MethodMatcher a
onMethod = (MethodMatcher .) . Map.singleton
onGET :: a -> MethodMatcher a
onGET = onMethod GET
onPOST :: a -> MethodMatcher a
onPOST = onMethod POST
onHEAD :: a -> MethodMatcher a
onHEAD = onMethod HEAD
onPUT :: a -> MethodMatcher a
onPUT = onMethod PUT
onDELETE :: a -> MethodMatcher a
onDELETE = onMethod DELETE
onTRACE :: a -> MethodMatcher a
onTRACE = onMethod TRACE
onCONNECT :: a -> MethodMatcher a
onCONNECT = onMethod CONNECT
onOPTIONS :: a -> MethodMatcher a
onOPTIONS = onMethod OPTIONS
onPATCH :: a -> MethodMatcher a
onPATCH = onMethod PATCH
matchOnlyMethod :: MonadRespond m => StdMethod -> m ResponseReceived -> m ResponseReceived
matchOnlyMethod m = matchMethod . onMethod m
matchGET :: MonadRespond m => m ResponseReceived -> m ResponseReceived
matchGET = matchOnlyMethod GET