    {-# 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