diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Auth.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +module Yesod.Helpers.Auth + ( -- * Subsite + Auth + , AuthPlugin (..) + , AuthRoute (..) + , getAuth + , YesodAuth (..) + -- * Plugin interface + , Creds (..) + , setCreds + -- * User functions + , maybeAuthId + , maybeAuth + , requireAuthId + , requireAuth + ) 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 :: forall s. (Route Auth -> Route m) -> GWidget s 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, if no other + -- destination exists. + loginDest :: m -> Route m + + -- | Default destination on successful logout, if no other + -- destination exists. + logoutDest :: 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] + + -- | What to show on the login page. + loginHandler :: GHandler Auth m RepHtml + loginHandler = defaultLayout $ do + setTitle $ string "Login" + tm <- liftHandler getRouteToMaster + mapM_ (flip apLogin tm) authPlugins + +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" + +-- | FIXME: won't show up till redirect +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 [$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 $ loginDest y + else return () + +getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson +getCheckR = do + creds <- maybeAuthId + defaultLayoutJson (do + setTitle $ string "Authentication Status" + addHtml $ 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 = loginHandler + +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 $ logoutDest 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" diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE QuasiQuotes #-} +-- | Provides a dummy authentication module that simply lets a user specify +-- his/her identifier. This is not intended for real world use, just for +-- testing. +module Yesod.Helpers.Auth.Dummy + ( authDummy + ) where + +import Yesod +import Yesod.Helpers.Auth + +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" [] + login authToMaster = [$hamlet| +%form!method=post!action=@authToMaster.url@ + Your new identifier is: $ + %input!type=text!name=ident + %input!type=submit!value="Dummy Login" +|] diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Auth/Email.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies #-} +module Yesod.Helpers.Auth.Email + ( authEmail + , YesodAuthEmail (..) + , EmailCreds (..) + , saltPass + ) where + +import Yesod +import Network.Mail.Mime (randomString) +import Yesod.Helpers.Auth +import System.Random +import Control.Monad (when) +import Control.Applicative ((<$>), (<*>)) +import Data.Digest.Pure.MD5 +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (encodeUtf8) + +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' tm = [$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" + addHamlet [$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!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" + addWidget [$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" + addHtml [$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" + 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" + addHamlet [$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 $ loginDest y + +saltLength :: Int +saltLength = 5 + +-- | Salt a password with a randomly generated salt. +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 $ fromString $ salt ++ pass) + where + fromString = encodeUtf8 . T.pack + +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/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Helpers.Auth.Facebook + ( authFacebook + , facebookUrl + ) where + +import Yesod +import Yesod.Helpers.Auth +import qualified Web.Authenticate.Facebook as Facebook +import Data.Object (fromMapping, lookupScalar) +import Data.Maybe (fromMaybe) + +facebookUrl :: AuthRoute +facebookUrl = PluginR "facebook" ["forward"] + +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" ["forward"] = do + tm <- getRouteToMaster + render <- getUrlRender + let fb = Facebook.Facebook cid secret $ render $ tm url + redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms + 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 tm = do + render <- liftHandler getUrlRender + let fb = Facebook.Facebook cid secret $ render $ tm url + let furl = Facebook.getForwardUrl fb $ perms + addHtml [$hamlet| +%p + %a!href=$furl$ Login with Facebook +|] diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Helpers.Auth.OpenId + ( authOpenId + , forwardUrl + ) where + +import Yesod +import Yesod.Helpers.Auth +import qualified Web.Authenticate.OpenId as OpenId +import Control.Monad.Attempt + +forwardUrl :: AuthRoute +forwardUrl = PluginR "openid" ["forward"] + +authOpenId :: YesodAuth m => AuthPlugin m +authOpenId = + AuthPlugin "openid" dispatch login + where + complete = PluginR "openid" ["complete"] + name = "openid_identifier" + login tm = do + ident <- newIdent + addCassius [$cassius| +#$ident$ + background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; + padding-left: 18px; +|] + addHamlet [$hamlet| +%form!method=get!action=@tm.forwardUrl@ + %label!for=openid OpenID: $ + %input#$ident$!type=text!name=$name$!value="http://" + %input!type=submit!value="Login via OpenID" +|] + dispatch "GET" ["forward"] = do + (roid, _, _) <- runFormGet $ 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 + completeHelper $ reqGetParams rr + dispatch "POST" ["complete"] = do + rr <- getRequest + (posts, _) <- liftIO $ reqRequestBody rr + completeHelper posts + dispatch _ _ = notFound + +completeHelper :: YesodAuth m => [(String, String)] -> GHandler Auth m () +completeHelper gets' = do + 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 diff --git a/Yesod/Helpers/Auth/Rpxnow.hs b/Yesod/Helpers/Auth/Rpxnow.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Auth/Rpxnow.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Helpers.Auth.Rpxnow + ( authRpxnow + ) where + +import Yesod +import Yesod.Helpers.Auth +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 tm = do + let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] + addHamlet [$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/Yesod/Helpers/Auth2.hs b/Yesod/Helpers/Auth2.hs deleted file mode 100644 --- a/Yesod/Helpers/Auth2.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -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 :: forall s. (Route Auth -> Route m) -> GWidget s 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, if no other - -- destination exists. - loginDest :: m -> Route m - - -- | Default destination on successful logout, if no other - -- destination exists. - logoutDest :: 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] - - -- | What to show on the login page. - loginHandler :: GHandler Auth m RepHtml - loginHandler = defaultLayout $ do - setTitle $ string "Login" - tm <- liftHandler getRouteToMaster - mapM_ (flip apLogin tm) authPlugins - -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 $ loginDest 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 = loginHandler - -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 $ logoutDest 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" [] - login authToMaster = do - addBody [$hamlet| -%form!method=post!action=@authToMaster.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 deleted file mode 100644 --- a/Yesod/Helpers/Auth2/Email.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# 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 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' tm = do - 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!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" - 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 $ loginDest 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 deleted file mode 100644 --- a/Yesod/Helpers/Auth2/Facebook.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Yesod.Helpers.Auth2.Facebook - ( authFacebook - , facebookUrl - ) where - -import Yesod -import Yesod.Helpers.Auth2 -import qualified Web.Authenticate.Facebook as Facebook -import Data.Object (fromMapping, lookupScalar) -import Data.Maybe (fromMaybe) - -facebookUrl :: AuthRoute -facebookUrl = PluginR "facebook" ["forward"] - -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" ["forward"] = do - tm <- getRouteToMaster - render <- getUrlRender - let fb = Facebook.Facebook cid secret $ render $ tm url - redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms - 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 tm = do - 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 deleted file mode 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Yesod.Helpers.Auth2.OpenId - ( authOpenId - , forwardUrl - ) where - -import Yesod -import Yesod.Helpers.Auth2 -import qualified Web.Authenticate.OpenId as OpenId -import Control.Monad.Attempt - -forwardUrl :: AuthRoute -forwardUrl = PluginR "openid" ["forward"] - -authOpenId :: YesodAuth m => AuthPlugin m -authOpenId = - AuthPlugin "openid" dispatch login - where - complete = PluginR "openid" ["complete"] - name = "openid_identifier" - login tm = do - ident <- newIdent - addStyle [$cassius| -#$ident$ - background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; - padding-left: 18px; -|] - addBody [$hamlet| -%form!method=get!action=@tm.forwardUrl@ - %label!for=openid OpenID: $ - %input#$ident$!type=text!name=$name$!value="http://" - %input!type=submit!value="Login via OpenID" -|] - dispatch "GET" ["forward"] = do - (roid, _, _) <- runFormGet $ 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 - completeHelper $ reqGetParams rr - dispatch "POST" ["complete"] = do - rr <- getRequest - (posts, _) <- liftIO $ reqRequestBody rr - completeHelper posts - dispatch _ _ = notFound - -completeHelper :: YesodAuth m => [(String, String)] -> GHandler Auth m () -completeHelper gets' = do - 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 diff --git a/Yesod/Helpers/Auth2/Rpxnow.hs b/Yesod/Helpers/Auth2/Rpxnow.hs deleted file mode 100644 --- a/Yesod/Helpers/Auth2/Rpxnow.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# 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 tm = do - 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/yesod-auth.cabal b/yesod-auth.cabal --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.1.4.1 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -15,21 +15,24 @@ build-depends: base >= 4 && < 5 , authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 - , yesod >= 0.5.2 && < 0.6 + , yesod >= 0.6 && < 0.7 , wai >= 0.2 && < 0.3 , template-haskell , pureMD5 >= 1.1 && < 2.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 + , text >= 0.7 && < 0.11 + , blaze-builder >= 0.1 && < 0.2 + , mime-mail >= 0.0 && < 0.1 + exposed-modules: Yesod.Helpers.Auth + Yesod.Helpers.Auth.Dummy + Yesod.Helpers.Auth.Email + Yesod.Helpers.Auth.Facebook + Yesod.Helpers.Auth.OpenId + Yesod.Helpers.Auth.Rpxnow ghc-options: -Wall source-repository head type: git - location: git://github.com/snoyberg/yesod.git + location: git://github.com/snoyberg/yesod-auth.git