{-# 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 = 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
bisLazyLoad :: Bool
bisAudience :: Maybe Text
bisLazyLoad :: BrowserIdSettings -> Bool
bisAudience :: BrowserIdSettings -> Maybe Text
..} = 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
                Text
audience <-
                    case Maybe Text
bisAudience of
                        Just Text
a -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
a
                        Maybe Text
Nothing -> do
                            Route m -> Text
r <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
                            AuthRoute -> Route m
tm <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') forall a b. (a -> b) -> a -> b
$ Text -> Text
stripScheme forall a b. (a -> b) -> a -> b
$ Route m -> Text
r forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route m
tm AuthRoute
LoginR
                Manager
manager <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
                Maybe Text
memail <- forall (m :: * -> *).
MonadIO m =>
Text -> Text -> Manager -> m (Maybe Text)
checkAssertion Text
audience Text
assertion Manager
manager
                case Maybe Text
memail of
                    Maybe Text
Nothing -> do
                      $Text -> Text -> m ()
logErrorS Text
"yesod-auth" Text
"BrowserID assertion failure"
                      AuthRoute -> Route m
tm <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                      forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route m
tm AuthRoute
LoginR) Text
"BrowserID login error."
                    Just Text
email -> 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"]) -> forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
                ( ByteString
"image/png" :: ByteString
                , forall a. ToContent a => a -> Content
toContent $(embedFile "persona_sign_in_blue.png")
                )
            (Text
_, []) -> forall (m :: * -> *) a. MonadHandler m => m a
badMethod
            (Text, Texts)
_ -> forall (m :: * -> *) a. MonadHandler m => m a
notFound
    , apLogin :: (AuthRoute -> Route m) -> WidgetFor m ()
apLogin = \AuthRoute -> Route m
toMaster -> do
        Text
onclick <- forall master.
BrowserIdSettings
-> (AuthRoute -> Route master) -> WidgetFor master Text
createOnClick BrowserIdSettings
bis AuthRoute -> Route m
toMaster

        Bool
autologin <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"true") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"autologin"
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autologin forall a b. (a -> b) -> a -> b
$ forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [julius|#{rawJS onclick}();|]

        forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
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 = forall a. a -> Maybe a -> a
fromMaybe Text
t forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"//" forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ 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
bisLazyLoad :: Bool
bisAudience :: Maybe Text
bisLazyLoad :: BrowserIdSettings -> Bool
bisAudience :: BrowserIdSettings -> Maybe Text
..} AuthRoute -> Route master
toMaster Maybe (Route master)
mOnRegistration = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
bisLazyLoad forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
browserIdJs
    Text
onclick <- forall (m :: * -> *). MonadHandler m => m Text
newIdent
    Route master -> Text
render <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
    let login :: Value
login = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Text -> Text
getPath forall a b. (a -> b) -> a -> b
$ Route master -> Text
render Route master
loginRoute -- (toMaster LoginR)
        loginRoute :: Route master
loginRoute = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthRoute -> Route master
toMaster AuthRoute
LoginR) forall a. a -> a
id Maybe (Route master)
mOnRegistration
    forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
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");
            }
        }
    |]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bisLazyLoad forall a b. (a -> b) -> a -> b
$ forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
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);
        })();
    |]

    Bool
autologin <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"true") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"autologin"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autologin forall a b. (a -> b) -> a -> b
$ forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [julius|#{rawJS onclick}();|]
    forall (m :: * -> *) a. Monad m => a -> m a
return Text
onclick
  where
    getPath :: Text -> Text
getPath Text
t = forall a. a -> Maybe a -> a
fromMaybe Text
t forall a b. (a -> b) -> a -> b
$ do
        URI
uri <- String -> Maybe URI
parseURI forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath URI
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 = forall master.
BrowserIdSettings
-> (AuthRoute -> Route master)
-> Maybe (Route master)
-> WidgetFor master Text
createOnClickOverride BrowserIdSettings
bidSettings AuthRoute -> Route master
toMaster forall a. Maybe a
Nothing