Initial source pull from Yesod newauth branch

.gitignore

@@ -0,0 +1,4 @@
+dist
+*.swp
+auth2.db3
+client_session_key.aes

LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Yesod/Helpers/Auth2.hs

@@ -0,0 +1,200 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Yesod.Helpers.Auth2
+    ( Auth
+    , AuthPlugin (..)
+    , AuthRoute (..)
+    , getAuth
+    , Creds (..)
+    , YesodAuth (..)
+    , setCreds
+    , maybeAuthId
+    , maybeAuth
+    , requireAuthId
+    , requireAuth
+    , authDummy
+    ) where
+
+import Yesod
+import Language.Haskell.TH.Syntax hiding (lift)
+import qualified Data.ByteString.Char8 as S8
+import qualified Network.Wai as W
+
+data Auth = Auth
+
+type Method = String
+type Piece = String
+
+data AuthPlugin m = AuthPlugin
+    { apName :: String
+    , apDispatch :: Method -> [Piece] -> GHandler Auth m ()
+    , apLogin :: GWidget Auth m ()
+    }
+
+getAuth :: a -> Auth
+getAuth = const Auth
+
+-- | User credentials
+data Creds m = Creds
+    { credsPlugin :: String -- ^ How the user was authenticated
+    , credsIdent :: String -- ^ Identifier. Exact meaning depends on plugin.
+    , credsExtra :: [(String, String)]
+    }
+
+class Yesod m => YesodAuth m where
+    type AuthId m
+
+    -- | Default destination on successful login or logout, if no other
+    -- destination exists.
+    defaultDest :: m -> Route m
+
+    getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
+
+    showAuthId :: m -> AuthId m -> String
+    readAuthId :: m -> String -> Maybe (AuthId m)
+
+    authPlugins :: [AuthPlugin m]
+
+mkYesodSub "Auth"
+    [ ClassP ''YesodAuth [VarT $ mkName "master"]
+    ] [$parseRoutes|
+/check                 CheckR      GET
+/login                 LoginR      GET
+/logout                LogoutR     GET POST
+/page/#String/*Strings PluginR
+|]
+
+credsKey :: String
+credsKey = "_ID"
+
+setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()
+setCreds doRedirects creds = do
+    y <- getYesod
+    maid <- getAuthId creds
+    case maid of
+        Nothing ->
+            if doRedirects
+                then do
+                    case authRoute y of
+                        Nothing -> do
+                            rh <- defaultLayout $ addBody [$hamlet|
+%h1 Invalid login
+|]
+                            sendResponse rh
+                        Just ar -> do
+                            setMessage $ string "Invalid login"
+                            redirect RedirectTemporary ar
+                else return ()
+        Just aid -> do
+            setSession credsKey $ showAuthId y aid
+            if doRedirects
+                then do
+                    setMessage $ string "You are now logged in"
+                    redirect RedirectTemporary $ defaultDest y
+                else return ()
+
+getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
+getCheckR = do
+    creds <- maybeAuthId
+    defaultLayoutJson (do
+        setTitle $ string "Authentication Status"
+        addBody $ html creds) (json creds)
+  where
+    html creds = [$hamlet|
+%h1 Authentication Status
+$maybe creds _
+    %p Logged in.
+$nothing
+    %p Not logged in.
+|]
+    json creds =
+        jsonMap
+            [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds)
+            ]
+
+getLoginR :: YesodAuth m => GHandler Auth m RepHtml
+getLoginR = defaultLayout $ do
+    setTitle $ string "Login"
+    mapM_ apLogin authPlugins
+
+getLogoutR :: YesodAuth m => GHandler Auth m ()
+getLogoutR = postLogoutR -- FIXME redirect to post
+
+postLogoutR :: YesodAuth m => GHandler Auth m ()
+postLogoutR = do
+    y <- getYesod
+    deleteSession credsKey
+    redirectUltDest RedirectTemporary $ defaultDest y
+
+handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m ()
+handlePluginR plugin pieces = do
+    env <- waiRequest
+    let method = S8.unpack $ W.requestMethod env
+    case filter (\x -> apName x == plugin) authPlugins of
+        [] -> notFound
+        ap:_ -> apDispatch ap method pieces
+
+-- | Retrieves user credentials, if user is authenticated.
+maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
+maybeAuthId = do
+    ms <- lookupSession credsKey
+    y <- getYesod
+    case ms of
+        Nothing -> return Nothing
+        Just s -> return $ readAuthId y s
+
+maybeAuth :: ( YesodAuth m
+             , Key val ~ AuthId m
+             , PersistBackend (YesodDB m (GHandler s m))
+             , PersistEntity val
+             , YesodPersist m
+             ) => GHandler s m (Maybe (Key val, val))
+maybeAuth = do
+    maid <- maybeAuthId
+    case maid of
+        Nothing -> return Nothing
+        Just aid -> do
+            ma <- runDB $ get aid
+            case ma of
+                Nothing -> return Nothing
+                Just a -> return $ Just (aid, a)
+
+requireAuthId :: YesodAuth m => GHandler s m (AuthId m)
+requireAuthId = maybeAuthId >>= maybe redirectLogin return
+
+requireAuth :: ( YesodAuth m
+               , Key val ~ AuthId m
+               , PersistBackend (YesodDB m (GHandler s m))
+               , PersistEntity val
+               , YesodPersist m
+               ) => GHandler s m (Key val, val)
+requireAuth = maybeAuth >>= maybe redirectLogin return
+
+redirectLogin :: Yesod m => GHandler s m a
+redirectLogin = do
+    y <- getYesod
+    setUltDest'
+    case authRoute y of
+        Just z -> redirect RedirectTemporary z
+        Nothing -> permissionDenied "Please configure authRoute"
+
+authDummy :: YesodAuth m => AuthPlugin m
+authDummy =
+    AuthPlugin "dummy" dispatch login
+  where
+    dispatch "POST" [] = do
+        ident <- runFormPost' $ stringInput "ident"
+        setCreds True $ Creds "dummy" ident []
+    dispatch _ _ = notFound
+    url = PluginR "dummy" []
+    authToMaster = liftHandler getRouteToMaster
+    login = do
+        tm <- authToMaster
+        addBody [$hamlet|
+%form!method=post!action=@tm.url@
+    Your new identifier is: $
+    %input!type=text!name=ident
+    %input!type=submit!value="Dummy Login"
+|]

