packages feed

yesod-auth (empty) → 0.0.0

raw patch · 8 files changed

+670/−0 lines, 8 filesdep +authenticatedep +basedep +bytestringsetup-changed

Dependencies added: authenticate, base, bytestring, control-monad-attempt, data-object, pureMD5, random, template-haskell, utf8-string, wai, yesod

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yesod/Helpers/Auth2.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Yesod.Helpers.Auth2+    ( Auth+    , AuthPlugin (..)+    , AuthRoute (..)+    , getAuth+    , Creds (..)+    , YesodAuth (..)+    , setCreds+    , maybeAuthId+    , maybeAuth+    , requireAuthId+    , requireAuth+    , authDummy+    ) where++import Yesod+import Language.Haskell.TH.Syntax hiding (lift)+import qualified Data.ByteString.Char8 as S8+import qualified Network.Wai as W++data Auth = Auth++type Method = String+type Piece = String++data AuthPlugin m = AuthPlugin+    { apName :: String+    , apDispatch :: Method -> [Piece] -> GHandler Auth m ()+    , apLogin :: GWidget Auth m ()+    }++getAuth :: a -> Auth+getAuth = const Auth++-- | User credentials+data Creds m = Creds+    { credsPlugin :: String -- ^ How the user was authenticated+    , credsIdent :: String -- ^ Identifier. Exact meaning depends on plugin.+    , credsExtra :: [(String, String)]+    }++class Yesod m => YesodAuth m where+    type AuthId m++    -- | Default destination on successful login or logout, if no other+    -- destination exists.+    defaultDest :: m -> Route m++    getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))++    showAuthId :: m -> AuthId m -> String+    readAuthId :: m -> String -> Maybe (AuthId m)++    authPlugins :: [AuthPlugin m]++mkYesodSub "Auth"+    [ ClassP ''YesodAuth [VarT $ mkName "master"]+    ] [$parseRoutes|+/check                 CheckR      GET+/login                 LoginR      GET+/logout                LogoutR     GET POST+/page/#String/*Strings PluginR+|]++credsKey :: String+credsKey = "_ID"++setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()+setCreds doRedirects creds = do+    y <- getYesod+    maid <- getAuthId creds+    case maid of+        Nothing ->+            if doRedirects+                then do+                    case authRoute y of+                        Nothing -> do+                            rh <- defaultLayout $ addBody [$hamlet|+%h1 Invalid login+|]+                            sendResponse rh+                        Just ar -> do+                            setMessage $ string "Invalid login"+                            redirect RedirectTemporary ar+                else return ()+        Just aid -> do+            setSession credsKey $ showAuthId y aid+            if doRedirects+                then do+                    setMessage $ string "You are now logged in"+                    redirect RedirectTemporary $ defaultDest y+                else return ()++getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson+getCheckR = do+    creds <- maybeAuthId+    defaultLayoutJson (do+        setTitle $ string "Authentication Status"+        addBody $ html creds) (json creds)+  where+    html creds = [$hamlet|+%h1 Authentication Status+$maybe creds _+    %p Logged in.+$nothing+    %p Not logged in.+|]+    json creds =+        jsonMap+            [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds)+            ]++getLoginR :: YesodAuth m => GHandler Auth m RepHtml+getLoginR = defaultLayout $ do+    setTitle $ string "Login"+    mapM_ apLogin authPlugins++getLogoutR :: YesodAuth m => GHandler Auth m ()+getLogoutR = postLogoutR -- FIXME redirect to post++postLogoutR :: YesodAuth m => GHandler Auth m ()+postLogoutR = do+    y <- getYesod+    deleteSession credsKey+    redirectUltDest RedirectTemporary $ defaultDest y++handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m ()+handlePluginR plugin pieces = do+    env <- waiRequest+    let method = S8.unpack $ W.requestMethod env+    case filter (\x -> apName x == plugin) authPlugins of+        [] -> notFound+        ap:_ -> apDispatch ap method pieces++-- | Retrieves user credentials, if user is authenticated.+maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))+maybeAuthId = do+    ms <- lookupSession credsKey+    y <- getYesod+    case ms of+        Nothing -> return Nothing+        Just s -> return $ readAuthId y s++maybeAuth :: ( YesodAuth m+             , Key val ~ AuthId m+             , PersistBackend (YesodDB m (GHandler s m))+             , PersistEntity val+             , YesodPersist m+             ) => GHandler s m (Maybe (Key val, val))+maybeAuth = do+    maid <- maybeAuthId+    case maid of+        Nothing -> return Nothing+        Just aid -> do+            ma <- runDB $ get aid+            case ma of+                Nothing -> return Nothing+                Just a -> return $ Just (aid, a)++requireAuthId :: YesodAuth m => GHandler s m (AuthId m)+requireAuthId = maybeAuthId >>= maybe redirectLogin return++requireAuth :: ( YesodAuth m+               , Key val ~ AuthId m+               , PersistBackend (YesodDB m (GHandler s m))+               , PersistEntity val+               , YesodPersist m+               ) => GHandler s m (Key val, val)+requireAuth = maybeAuth >>= maybe redirectLogin return++redirectLogin :: Yesod m => GHandler s m a+redirectLogin = do+    y <- getYesod+    setUltDest'+    case authRoute y of+        Just z -> redirect RedirectTemporary z+        Nothing -> permissionDenied "Please configure authRoute"++authDummy :: YesodAuth m => AuthPlugin m+authDummy =+    AuthPlugin "dummy" dispatch login+  where+    dispatch "POST" [] = do+        ident <- runFormPost' $ stringInput "ident"+        setCreds True $ Creds "dummy" ident []+    dispatch _ _ = notFound+    url = PluginR "dummy" []+    authToMaster = liftHandler getRouteToMaster+    login = do+        tm <- authToMaster+        addBody [$hamlet|+%form!method=post!action=@tm.url@+    Your new identifier is: $+    %input!type=text!name=ident+    %input!type=submit!value="Dummy Login"+|]
+ Yesod/Helpers/Auth2/Email.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}+module Yesod.Helpers.Auth2.Email+    ( authEmail+    , YesodAuthEmail (..)+    , EmailCreds (..)+    ) where++import Yesod+import Yesod.Mail (randomString)+import Yesod.Helpers.Auth2+import System.Random+import Control.Monad (when)+import Control.Applicative ((<$>), (<*>))+import Data.Digest.Pure.MD5+import Data.String (fromString)+import qualified Data.ByteString.Lazy.UTF8 as LU++login, register, setpass :: AuthRoute+login = PluginR "email" ["login"]+register = PluginR "email" ["register"]+setpass = PluginR "email" ["set-password"]++verify :: String -> String -> AuthRoute -- FIXME+verify eid verkey = PluginR "email" ["verify", eid, verkey]++type Email = String+type VerKey = String+type VerUrl = String+type SaltedPass = String+type VerStatus = Bool++-- | Data stored in a database for each e-mail address.+data EmailCreds m = EmailCreds+    { emailCredsId :: AuthEmailId m+    , emailCredsAuthId :: Maybe (AuthId m)+    , emailCredsStatus :: VerStatus+    , emailCredsVerkey :: Maybe VerKey+    }++class YesodAuth m => YesodAuthEmail m where+    type AuthEmailId m++    showAuthEmailId :: m -> AuthEmailId m -> String+    readAuthEmailId :: m -> String -> Maybe (AuthEmailId m)++    addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)+    sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()+    getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)+    setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()+    verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))+    getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)+    setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()+    getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))+    getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)++    -- | Generate a random alphanumeric string.+    randomKey :: m -> IO String+    randomKey _ = do+        stdgen <- newStdGen+        return $ fst $ randomString 10 stdgen++authEmail :: YesodAuthEmail m => AuthPlugin m+authEmail =+    AuthPlugin "email" dispatch login'+  where+    go x = x >>= sendResponse+    dispatch "GET" ["register"] = go getRegisterR+    dispatch "POST" ["register"] = go postRegisterR+    dispatch "GET" ["verify", eid, verkey] = do+        y <- getYesod+        case readAuthEmailId y eid of+            Nothing -> notFound+            Just eid' -> go $ getVerifyR eid' verkey+    dispatch "POST" ["login"] = go postLoginR+    dispatch "GET" ["set-password"] = go getPasswordR+    dispatch "POST" ["set-password"] = go postPasswordR+    dispatch _ _ = notFound++    login' = do+        tm <- liftHandler getRouteToMaster+        addBody [$hamlet|+%form!method=post!action=@tm.login@+    %table+        %tr+            %th E-mail+            %td+                %input!type=email!name=email+        %tr+            %th Password+            %td+                %input!type=password!name=password+        %tr+            %td!colspan=2+                %input!type=submit!value="Login via email"+                %a!href=@tm.register@ I don't have an account+|]++getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml+getRegisterR = do+    toMaster <- getRouteToMaster+    defaultLayout $ do+        setTitle $ string "Register a new account"+        addBody [$hamlet|+%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.+%form!method=post!action=@toMaster.register@+    %label!for=email E-mail+    %input#email!type=email!name=email!width=150+    %input!type=submit!value=Register+|]++postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml+postRegisterR = do+    y <- getYesod+    email <- runFormPost' $ emailInput "email"+    mecreds <- getEmailCreds email+    (lid, verKey) <-+        case mecreds of+            Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)+            Just (EmailCreds lid _ _ Nothing) -> do+                key <- liftIO $ randomKey y+                setVerifyKey lid key+                return (lid, key)+            Nothing -> do+                key <- liftIO $ randomKey y+                lid <- addUnverified email key+                return (lid, key)+    render <- getUrlRender+    tm <- getRouteToMaster+    let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey+    sendVerifyEmail email verKey verUrl+    defaultLayout $ do+        setTitle $ string "Confirmation e-mail sent"+        addBody [$hamlet|+%p A confirmation e-mail has been sent to $email$.+|]++getVerifyR :: YesodAuthEmail m+           => AuthEmailId m -> String -> GHandler Auth m RepHtml+getVerifyR lid key = do+    realKey <- getVerifyKey lid+    memail <- getEmail lid+    case (realKey == Just key, memail) of+        (True, Just email) -> do+            muid <- verifyAccount lid+            case muid of+                Nothing -> return ()+                Just uid -> do+                    setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?+                    toMaster <- getRouteToMaster+                    setMessage $ string "Address verified, please set a new password"+                    redirect RedirectTemporary $ toMaster setpass+        _ -> return ()+    defaultLayout $ do+        setTitle $ string "Invalid verification key"+        addBody [$hamlet|+%p I'm sorry, but that was an invalid verification key.+|]++postLoginR :: YesodAuthEmail master => GHandler Auth master ()+postLoginR = do+    (email, pass) <- runFormPost' $ (,)+        <$> emailInput "email"+        <*> stringInput "password"+    y <- getYesod+    mecreds <- getEmailCreds email+    maid <-+        case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of+            (Just aid, Just True) -> do+                mrealpass <- getPassword aid+                case mrealpass of+                    Nothing -> return Nothing+                    Just realpass -> return $+                        if isValidPass pass realpass+                            then Just aid+                            else Nothing+            _ -> return Nothing+    case maid of+        Just aid ->+            setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?+        Nothing -> do+            setMessage $ string "Invalid email/password combination"+            toMaster <- getRouteToMaster+            redirect RedirectTemporary $ toMaster LoginR++getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml+getPasswordR = do+    toMaster <- getRouteToMaster+    maid <- maybeAuthId+    case maid of+        Just _ -> return ()+        Nothing -> do+            setMessage $ string "You must be logged in to set a password"+            redirect RedirectTemporary $ toMaster login+    defaultLayout $ do+        setTitle $ string "Set password"+        addBody [$hamlet|+%h3 Set a new password+%form!method=post!action=@toMaster.setpass@+    %table+        %tr+            %th New password+            %td+                %input!type=password!name=new+        %tr+            %th Confirm+            %td+                %input!type=password!name=confirm+        %tr+            %td!colspan=2+                %input!type=submit!value=Submit+|]++postPasswordR :: YesodAuthEmail master => GHandler Auth master ()+postPasswordR = do+    (new, confirm) <- runFormPost' $ (,)+        <$> stringInput "new"+        <*> stringInput "confirm"+    toMaster <- getRouteToMaster+    when (new /= confirm) $ do+        setMessage $ string "Passwords did not match, please try again"+        redirect RedirectTemporary $ toMaster setpass+    maid <- maybeAuthId+    aid <- case maid of+            Nothing -> do+                setMessage $ string "You must be logged in to set a password"+                redirect RedirectTemporary $ toMaster login+            Just aid -> return aid+    salted <- liftIO $ saltPass new+    setPassword aid salted+    setMessage $ string "Password updated"+    y <- getYesod+    redirect RedirectTemporary $ defaultDest y++saltLength :: Int+saltLength = 5++saltPass :: String -> IO String+saltPass pass = do+    stdgen <- newStdGen+    let salt = take saltLength $ randomRs ('A', 'Z') stdgen+    return $ saltPass' salt pass++saltPass' :: String -> String -> String+saltPass' salt pass = salt ++ show (md5 $ LU.fromString $ salt ++ pass)++isValidPass :: String -- ^ cleartext password+            -> SaltedPass -- ^ salted password+            -> Bool+isValidPass clear salted =+    let salt = take saltLength salted+     in salted == saltPass' salt clear
+ Yesod/Helpers/Auth2/Facebook.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE QuasiQuotes #-}+module Yesod.Helpers.Auth2.Facebook+    ( authFacebook+    ) where++import Yesod+import Yesod.Helpers.Auth2+import qualified Web.Authenticate.Facebook as Facebook+import Data.Object (fromMapping, lookupScalar)+import Data.Maybe (fromMaybe)++authFacebook :: YesodAuth m+             => String -- ^ Application ID+             -> String -- ^ Application secret+             -> [String] -- ^ Requested permissions+             -> AuthPlugin m+authFacebook cid secret perms =+    AuthPlugin "facebook" dispatch login+  where+    url = PluginR "facebook" []+    dispatch "GET" [] = do+        render <- getUrlRender+        tm <- getRouteToMaster+        let fb = Facebook.Facebook cid secret $ render $ tm url+        code <- runFormGet' $ stringInput "code"+        at <- liftIO $ Facebook.getAccessToken fb code+        let Facebook.AccessToken at' = at+        so <- liftIO $ Facebook.getGraphData at "me"+        let c = fromMaybe (error "Invalid response from Facebook") $ do+            m <- fromMapping so+            id' <- lookupScalar "id" m+            let name = lookupScalar "name" m+            let email = lookupScalar "email" m+            let id'' = "http://graph.facebook.com/" ++ id'+            return+                $ Creds "facebook" id''+                $ maybe id (\x -> (:) ("verifiedEmail", x)) email+                $ maybe id (\x -> (:) ("displayName ", x)) name+                [ ("accessToken", at')+                ]+        setCreds True c+    dispatch _ _ = notFound+    login = do+        tm <- liftHandler getRouteToMaster+        render <- liftHandler getUrlRender+        let fb = Facebook.Facebook cid secret $ render $ tm url+        let furl = Facebook.getForwardUrl fb $ perms+        addBody [$hamlet|+%p+    %a!href=$furl$ Login with Facebook+|]
+ Yesod/Helpers/Auth2/OpenId.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE QuasiQuotes #-}+module Yesod.Helpers.Auth2.OpenId+    ( authOpenId+    ) where++import Yesod+import Yesod.Helpers.Auth2+import qualified Web.Authenticate.OpenId as OpenId+import Control.Monad.Attempt++authOpenId :: YesodAuth m => AuthPlugin m+authOpenId =+    AuthPlugin "openid" dispatch login+  where+    forward = PluginR "openid" ["forward"]+    complete = PluginR "openid" ["complete"]+    name = "openid_identifier"+    login = do+        tm <- liftHandler getRouteToMaster+        addStyle [$cassius|+#openid+    background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;+    padding-left: 18px;+|]+        addBody [$hamlet|+%form!method=post!action=@tm.forward@+    %label!for=openid OpenID: $+    %input#openid!type=text!name=$name$+    %input!type=submit!value="Login via OpenID"+|]+    dispatch "POST" ["forward"] = do+        (roid, _, _) <- runFormPost $ stringInput name+        case roid of+            FormSuccess oid -> do+                render <- getUrlRender+                toMaster <- getRouteToMaster+                let complete' = render $ toMaster complete+                res <- runAttemptT $ OpenId.getForwardUrl oid complete'+                attempt+                  (\err -> do+                        setMessage $ string $ show err+                        redirect RedirectTemporary $ toMaster LoginR)+                  (redirectString RedirectTemporary)+                  res+            _ -> do+                toMaster <- getRouteToMaster+                setMessage $ string "No OpenID identifier found"+                redirect RedirectTemporary $ toMaster LoginR+    dispatch "GET" ["complete"] = do+        rr <- getRequest+        let gets' = reqGetParams rr+        res <- runAttemptT $ OpenId.authenticate gets'+        toMaster <- getRouteToMaster+        let onFailure err = do+            setMessage $ string $ show err+            redirect RedirectTemporary $ toMaster LoginR+        let onSuccess (OpenId.Identifier ident) =+                setCreds True $ Creds "openid" ident []+        attempt onFailure onSuccess res+    dispatch _ _ = notFound
+ Yesod/Helpers/Auth2/Rpxnow.hs view
@@ -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"]
+ yesod-auth.cabal view
@@ -0,0 +1,35 @@+name:            yesod-auth+version:         0.0.0+license:         BSD3+license-file:    LICENSE+author:          Michael Snoyman <michael@snoyman.com>+maintainer:      Michael Snoyman <michael@snoyman.com>+synopsis:        Authentication for Yesod.+category:        Web+stability:       Stable+cabal-version:   >= 1.6+build-type:      Simple+homepage:        http://docs.yesodweb.com/++library+    build-depends:   base                    >= 4         && < 5+                   , authenticate            >= 0.6.4     && < 0.7+                   , bytestring              >= 0.9.1.4   && < 0.10+                   , yesod                   >= 0.5.1     && < 0.6+                   , wai                     >= 0.2       && < 0.3+                   , template-haskell+                   , pureMD5                 >= 1.1       && < 1.2+                   , random                  >= 1.0       && < 1.1+                   , data-object             >= 0.3.1.3   && < 0.4+                   , control-monad-attempt   >= 0.3.0     && < 0.4+                   , utf8-string             >= 0.3.4     && < 0.4+    exposed-modules: Yesod.Helpers.Auth2+                     Yesod.Helpers.Auth2.Email+                     Yesod.Helpers.Auth2.Facebook+                     Yesod.Helpers.Auth2.OpenId+                     Yesod.Helpers.Auth2.Rpxnow+    ghc-options:     -Wall++source-repository head+  type:     git+  location: git://github.com/snoyberg/yesod.git