{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Server.Authentication.Utils
( getCallbackUri
, saveReferer
, redirectToCurrentRefererIfAllowed
, redirectToSavedRefererIfAllowed
, redirectToBodyRefererIfAllowed
, presentMessageAndRedirectToTargetUrl
, presentMessageAndRedirectToBodyRefererIfAllowed
, presentMessageAndRedirectToCookieRefererIfAllowed
, isAllowedReferer
, retrieveRequestHeaderRefererIfAllowed
, retrieveBodyRefererIfAllowed
, retrieveCookieRefererIfAllowed
) where

import Happstack.Server
import Data.List (isPrefixOf)
import Data.Maybe (maybe)
import Control.Applicative (optional)
import URI.ByteString (URI, parseURI, strictURIParserOptions)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Char8 as BSS8
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze as B
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

-- | Retrieves the appropriate callback URI based on the Host header.
getCallbackUri :: T.Text -> ServerPart URI
getCallbackUri :: Text -> ServerPartT IO URI
getCallbackUri Text
callbackPath = do
    -- TODO: allow list for hosts
    Request
rq <- ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    case String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"host" Request
rq of
        Maybe ByteString
Nothing -> ServerPartT IO URI
forall a. Monoid a => a
mempty
        Just ByteString
rawHost -> do
            let host :: Text
host = ByteString -> Text
TE.decodeUtf8 ByteString
rawHost
            let scheme :: Text
scheme = if ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') Text
host) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"localhost", Text
"127.0.0.1"] then Text
"http" else Text
"https"
            case URIParserOptions -> ByteString -> Either URIParseError URI
parseURI URIParserOptions
strictURIParserOptions (ByteString -> Either URIParseError URI)
-> ByteString -> Either URIParseError URI
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
scheme, Text
"://", Text
host, Text
callbackPath] of
                Left URIParseError
_ -> ServerPartT IO URI
forall a. Monoid a => a
mempty
                Right URI
parsedURI -> URI -> ServerPartT IO URI
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return URI
parsedURI

-- * Allow lists
-- | List of allowed referer prefixes.
allowedRefererPrefixes :: [T.Text]
allowedRefererPrefixes :: [Text]
allowedRefererPrefixes =
    [ Text
"http://localhost:8000/"
    , Text
"http://localhost:8080/"
    , Text
"https://lojban.johnjq.com/"
    , Text
"https://lojban.io/"
    ]

-- | Checks whether a given referer is allowed.
isAllowedReferer :: T.Text -> Bool
isAllowedReferer :: Text -> Bool
isAllowedReferer Text
referer = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
referer) [Text]
allowedRefererPrefixes

-- * Plain redirects
-- | Redirects to the current referer, if allowed; otherwise, redirects to homepage.
-- TODO: rename function to "redirectToRequestHeaderRefererIfAllowed"
redirectToCurrentRefererIfAllowed :: ServerPart Response
redirectToCurrentRefererIfAllowed :: ServerPart Response
redirectToCurrentRefererIfAllowed = do
    Maybe Text
refererMaybe <- ServerPart (Maybe Text)
retrieveRequestHeaderRefererIfAllowed
    case Maybe Text
refererMaybe of
        Maybe Text
Nothing -> ServerPart Response
redirectToHomepage
        Just Text
