BrowserId

Yesod/Auth/BrowserId.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Auth.BrowserId
+    ( authBrowserId
+    ) where
+
+import Yesod.Auth
+import Web.Authenticate.BrowserId
+import Data.Text (Text)
+import Yesod.Core
+import Text.Hamlet (hamlet)
+import Control.Monad.IO.Class (liftIO)
+
+#include "qq.h"
+
+pid :: Text
+pid = "browserid"
+
+complete :: AuthRoute
+complete = PluginR pid []
+
+authBrowserId :: YesodAuth m
+              => Text -- ^ audience
+              -> AuthPlugin m
+authBrowserId audience = AuthPlugin
+    { apName = pid
+    , apDispatch = \m ps ->
+        case (m, ps) of
+            ("GET", [assertion]) -> do
+                memail <- liftIO $ checkAssertion audience assertion
+                case memail of
+                    Nothing -> error "Invalid assertion"
+                    Just email -> setCreds True Creds
+                        { credsPlugin = pid
+                        , credsIdent = email
+                        , credsExtra = []
+                        }
+            (_, []) -> badMethod
+            _ -> notFound
+    , apLogin = \toMaster -> do
+        addScriptRemote browserIdJs
+        addHamlet [QQ(hamlet)|
+<p>
+    <a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
+        <img src="https://browserid.org/i/sign_in_green.png">
+|]
+    }

browserid.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+import Yesod.Core
+import Yesod.Auth
+import Yesod.Auth.BrowserId
+import Data.Text (Text)
+import Text.Hamlet (hamlet)
+import Control.Monad.IO.Class (liftIO)
+import Yesod.Form
+import Network.Wai.Handler.Warp (run)
+
+data BID = BID
+type Handler = GHandler BID BID
+
+mkYesod "BID" [parseRoutes|
+/ RootR GET
+/after AfterLoginR GET
+/auth AuthR Auth getAuth
+|]
+
+getRootR :: Handler ()
+getRootR = redirect RedirectTemporary $ AuthR LoginR
+
+getAfterLoginR :: Handler RepHtml
+getAfterLoginR = do
+    mauth <- maybeAuthId
+    defaultLayout $ addHamlet [hamlet|
+<p>Auth: #{show mauth}
+|]
+
+instance Yesod BID where
+    approot _ = "http://localhost:3000"
+
+instance YesodAuth BID where
+    type AuthId BID = Text
+    loginDest _ = AfterLoginR
+    logoutDest _ = AuthR LoginR
+    getAuthId = return . Just . credsIdent
+    authPlugins = [authBrowserId "localhost:3000"]
+
+instance RenderMessage BID FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+main :: IO ()
+main = toWaiApp BID >>= run 3000

yesod-auth.cabal

@@ -20,7 +20,7 @@ library
         cpp-options:     -DGHC7
     else
         build-depends:   base                      >= 4        && < 4.3
-    build-depends:   authenticate            >= 0.9       && < 0.10
+    build-depends:   authenticate            >= 0.9.2     && < 0.10
                    , bytestring              >= 0.9.1.4   && < 0.10
                    , yesod-core              >= 0.9       && < 0.10
                    , wai                     >= 0.4       && < 0.5
@@ -45,6 +45,7 @@ library
                    , pwstore-fast            >= 2.1       && < 2.2
 
     exposed-modules: Yesod.Auth
+                     Yesod.Auth.BrowserId
                      Yesod.Auth.Dummy
                      Yesod.Auth.Email
                      Yesod.Auth.Facebook