Yesod/Helpers/Auth2/Email.hs

@@ -0,0 +1,251 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
+module Yesod.Helpers.Auth2.Email
+    ( authEmail
+    , YesodAuthEmail (..)
+    , EmailCreds (..)
+    ) where
+
+import Yesod
+import Yesod.Mail (randomString)
+import Yesod.Helpers.Auth2
+import System.Random
+import Control.Monad (when)
+import Control.Applicative ((<$>), (<*>))
+import Data.Digest.Pure.MD5
+import Data.String (fromString)
+import qualified Data.ByteString.Lazy.UTF8 as LU
+
+login, register, setpass :: AuthRoute
+login = PluginR "email" ["login"]
+register = PluginR "email" ["register"]
+setpass = PluginR "email" ["set-password"]
+
+verify :: String -> String -> AuthRoute -- FIXME
+verify eid verkey = PluginR "email" ["verify", eid, verkey]
+
+type Email = String
+type VerKey = String
+type VerUrl = String
+type SaltedPass = String
+type VerStatus = Bool
+
+-- | Data stored in a database for each e-mail address.
+data EmailCreds m = EmailCreds
+    { emailCredsId :: AuthEmailId m
+    , emailCredsAuthId :: Maybe (AuthId m)
+    , emailCredsStatus :: VerStatus
+    , emailCredsVerkey :: Maybe VerKey
+    }
+
+class YesodAuth m => YesodAuthEmail m where
+    type AuthEmailId m
+
+    showAuthEmailId :: m -> AuthEmailId m -> String
+    readAuthEmailId :: m -> String -> Maybe (AuthEmailId m)
+
+    addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
+    sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
+    getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)
+    setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()
+    verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))
+    getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)
+    setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()
+    getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))
+    getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)
+
+    -- | Generate a random alphanumeric string.
+    randomKey :: m -> IO String
+    randomKey _ = do
+        stdgen <- newStdGen
+        return $ fst $ randomString 10 stdgen
+
+authEmail :: YesodAuthEmail m => AuthPlugin m
+authEmail =
+    AuthPlugin "email" dispatch login'
+  where
+    go x = x >>= sendResponse
+    dispatch "GET" ["register"] = go getRegisterR
+    dispatch "POST" ["register"] = go postRegisterR
+    dispatch "GET" ["verify", eid, verkey] = do
+        y <- getYesod
+        case readAuthEmailId y eid of
+            Nothing -> notFound
+            Just eid' -> go $ getVerifyR eid' verkey
+    dispatch "POST" ["login"] = go postLoginR
+    dispatch "GET" ["set-password"] = go getPasswordR
+    dispatch "POST" ["set-password"] = go postPasswordR
+    dispatch _ _ = notFound
+
+    login' = do
+        tm <- liftHandler getRouteToMaster
+        addBody [$hamlet|
+%form!method=post!action=@tm.login@
+    %table
+        %tr
+            %th E-mail
+            %td
+                %input!type=email!name=email
+        %tr
+            %th Password
+            %td
+                %input!type=password!name=password
+        %tr
+            %td!colspan=2
+                %input!type=submit!value="Login via email"
+                %a!href=@tm.register@ I don't have an account
+|]
+
+getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
+getRegisterR = do
+    toMaster <- getRouteToMaster
+    defaultLayout $ do
+        setTitle $ string "Register a new account"
+        addBody [$hamlet|
+%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
+%form!method=post!action=@toMaster.register@
+    %label!for=email E-mail
+    %input#email!type=email!name=email!width=150
+    %input!type=submit!value=Register
+|]
+
+postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
+postRegisterR = do
+    y <- getYesod
+    email <- runFormPost' $ emailInput "email"
+    mecreds <- getEmailCreds email
+    (lid, verKey) <-
+        case mecreds of
+            Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
+            Just (EmailCreds lid _ _ Nothing) -> do
+                key <- liftIO $ randomKey y
+                setVerifyKey lid key
+                return (lid, key)
+            Nothing -> do
+                key <- liftIO $ randomKey y
+                lid <- addUnverified email key
+                return (lid, key)
+    render <- getUrlRender
+    tm <- getRouteToMaster
+    let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey
+    sendVerifyEmail email verKey verUrl
+    defaultLayout $ do
+        setTitle $ string "Confirmation e-mail sent"
+        addBody [$hamlet|
+%p A confirmation e-mail has been sent to $email$.
+|]
+
+getVerifyR :: YesodAuthEmail m
+           => AuthEmailId m -> String -> GHandler Auth m RepHtml
+getVerifyR lid key = do
+    realKey <- getVerifyKey lid
+    memail <- getEmail lid
+    case (realKey == Just key, memail) of
+        (True, Just email) -> do
+            muid <- verifyAccount lid
+            case muid of
+                Nothing -> return ()
+                Just uid -> do
+                    setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?
+                    toMaster <- getRouteToMaster
+                    setMessage $ string "Address verified, please set a new password"
+                    redirect RedirectTemporary $ toMaster setpass
+        _ -> return ()
+    defaultLayout $ do
+        setTitle $ string "Invalid verification key"
+        addBody [$hamlet|
+%p I'm sorry, but that was an invalid verification key.
+|]
+
+postLoginR :: YesodAuthEmail master => GHandler Auth master ()
+postLoginR = do
+    (email, pass) <- runFormPost' $ (,)
+        <$> emailInput "email"
+        <*> stringInput "password"
+    y <- getYesod
+    mecreds <- getEmailCreds email
+    maid <-
+        case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
+            (Just aid, Just True) -> do
+                mrealpass <- getPassword aid
+                case mrealpass of
+                    Nothing -> return Nothing
+                    Just realpass -> return $
+                        if isValidPass pass realpass
+                            then Just aid
+                            else Nothing
+            _ -> return Nothing
+    case maid of
+        Just aid ->
+            setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?
+        Nothing -> do
+            setMessage $ string "Invalid email/password combination"
+            toMaster <- getRouteToMaster
+            redirect RedirectTemporary $ toMaster LoginR
+
+getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml
+getPasswordR = do
+    toMaster <- getRouteToMaster
+    maid <- maybeAuthId
+    case maid of
+        Just _ -> return ()
+        Nothing -> do
+            setMessage $ string "You must be logged in to set a password"
+            redirect RedirectTemporary $ toMaster login
+    defaultLayout $ do
+        setTitle $ string "Set password"
+        addBody [$hamlet|
+%h3 Set a new password
+%form!method=post!action=@toMaster.setpass@
+    %table
+        %tr
+            %th New password
+            %td
+                %input!type=password!name=new
+        %tr
+            %th Confirm
+            %td
+                %input!type=password!name=confirm
+        %tr
+            %td!colspan=2
+                %input!type=submit!value=Submit
+|]
+
+postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
+postPasswordR = do
+    (new, confirm) <- runFormPost' $ (,)
+        <$> stringInput "new"
+        <*> stringInput "confirm"
+    toMaster <- getRouteToMaster
+    when (new /= confirm) $ do
+        setMessage $ string "Passwords did not match, please try again"
+        redirect RedirectTemporary $ toMaster setpass
+    maid <- maybeAuthId
+    aid <- case maid of
+            Nothing -> do
+                setMessage $ string "You must be logged in to set a password"
+                redirect RedirectTemporary $ toMaster login
+            Just aid -> return aid
+    salted <- liftIO $ saltPass new
+    setPassword aid salted
+    setMessage $ string "Password updated"
+    y <- getYesod
+    redirect RedirectTemporary $ defaultDest y
+
+saltLength :: Int
+saltLength = 5
+
+saltPass :: String -> IO String
+saltPass pass = do
+    stdgen <- newStdGen
+    let salt = take saltLength $ randomRs ('A', 'Z') stdgen
+    return $ saltPass' salt pass
+
+saltPass' :: String -> String -> String
+saltPass' salt pass = salt ++ show (md5 $ LU.fromString $ salt ++ pass)
+
+isValidPass :: String -- ^ cleartext password
+            -> SaltedPass -- ^ salted password
+            -> Bool
+isValidPass clear salted =
+    let salt = take saltLength salted
+     in salted == saltPass' salt clear

