124 lines
3.9 KiB
Haskell
124 lines
3.9 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
module Yesod.Auth.BrowserId
|
|
( authBrowserId
|
|
, authBrowserIdAudience
|
|
, createOnClick
|
|
) where
|
|
|
|
import Yesod.Auth
|
|
import Web.Authenticate.BrowserId
|
|
import Data.Text (Text)
|
|
import Yesod.Core
|
|
import Text.Hamlet (hamlet)
|
|
import qualified Data.Text as T
|
|
import Data.Maybe (fromMaybe)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad (when)
|
|
import Control.Exception (throwIO)
|
|
import Text.Julius (julius, rawJS)
|
|
import Data.Aeson (toJSON)
|
|
import Network.URI (uriPath, parseURI)
|
|
import Data.FileEmbed (embedFile)
|
|
import Data.ByteString (ByteString)
|
|
import Control.Monad.Trans.Class
|
|
|
|
pid :: Text
|
|
pid = "browserid"
|
|
|
|
complete :: Route Auth
|
|
complete = PluginR pid []
|
|
|
|
-- | Log into browser ID with an audience value determined from the 'approot'.
|
|
authBrowserId :: YesodAuth m => AuthPlugin m
|
|
authBrowserId = helper Nothing
|
|
|
|
-- | Log into browser ID with the given audience value. Note that this must be
|
|
-- your actual hostname, or login will fail.
|
|
authBrowserIdAudience
|
|
:: YesodAuth m
|
|
=> Text -- ^ audience
|
|
-> AuthPlugin m
|
|
authBrowserIdAudience = helper . Just
|
|
|
|
helper :: YesodAuth m
|
|
=> Maybe Text -- ^ audience
|
|
-> AuthPlugin m
|
|
helper maudience = AuthPlugin
|
|
{ apName = pid
|
|
, apDispatch = \m ps ->
|
|
case (m, ps) of
|
|
("GET", [assertion]) -> do
|
|
master <- lift getYesod
|
|
audience <-
|
|
case maudience of
|
|
Just a -> return a
|
|
Nothing -> do
|
|
r <- getUrlRender
|
|
return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR
|
|
memail <- lift $ checkAssertion audience assertion (authHttpManager master)
|
|
case memail of
|
|
Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion
|
|
Just email -> lift $ setCreds True Creds
|
|
{ credsPlugin = pid
|
|
, credsIdent = email
|
|
, credsExtra = []
|
|
}
|
|
("GET", ["static", "sign-in.png"]) -> sendResponse
|
|
( "image/png" :: ByteString
|
|
, toContent $(embedFile "persona_sign_in_blue.png")
|
|
)
|
|
(_, []) -> badMethod
|
|
_ -> notFound
|
|
, apLogin = \toMaster -> do
|
|
onclick <- createOnClick 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 = PluginR pid ["static", "sign-in.png"]
|
|
stripScheme t = fromMaybe t $ T.stripPrefix "//" $ snd $ T.breakOn "//" t
|
|
|
|
-- | Generates a function to handle on-click events, and returns that function
|
|
-- name.
|
|
createOnClick :: (Route Auth -> Route master) -> WidgetT master IO Text
|
|
createOnClick toMaster = do
|
|
addScriptRemote browserIdJs
|
|
onclick <- newIdent
|
|
render <- getUrlRender
|
|
let login = toJSON $ getPath $ render $ toMaster LoginR
|
|
toWidget [julius|
|
|
function #{rawJS onclick}() {
|
|
navigator.id.watch({
|
|
onlogin: function (assertion) {
|
|
if (assertion) {
|
|
document.location = "@{toMaster complete}" + "/" + assertion;
|
|
}
|
|
},
|
|
onlogout: function () {}
|
|
});
|
|
navigator.id.request({
|
|
returnTo: #{login} + "?autologin=true"
|
|
});
|
|
}
|
|
|]
|
|
|
|
autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
|
|
when autologin $ toWidget [julius|#{rawJS onclick}();|]
|
|
return onclick
|
|
where
|
|
getPath t = fromMaybe t $ do
|
|
uri <- parseURI $ T.unpack t
|
|
return $ T.pack $ uriPath uri
|