From 559f9d53d92f104245ce415e7dfe5e93875d2721 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 28 Sep 2010 15:29:41 +0200 Subject: [PATCH] Initial source pull from Yesod newauth branch --- .gitignore | 4 + LICENSE | 25 ++++ Yesod/Helpers/Auth2.hs | 200 +++++++++++++++++++++++++ Yesod/Helpers/Auth2/Email.hs | 251 ++++++++++++++++++++++++++++++++ Yesod/Helpers/Auth2/Facebook.hs | 51 +++++++ Yesod/Helpers/Auth2/OpenId.hs | 60 ++++++++ Yesod/Helpers/Auth2/Rpxnow.hs | 46 ++++++ auth2.hs | 135 +++++++++++++++++ yesod-auth.cabal | 35 +++++ 9 files changed, 807 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 Yesod/Helpers/Auth2.hs create mode 100644 Yesod/Helpers/Auth2/Email.hs create mode 100644 Yesod/Helpers/Auth2/Facebook.hs create mode 100644 Yesod/Helpers/Auth2/OpenId.hs create mode 100644 Yesod/Helpers/Auth2/Rpxnow.hs create mode 100644 auth2.hs create mode 100644 yesod-auth.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..d6197881 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +dist +*.swp +auth2.db3 +client_session_key.aes diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/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. diff --git a/Yesod/Helpers/Auth2.hs b/Yesod/Helpers/Auth2.hs new file mode 100644 index 00000000..6fd574c0 --- /dev/null +++ b/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" +|] diff --git a/Yesod/Helpers/Auth2/Email.hs b/Yesod/Helpers/Auth2/Email.hs new file mode 100644 index 00000000..330b964f --- /dev/null +++ b/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 diff --git a/Yesod/Helpers/Auth2/Facebook.hs b/Yesod/Helpers/Auth2/Facebook.hs new file mode 100644 index 00000000..dd0af3a9 --- /dev/null +++ b/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 +|] diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs new file mode 100644 index 00000000..369f18bd --- /dev/null +++ b/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 diff --git a/Yesod/Helpers/Auth2/Rpxnow.hs b/Yesod/Helpers/Auth2/Rpxnow.hs new file mode 100644 index 00000000..faa127e9 --- /dev/null +++ b/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"] diff --git a/auth2.hs b/auth2.hs new file mode 100644 index 00000000..6e4ad558 --- /dev/null +++ b/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 diff --git a/yesod-auth.cabal b/yesod-auth.cabal new file mode 100644 index 00000000..f6baa0dd --- /dev/null +++ b/yesod-auth.cabal @@ -0,0 +1,35 @@ +name: yesod-auth +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +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