Yesod/Helpers/Auth2/Facebook.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yesod.Helpers.Auth2.Facebook
+    ( authFacebook
+    ) where
+
+import Yesod
+import Yesod.Helpers.Auth2
+import qualified Web.Authenticate.Facebook as Facebook
+import Data.Object (fromMapping, lookupScalar)
+import Data.Maybe (fromMaybe)
+
+authFacebook :: YesodAuth m
+             => String -- ^ Application ID
+             -> String -- ^ Application secret
+             -> [String] -- ^ Requested permissions
+             -> AuthPlugin m
+authFacebook cid secret perms =
+    AuthPlugin "facebook" dispatch login
+  where
+    url = PluginR "facebook" []
+    dispatch "GET" [] = do
+        render <- getUrlRender
+        tm <- getRouteToMaster
+        let fb = Facebook.Facebook cid secret $ render $ tm url
+        code <- runFormGet' $ stringInput "code"
+        at <- liftIO $ Facebook.getAccessToken fb code
+        let Facebook.AccessToken at' = at
+        so <- liftIO $ Facebook.getGraphData at "me"
+        let c = fromMaybe (error "Invalid response from Facebook") $ do
+            m <- fromMapping so
+            id' <- lookupScalar "id" m
+            let name = lookupScalar "name" m
+            let email = lookupScalar "email" m
+            let id'' = "http://graph.facebook.com/" ++ id'
+            return
+                $ Creds "facebook" id''
+                $ maybe id (\x -> (:) ("verifiedEmail", x)) email
+                $ maybe id (\x -> (:) ("displayName ", x)) name
+                [ ("accessToken", at')
+                ]
+        setCreds True c
+    dispatch _ _ = notFound
+    login = do
+        tm <- liftHandler getRouteToMaster
+        render <- liftHandler getUrlRender
+        let fb = Facebook.Facebook cid secret $ render $ tm url
+        let furl = Facebook.getForwardUrl fb $ perms
+        addBody [$hamlet|
+%p
+    %a!href=$furl$ Login with Facebook
+|]

Yesod/Helpers/Auth2/OpenId.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yesod.Helpers.Auth2.OpenId
+    ( authOpenId
+    ) where
+
+import Yesod
+import Yesod.Helpers.Auth2
+import qualified Web.Authenticate.OpenId as OpenId
+import Control.Monad.Attempt
+
+authOpenId :: YesodAuth m => AuthPlugin m
+authOpenId =
+    AuthPlugin "openid" dispatch login
+  where
+    forward = PluginR "openid" ["forward"]
+    complete = PluginR "openid" ["complete"]
+    name = "openid_identifier"
+    login = do
+        tm <- liftHandler getRouteToMaster
+        addStyle [$cassius|
+#openid
+    background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
+    padding-left: 18px;
+|]
+        addBody [$hamlet|
+%form!method=post!action=@tm.forward@
+    %label!for=openid OpenID: $
+    %input#openid!type=text!name=$name$
+    %input!type=submit!value="Login via OpenID"
+|]
+    dispatch "POST" ["forward"] = do
+        (roid, _, _) <- runFormPost $ stringInput name
+        case roid of
+            FormSuccess oid -> do
+                render <- getUrlRender
+                toMaster <- getRouteToMaster
+                let complete' = render $ toMaster complete
+                res <- runAttemptT $ OpenId.getForwardUrl oid complete'
+                attempt
+                  (\err -> do
+                        setMessage $ string $ show err
+                        redirect RedirectTemporary $ toMaster LoginR)
+                  (redirectString RedirectTemporary)
+                  res
+            _ -> do
+                toMaster <- getRouteToMaster
+                setMessage $ string "No OpenID identifier found"
+                redirect RedirectTemporary $ toMaster LoginR
+    dispatch "GET" ["complete"] = do
+        rr <- getRequest
+        let gets' = reqGetParams rr
+        res <- runAttemptT $ OpenId.authenticate gets'
+        toMaster <- getRouteToMaster
+        let onFailure err = do
+            setMessage $ string $ show err
+            redirect RedirectTemporary $ toMaster LoginR
+        let onSuccess (OpenId.Identifier ident) =
+                setCreds True $ Creds "openid" ident []
+        attempt onFailure onSuccess res
+    dispatch _ _ = notFound

Yesod/Helpers/Auth2/Rpxnow.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yesod.Helpers.Auth2.Rpxnow
+    ( authRpxnow
+    ) where
+
+import Yesod
+import Yesod.Helpers.Auth2
+import qualified Web.Authenticate.Rpxnow as Rpxnow
+import Control.Monad (mplus)
+
+authRpxnow :: YesodAuth m
+           => String -- ^ app name
+           -> String -- ^ key
+           -> AuthPlugin m
+authRpxnow app apiKey =
+    AuthPlugin "rpxnow" dispatch login
+  where
+    login = do
+        tm <- liftHandler getRouteToMaster
+        let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
+        addBody [$hamlet|
+%iframe!src="http://$app$.rpxnow.com/openid/embed?token_url=@url@"!scrolling=no!frameBorder=no!allowtransparency=true!style="width:400px;height:240px"
+|]
+    dispatch _ [] = do
+        token1 <- lookupGetParam "token"
+        token2 <- lookupPostParam "token"
+        let token = case token1 `mplus` token2 of
+                        Nothing -> invalidArgs ["token: Value not supplied"]
+                        Just x -> x
+        Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token
+        let creds =
+                Creds "rpxnow" ident
+                $ maybe id (\x -> (:) ("verifiedEmail", x))
+                    (lookup "verifiedEmail" extra)
+                $ maybe id (\x -> (:) ("displayName", x))
+                    (getDisplayName extra)
+                  []
+        setCreds True creds
+    dispatch _ _ = notFound
+
+-- | Get some form of a display name.
+getDisplayName :: [(String, String)] -> Maybe String
+getDisplayName extra =
+    foldr (\x -> mplus (lookup x extra)) Nothing choices
+  where
+    choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]

