From 1b82d4ea5a23086cc071bddb8f90095a2d1e5854 Mon Sep 17 00:00:00 2001
From: Marc Scholten <marc@digitallyinduced.com>
Date: Thu, 23 Sep 2021 18:39:44 +0200
Subject: [PATCH] Added a onlyAllowMethods function to filter for specific
 methods when building custom routing parsers

---
 IHP/RouterSupport.hs | 32 ++++++++++++++++++++++++++++++++
 1 file changed, 32 insertions(+)

diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs
index e668b8c0f..3f74b7a26 100644
--- a/IHP/RouterSupport.hs
+++ b/IHP/RouterSupport.hs
@@ -23,6 +23,7 @@ CanRoute (..)
 , parseText
 , webSocketApp
 , webSocketAppWithCustomPath
+, onlyAllowMethods
 ) where
 
 import qualified Prelude
@@ -599,6 +600,37 @@ post path action = do
         _   -> fail "Invalid method, expected POST"
 {-# INLINABLE post #-}
 
+-- | Filter methods when writing a custom routing parser
+--
+-- __Example:__
+--
+-- > instance CanRoute ApiController where
+-- >    parseRoute' = do
+-- >        string "/api/"
+-- >        let
+-- >            createRecordAction = do
+-- >                onlyAllowMethods [POST]
+-- >
+-- >                table <- parseText
+-- >                endOfInput
+-- >                pure CreateRecordAction { table }
+-- >
+-- >            updateRecordAction = do
+-- >                onlyAllowMethods [PATCH]
+-- >                
+-- >                table <- parseText
+-- >                string "/"
+-- >                id <- parseUUID
+-- >                pure UpdateRecordAction { table, id }
+-- >        
+-- > createRecordAction <|> updateRecordAction
+--
+onlyAllowMethods :: (?context :: RequestContext) => [StdMethod] -> Parser ()
+onlyAllowMethods methods = do
+    method <- getMethod
+    unless (method `elem` methods) (fail ("Invalid method, expected one of: " <> show methods))
+{-# INLINABLE onlyAllowMethods #-}
+
 -- | Routes to a given WebSocket app if the path matches the WebSocket app name
 --
 -- __Example:__