referer -> Text -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect Text
referer (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse Text
T.empty

-- | Redirects to the referer from the "referer" parameter in the request body, if allowed; otherwise, redirects to homepage.
redirectToBodyRefererIfAllowed :: ServerPart Response
redirectToBodyRefererIfAllowed :: ServerPart Response
redirectToBodyRefererIfAllowed = do
    Maybe Text
refererMaybe <- ServerPart (Maybe Text)
retrieveBodyRefererIfAllowed
    case Maybe Text
refererMaybe of
        Maybe Text
Nothing -> ServerPart Response
redirectToHomepage
        Just Text
referer -> Text -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect Text
referer (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse Text
T.empty

-- TODO: rename to "saveRefererToCookie"
-- TODO: place this function outside of the "Plain redirects" section
-- | Saves the referer from the "Referer" request header to the specified cookie.
saveReferer :: T.Text -> ServerPart ()
saveReferer :: Text -> ServerPart ()
saveReferer Text
refererCookieName = do
    Request
rq <- ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    let refererMaybe :: Maybe String
refererMaybe = do
            String
originalReferer <- ByteString -> String
BSS8.unpack (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Referer" Request
rq
            if Text -> Bool
isAllowedReferer (String -> Text
T.pack String
originalReferer) then
                String -> Maybe String
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return String
originalReferer
            else
                Maybe String
forall a. Maybe a
Nothing
    case Maybe String
refererMaybe of
        Just String
referer -> CookieLife -> Cookie -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie CookieLife
Session (Cookie -> ServerPart ()) -> Cookie -> ServerPart ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Cookie
mkCookie (Text -> String
T.unpack Text
refererCookieName) String
referer
        Maybe String
Nothing -> String -> ServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie (Text -> String
T.unpack Text
refererCookieName)
    () -> ServerPart ()
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- TODO: rename this function to "redirectToCookieRefererIfAllowed"
-- | Redirects to the referer from the specified cookie, if allowed; otherwise, redirects to homepage.
redirectToSavedRefererIfAllowed :: T.Text -> ServerPart Response
redirectToSavedRefererIfAllowed :: Text -> ServerPart Response
redirectToSavedRefererIfAllowed Text
refererCookieName = do
    Maybe Text
refererMaybe <- Text -> ServerPart (Maybe Text)
retrieveCookieRefererIfAllowed Text
refererCookieName
    case Maybe Text
refererMaybe of
        Maybe Text
Nothing -> ServerPart Response
redirectToHomepage
        Just Text
referer -> Text -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect Text
referer (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse Text
T.empty

-- | Redirects to the homepage.
redirectToHomepage :: ServerPart Response
redirectToHomepage :: ServerPart Response
redirectToHomepage = Text -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect (Text
"/" :: T.Text) (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse Text
T.empty

-- * Redirects with custom message
-- | Display a custom message and then redirects to the referer found in the "referer" parameter in the request body, if allowed; otherwise, redirects to homepage.
presentMessageAndRedirectToBodyRefererIfAllowed :: T.Text -> ServerPart Response
presentMessageAndRedirectToBodyRefererIfAllowed :: Text -> ServerPart Response
presentMessageAndRedirectToBodyRefererIfAllowed Text
message = do
    let fallbackReferer :: Text
fallbackReferer = Text
"/"
    Maybe Text
bodyRefererMaybe <- ServerPart (Maybe Text)
retrieveBodyRefererIfAllowed
    case Maybe Text
bodyRefererMaybe of
        Maybe Text
Nothing -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl Text
fallbackReferer Text
message
        Just Text
bodyReferer -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl Text
bodyReferer Text
message

-- | Display a custom message and then redirects to the referer found in the specified cookie, if allowed; otherwise, redirects to homepage.
presentMessageAndRedirectToCookieRefererIfAllowed :: T.Text -> T.Text -> ServerPart Response
presentMessageAndRedirectToCookieRefererIfAllowed :: Text -> Text -> ServerPart Response
presentMessageAndRedirectToCookieRefererIfAllowed Text
refererCookieName Text
message = do
    let fallbackReferer :: Text
fallbackReferer = Text
"/"
    Maybe Text
cookieRefererMaybe <- Text -> ServerPart (Maybe Text)
retrieveCookieRefererIfAllowed Text
refererCookieName
    case Maybe Text
cookieRefererMaybe of
        Maybe Text
Nothing -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl Text
fallbackReferer Text
message
        Just Text
cookieReferer -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl Text
cookieReferer Text
message

-- | Display a custom message and then redirects to the target url.
presentMessageAndRedirectToTargetUrl :: T.Text -> T.Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl :: Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl Text
targetUrl Text
message = Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> Response) -> Html -> Response
forall a b. (a -> b) -> a -> b
$ do
    -- TODO: implement fallback if JS is disabled (response header for redirect + "if you are not redirected in X seconds... link" in HTML)
    let escapeString :: Text -> Text
escapeString =  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"\\\"" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\" Text
"\\\\"
    let embeddedCode :: Text
embeddedCode = [Text] -> Text
T.concat
            [ Text
"alert(\"" Text -> Text -> Text
`T.append` (Text -> Text
escapeString Text
message) Text -> Text -> Text
`T.append` Text
"\");"
            , Text
"window.location = \"" Text -> Text -> Text
`T.append` (Text -> Text
escapeString Text
targetUrl) Text -> Text -> Text
`T.append` Text
"\";"
            ]
    Html -> Html
H.script (Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml Text
embeddedCode)
      Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
B.! AttributeValue -> Attribute
A.type_ AttributeValue
"text/javascript"

-- * Referer retrieval
-- | Retrieves the referer found in the "Referer" request header, if allowed; otherwise, returns `Nothing`.
retrieveRequestHeaderRefererIfAllowed :: ServerPart (Maybe T.Text)
retrieveRequestHeaderRefererIfAllowed :: ServerPart (Maybe Text)
retrieveRequestHeaderRefererIfAllowed = ((ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> Text) -> Maybe ByteString -> Maybe Text)
-> (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSS8.unpack) (Maybe ByteString -> Maybe Text)
-> (Request -> Maybe ByteString) -> Request -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Referer" (Request -> Maybe Text)
-> ServerPartT IO Request -> ServerPart (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq ServerPart (Maybe Text)
-> (Maybe Text -> ServerPart (Maybe Text))
-> ServerPart (Maybe Text)
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Text -> ServerPart (Maybe Text)
retrieveSpecifiedRefererIfAllowed

-- | Retrieves the referer found in the "referer" parameter in the request body, if allowed; otherwise, returns `Nothing`.
retrieveBodyRefererIfAllowed :: ServerPart (Maybe T.Text)
retrieveBodyRefererIfAllowed :: ServerPart (Maybe Text)
retrieveBodyRefererIfAllowed = ((Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
TL.toStrict) (Maybe Text -> Maybe Text)
-> ServerPartT IO (Maybe Text) -> ServerPart (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServerPartT IO Text -> ServerPartT IO (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ServerPartT IO Text -> ServerPartT IO (Maybe Text))
-> ServerPartT IO Text -> ServerPartT IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ServerPartT IO Text -> ServerPartT IO Text
forall (m :: * -> *) a. HasRqData m => m a -> m a
body (ServerPartT IO Text -> ServerPartT IO Text)
-> ServerPartT IO Text -> ServerPartT IO Text
forall a b. (a -> b) -> a -> b
$ String -> ServerPartT IO Text
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m Text
lookText String
"referer") ServerPart (Maybe Text)
-> (Maybe Text -> ServerPart (Maybe Text))
-> ServerPart (Maybe Text)
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Text -> ServerPart (Maybe Text)
retrieveSpecifiedRefererIfAllowed

-- | Retrieves the referer found in the specified cookie, if allowed; otherwise, returns `Nothing`.
retrieveCookieRefererIfAllowed :: T.Text -> ServerPart (Maybe T.Text)
retrieveCookieRefererIfAllowed :: Text -> ServerPart (Maybe Text)
retrieveCookieRefererIfAllowed Text
refererCookieName = ((String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack) (Maybe String -> Maybe Text)
-> ServerPartT IO (Maybe String) -> ServerPart (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServerPartT IO String -> ServerPartT IO (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ServerPartT IO String -> ServerPartT IO (Maybe String))
-> ServerPartT IO String -> ServerPartT IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> ServerPartT IO String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
lookCookieValue (String -> ServerPartT IO String)
-> String -> ServerPartT IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
refererCookieName) ServerPart (Maybe Text)
-> (Maybe Text -> ServerPart (Maybe Text))
-> ServerPart (Maybe Text)
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Text -> ServerPart (Maybe Text)
retrieveSpecifiedRefererIfAllowed

-- | Retrieves the specified referer, if allowed; otherwise, returns `Nothing`.
retrieveSpecifiedRefererIfAllowed :: Maybe T.Text -> ServerPart (Maybe T.Text)
retrieveSpecifiedRefererIfAllowed :: Maybe Text -> ServerPart (Maybe Text)
retrieveSpecifiedRefererIfAllowed Maybe Text
refererMaybe = Maybe Text -> ServerPart (Maybe Text)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> ServerPart (Maybe Text))
-> Maybe Text -> ServerPart (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
    Text
referer <- Maybe Text
refererMaybe
    if Text -> Bool
isAllowedReferer Text
referer then
        Text -> Maybe Text
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
referer
    else
        Maybe Text
forall a. Maybe a
Nothing