{-# 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 :: Maybe Text -> Bool -> BrowserIdSettings
BrowserIdSettings
        { bisAudience :: Maybe Text
bisAudience = Maybe Text
forall a. Maybe a
Nothing
        , bisLazyLoad :: Bool
bisLazyLoad = Bool
True
        }

authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m
authBrowserId :: BrowserIdSettings -> AuthPlugin m
authBrowserId bis :: BrowserIdSettings
bis@BrowserIdSettings {Bool
Maybe Text
bisLazyLoad :: Bool
bisAudience :: Maybe Text
bisLazyLoad :: BrowserIdSettings -> Bool
bisAudience :: BrowserIdSettings -> Maybe Text
..} = AuthPlugin :: forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
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 -> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
a
                        Maybe Text
Nothing -> do
                            Route m -> Text
r <- m (Route m -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
                            AuthRoute -> Route m
tm <- m (AuthRoute -> Route m)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                            Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
stripScheme (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Route m -> Text
r (Route m -> Text) -> Route m -> Text
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route m
tm AuthRoute
LoginR
                Manager
manager <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
                Maybe Text
memail <- Text -> Text -> Manager -> m (Maybe Text)
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 <- m (AuthRoute -> Route m)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                      Route (HandlerSite m) -> Text -> m TypedContent
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 -> Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds :: forall master. Text -> Text -> [(Text, Text)] -> Creds master
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
        Text
onclick <- BrowserIdSettings -> (AuthRoute -> Route m) -> WidgetFor m Text
forall master.
BrowserIdSettings
-> (AuthRoute -> Route master) -> WidgetFor master Text
createOnClick BrowserIdSettings
bis AuthRoute -> Route m
toMaster

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

        ((Route m -> [(Text, Text)] -> Text) -> MarkupM ())
-> WidgetFor m ()
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 = 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
$ 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 :: 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
    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
    Text
onclick <- WidgetFor master Text
forall (m :: * -> *). MonadHandler m => m Text
newIdent
    Route master -> Text
render <- WidgetFor master (Route master -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
    let login :: Value
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
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
    JavascriptUrl (Route master) -> WidgetFor master ()
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");
            }
        }
    |]
    Bool -> WidgetFor master () -> WidgetFor master ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bisLazyLoad (WidgetFor master () -> WidgetFor master ())
-> WidgetFor master () -> WidgetFor master ()
forall a b. (a -> b) -> a -> b
$ JavascriptUrl (Route master) -> WidgetFor master ()
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 <- (Maybe Text -> Bool)
-> WidgetFor master (Maybe Text) -> WidgetFor master Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"true") (WidgetFor master (Maybe Text) -> WidgetFor master Bool)
-> WidgetFor master (Maybe Text) -> WidgetFor master Bool
forall a b. (a -> b) -> a -> b
$ Text -> WidgetFor master (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"autologin"
    Bool -> WidgetFor master () -> WidgetFor master ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autologin (WidgetFor master () -> WidgetFor master ())
-> WidgetFor master () -> WidgetFor master ()
forall a b. (a -> b) -> a -> b
$ JavascriptUrl (Route master) -> WidgetFor master ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [julius|#{rawJS onclick}();|]
    Text -> WidgetFor master Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
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
uri <- String -> Maybe URI
parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
        Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
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 :: 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