Skip to content
Snippets Groups Projects
Verified Commit fe1bf0cd authored by jan.hamal.dvorak's avatar jan.hamal.dvorak
Browse files

Add referrer support

parent b017ece7
Branches
No related tags found
No related merge requests found
...@@ -19,6 +19,7 @@ module Web.Hikaru.Action ...@@ -19,6 +19,7 @@ module Web.Hikaru.Action
, getMethod , getMethod
, getHeaders , getHeaders
, getHeaderMaybe , getHeaderMaybe
, getHeaderDefault
, getAccept , getAccept
, getAcceptCharset , getAcceptCharset
, getAcceptEncoding , getAcceptEncoding
...@@ -33,6 +34,7 @@ module Web.Hikaru.Action ...@@ -33,6 +34,7 @@ module Web.Hikaru.Action
, getCookies , getCookies
, getCookieMaybe , getCookieMaybe
, getCookieDefault , getCookieDefault
, getReferrer
, getBodyLength , getBodyLength
, setBodyLimit , setBodyLimit
, getBodyLimit , getBodyLimit
...@@ -63,6 +65,7 @@ module Web.Hikaru.Action ...@@ -63,6 +65,7 @@ module Web.Hikaru.Action
, sendString , sendString
, sendJSON , sendJSON
, redirect , redirect
, redirectBack
, setResponseFile , setResponseFile
, setResponseBuilder , setResponseBuilder
, setResponseBS , setResponseBS
...@@ -270,6 +273,14 @@ where ...@@ -270,6 +273,14 @@ where
getHeaderMaybe n = lookup n <$> getHeaders 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 @\"*/*\"@. -- Obtain the Accept header value or the default value of @\"*/*\"@.
-- --
...@@ -393,6 +404,17 @@ where ...@@ -393,6 +404,17 @@ where
getCookieDefault n v = fromMaybe v <$> getCookieMaybe n 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. -- Try to obtain request body length.
-- This will fail when the body is chunked. -- This will fail when the body is chunked.
...@@ -854,6 +876,13 @@ where ...@@ -854,6 +876,13 @@ where
setHeader hLocation (cs location) 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. -- Create response body using a file.
-- --
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment