From 5e3ae824da91812b451edca4ef92996dac7b9ee5 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 21 Jul 2011 18:03:59 +0300
Subject: [PATCH] Added BrowserId support

---
 Web/Authenticate/BrowserId.hs | 37 ++++++++++++++++++++++++++++
 authenticate.cabal            |  1 +
 browserid.hs                  | 46 +++++++++++++++++++++++++++++++++++
 3 files changed, 84 insertions(+)
 create mode 100644 Web/Authenticate/BrowserId.hs
 create mode 100644 browserid.hs

diff --git a/Web/Authenticate/BrowserId.hs b/Web/Authenticate/BrowserId.hs
new file mode 100644
index 00000000..eb95bb27
--- /dev/null
+++ b/Web/Authenticate/BrowserId.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Web.Authenticate.BrowserId
+    ( browserIdJs
+    , checkAssertion
+    ) where
+
+import Data.Text (Text)
+import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, queryString, withManager)
+import Network.HTTP.Types (queryTextToQuery)
+import Data.Aeson (json, Value (Object, String))
+import Data.Attoparsec.Lazy (parse, maybeResult)
+import qualified Data.Map as Map
+
+-- | Location of the Javascript file hosted by browserid.org
+browserIdJs :: Text
+browserIdJs = "https://browserid.org/include.js"
+
+checkAssertion :: Text -- ^ audience
+               -> Text -- ^ assertion
+               -> IO (Maybe Text)
+checkAssertion audience assertion = do
+    req' <- parseUrl "https://browserid.org/verify"
+    let req = req'
+                { queryString = queryTextToQuery
+                    [ ("audience", Just audience)
+                    , ("assertion", Just assertion)
+                    ]
+                }
+    res <- withManager $ httpLbs req
+    let lbs = responseBody res
+    return $ maybeResult (parse json lbs) >>= getEmail
+  where
+    getEmail (Object o) =
+        case (Map.lookup "status" o, Map.lookup "email" o) of
+            (Just (String "okay"), Just (String e)) -> Just e
+            _ -> Nothing
+    getEmail _ = Nothing
diff --git a/authenticate.cabal b/authenticate.cabal
index 014d48e7..32b7e4b6 100644
--- a/authenticate.cabal
+++ b/authenticate.cabal
@@ -38,6 +38,7 @@ library
                      containers
     exposed-modules: Web.Authenticate.Rpxnow,
                      Web.Authenticate.OpenId,
+                     Web.Authenticate.BrowserId,
                      Web.Authenticate.OpenId.Providers,
                      Web.Authenticate.OAuth,
                      Web.Authenticate.Facebook
diff --git a/browserid.hs b/browserid.hs
new file mode 100644
index 00000000..bf365956
--- /dev/null
+++ b/browserid.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+import Yesod
+import Web.Authenticate.BrowserId
+import Data.Object
+import Data.Maybe (fromMaybe)
+import Network.HTTP.Enumerator
+import Data.Text (Text)
+
+data BID = BID
+mkYesod "BID" [parseRoutes|
+/ RootR GET
+/complete/#Text CompleteR GET
+|]
+
+instance Yesod BID where approot _ = "http://localhost:3000"
+
+getRootR = defaultLayout $ do
+    addScriptRemote browserIdJs
+    addJulius [julius|
+function bidClick() {
+    navigator.id.getVerifiedEmail(function(assertion) {
+        if (assertion) {
+            document.location = "@{CompleteR ""}" + assertion;
+        } else {
+            alert("Invalid BrowserId login");
+        }
+    });
+}
+|]
+    addHamlet [hamlet|
+<p>
+    <a href="javascript:bidClick();">
+        <img src="https://browserid.org/i/sign_in_red.png">
+|]
+
+getCompleteR assertion = do
+    memail <- liftIO $ checkAssertion "localhost:3000" assertion
+    defaultLayout $ addHamlet [hamlet|
+<p>You tried to log in, let's see if it worked.
+$maybe email <- memail
+    <p>Yes it did! You are: #{email}
+$nothing
+    <p>Nope, sorry
+|]
+
+main = warp 3000 BID