{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
-- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this
-- module is no longer recommended for use.
module Yesod.Auth.BrowserId
    {-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-}
    ( authBrowserId
    , createOnClick, createOnClickOverride
    , def
    , BrowserIdSettings
    , bisAudience
    , bisLazyLoad
    , forwardUrl
    ) where

import Yesod.Auth
import Web.Authenticate.BrowserId
import Data.Text (Text)
import Yesod.Core
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Control.Monad (when, unless)
import Text.Julius (rawJS)
import Network.URI (uriPath, parseURI)
import Data.FileEmbed (embedFile)
import Data.ByteString (ByteString)
import Data.Default

pid :: Text
pid :: Text
pid = Text
"browserid"

forwardUrl :: AuthRoute
forwardUrl :: AuthRoute
forwardUrl = Text -> Texts -> AuthRoute
PluginR Text
pid []

complete :: AuthRoute
complete :: AuthRoute
complete = AuthRoute
forwardUrl

-- | A settings type for various configuration options relevant to BrowserID.
--
-- See: <http://www.yesodweb.com/book/settings-types>
--
-- Since 1.2.0
data BrowserIdSettings = BrowserIdSettings
    { BrowserIdSettings -> Maybe Text
bisAudience :: Maybe Text
    -- ^ BrowserID audience value. If @Nothing@, will be extracted based on the
    -- approot.
    --
    -- Default: @Nothing@
    --
    -- Since 1.2.0
    , BrowserIdSettings -> Bool
bisLazyLoad :: Bool
    -- ^ Use asynchronous Javascript loading for the BrowserID JS file.
    --
    -- Default: @True@.
    --
    -- Since 1.2.0
    }

instance Default BrowserIdSettings where
    def :: BrowserIdSettings
def = BrowserIdSettings
        { bisAudience :: Maybe Text
bisAudience = Maybe Text
forall a. Maybe a
Nothing
        , bisLazyLoad :: Bool
bisLazyLoad = Bool
True
        }

authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m
authBrowserId :: forall m. YesodAuth m => BrowserIdSettings -> AuthPlugin m
authBrowserId bis :: BrowserIdSettings
bis@BrowserIdSettings {Bool
Maybe Text
bisAudience :: BrowserIdSettings -> Maybe Text
bisLazyLoad :: BrowserIdSettings -> Bool
bisAudience :: Maybe Text
bisLazyLoad :: Bool
..} = AuthPlugin
    { apName :: Text
apName = Text
pid
    , apDispatch :: Text -> Texts -> AuthHandler m TypedContent
apDispatch = \Text
m Texts
ps ->
        case (Text
m, Texts
ps) of
            (Text
"GET", [Text
assertion]) -> do
                audience <-
                    case Maybe Text
bisAudience of
                        Just Text
a -> Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
a
                        Maybe Text
Nothing -> do
                            r <- m (Route m -> Text)
m (Route (HandlerSite m) -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
                            tm <- getRouteToParent
                            return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
                manager <- authHttpManager
                memail <- checkAssertion audience assertion manager
                case memail of
                    Maybe Text
Nothing -> do
                      $Text -> Text -> m ()
logErrorS Text
"yesod-auth" Text
"BrowserID assertion failure"
                      tm <- m (Route (SubHandlerSite m) -> Route (HandlerSite m))
m (AuthRoute -> Route m)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                      loginErrorMessage (tm LoginR) "BrowserID login error."
                    Just Text
email -> Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds
                        { credsPlugin :: Text
credsPlugin = Text
pid
                        , credsIdent :: Text
credsIdent = Text
email
                        , credsExtra :: [(Text, Text)]
credsExtra = []
                        }
            (Text
"GET", [Text
"static", Text
"sign-in.png"]) -> (ByteString, Content) -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
                ( ByteString
"image/png" :: ByteString
                , ByteString -> Content
forall a. ToContent a => a -> Content
toContent $(embedFile "persona_sign_in_blue.png")
                )
            (Text
_, []) -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
badMethod
            (Text, Texts)
_ -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
    , apLogin :: (AuthRoute -> Route m) -> WidgetFor m ()
apLogin = \AuthRoute -> Route m
toMaster -> do
        onclick <- BrowserIdSettings -> (AuthRoute -> Route m) -> WidgetFor m Text
forall master.
BrowserIdSettings
-> (AuthRoute -> Route master) -> WidgetFor master Text
createOnClick BrowserIdSettings
bis AuthRoute -> Route m
toMaster

        autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
        when autologin $ toWidget [julius|#{rawJS onclick}();|]

        toWidget [hamlet|
$newline never
<p>
    <a href="javascript:#{onclick}()">
        <img src=@{toMaster loginIcon}>
|]
    }
  where
    loginIcon :: AuthRoute
loginIcon = Text -> Texts -> AuthRoute
PluginR Text
pid [Text
"static", Text
"sign-in.png"]
    stripScheme :: Text -> Text
stripScheme Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"//" (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"//" Text
t

-- | Generates a function to handle on-click events, and returns that function
-- name.
createOnClickOverride :: BrowserIdSettings
              -> (Route Auth -> Route master)
              -> Maybe (Route master)
              -> WidgetFor master Text
createOnClickOverride :: forall master.
BrowserIdSettings
-> (AuthRoute -> Route master)
-> Maybe (Route master)
-> WidgetFor master Text
createOnClickOverride BrowserIdSettings {Bool
Maybe Text
bisAudience :: BrowserIdSettings -> Maybe Text
bisLazyLoad :: BrowserIdSettings -> Bool
bisAudience :: Maybe Text
bisLazyLoad :: Bool
..} AuthRoute -> Route master
toMaster Maybe (Route master)
mOnRegistration = do
    Bool -> WidgetFor master () -> WidgetFor master ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
bisLazyLoad (WidgetFor master () -> WidgetFor master ())
-> WidgetFor master () -> WidgetFor master ()
forall a b. (a -> b) -> a -> b
$ Text -> WidgetFor master ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
browserIdJs
    onclick <- WidgetFor master Text
forall (m :: * -> *). MonadHandler m => m Text
newIdent
    render <- getUrlRender
    let login = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Text
getPath (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Route master -> Text
render Route master
loginRoute -- (toMaster LoginR)
        loginRoute = Route master
-> (Route master -> Route master)
-> Maybe (Route master)
-> Route master
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthRoute -> Route master
toMaster AuthRoute
LoginR) Route master -> Route master
forall a. a -> a
id Maybe (Route master)
mOnRegistration
    toWidget [julius|
        function #{rawJS onclick}() {
            if (navigator.id) {
                navigator.id.watch({
                    onlogin: function (assertion) {
                        if (assertion) {
                            document.location = "@{toMaster complete}/" + assertion;
                        }
                    },
                    onlogout: function () {}
                });
                navigator.id.request({
                    returnTo: #{login} + "?autologin=true"
                });
            }
            else {
                alert("Loading, please try again");
            }
        }
    |]
    when bisLazyLoad $ toWidget [julius|
        (function(){
            var bid = document.createElement("script");
            bid.async = true;
            bid.src = #{toJSON browserIdJs};
            var s = document.getElementsByTagName('script')[0];
            s.parentNode.insertBefore(bid, s);
        })();
    |]

    autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
    when autologin $ toWidget [julius|#{rawJS onclick}();|]
    return onclick
  where
    getPath :: Text -> Text
getPath Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
        uri <- String -> Maybe URI
parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
        return $ T.pack $ uriPath uri

-- | Generates a function to handle on-click events, and returns that function
-- name.
createOnClick :: BrowserIdSettings
              -> (Route Auth -> Route master)
              -> WidgetFor master Text
createOnClick :: forall master.
BrowserIdSettings
-> (AuthRoute -> Route master) -> WidgetFor master Text
createOnClick BrowserIdSettings
bidSettings AuthRoute -> Route master
toMaster = BrowserIdSettings
-> (AuthRoute -> Route master)
-> Maybe (Route master)
-> WidgetFor master Text
forall master.
BrowserIdSettings
-> (AuthRoute -> Route master)
-> Maybe (Route master)
-> WidgetFor master Text
createOnClickOverride BrowserIdSettings
bidSettings AuthRoute -> Route master
toMaster Maybe (Route master)
forall a. Maybe a
Nothing