Add referrer support

Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>

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.
   --