{-|
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, ?respond :: Respond, HasPath action) => action -> IO ResponseReceived
redirectTo :: forall action.
(?request::Request, ?respond::Respond, HasPath action) =>
action -> IO ResponseReceived
redirectTo action
action = (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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, ?respond :: Respond, HasPath action) => action -> IO ResponseReceived
redirectToSeeOther :: forall action.
(?request::Request, ?respond::Respond, HasPath action) =>
action -> IO ResponseReceived
redirectToSeeOther action
action = (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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, ?respond :: Respond) => Text -> IO ResponseReceived
redirectToPath :: (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
redirectToPath Text
path = (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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, ?respond :: Respond) => Text -> IO ResponseReceived
redirectToPathSeeOther :: (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
redirectToPathSeeOther Text
path = (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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 :: (?request :: Request, ?respond :: Respond) => Text -> IO ResponseReceived
redirectToUrl :: (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
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)
    (?request::Request, ?respond::Respond) => Respond
Respond
respondWith 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 :: (?request :: Request, ?respond :: Respond) => Text -> IO ResponseReceived
redirectToUrlSeeOther :: (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
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)
    (?request::Request, ?respond::Respond) => Respond
Respond
respondWith 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, ?respond :: Respond) => IO ResponseReceived
redirectBack :: (?request::Request, ?respond::Respond) => IO ResponseReceived
redirectBack = (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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, ?respond :: Respond) => Text -> IO ResponseReceived
redirectBackWithFallback :: (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
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 -> (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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 -> (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
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, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
redirectToPath Text
fallbackPathOrUrl     -- Fallback Is Path "/../"
{-# INLINABLE redirectBackWithFallback #-}