packages feed

yesod-auth 0.1.4.1 → 0.2.0

raw patch · 12 files changed

+658/−640 lines, 12 filesdep +blaze-builderdep +mime-maildep +textdep −utf8-stringdep ~yesod

Dependencies added: blaze-builder, mime-mail, text

Dependencies removed: utf8-string

Dependency ranges changed: yesod

Files

+ Yesod/Helpers/Auth.hs view
@@ -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"
+ Yesod/Helpers/Auth/Dummy.hs view
@@ -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"+|]
+ Yesod/Helpers/Auth/Email.hs view
@@ -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
+ Yesod/Helpers/Auth/Facebook.hs view
@@ -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+|]
+ Yesod/Helpers/Auth/OpenId.hs view
@@ -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
+ Yesod/Helpers/Auth/Rpxnow.hs view
@@ -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"]
− Yesod/Helpers/Auth2.hs 
@@ -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"-|]
− Yesod/Helpers/Auth2/Email.hs 
@@ -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
− Yesod/Helpers/Auth2/Facebook.hs 
@@ -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-|]
− Yesod/Helpers/Auth2/OpenId.hs 
@@ -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
− Yesod/Helpers/Auth2/Rpxnow.hs 
@@ -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"]
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name:            yesod-auth-version:         0.1.4.1+version:         0.2.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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