{-|
Module: IHP.Controller.Redirect
Description: redirect helpers
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Controller.Redirect
( redirectTo
, redirectToPath
, redirectToUrl
, redirectToSeeOther
, redirectToPathSeeOther
, redirectToUrlSeeOther
, redirectBack
, redirectBackWithFallback
) where

import Prelude
import Data.Text (Text)
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs, convertString)
import qualified Network.Wai.Util
import Network.URI (parseURI, uriToString)
import IHP.Router.UrlGenerator (HasPath (pathTo))
import Network.HTTP.Types.Status
import qualified Network.Wai.Middleware.Approot as Approot
import IHP.ControllerSupport

-- | Redirects to an action
--
-- __Example:__
--
-- > redirectTo ShowProjectAction { projectId = project.id }
--
-- Use 'redirectToPath' if you want to redirect to a non-action url.
redirectTo :: (?request :: Request, HasPath action) => action -> IO ()
redirectTo :: forall action.
(?request::Request, HasPath action) =>
action -> IO ()
redirectTo action
action = (?request::Request) => Text -> IO ()
Text -> IO ()
redirectToPath (action -> Text
forall controller. HasPath controller => controller -> Text
pathTo action
action)
{-# INLINABLE redirectTo #-}

-- | Redirects to an action using HTTP 303 See Other
--
-- Forces the follow-up request to be a GET (useful after POST/DELETE).
redirectToSeeOther :: (?request :: Request, HasPath action) => action -> IO ()
redirectToSeeOther :: forall action.
(?request::Request, HasPath action) =>
action -> IO ()
redirectToSeeOther action
action = (?request::Request) => Text -> IO ()
Text -> IO ()
redirectToPathSeeOther (action -> Text
forall controller. HasPath controller => controller -> Text
pathTo action
action)
{-# INLINABLE redirectToSeeOther #-}

-- TODO: redirectTo user

-- | Redirects to a path (given as a string)
--
-- __Example:__
--
-- > redirectToPath "/blog/wp-login.php"
--
-- Use 'redirectTo' if you want to redirect to a controller action.
redirectToPath :: (?request :: Request) => Text -> IO ()
redirectToPath :: (?request::Request) => Text -> IO ()
redirectToPath Text
path = Text -> IO ()
redirectToUrl (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
convertString ByteString
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
    where
        baseUrl :: ByteString
baseUrl = Request -> ByteString
Approot.getApproot ?request::Request
Request
?request
{-# INLINABLE redirectToPath #-}

-- | Redirects to a path using HTTP 303 See Other
--
-- Forces the follow-up request to be a GET (useful after POST/DELETE).
redirectToPathSeeOther :: (?request :: Request) => Text -> IO ()
redirectToPathSeeOther :: (?request::Request) => Text -> IO ()
redirectToPathSeeOther Text
path = Text -> IO ()
redirectToUrlSeeOther (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
convertString ByteString
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
    where
        baseUrl :: ByteString
baseUrl = Request -> ByteString
Approot.getApproot ?request::Request
Request
?request
{-# INLINABLE redirectToPathSeeOther #-}

-- | Redirects to a url (given as a string)
--
-- __Example:__
--
-- > redirectToUrl "https://example.com/hello-world.html"
--
-- Use 'redirectToPath' if you want to redirect to a relative path like @/hello-world.html@
redirectToUrl :: Text -> IO ()
redirectToUrl :: Text -> IO ()
redirectToUrl Text
url = do
    let !parsedUrl :: URI
parsedUrl = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe
            ([Char] -> URI
forall a. HasCallStack => [Char] -> a
error ([Char]
"redirectToPath: Unable to parse url: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
url))
            ([Char] -> Maybe URI
parseURI (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
url))
    let !redirectResponse :: Response
redirectResponse = Response -> Maybe Response -> Response
forall a. a -> Maybe a -> a
fromMaybe
            ([Char] -> Response
forall a. HasCallStack => [Char] -> a
error [Char]
"redirectToPath: Unable to construct redirect response")
            (Status -> ResponseHeaders -> URI -> Maybe Response
Network.Wai.Util.redirect Status
status302 [] URI
parsedUrl)
    Response -> IO ()
respondAndExit Response
redirectResponse
{-# INLINABLE redirectToUrl #-}

-- | Redirects to a url using HTTP 303 See Other
--
-- Forces the follow-up request to be a GET (useful after POST/DELETE).
redirectToUrlSeeOther :: Text -> IO ()
redirectToUrlSeeOther :: Text -> IO ()
redirectToUrlSeeOther Text
url = do
    let !parsedUrl :: URI
parsedUrl = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe
            ([Char] -> URI
forall a. HasCallStack => [Char] -> a
error ([Char]
"redirectToUrlSeeOther: Unable to parse url: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
url))
            ([Char] -> Maybe URI
parseURI (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
url))
    let !redirectResponse :: Response
redirectResponse = Response -> Maybe Response -> Response
forall a. a -> Maybe a -> a
fromMaybe
            ([Char] -> Response
forall a. HasCallStack => [Char] -> a
error [Char]
"redirectToUrlSeeOther: Unable to construct redirect response")
            (Status -> ResponseHeaders -> URI -> Maybe Response
Network.Wai.Util.redirect Status
status303 [] URI
parsedUrl)
    Response -> IO ()
respondAndExit Response
redirectResponse
{-# INLINABLE redirectToUrlSeeOther #-}

-- | Redirects back to the last page
--
-- Uses the Referer header to do a redirect to page that got you here.
--
-- In case the Referer header is not set this function will redirect to @/@. Use 'redirectBackWithFallback' when you want
-- to specify a custom fallback path.
--
-- __Example:__
--
-- > action LikeAction { postId } = do
-- >     post <- fetch postId
-- >     post
-- >         |> incrementField #likesCount
-- >         |> updateRecord
-- >
-- >     redirectBack
--
redirectBack :: (?request :: Request) => IO ()
redirectBack :: (?request::Request) => IO ()
redirectBack = (?request::Request) => Text -> IO ()
Text -> IO ()
redirectBackWithFallback Text
"/"
{-# INLINABLE redirectBack #-}

-- | Redirects back to the last page or the given fallback path in case the Referer header is missing
--
-- If you don't care about the missing-Referer-header case, use 'redirectBack'.
--
-- __Example:__
--
-- > action LikeAction { postId } = do
-- >     post <- fetch postId
-- >     post
-- >         |> incrementField #likesCount
-- >         |> updateRecord
-- >
-- >     redirectBackWithFallback (pathTo ShowPostAction { postId = post.id })
--
redirectBackWithFallback :: (?request :: Request) => Text -> IO ()
redirectBackWithFallback :: (?request::Request) => Text -> IO ()
redirectBackWithFallback Text
fallbackPathOrUrl = do
    case (?request::Request) => ByteString -> Maybe ByteString
ByteString -> Maybe ByteString
getHeader ByteString
"Referer" of
        Just ByteString
referer -> case [Char] -> Maybe URI
parseURI (ByteString -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
referer) of
                Just URI
uri -> Text -> IO ()
redirectToUrl ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (([Char] -> [Char]) -> URI -> [Char] -> [Char]
uriToString [Char] -> [Char]
forall a. a -> a
id URI
uri [Char]
""))           -- Referer Is URL "https://google.com/..."
                Maybe URI
Nothing -> (?request::Request) => Text -> IO ()
Text -> IO ()
redirectToPath (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
referer)          -- Referer Is Path "/../"
        Maybe ByteString
Nothing -> case [Char] -> Maybe URI
parseURI (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
fallbackPathOrUrl) of
                Just URI
uri -> Text -> IO ()
redirectToUrl ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (([Char] -> [Char]) -> URI -> [Char] -> [Char]
uriToString [Char] -> [Char]
forall a. a -> a
id URI
uri [Char]
""))           -- Fallback Is URL "https://google.com/..."
                Maybe URI
Nothing -> (?request::Request) => Text -> IO ()
Text -> IO ()
redirectToPath Text
fallbackPathOrUrl     -- Fallback Is Path "/../"
{-# INLINABLE redirectBackWithFallback #-}