diff --git a/lib/Web/Hikaru/Action.hs b/lib/Web/Hikaru/Action.hs index b4b5ca9574f0f1934ef63f1d69b674b35db35783..7fa6ff011e4c33e805351a514c02d8c6a0b7ed0a 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. --