From fe1bf0cd22f5f78b5941a877e4321c11c282f108 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org> Date: Sat, 4 May 2019 15:52:55 +0200 Subject: [PATCH] Add referrer support MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org> --- lib/Web/Hikaru/Action.hs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/lib/Web/Hikaru/Action.hs b/lib/Web/Hikaru/Action.hs index b4b5ca9..7fa6ff0 100644 --- a/lib/Web/Hikaru/Action.hs +++ b/lib/Web/Hikaru/Action.hs @@ -19,6 +19,7 @@ module Web.Hikaru.Action , getMethod , getHeaders , getHeaderMaybe + , getHeaderDefault , getAccept , getAcceptCharset , getAcceptEncoding @@ -33,6 +34,7 @@ module Web.Hikaru.Action , getCookies , getCookieMaybe , getCookieDefault + , getReferrer , getBodyLength , setBodyLimit , getBodyLimit @@ -63,6 +65,7 @@ module Web.Hikaru.Action , sendString , sendJSON , redirect + , redirectBack , setResponseFile , setResponseBuilder , setResponseBS @@ -270,6 +273,14 @@ where getHeaderMaybe n = lookup n <$> getHeaders + -- | + -- Obtain a specific request header or the given default value. + -- + getHeaderDefault :: (MonadAction m) + => HeaderName -> ByteString -> m ByteString + getHeaderDefault n v = fromMaybe v <$> getHeaderMaybe n + + -- | -- Obtain the Accept header value or the default value of @\"*/*\"@. -- @@ -393,6 +404,17 @@ where getCookieDefault n v = fromMaybe v <$> getCookieMaybe n + -- | + -- Returns HTTP @Referrer@ header or just @/@. + -- + -- Useful for redirects back to where the user came from. + -- + getReferrer :: (MonadAction m) => m Text + getReferrer = do + header <- getHeaderDefault hReferer "/" + return (cs header) + + -- | -- Try to obtain request body length. -- This will fail when the body is chunked. @@ -854,6 +876,13 @@ where setHeader hLocation (cs location) + -- | + -- Redirect the user to where he came from using 'getReferrer'. + -- + redirectBack :: (MonadAction m) => m () + redirectBack = redirect =<< getReferrer + + -- | -- Create response body using a file. -- -- GitLab