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

import IHP.Prelude
import qualified Network.Wai.Util
import Network.URI (parseURI)
import IHP.Controller.RequestContext
import IHP.RouterSupport (HasPath (pathTo))
import IHP.FrameworkConfig
import Network.HTTP.Types.Status

import IHP.Controller.Context
import IHP.ControllerSupport

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

-- 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 :: (?context :: ControllerContext) => Text -> IO ()
redirectToPath :: Text -> IO ()
redirectToPath Text
path = (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
redirectToUrl ((FrameworkConfig -> Text) -> Text
forall context a.
(?context::context, ConfigProvider context) =>
(FrameworkConfig -> a) -> a
fromConfig FrameworkConfig -> Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
{-# INLINABLE redirectToPath #-}

-- | 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 :: (?context :: ControllerContext) => Text -> IO ()
redirectToUrl :: Text -> IO ()
redirectToUrl Text
url = do
    let RequestContext { Respond
$sel:respond:RequestContext :: RequestContext -> Respond
respond :: Respond
respond } = ?context::ControllerContext
ControllerContext
?context ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext
    let !parsedUrl :: URI
parsedUrl = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe
            (Text -> URI
forall a. Text -> a
error (Text
"redirectToPath: Unable to parse url: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
show Text
url))
            (String -> Maybe URI
parseURI (Text -> String
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
            (Text -> Response
forall a. Text -> a
error Text
"redirectToPath: Unable to construct redirect response")
            (Status -> ResponseHeaders -> URI -> Maybe Response
Network.Wai.Util.redirect Status
status302 [] URI
parsedUrl)
    (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit Response
redirectResponse
{-# INLINABLE redirectToUrl #-}


-- | 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 :: (?context :: ControllerContext) => IO ()
redirectBack :: IO ()
redirectBack = (?context::ControllerContext) => 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 = get #id post })
--
redirectBackWithFallback :: (?context :: ControllerContext) => Text -> IO ()
redirectBackWithFallback :: Text -> IO ()
redirectBackWithFallback Text
fallbackPathOrUrl = do
    case (?context::ControllerContext) => ByteString -> Maybe ByteString
ByteString -> Maybe ByteString
getHeader ByteString
"Referer" of
        Just ByteString
referer -> case String -> Maybe URI
parseURI (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
referer) of
                Just URI
uri -> (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
redirectToUrl (URI -> Text
forall a. Show a => a -> Text
tshow URI
uri)           -- Referer Is URL "https://google.com/..."
                Maybe URI
Nothing -> (?context::ControllerContext) => 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 String -> Maybe URI
parseURI (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
fallbackPathOrUrl) of
                Just URI
uri -> (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
redirectToUrl (URI -> Text
forall a. Show a => a -> Text
tshow URI
uri)           -- Fallback Is URL "https://google.com/..."
                Maybe URI
Nothing -> (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
redirectToPath Text
fallbackPathOrUrl     -- Fallback Is Path "/../"
{-# INLINABLE redirectBackWithFallback #-}