From 68009a05262afac40e0111e6abcebf7616f496d9 Mon Sep 17 00:00:00 2001 From: Artem Chernyak Date: Thu, 18 Jul 2024 20:33:29 -0500 Subject: [PATCH] add redirects per status code (#402) --- Web/Scotty.hs | 52 +++++++++++++++++++++++++++--- Web/Scotty/Action.hs | 62 +++++++++++++++++++++++++++++++++--- Web/Scotty/Internal/Types.hs | 2 +- Web/Scotty/Trans.hs | 7 ++-- Web/Scotty/Trans/Lazy.hs | 48 ++++++++++++++++++++++++++-- Web/Scotty/Trans/Strict.hs | 7 ++-- changelog.md | 1 + test/Web/ScottySpec.hs | 58 +++++++++++++++++++++++++++++++++ 8 files changed, 220 insertions(+), 17 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index cfb07290..415c8a1f 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -33,8 +33,10 @@ module Web.Scotty , pathParams, captureParams, formParams, queryParams -- *** Files , files, filesOpts - -- ** Modifying the Response and Redirecting - , status, addHeader, setHeader, redirect + -- ** Modifying the Response + , status, addHeader, setHeader + -- ** Redirecting + , redirect, redirect300, redirect301, redirect302, redirect303, redirect304, redirect307, redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route @@ -222,8 +224,8 @@ liftAndCatchIO :: IO a -> ActionM a liftAndCatchIO = Trans.liftAndCatchIO {-# DEPRECATED liftAndCatchIO "Use liftIO instead" #-} --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect --- will not be run. +-- | Synonym for 'redirect302'. +-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" -- @@ -233,6 +235,48 @@ liftAndCatchIO = Trans.liftAndCatchIO redirect :: Text -> ActionM a redirect = Trans.redirect +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect300 :: Text -> ActionM a +redirect300 = Trans.redirect300 + +-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect301 :: Text -> ActionM a +redirect301 = Trans.redirect301 + +-- | Redirect to given URL with status 302 (Found). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect302 :: Text -> ActionM a +redirect302 = Trans.redirect302 + +-- | Redirect to given URL with status 303 (See Other). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect303 :: Text -> ActionM a +redirect303 = Trans.redirect303 + +-- | Redirect to given URL with status 304 (Not Modified). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect304 :: Text -> ActionM a +redirect304 = Trans.redirect304 + +-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect307 :: Text -> ActionM a +redirect307 = Trans.redirect307 + +-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect308 :: Text -> ActionM a +redirect308 = Trans.redirect308 + -- | Get the 'Request' object. request :: ActionM Request request = Trans.request diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index b80a1653..7ad3cd82 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -46,6 +46,13 @@ module Web.Scotty.Action , nested , readEither , redirect + , redirect300 + , redirect301 + , redirect302 + , redirect303 + , redirect304 + , redirect307 + , redirect308 , request , rescue , setHeader @@ -146,8 +153,8 @@ statusErrorHandler = Handler $ \case -- All other cases of 'ActionError' are converted to HTTP responses. actionErrorHandler :: MonadIO m => ErrorHandler m actionErrorHandler = Handler $ \case - AERedirect url -> do - status status302 + AERedirect s url -> do + status s setHeader "Location" url AENext -> next AEFinish -> return () @@ -270,8 +277,8 @@ liftAndCatchIO :: MonadIO m => IO a -> ActionT m a liftAndCatchIO = liftIO {-# DEPRECATED liftAndCatchIO "Use liftIO instead" #-} --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect --- will not be run. +-- | Synonym for 'redirect302'. +-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" -- @@ -279,7 +286,52 @@ liftAndCatchIO = liftIO -- -- > redirect "/foo/bar" redirect :: (Monad m) => T.Text -> ActionT m a -redirect = E.throw . AERedirect +redirect = redirect302 + +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect300 :: (Monad m) => T.Text -> ActionT m a +redirect300 = redirectStatus status300 + +-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect301 :: (Monad m) => T.Text -> ActionT m a +redirect301 = redirectStatus status301 + +-- | Redirect to given URL with status 302 (Found). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect302 :: (Monad m) => T.Text -> ActionT m a +redirect302 = redirectStatus status302 + +-- | Redirect to given URL with status 303 (See Other). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect303 :: (Monad m) => T.Text -> ActionT m a +redirect303 = redirectStatus status303 + +-- | Redirect to given URL with status 304 (Not Modified). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect304 :: (Monad m) => T.Text -> ActionT m a +redirect304 = redirectStatus status304 + +-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect307 :: (Monad m) => T.Text -> ActionT m a +redirect307 = redirectStatus status307 + +-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect308 :: (Monad m) => T.Text -> ActionT m a +redirect308 = redirectStatus status308 + +redirectStatus :: (Monad m) => Status -> T.Text -> ActionT m a +redirectStatus s = E.throw . AERedirect s -- | Finish the execution of the current action. Like throwing an uncatchable -- exception. Any code after the call to finish will not be run. diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 588c0df7..55726f13 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -122,7 +122,7 @@ newtype ScottyT m a = -- The exception constructor is not exposed to the user and all exceptions of this type are caught -- and processed within the 'runAction' function. data ActionError - = AERedirect T.Text -- ^ Redirect + = AERedirect Status T.Text -- ^ Redirect | AENext -- ^ Stop processing this route and skip to the next one | AEFinish -- ^ Stop processing the request deriving (Show, Typeable) diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 159b8384..b3468eac 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -39,8 +39,11 @@ module Web.Scotty.Trans , pathParams, captureParams, formParams, queryParams -- *** Files , files, filesOpts - -- ** Modifying the Response and Redirecting - , status, Lazy.addHeader, Lazy.setHeader, Lazy.redirect + -- ** Modifying the Response + , status, Lazy.addHeader, Lazy.setHeader + -- ** Redirecting + , Lazy.redirect, Lazy.redirect300, Lazy.redirect301, Lazy.redirect302, Lazy.redirect303 + , Lazy.redirect304, Lazy.redirect307, Lazy.redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route diff --git a/Web/Scotty/Trans/Lazy.hs b/Web/Scotty/Trans/Lazy.hs index 484cbbcc..68fa4dc7 100644 --- a/Web/Scotty/Trans/Lazy.hs +++ b/Web/Scotty/Trans/Lazy.hs @@ -26,8 +26,8 @@ raiseStatus :: Monad m => Status -> T.Text -> ActionT m a raiseStatus s = Base.raiseStatus s . T.toStrict {-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-} --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect --- will not be run. +-- | Synonym for 'redirect302'. +-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" -- @@ -35,7 +35,49 @@ raiseStatus s = Base.raiseStatus s . T.toStrict -- -- > redirect "/foo/bar" redirect :: (Monad m) => T.Text -> ActionT m a -redirect = Base.redirect . T.toStrict +redirect = redirect302 + +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect300 :: (Monad m) => T.Text -> ActionT m a +redirect300 = Base.redirect300 . T.toStrict + +-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect301 :: (Monad m) => T.Text -> ActionT m a +redirect301 = Base.redirect301 . T.toStrict + +-- | Redirect to given URL with status 302 (Found). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect302 :: (Monad m) => T.Text -> ActionT m a +redirect302 = Base.redirect302 . T.toStrict + +-- | Redirect to given URL with status 303 (See Other). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect303 :: (Monad m) => T.Text -> ActionT m a +redirect303 = Base.redirect303 . T.toStrict + +-- | Redirect to given URL with status 304 (Not Modified). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect304 :: (Monad m) => T.Text -> ActionT m a +redirect304 = Base.redirect304 . T.toStrict + +-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect307 :: (Monad m) => T.Text -> ActionT m a +redirect307 = Base.redirect307 . T.toStrict + +-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect308 :: (Monad m) => T.Text -> ActionT m a +redirect308 = Base.redirect308 . T.toStrict -- | Get a request header. Header name is case-insensitive. header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) diff --git a/Web/Scotty/Trans/Strict.hs b/Web/Scotty/Trans/Strict.hs index a835b78d..ccd90c56 100644 --- a/Web/Scotty/Trans/Strict.hs +++ b/Web/Scotty/Trans/Strict.hs @@ -29,8 +29,11 @@ module Web.Scotty.Trans.Strict , captureParamMaybe, formParamMaybe, queryParamMaybe , captureParams, formParams, queryParams , jsonData, files - -- ** Modifying the Response and Redirecting - , status, Base.addHeader, Base.setHeader, Base.redirect + -- ** Modifying the Response + , status, Base.addHeader, Base.setHeader + -- ** Redirecting + , Base.redirect, Base.redirect300, Base.redirect301, Base.redirect302, Base.redirect303 + , Base.redirect304, Base.redirect307, Base.redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route diff --git a/changelog.md b/changelog.md index 80575efb..102bc494 100644 --- a/changelog.md +++ b/changelog.md @@ -3,6 +3,7 @@ * Fixed cookie example from `Cookie` module documentation. `getCookie` Function would return strict variant of `Text`. Will convert it into lazy variant using `fromStrict`. * Exposed simple functions of `Cookie` module via `Web.Scotty` & `Web.Scotty.Trans`. * Add tests for URL encoding of query parameters and form parameters. Add `formData` action for decoding `FromForm` instances (#321). +* Add explicit redirect functions for all redirect status codes. ### Breaking changes * Remove dependency on data-default class (#386). We have been exporting constants for default config values since 0.20, and this dependency was simply unnecessary. diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 0279adfd..c6c36dfc 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -223,6 +223,64 @@ spec = do it "Responds with a 302 Redirect" $ do get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } + describe "redirect300" $ do + withApp ( + do + Scotty.get "/a" $ redirect300 "/b" + ) $ do + it "Responds with a 300 Redirect" $ do + get "/a" `shouldRespondWith` 300 { matchHeaders = ["Location" <:> "/b"] } + + + describe "redirect301" $ do + withApp ( + do + Scotty.get "/a" $ redirect301 "/b" + ) $ do + it "Responds with a 301 Redirect" $ do + get "/a" `shouldRespondWith` 301 { matchHeaders = ["Location" <:> "/b"] } + + describe "redirect302" $ do + withApp ( + do + Scotty.get "/a" $ redirect302 "/b" + ) $ do + it "Responds with a 302 Redirect" $ do + get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } + + + describe "redirect303" $ do + withApp ( + do + Scotty.delete "/a" $ redirect303 "/b" + ) $ do + it "Responds with a 303 as passed in" $ do + delete "/a" `shouldRespondWith` 303 { matchHeaders = ["Location" <:> "/b"]} + + describe "redirect304" $ do + withApp ( + do + Scotty.get "/a" $ redirect304 "/b" + ) $ do + it "Responds with a 304 Redirect" $ do + get "/a" `shouldRespondWith` 304 { matchHeaders = ["Location" <:> "/b"] } + + describe "redirect307" $ do + withApp ( + do + Scotty.get "/a" $ redirect307 "/b" + ) $ do + it "Responds with a 307 Redirect" $ do + get "/a" `shouldRespondWith` 307 { matchHeaders = ["Location" <:> "/b"] } + + describe "redirect308" $ do + withApp ( + do + Scotty.get "/a" $ redirect308 "/b" + ) $ do + it "Responds with a 308 Redirect" $ do + get "/a" `shouldRespondWith` 308 { matchHeaders = ["Location" <:> "/b"] } + describe "Parsable" $ do it "parses a UTCTime string" $ do parseParam "2023-12-18T00:38:00Z" `shouldBe` Right (UTCTime (fromGregorian 2023 12 18) (secondsToDiffTime (60 * 38)) )