auth2.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+import Yesod
+import Yesod.Mail
+
+import Yesod.Helpers.Auth2
+import Yesod.Helpers.Auth2.OpenId
+import Yesod.Helpers.Auth2.Rpxnow
+import Yesod.Helpers.Auth2.Facebook
+import Yesod.Helpers.Auth2.Email
+
+import Control.Monad (join)
+import Database.Persist.Sqlite
+import Safe (readMay)
+
+mkPersist [$persist|
+Email
+    email String
+    status Bool update
+    verkey String null update
+    password String null update
+    UniqueEmail email
+|]
+
+data A2 = A2 { connPool :: ConnectionPool }
+mkYesod "A2" [$parseRoutes|
+/auth AuthR Auth getAuth
+|]
+instance Yesod A2 where approot _ = "http://localhost:3000"
+instance YesodAuth A2 where
+    type AuthId A2 = String
+    defaultDest _ = AuthR CheckR
+    getAuthId = return . Just . credsIdent
+    showAuthId = const id
+    readAuthId = const Just
+    authPlugins =
+        [ authDummy
+        , authOpenId
+        , authRpxnow "yesod-test" "c8043882f14387d7ad8dfc99a1a8dab2e028f690"
+        , authFacebook
+            "d790dfc0203e31c0209ed32f90782c31"
+            "a7685e10c8977f5435e599aaf1d232eb"
+            []
+        , authEmail
+        ]
+
+main :: IO ()
+main = withConnectionPool $ \p -> do
+    flip runConnectionPool p $ runMigration $ migrate (undefined :: Email)
+    basicHandler 3000 $ A2 p
+
+instance YesodAuthEmail A2 where
+    type AuthEmailId A2 = EmailId
+    showAuthEmailId _ = show
+    readAuthEmailId _ = readMay
+
+    addUnverified email verkey = runDB $ insert $ Email email False (Just verkey) Nothing
+    sendVerifyEmail email verkey verurl = do
+        render <- getUrlRenderParams
+        tm <- getRouteToMaster
+        let lbs = renderHamlet render [$hamlet|
+%p
+    %a!href=$verurl$ Verify your email address.
+|]
+        liftIO $ renderSendMail Mail
+            { mailHeaders =
+                [ ("To", email)
+                , ("From", "reply@orangeroster.com")
+                , ("Subject", "OrangeRoster: Verify your email address")
+                ]
+            , mailPlain = verurl
+            , mailParts =
+                [ Part
+                    { partType = "text/html; charset=utf-8"
+                    , partEncoding = None
+                    , partDisposition = Inline
+                    , partContent = lbs
+                    }
+                ]
+            }
+    getVerifyKey emailid = runDB $ do
+        x <- get $ fromIntegral emailid
+        return $ maybe Nothing emailVerkey x
+    setVerifyKey emailid verkey = runDB $
+        update (fromIntegral emailid) [EmailVerkey $ Just verkey]
+    verifyAccount emailid' = runDB $ do
+        {- FIXME
+        let emailid = fromIntegral emailid'
+        x <- get emailid
+        uid <-
+            case x of
+                Nothing -> return Nothing
+                Just (Email (Just uid) _ _) -> return $ Just uid
+                Just (Email Nothing email _) -> do
+                    update emailid [EmailStatus True]
+                    return $ Just email
+        update emailid [EmailVerkey Nothing]
+        return uid
+        -}
+        return Nothing
+    getPassword _ = return Nothing -- FIXME runDB . fmap (join . fmap emailPassword) . get
+    setPassword emailid password = runDB $ do
+        {- FIXME
+        _x <- get emailid
+        case x of
+            Just (Email (Just uid) _ _) -> do
+                update uid [EmailPassword $ Just password]
+                update emailid [EmailVerkey Nothing]
+            _ -> return ()
+        -}
+        return ()
+    getEmailCreds email = runDB $ do
+        x <- getBy $ UniqueEmail email
+        case x of
+            Nothing -> return Nothing
+            Just (eid, e) ->
+                return $ Just EmailCreds
+                    { emailCredsId = fromIntegral eid
+                    , emailCredsAuthId = Just $ emailEmail e
+                    , emailCredsStatus = emailStatus e
+                    , emailCredsVerkey = emailVerkey e
+                    }
+    getEmail emailid = runDB $ do
+        x <- get $ fromIntegral emailid
+        return $ fmap emailEmail x
+
+instance YesodPersist A2 where
+    type YesodDB A2 = SqlPersist
+    runDB db = fmap connPool getYesod >>= runConnectionPool db
+
+withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
+withConnectionPool = withSqlitePool "auth2.db3" 10
+
+runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
+runConnectionPool = runSqlPool

yesod-auth.cabal

@@ -0,0 +1,35 @@
+name:            yesod-auth
+version:         0.0.0
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        Authentication for Yesod.
+category:        Web
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://docs.yesodweb.com/
+
+library
+    build-depends:   base                    >= 4         && < 5
+                   , authenticate            >= 0.6.4     && < 0.7
+                   , bytestring              >= 0.9.1.4   && < 0.10
+                   , yesod                   >= 0.5.1     && < 0.6
+                   , wai                     >= 0.2       && < 0.3
+                   , template-haskell
+                   , pureMD5                 >= 1.1       && < 1.2
+                   , random                  >= 1.0       && < 1.1
+                   , data-object             >= 0.3.1.3   && < 0.4
+                   , control-monad-attempt   >= 0.3.0     && < 0.4
+                   , utf8-string             >= 0.3.4     && < 0.4
+    exposed-modules: Yesod.Helpers.Auth2
+                     Yesod.Helpers.Auth2.Email
+                     Yesod.Helpers.Auth2.Facebook
+                     Yesod.Helpers.Auth2.OpenId
+                     Yesod.Helpers.Auth2.Rpxnow
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/snoyberg/yesod.git