yesod-auth 0.4.0.2 → 0.5.0
raw patch · 20 files changed
+1273/−1228 lines, 20 filesdep ~hamletdep ~yesod-coresetup-changed
Dependency ranges changed: hamlet, yesod-core
Files
- LICENSE +25/−25
- Setup.lhs +8/−8
- Yesod/Auth.hs +234/−0
- Yesod/Auth/Dummy.hs +35/−0
- Yesod/Auth/Email.hs +306/−0
- Yesod/Auth/Facebook.hs +86/−0
- Yesod/Auth/HashDB.hs +210/−0
- Yesod/Auth/Message.hs +64/−0
- Yesod/Auth/OAuth.hs +89/−0
- Yesod/Auth/OpenId.hs +98/−0
- Yesod/Auth/Rpxnow.hs +59/−0
- Yesod/Helpers/Auth.hs +0/−270
- Yesod/Helpers/Auth/Dummy.hs +0/−35
- Yesod/Helpers/Auth/Email.hs +0/−298
- Yesod/Helpers/Auth/Facebook.hs +0/−82
- Yesod/Helpers/Auth/HashDB.hs +0/−210
- Yesod/Helpers/Auth/OAuth.hs +0/−89
- Yesod/Helpers/Auth/OpenId.hs +0/−94
- Yesod/Helpers/Auth/Rpxnow.hs +0/−59
- yesod-auth.cabal +59/−58
LICENSE view
@@ -1,25 +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. +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.lhs view
@@ -1,8 +1,8 @@-#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple -> import System.Cmd (system) - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple+> import System.Cmd (system)++> main :: IO ()+> main = defaultMain
+ Yesod/Auth.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Auth+ ( -- * Subsite+ Auth+ , AuthPlugin (..)+ , AuthRoute (..)+ , getAuth+ , YesodAuth (..)+ -- * Plugin interface+ , Creds (..)+ , setCreds+ -- * User functions+ , maybeAuthId+ , maybeAuth+ , requireAuthId+ , requireAuth+ ) where++import Yesod.Core+import Yesod.Persist+import Yesod.Json+import Text.Blaze+import Language.Haskell.TH.Syntax hiding (lift)+import qualified Network.Wai as W+import Text.Hamlet (hamlet)+import qualified Data.Map as Map+import Control.Monad.Trans.Class (lift)+import Data.Aeson+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Web.Routes.Quasi (toSinglePiece, fromSinglePiece)+import Yesod.Auth.Message (AuthMessage, defaultMessage)+import qualified Yesod.Auth.Message as Msg++data Auth = Auth++type Method = Text+type Piece = Text++data AuthPlugin m = AuthPlugin+ { apName :: Text+ , 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 :: Text -- ^ How the user was authenticated+ , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.+ , credsExtra :: [(Text, Text)]+ }++class (Yesod m, SinglePiece (AuthId 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))++ authPlugins :: [AuthPlugin m]++ -- | What to show on the login page.+ loginHandler :: GHandler Auth m RepHtml+ loginHandler = defaultLayout $ do+ setTitle "Login"+ tm <- lift getRouteToMaster+ mapM_ (flip apLogin tm) authPlugins++ renderAuthMessage :: m+ -> [Text] -- ^ languages+ -> AuthMessage -> Html+ renderAuthMessage _ _ = defaultMessage++type Texts = [Text]++mkYesodSub "Auth"+ [ ClassP ''YesodAuth [VarT $ mkName "master"]+ ]+#define STRINGS *Texts+#if GHC7+ [parseRoutes|+#else+ [$parseRoutes|+#endif+/check CheckR GET+/login LoginR GET+/logout LogoutR GET POST+/page/#Text/STRINGS PluginR+|]++credsKey :: Text+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+ l <- languages+ let mr = renderMessage Auth y l+ case maid of+ Nothing ->+ if doRedirects+ then do+ case authRoute y of+ Nothing -> do+ rh <- defaultLayout+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ <h1>Invalid login+|]+ sendResponse rh+ Just ar -> do+ setMessage $ mr Msg.InvalidLogin+ redirect RedirectTemporary ar+ else return ()+ Just aid -> do+ setSession credsKey $ toSinglePiece aid+ if doRedirects+ then do+ setMessage $ mr Msg.NowLoggedIn+ redirectUltDest RedirectTemporary $ loginDest y+ else return ()++getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson+getCheckR = do+ creds <- maybeAuthId+ defaultLayoutJson (do+ setTitle "Authentication Status"+ addHtml $ html creds) (json' creds)+ where+ html creds =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+<h1>Authentication Status+$maybe _ <- creds+ <p>Logged in.+$nothing+ <p>Not logged in.+|]+ json' creds =+ Object $ Map.fromList+ [ (T.pack "logged_in", Bool $ 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 => Text -> [Text] -> GHandler Auth m ()+handlePluginR plugin pieces = do+ env <- waiRequest+ let method = decodeUtf8With lenientDecode $ 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+ case ms of+ Nothing -> return Nothing+ Just s -> return $ fromSinglePiece s++maybeAuth :: ( YesodAuth m+ , Key val ~ AuthId m+ , PersistBackend (YesodDB m (GGHandler s m IO))+ , 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 (GGHandler s m IO))+ , 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"++instance YesodAuth m => YesodMessage Auth m where+ type Message Auth m = AuthMessage+ renderMessage = const renderAuthMessage
+ Yesod/Auth/Dummy.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- | 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.Auth.Dummy+ ( authDummy+ ) where++import Yesod.Auth+import Yesod.Form (runFormPost', stringInput)+import Yesod.Handler (notFound)+import Text.Hamlet (hamlet)++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 =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+<form method="post" action="@{authToMaster url}">+ \Your new identifier is: + <input type="text" name="ident">+ <input type="submit" value="Dummy Login">+|]
+ Yesod/Auth/Email.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Auth.Email+ ( -- * Plugin+ authEmail+ , YesodAuthEmail (..)+ , EmailCreds (..)+ , saltPass+ -- * Routes+ , loginR+ , registerR+ , setpassR+ ) where++import Network.Mail.Mime (randomString)+import Yesod.Auth+import System.Random+import Control.Monad (when)+import Control.Applicative ((<$>), (<*>))+import Data.Digest.Pure.MD5+import qualified Data.Text.Lazy as T+import qualified Data.Text as TS+import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Text (Text)++import Yesod.Form+import Yesod.Handler+import Yesod.Content+import Yesod.Widget+import Yesod.Core+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Web.Routes.Quasi (toSinglePiece, fromSinglePiece)+import qualified Yesod.Auth.Message as Msg++loginR, registerR, setpassR :: AuthRoute+loginR = PluginR "email" ["login"]+registerR = PluginR "email" ["register"]+setpassR = PluginR "email" ["set-password"]++verify :: Text -> Text -> AuthRoute -- FIXME+verify eid verkey = PluginR "email" ["verify", eid, verkey]++type Email = Text+type VerKey = Text+type VerUrl = Text+type SaltedPass = Text+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, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where+ type 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 Text+ randomKey _ = do+ stdgen <- newStdGen+ return $ TS.pack $ fst $ randomString 10 stdgen++authEmail :: YesodAuthEmail m => AuthPlugin m+authEmail =+ AuthPlugin "email" dispatch $ \tm -> do+ y <- lift getYesod+ l <- lift languages+ let mr = renderMessage (getAuth 'x') y l+#if GHC7+ [whamlet|+#else+ [$whamlet|+#endif+<form method="post" action="@{tm loginR}">+ <table>+ <tr>+ <th>#{mr Msg.Email}+ <td>+ <input type="email" name="email">+ <tr>+ <th>#{mr Msg.Password}+ <td>+ <input type="password" name="password">+ <tr>+ <td colspan="2">+ <input type="submit" value=#{mr Msg.LoginViaEmail}>+ <a href="@{tm registerR}">I don't have an account+|]+ where+ dispatch "GET" ["register"] = getRegisterR >>= sendResponse+ dispatch "POST" ["register"] = postRegisterR >>= sendResponse+ dispatch "GET" ["verify", eid, verkey] =+ case fromSinglePiece eid of+ Nothing -> notFound+ Just eid' -> getVerifyR eid' verkey >>= sendResponse+ dispatch "POST" ["login"] = postLoginR >>= sendResponse+ dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse+ dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse+ dispatch _ _ = notFound++getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml+getRegisterR = do+ toMaster <- getRouteToMaster+ mr <- getMessageRender+ defaultLayout $ do+ setTitle $ mr Msg.RegisterLong+ addWidget+#if GHC7+ [whamlet|+#else+ [$whamlet|+#endif+<p>_{Msg.EnterEmail}+<form method="post" action="@{toMaster registerR}">+ <label for="email">_{Msg.Email}+ <input type="email" name="email" width="150">+ <input type="submit" value=_{Msg.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 (toSinglePiece lid) verKey+ sendVerifyEmail email verKey verUrl+ mr <- getMessageRender+ defaultLayout $ do+ setTitle $ mr Msg.ConfirmationEmailSentTitle+ addWidget+#if GHC7+ [whamlet|+#else+ [$whamlet|+#endif+<p>_{Msg.ConfirmationEmailSent email}+|]++getVerifyR :: YesodAuthEmail m+ => AuthEmailId m -> Text -> 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+ mr <- getMessageRender+ setMessage $ mr Msg.AddressVerified+ redirect RedirectTemporary $ toMaster setpassR+ _ -> return ()+ mr <- getMessageRender+ defaultLayout $ do+ setTitle $ mr Msg.InvalidKey+ addWidget+#if GHC7+ [whamlet|+#else+ [$whamlet|+#endif+<p>_{Msg.InvalidKey}+|]++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+ y <- getYesod+ mr <- getMessageRender+ setMessage $ mr Msg.InvalidEmailPass+ toMaster <- getRouteToMaster+ redirect RedirectTemporary $ toMaster LoginR++getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml+getPasswordR = do+ toMaster <- getRouteToMaster+ maid <- maybeAuthId+ mr <- getMessageRender+ case maid of+ Just _ -> return ()+ Nothing -> do+ setMessage $ mr Msg.BadSetPass+ redirect RedirectTemporary $ toMaster loginR+ defaultLayout $ do+ setTitle $ mr Msg.SetPassTitle+ addWidget+#if GHC7+ [whamlet|+#else+ [$whamlet|+#endif+<h3>_{Msg.SetPass}+<form method="post" action="@{toMaster setpassR}">+ <table>+ <tr>+ <th>_{Msg.NewPass}+ <td>+ <input type="password" name="new">+ <tr>+ <th>_{Msg.ConfirmPass}+ <td>+ <input type="password" name="confirm">+ <tr>+ <td colspan="2">+ <input type="submit" value="_{Msg.SetPassTitle}">+|]++postPasswordR :: YesodAuthEmail master => GHandler Auth master ()+postPasswordR = do+ (new, confirm) <- runFormPost' $ (,)+ <$> stringInput "new"+ <*> stringInput "confirm"+ toMaster <- getRouteToMaster+ y <- getYesod+ when (new /= confirm) $ do+ mr <- getMessageRender+ setMessage $ mr Msg.PassMismatch+ redirect RedirectTemporary $ toMaster setpassR+ maid <- maybeAuthId+ aid <- case maid of+ Nothing -> do+ mr <- getMessageRender+ setMessage $ mr Msg.BadSetPass+ redirect RedirectTemporary $ toMaster loginR+ Just aid -> return aid+ salted <- liftIO $ saltPass new+ setPassword aid salted+ mr <- getMessageRender+ setMessage $ mr Msg.PassUpdated+ redirect RedirectTemporary $ loginDest y++saltLength :: Int+saltLength = 5++-- | Salt a password with a randomly generated salt.+saltPass :: Text -> IO Text+saltPass pass = do+ stdgen <- newStdGen+ let salt = take saltLength $ randomRs ('A', 'Z') stdgen+ return $ TS.pack $ saltPass' salt $ TS.unpack pass++saltPass' :: String -> String -> String+saltPass' salt pass =+ salt ++ show (md5 $ fromString $ salt ++ pass)+ where+ fromString = encodeUtf8 . T.pack++isValidPass :: Text -- ^ cleartext password+ -> SaltedPass -- ^ salted password+ -> Bool+isValidPass clear' salted' =+ let salt = take saltLength salted+ in salted == saltPass' salt clear+ where+ clear = TS.unpack clear'+ salted = TS.unpack salted'
+ Yesod/Auth/Facebook.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Auth.Facebook+ ( authFacebook+ , facebookUrl+ ) where++import Yesod.Auth+import qualified Web.Authenticate.Facebook as Facebook+import Data.Aeson+import Data.Aeson.Types (parseMaybe)+import Data.Maybe (fromMaybe)++import Yesod.Form+import Yesod.Handler+import Yesod.Widget+import Yesod.Request (languages)+import Text.Hamlet (hamlet)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Data.Text (Text)+import Control.Monad (mzero)+import Data.Monoid (mappend)+import qualified Data.Aeson.Types+import qualified Yesod.Auth.Message as Msg++facebookUrl :: AuthRoute+facebookUrl = PluginR "facebook" ["forward"]++authFacebook :: YesodAuth m+ => Text -- ^ Application ID+ -> Text -- ^ Application secret+ -> [Text] -- ^ 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+ redirectText 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")+ $ parseMaybe (parseCreds at') $ either error id so+ setCreds True c+ dispatch _ _ = notFound+ login tm = do+ render <- lift getUrlRender+ let fb = Facebook.Facebook cid secret $ render $ tm url+ let furl = Facebook.getForwardUrl fb $ perms+ y <- lift getYesod+ l <- lift languages+ let mr = renderMessage (getAuth 'x') y l+ addHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+<p>+ <a href="#{furl}">#{mr Msg.Facebook}+|]++parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)+parseCreds at' (Object m) = do+ id' <- m .: "id"+ let id'' = "http://graph.facebook.com/" `mappend` id'+ name <- m .: "name"+ email <- m .: "email"+ return+ $ Creds "facebook" id''+ $ maybe id (\x -> (:) ("verifiedEmail", x)) email+ $ maybe id (\x -> (:) ("displayName ", x)) name+ [ ("accessToken", at')+ ]+parseCreds _ _ = mzero
+ Yesod/Auth/HashDB.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Auth.HashDB+-- Copyright : (c) Patrick Brisbin 2010 +-- License : as-is+--+-- Maintainer : pbrisbin@gmail.com+-- Stability : Stable+-- Portability : Portable+--+-- A yesod-auth AuthPlugin designed to look users up in Persist where+-- their user id's and a sha1 hash of their password will already be+-- stored.+--+-- Example usage:+--+-- > -- import the function+-- > import Auth.HashDB+-- >+-- > -- make sure you have an auth route+-- > mkYesodData "MyApp" [$parseRoutes|+-- > / RootR GET+-- > /auth AuthR Auth getAuth+-- > |]+-- >+-- >+-- > -- make your app an instance of YesodAuth using this plugin+-- > instance YesodAuth MyApp where+-- > type AuthId MyApp = UserId+-- >+-- > loginDest _ = RootR+-- > logoutDest _ = RootR+-- > getAuthId = getAuthIdHashDB AuthR +-- > showAuthId _ = showIntegral+-- > readAuthId _ = readIntegral+-- > authPlugins = [authHashDB]+-- >+-- >+-- > -- include the migration function in site startup+-- > withServer :: (Application -> IO a) -> IO a+-- > withServer f = withConnectionPool $ \p -> do+-- > runSqlPool (runMigration migrateUsers) p+-- > let h = DevSite p+--+-- Your app must be an instance of YesodPersist and the username and+-- hashed-passwords must be added manually to the database.+--+-- > echo -n 'MyPassword' | sha1sum+--+-- can be used to get the hash from the commandline.+--+-------------------------------------------------------------------------------+module Yesod.Auth.HashDB+ ( authHashDB+ , getAuthIdHashDB+ , UserId+ , migrateUsers+ ) where++import Yesod.Persist+import Yesod.Handler+import Yesod.Form+import Yesod.Auth+import Text.Hamlet (hamlet)++import Control.Applicative ((<$>), (<*>))+import Data.ByteString.Lazy.Char8 (pack)+import Data.Digest.Pure.SHA (sha1, showDigest)+import Data.Text (Text, unpack)+import Data.Maybe (fromMaybe)++-- | Computer the sha1 of a string and return it as a string+sha1String :: String -> String+sha1String = showDigest . sha1 . pack++-- | Generate data base instances for a valid user+share2 mkPersist (mkMigrate "migrateUsers")+#if GHC7+ [persist|+#else+ [$persist|+#endif+User+ username Text Eq+ password Text+ UniqueUser username+|]++-- | Given a (user,password) in plaintext, validate them against the+-- database values+validateUser :: (YesodPersist y, + PersistBackend (YesodDB y (GGHandler sub y IO))) + => (Text, Text) + -> GHandler sub y Bool+validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->+ case dbUser of+ -- user not found+ Nothing -> return False+ -- validate password+ Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser)++login :: AuthRoute+login = PluginR "hashdb" ["login"]++-- | Handle the login form+postLoginR :: (YesodAuth y,+ YesodPersist y, + PersistBackend (YesodDB y (GGHandler Auth y IO)))+ => GHandler Auth y ()+postLoginR = do+ (mu,mp) <- runFormPost' $ (,)+ <$> maybeStringInput "username"+ <*> maybeStringInput "password"++ isValid <- case (mu,mp) of+ (Nothing, _ ) -> return False+ (_ , Nothing) -> return False+ (Just u , Just p ) -> validateUser (u,p)++ if isValid+ then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []+ else do+ setMessage+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ Invalid username/password+|]+ toMaster <- getRouteToMaster+ redirect RedirectTemporary $ toMaster LoginR++-- | A drop in for the getAuthId method of your YesodAuth instance which+-- can be used if authHashDB is the only plugin in use.+getAuthIdHashDB :: (Key User ~ AuthId master,+ PersistBackend (YesodDB master (GGHandler sub master IO)),+ YesodPersist master,+ YesodAuth master)+ => (AuthRoute -> Route master) -- ^ your site's Auth Route+ -> Creds m -- ^ the creds argument+ -> GHandler sub master (Maybe UserId)+getAuthIdHashDB authR creds = do+ muid <- maybeAuth+ case muid of+ -- user already authenticated+ Just (uid, _) -> return $ Just uid+ Nothing -> do+ x <- runDB $ getBy $ UniqueUser (credsIdent creds)+ case x of+ -- user exists+ Just (uid, _) -> return $ Just uid+ Nothing -> do+ setMessage+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ User not found+|]+ redirect RedirectTemporary $ authR LoginR++-- | Prompt for username and password, validate that against a database+-- which holds the username and a hash of the password+authHashDB :: (YesodAuth y,+ YesodPersist y, + PersistBackend (YesodDB y (GGHandler Auth y IO)))+ => AuthPlugin y+authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ <div id="header">+ <h1>Login++ <div id="login">+ <form method="post" action="@{tm login}">+ <table>+ <tr>+ <th>Username:+ <td>+ <input id="x" name="username" autofocus="" required>+ <tr>+ <th>Password:+ <td>+ <input type="password" name="password" required>+ <tr>+ <td> + <td>+ <input type="submit" value="Login">++ <script>+ if (!("autofocus" in document.createElement("input"))) {+ document.getElementById("x").focus();+ }++|]+ where+ dispatch "POST" ["login"] = postLoginR >>= sendResponse+ dispatch _ _ = notFound
+ Yesod/Auth/Message.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Auth.Message+ ( AuthMessage (..)+ , defaultMessage+ ) where++import Text.Blaze (Html, toHtml)+import Data.Monoid (mappend)+import Data.Text (Text)++data AuthMessage =+ NoOpenID+ | LoginOpenID+ | Email+ | Password+ | Register+ | RegisterLong+ | EnterEmail+ | ConfirmationEmailSentTitle+ | ConfirmationEmailSent Text+ | AddressVerified+ | InvalidKeyTitle+ | InvalidKey+ | InvalidEmailPass+ | BadSetPass+ | SetPassTitle+ | SetPass+ | NewPass+ | ConfirmPass+ | PassMismatch+ | PassUpdated+ | Facebook+ | LoginViaEmail+ | InvalidLogin+ | NowLoggedIn++defaultMessage :: AuthMessage -> Html+defaultMessage NoOpenID = "No OpenID identifier found"+defaultMessage LoginOpenID = "Login via OpenID"+defaultMessage Email = "Email"+defaultMessage Password = "Password"+defaultMessage Register = "Register"+defaultMessage RegisterLong = "Register a new account"+defaultMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."+defaultMessage ConfirmationEmailSentTitle = "Confirmation e-mail sent"+defaultMessage (ConfirmationEmailSent email) =+ "A confirmation e-mail has been sent to " `mappend`+ toHtml email `mappend`+ "."+defaultMessage AddressVerified = "Address verified, please set a new password"+defaultMessage InvalidKeyTitle = "Invalid verification key"+defaultMessage InvalidKey = "I'm sorry, but that was an invalid verification key."+defaultMessage InvalidEmailPass = "Invalid email/password combination"+defaultMessage BadSetPass = "You must be logged in to set a password"+defaultMessage SetPassTitle = "Set password"+defaultMessage SetPass = "Set a new password"+defaultMessage NewPass = "New password"+defaultMessage ConfirmPass = "Confirm"+defaultMessage PassMismatch = "Passwords did not match, please try again"+defaultMessage PassUpdated = "Password updated"+defaultMessage Facebook = "Login with Facebook"+defaultMessage LoginViaEmail = "Login via email"+defaultMessage InvalidLogin = "Invalid login"+defaultMessage NowLoggedIn = "You are now logged in"
+ Yesod/Auth/OAuth.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings #-}+{-# OPTIONS_GHC -fwarn-unused-imports #-}+module Yesod.Auth.OAuth+ ( authOAuth+ , oauthUrl+ , authTwitter+ , twitterUrl+ ) where+import Yesod.Auth+import Yesod.Form+import Yesod.Handler+import Yesod.Widget+import Text.Hamlet (hamlet)+import Web.Authenticate.OAuth+import Data.Maybe+import Data.String+import Data.ByteString.Char8 (pack)+import Control.Arrow ((***))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Data.Text (Text, unpack)+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.ByteString (ByteString)++oauthUrl :: Text -> AuthRoute+oauthUrl name = PluginR name ["forward"]++authOAuth :: YesodAuth m =>+ Text -- ^ Service Name+ -> String -- ^ OAuth Parameter Name to use for identify+ -> String -- ^ Request URL+ -> String -- ^ Access Token URL+ -> String -- ^ Authorize URL+ -> String -- ^ Consumer Key+ -> String -- ^ Consumer Secret+ -> AuthPlugin m+authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login+ where+ url = PluginR name []+ oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl+ , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl+ , oauthSignatureMethod = HMACSHA1+ , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec+ , oauthCallback = Nothing+ }+ dispatch "GET" ["forward"] = do+ render <- getUrlRender+ tm <- getRouteToMaster+ let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }+ tok <- liftIO $ getTemporaryCredential oauth'+ redirectText RedirectTemporary (fromString $ authorizeUrl oauth' tok)+ dispatch "GET" [] = do+ verifier <- runFormGet' $ stringInput "oauth_verifier"+ oaTok <- runFormGet' $ stringInput "oauth_token"+ let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)+ ] + accTok <- liftIO $ getAccessToken oauth reqTok+ let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok+ creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok+ setCreds True creds+ dispatch _ _ = notFound+ login tm = do+ render <- lift getUrlRender+ let oaUrl = render $ tm $ oauthUrl name+ addHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+ <a href=#{oaUrl}>Login with #{name}+ |]++authTwitter :: YesodAuth m =>+ String -- ^ Consumer Key+ -> String -- ^ Consumer Secret+ -> AuthPlugin m+authTwitter = authOAuth "twitter"+ "screen_name"+ "http://twitter.com/oauth/request_token"+ "http://twitter.com/oauth/access_token"+ "http://twitter.com/oauth/authorize"++twitterUrl :: AuthRoute+twitterUrl = oauthUrl "twitter"++bsToText :: ByteString -> Text+bsToText = decodeUtf8With lenientDecode
+ Yesod/Auth/OpenId.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Auth.OpenId+ ( authOpenId+ , forwardUrl+ ) where++import Yesod.Auth+import qualified Web.Authenticate.OpenId as OpenId+import Control.Monad.Attempt++import Yesod.Form+import Yesod.Handler+import Yesod.Widget+import Yesod.Request+import Text.Hamlet (hamlet)+import Text.Cassius (cassius)+import Text.Blaze (toHtml)+import Control.Monad.Trans.Class (lift)+import Data.Text (Text)+import qualified Yesod.Auth.Message as Msg++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 <- lift newIdent+ y <- lift getYesod+ addCassius+#if GHC7+ [cassius|##{ident}+#else+ [$cassius|##{ident}+#endif+ background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;+ padding-left: 18px;+|]+ l <- lift languages+ let mr = renderMessage (getAuth 'x') y l+ addHamlet+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+<form method="get" action="@{tm forwardUrl}">+ <label for="#{ident}">OpenID: + <input id="#{ident}" type="text" name="#{name}" value="http://">+ <input type="submit" value="#{mr Msg.LoginOpenID}">+|]+ dispatch "GET" ["forward"] = do+ (roid, _, _) <- runFormGet $ stringInput name+ y <- getYesod+ case roid of+ FormSuccess oid -> do+ render <- getUrlRender+ toMaster <- getRouteToMaster+ let complete' = render $ toMaster complete+ res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing []+ attempt+ (\err -> do+ setMessage $ toHtml $ show err+ redirect RedirectTemporary $ toMaster LoginR+ )+ (redirectText RedirectTemporary)+ res+ _ -> do+ toMaster <- getRouteToMaster+ mr <- getMessageRender+ setMessage $ mr Msg.NoOpenID+ redirect RedirectTemporary $ toMaster LoginR+ dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues+ dispatch "GET" ["complete"] = do+ rr <- getRequest+ completeHelper $ reqGetParams rr+ dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues+ dispatch "POST" ["complete"] = do+ (posts, _) <- runRequestBody+ completeHelper posts+ dispatch _ _ = notFound++completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()+completeHelper gets' = do+ res <- runAttemptT $ OpenId.authenticate gets'+ toMaster <- getRouteToMaster+ let onFailure err = do+ setMessage $ toHtml $ show err+ redirect RedirectTemporary $ toMaster LoginR+ let onSuccess (OpenId.Identifier ident, _) =+ setCreds True $ Creds "openid" ident []+ attempt onFailure onSuccess res
+ Yesod/Auth/Rpxnow.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Auth.Rpxnow+ ( authRpxnow+ ) where++import Yesod.Auth+import qualified Web.Authenticate.Rpxnow as Rpxnow+import Control.Monad (mplus)++import Yesod.Handler+import Yesod.Widget+import Yesod.Request+import Text.Hamlet (hamlet)+import Control.Monad.IO.Class (liftIO)+import Data.Text (pack, unpack)+import Control.Arrow ((***))++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+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+<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 <- lookupGetParams "token"+ token2 <- lookupPostParams "token"+ token <- case token1 ++ token2 of+ [] -> invalidArgs ["token: Value not supplied"]+ x:_ -> return $ unpack 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))+ (fmap pack $ getDisplayName $ map (unpack *** unpack) 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/Auth.hs
@@ -1,270 +0,0 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Helpers.Auth - ( -- * Subsite - Auth - , AuthPlugin (..) - , AuthRoute (..) - , getAuth - , YesodAuth (..) - -- * Plugin interface - , Creds (..) - , setCreds - -- * User functions - , maybeAuthId - , maybeAuth - , requireAuthId - , requireAuth - ) where - -import Yesod.Core -import Yesod.Persist -import Yesod.Json -import Text.Blaze -import Language.Haskell.TH.Syntax hiding (lift) -import qualified Network.Wai as W -import Text.Hamlet (hamlet) -import qualified Data.Map as Map -import Control.Monad.Trans.Class (lift) -import Data.Aeson -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Monoid (mconcat) -import Web.Routes.Quasi (toSinglePiece, fromSinglePiece) - -data Auth = Auth - -type Method = Text -type Piece = Text - -data AuthPlugin m = AuthPlugin - { apName :: Text - , 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 :: Text -- ^ How the user was authenticated - , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. - , credsExtra :: [(Text, Text)] - } - -class (Yesod m, SinglePiece (AuthId 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)) - - authPlugins :: [AuthPlugin m] - - -- | What to show on the login page. - loginHandler :: GHandler Auth m RepHtml - loginHandler = defaultLayout $ do - setTitle "Login" - tm <- lift getRouteToMaster - mapM_ (flip apLogin tm) authPlugins - - ----- Message strings. In theory in the future make this localizable - ----- See gist: https://gist.github.com/778712 - messageNoOpenID :: m -> Html - messageNoOpenID _ = "No OpenID identifier found" - messageLoginOpenID :: m -> Html - messageLoginOpenID _ = "Login via OpenID" - - messageEmail :: m -> Html - messageEmail _ = "Email" - messagePassword :: m -> Html - messagePassword _ = "Password" - messageRegister :: m -> Html - messageRegister _ = "Register" - messageRegisterLong :: m -> Html - messageRegisterLong _ = "Register a new account" - messageEnterEmail :: m -> Html - messageEnterEmail _ = "Enter your e-mail address below, and a confirmation e-mail will be sent to you." - messageConfirmationEmailSentTitle :: m -> Html - messageConfirmationEmailSentTitle _ = "Confirmation e-mail sent" - messageConfirmationEmailSent :: m -> Text -> Html - messageConfirmationEmailSent _ email = toHtml $ mconcat - ["A confirmation e-mail has been sent to ", email, "."] - messageAddressVerified :: m -> Html - messageAddressVerified _ = "Address verified, please set a new password" - messageInvalidKeyTitle :: m -> Html - messageInvalidKeyTitle _ = "Invalid verification key" - messageInvalidKey :: m -> Html - messageInvalidKey _ = "I'm sorry, but that was an invalid verification key." - messageInvalidEmailPass :: m -> Html - messageInvalidEmailPass _ = "Invalid email/password combination" - messageBadSetPass :: m -> Html - messageBadSetPass _ = "You must be logged in to set a password" - messageSetPassTitle :: m -> Html - messageSetPassTitle _ = "Set password" - messageSetPass :: m -> Html - messageSetPass _ = "Set a new password" - messageNewPass :: m -> Html - messageNewPass _ = "New password" - messageConfirmPass :: m -> Html - messageConfirmPass _ = "Confirm" - messagePassMismatch :: m -> Html - messagePassMismatch _ = "Passwords did not match, please try again" - messagePassUpdated :: m -> Html - messagePassUpdated _ = "Password updated" - - messageFacebook :: m -> Html - messageFacebook _ = "Login with Facebook" - -type Texts' = [Text] - -mkYesodSub "Auth" - [ ClassP ''YesodAuth [VarT $ mkName "master"] - ] -#define STRINGS *Texts' -#if GHC7 - [parseRoutes| -#else - [$parseRoutes| -#endif -/check CheckR GET -/login LoginR GET -/logout LogoutR GET POST -/page/#Text/STRINGS PluginR -|] - -credsKey :: Text -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 -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - <h1>Invalid login -|] - sendResponse rh - Just ar -> do - setMessage "Invalid login" - redirect RedirectTemporary ar - else return () - Just aid -> do - setSession credsKey $ toSinglePiece aid - if doRedirects - then do - setMessage "You are now logged in" - redirectUltDest RedirectTemporary $ loginDest y - else return () - -getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson -getCheckR = do - creds <- maybeAuthId - defaultLayoutJson (do - setTitle "Authentication Status" - addHtml $ html creds) (json' creds) - where - html creds = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<h1>Authentication Status -$maybe _ <- creds - <p>Logged in. -$nothing - <p>Not logged in. -|] - json' creds = - Object $ Map.fromList - [ (T.pack "logged_in", Bool $ 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 => Text -> [Text] -> GHandler Auth m () -handlePluginR plugin pieces = do - env <- waiRequest - let method = decodeUtf8With lenientDecode $ 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 - case ms of - Nothing -> return Nothing - Just s -> return $ fromSinglePiece s - -maybeAuth :: ( YesodAuth m - , Key val ~ AuthId m - , PersistBackend (YesodDB m (GGHandler s m IO)) - , 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 (GGHandler s m IO)) - , 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
@@ -1,35 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | 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.Helpers.Auth -import Yesod.Form (runFormPost', stringInput) -import Yesod.Handler (notFound) -import Text.Hamlet (hamlet) - -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 = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<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
@@ -1,298 +0,0 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module Yesod.Helpers.Auth.Email - ( -- * Plugin - authEmail - , YesodAuthEmail (..) - , EmailCreds (..) - , saltPass - -- * Routes - , loginR - , registerR - , setpassR - ) where - -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 qualified Data.Text as TS -import Data.Text.Lazy.Encoding (encodeUtf8) -import Data.Text (Text) - -import Yesod.Form -import Yesod.Handler -import Yesod.Content -import Yesod.Widget -import Yesod.Core -import Text.Hamlet (hamlet) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Web.Routes.Quasi (toSinglePiece, fromSinglePiece) - -loginR, registerR, setpassR :: AuthRoute -loginR = PluginR "email" ["login"] -registerR = PluginR "email" ["register"] -setpassR = PluginR "email" ["set-password"] - -verify :: Text -> Text -> AuthRoute -- FIXME -verify eid verkey = PluginR "email" ["verify", eid, verkey] - -type Email = Text -type VerKey = Text -type VerUrl = Text -type SaltedPass = Text -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, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where - type 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 Text - randomKey _ = do - stdgen <- newStdGen - return $ TS.pack $ fst $ randomString 10 stdgen - -authEmail :: YesodAuthEmail m => AuthPlugin m -authEmail = - AuthPlugin "email" dispatch $ \tm -> do - y <- lift getYesod -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<form method="post" action="@{tm loginR}"> - <table> - <tr> - <th>#{messageEmail y} - <td> - <input type="email" name="email"> - <tr> - <th>#{messagePassword y} - <td> - <input type="password" name="password"> - <tr> - <td colspan="2"> - <input type="submit" value="Login via email"> - <a href="@{tm registerR}">I don't have an account -|] - where - dispatch "GET" ["register"] = getRegisterR >>= sendResponse - dispatch "POST" ["register"] = postRegisterR >>= sendResponse - dispatch "GET" ["verify", eid, verkey] = - case fromSinglePiece eid of - Nothing -> notFound - Just eid' -> getVerifyR eid' verkey >>= sendResponse - dispatch "POST" ["login"] = postLoginR >>= sendResponse - dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse - dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse - dispatch _ _ = notFound - -getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml -getRegisterR = do - y <- getYesod - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle $ messageRegisterLong y - addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<p>#{messageEnterEmail y} -<form method="post" action="@{toMaster registerR}"> - <label for="email">#{messageEmail y} - <input type="email" name="email" width="150"> - <input type="submit" value="#{messageRegister y}"> -|] - -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 (toSinglePiece lid) verKey - sendVerifyEmail email verKey verUrl - defaultLayout $ do - setTitle $ messageConfirmationEmailSentTitle y - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<p>#{messageConfirmationEmailSent y email} -|] - -getVerifyR :: YesodAuthEmail m - => AuthEmailId m -> Text -> GHandler Auth m RepHtml -getVerifyR lid key = do - realKey <- getVerifyKey lid - memail <- getEmail lid - y <- getYesod - 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 $ messageAddressVerified y - redirect RedirectTemporary $ toMaster setpassR - _ -> return () - defaultLayout $ do - setTitle $ messageInvalidKey y - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<p>#{messageInvalidKey y} -|] - -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 - y <- getYesod - setMessage $ messageInvalidEmailPass y - toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster LoginR - -getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml -getPasswordR = do - toMaster <- getRouteToMaster - maid <- maybeAuthId - y <- getYesod - case maid of - Just _ -> return () - Nothing -> do - setMessage $ messageBadSetPass y - redirect RedirectTemporary $ toMaster loginR - defaultLayout $ do - setTitle $ messageSetPassTitle y - addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<h3>#{messageSetPass y} -<form method="post" action="@{toMaster setpassR}"> - <table> - <tr> - <th>#{messageNewPass y} - <td> - <input type="password" name="new"> - <tr> - <th>#{messageConfirmPass y} - <td> - <input type="password" name="confirm"> - <tr> - <td colspan="2"> - <input type="submit" value="#{messageSetPassTitle y}"> -|] - -postPasswordR :: YesodAuthEmail master => GHandler Auth master () -postPasswordR = do - (new, confirm) <- runFormPost' $ (,) - <$> stringInput "new" - <*> stringInput "confirm" - toMaster <- getRouteToMaster - y <- getYesod - when (new /= confirm) $ do - setMessage $ messagePassMismatch y - redirect RedirectTemporary $ toMaster setpassR - maid <- maybeAuthId - aid <- case maid of - Nothing -> do - setMessage $ messageBadSetPass y - redirect RedirectTemporary $ toMaster loginR - Just aid -> return aid - salted <- liftIO $ saltPass new - setPassword aid salted - setMessage $ messagePassUpdated y - redirect RedirectTemporary $ loginDest y - -saltLength :: Int -saltLength = 5 - --- | Salt a password with a randomly generated salt. -saltPass :: Text -> IO Text -saltPass pass = do - stdgen <- newStdGen - let salt = take saltLength $ randomRs ('A', 'Z') stdgen - return $ TS.pack $ saltPass' salt $ TS.unpack pass - -saltPass' :: String -> String -> String -saltPass' salt pass = - salt ++ show (md5 $ fromString $ salt ++ pass) - where - fromString = encodeUtf8 . T.pack - -isValidPass :: Text -- ^ cleartext password - -> SaltedPass -- ^ salted password - -> Bool -isValidPass clear' salted' = - let salt = take saltLength salted - in salted == saltPass' salt clear - where - clear = TS.unpack clear' - salted = TS.unpack salted'
− Yesod/Helpers/Auth/Facebook.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Helpers.Auth.Facebook - ( authFacebook - , facebookUrl - ) where - -import Yesod.Helpers.Auth -import qualified Web.Authenticate.Facebook as Facebook -import Data.Aeson -import Data.Aeson.Types (parseMaybe) -import Data.Maybe (fromMaybe) - -import Yesod.Form -import Yesod.Handler -import Yesod.Widget -import Text.Hamlet (hamlet) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Data.Text (Text) -import Control.Monad (mzero) -import Data.Monoid (mappend) -import qualified Data.Aeson.Types - -facebookUrl :: AuthRoute -facebookUrl = PluginR "facebook" ["forward"] - -authFacebook :: YesodAuth m - => Text -- ^ Application ID - -> Text -- ^ Application secret - -> [Text] -- ^ 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 - redirectText 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") - $ parseMaybe (parseCreds at') $ either error id so - setCreds True c - dispatch _ _ = notFound - login tm = do - render <- lift getUrlRender - let fb = Facebook.Facebook cid secret $ render $ tm url - let furl = Facebook.getForwardUrl fb $ perms - y <- lift getYesod - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<p> - <a href="#{furl}">#{messageFacebook y} -|] - -parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m) -parseCreds at' (Object m) = do - id' <- m .: "id" - let id'' = "http://graph.facebook.com/" `mappend` id' - name <- m .: "name" - email <- m .: "email" - return - $ Creds "facebook" id'' - $ maybe id (\x -> (:) ("verifiedEmail", x)) email - $ maybe id (\x -> (:) ("displayName ", x)) name - [ ("accessToken", at') - ] -parseCreds _ _ = mzero
− Yesod/Helpers/Auth/HashDB.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | --- Module : Yesod.Helpers.Auth.HashDB --- Copyright : (c) Patrick Brisbin 2010 --- License : as-is --- --- Maintainer : pbrisbin@gmail.com --- Stability : Stable --- Portability : Portable --- --- A yesod-auth AuthPlugin designed to look users up in Persist where --- their user id's and a sha1 hash of their password will already be --- stored. --- --- Example usage: --- --- > -- import the function --- > import Helpers.Auth.HashDB --- > --- > -- make sure you have an auth route --- > mkYesodData "MyApp" [$parseRoutes| --- > / RootR GET --- > /auth AuthR Auth getAuth --- > |] --- > --- > --- > -- make your app an instance of YesodAuth using this plugin --- > instance YesodAuth MyApp where --- > type AuthId MyApp = UserId --- > --- > loginDest _ = RootR --- > logoutDest _ = RootR --- > getAuthId = getAuthIdHashDB AuthR --- > showAuthId _ = showIntegral --- > readAuthId _ = readIntegral --- > authPlugins = [authHashDB] --- > --- > --- > -- include the migration function in site startup --- > withServer :: (Application -> IO a) -> IO a --- > withServer f = withConnectionPool $ \p -> do --- > runSqlPool (runMigration migrateUsers) p --- > let h = DevSite p --- --- Your app must be an instance of YesodPersist and the username and --- hashed-passwords must be added manually to the database. --- --- > echo -n 'MyPassword' | sha1sum --- --- can be used to get the hash from the commandline. --- -------------------------------------------------------------------------------- -module Yesod.Helpers.Auth.HashDB - ( authHashDB - , getAuthIdHashDB - , UserId - , migrateUsers - ) where - -import Yesod.Persist -import Yesod.Handler -import Yesod.Form -import Yesod.Helpers.Auth -import Text.Hamlet (hamlet) - -import Control.Applicative ((<$>), (<*>)) -import Data.ByteString.Lazy.Char8 (pack) -import Data.Digest.Pure.SHA (sha1, showDigest) -import Data.Text (Text, unpack) -import Data.Maybe (fromMaybe) - --- | Computer the sha1 of a string and return it as a string -sha1String :: String -> String -sha1String = showDigest . sha1 . pack - --- | Generate data base instances for a valid user -share2 mkPersist (mkMigrate "migrateUsers") -#if GHC7 - [persist| -#else - [$persist| -#endif -User - username Text Eq - password Text - UniqueUser username -|] - --- | Given a (user,password) in plaintext, validate them against the --- database values -validateUser :: (YesodPersist y, - PersistBackend (YesodDB y (GGHandler sub y IO))) - => (Text, Text) - -> GHandler sub y Bool -validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser -> - case dbUser of - -- user not found - Nothing -> return False - -- validate password - Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser) - -login :: AuthRoute -login = PluginR "hashdb" ["login"] - --- | Handle the login form -postLoginR :: (YesodAuth y, - YesodPersist y, - PersistBackend (YesodDB y (GGHandler Auth y IO))) - => GHandler Auth y () -postLoginR = do - (mu,mp) <- runFormPost' $ (,) - <$> maybeStringInput "username" - <*> maybeStringInput "password" - - isValid <- case (mu,mp) of - (Nothing, _ ) -> return False - (_ , Nothing) -> return False - (Just u , Just p ) -> validateUser (u,p) - - if isValid - then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] - else do - setMessage -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - Invalid username/password -|] - toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster LoginR - --- | A drop in for the getAuthId method of your YesodAuth instance which --- can be used if authHashDB is the only plugin in use. -getAuthIdHashDB :: (Key User ~ AuthId master, - PersistBackend (YesodDB master (GGHandler sub master IO)), - YesodPersist master, - YesodAuth master) - => (AuthRoute -> Route master) -- ^ your site's Auth Route - -> Creds m -- ^ the creds argument - -> GHandler sub master (Maybe UserId) -getAuthIdHashDB authR creds = do - muid <- maybeAuth - case muid of - -- user already authenticated - Just (uid, _) -> return $ Just uid - Nothing -> do - x <- runDB $ getBy $ UniqueUser (credsIdent creds) - case x of - -- user exists - Just (uid, _) -> return $ Just uid - Nothing -> do - setMessage -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - User not found -|] - redirect RedirectTemporary $ authR LoginR - --- | Prompt for username and password, validate that against a database --- which holds the username and a hash of the password -authHashDB :: (YesodAuth y, - YesodPersist y, - PersistBackend (YesodDB y (GGHandler Auth y IO))) - => AuthPlugin y -authHashDB = AuthPlugin "hashdb" dispatch $ \tm -> -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - <div id="header"> - <h1>Login - - <div id="login"> - <form method="post" action="@{tm login}"> - <table> - <tr> - <th>Username: - <td> - <input id="x" name="username" autofocus="" required> - <tr> - <th>Password: - <td> - <input type="password" name="password" required> - <tr> - <td> - <td> - <input type="submit" value="Login"> - - <script> - if (!("autofocus" in document.createElement("input"))) { - document.getElementById("x").focus(); - } - -|] - where - dispatch "POST" ["login"] = postLoginR >>= sendResponse - dispatch _ _ = notFound
− Yesod/Helpers/Auth/OAuth.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings #-} -{-# OPTIONS_GHC -fwarn-unused-imports #-} -module Yesod.Helpers.Auth.OAuth - ( authOAuth - , oauthUrl - , authTwitter - , twitterUrl - ) where -import Yesod.Helpers.Auth -import Yesod.Form -import Yesod.Handler -import Yesod.Widget -import Text.Hamlet (hamlet) -import Web.Authenticate.OAuth -import Data.Maybe -import Data.String -import Data.ByteString.Char8 (pack) -import Control.Arrow ((***)) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Data.Text (Text, unpack) -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.ByteString (ByteString) - -oauthUrl :: Text -> AuthRoute -oauthUrl name = PluginR name ["forward"] - -authOAuth :: YesodAuth m => - Text -- ^ Service Name - -> String -- ^ OAuth Parameter Name to use for identify - -> String -- ^ Request URL - -> String -- ^ Access Token URL - -> String -- ^ Authorize URL - -> String -- ^ Consumer Key - -> String -- ^ Consumer Secret - -> AuthPlugin m -authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login - where - url = PluginR name [] - oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl - , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl - , oauthSignatureMethod = HMACSHA1 - , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec - , oauthCallback = Nothing - } - dispatch "GET" ["forward"] = do - render <- getUrlRender - tm <- getRouteToMaster - let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - tok <- liftIO $ getTemporaryCredential oauth' - redirectText RedirectTemporary (fromString $ authorizeUrl oauth' tok) - dispatch "GET" [] = do - verifier <- runFormGet' $ stringInput "oauth_verifier" - oaTok <- runFormGet' $ stringInput "oauth_token" - let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok) - ] - accTok <- liftIO $ getAccessToken oauth reqTok - let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok - creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok - setCreds True creds - dispatch _ _ = notFound - login tm = do - render <- lift getUrlRender - let oaUrl = render $ tm $ oauthUrl name - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - <a href=#{oaUrl}>Login with #{name} - |] - -authTwitter :: YesodAuth m => - String -- ^ Consumer Key - -> String -- ^ Consumer Secret - -> AuthPlugin m -authTwitter = authOAuth "twitter" - "screen_name" - "http://twitter.com/oauth/request_token" - "http://twitter.com/oauth/access_token" - "http://twitter.com/oauth/authorize" - -twitterUrl :: AuthRoute -twitterUrl = oauthUrl "twitter" - -bsToText :: ByteString -> Text -bsToText = decodeUtf8With lenientDecode
− Yesod/Helpers/Auth/OpenId.hs
@@ -1,94 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Helpers.Auth.OpenId - ( authOpenId - , forwardUrl - ) where - -import Yesod.Helpers.Auth -import qualified Web.Authenticate.OpenId as OpenId -import Control.Monad.Attempt - -import Yesod.Form -import Yesod.Handler -import Yesod.Widget -import Yesod.Request -import Text.Hamlet (hamlet) -import Text.Cassius (cassius) -import Text.Blaze (toHtml) -import Control.Monad.Trans.Class (lift) -import Data.Text (Text) - -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 <- lift newIdent - y <- lift getYesod - addCassius -#if GHC7 - [cassius|##{ident} -#else - [$cassius|##{ident} -#endif - background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; - padding-left: 18px; -|] - addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<form method="get" action="@{tm forwardUrl}"> - <label for="#{ident}">OpenID: - <input id="#{ident}" type="text" name="#{name}" value="http://"> - <input type="submit" value="#{messageLoginOpenID y}"> -|] - dispatch "GET" ["forward"] = do - (roid, _, _) <- runFormGet $ stringInput name - y <- getYesod - case roid of - FormSuccess oid -> do - render <- getUrlRender - toMaster <- getRouteToMaster - let complete' = render $ toMaster complete - res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing [] - attempt - (\err -> do - setMessage $ toHtml $ show err - redirect RedirectTemporary $ toMaster LoginR - ) - (redirectText RedirectTemporary) - res - _ -> do - toMaster <- getRouteToMaster - setMessage $ messageNoOpenID y - redirect RedirectTemporary $ toMaster LoginR - dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues - dispatch "GET" ["complete"] = do - rr <- getRequest - completeHelper $ reqGetParams rr - dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues - dispatch "POST" ["complete"] = do - (posts, _) <- runRequestBody - completeHelper posts - dispatch _ _ = notFound - -completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () -completeHelper gets' = do - res <- runAttemptT $ OpenId.authenticate gets' - toMaster <- getRouteToMaster - let onFailure err = do - setMessage $ toHtml $ 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
@@ -1,59 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Helpers.Auth.Rpxnow - ( authRpxnow - ) where - -import Yesod.Helpers.Auth -import qualified Web.Authenticate.Rpxnow as Rpxnow -import Control.Monad (mplus) - -import Yesod.Handler -import Yesod.Widget -import Yesod.Request -import Text.Hamlet (hamlet) -import Control.Monad.IO.Class (liftIO) -import Data.Text (pack, unpack) -import Control.Arrow ((***)) - -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 -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -<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 <- lookupGetParams "token" - token2 <- lookupPostParams "token" - token <- case token1 ++ token2 of - [] -> invalidArgs ["token: Value not supplied"] - x:_ -> return $ unpack 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)) - (fmap pack $ getDisplayName $ map (unpack *** unpack) 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,58 +1,59 @@-name: yesod-auth -version: 0.4.0.2 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman, Patrick Brisbin -maintainer: Michael Snoyman <michael@snoyman.com> -synopsis: Authentication for Yesod. -category: Web, Yesod -stability: Stable -cabal-version: >= 1.6.0 -build-type: Simple -homepage: http://www.yesodweb.com/ - -flag ghc7 - -library - if flag(ghc7) - build-depends: base >= 4.3 && < 5 - cpp-options: -DGHC7 - else - build-depends: base >= 4 && < 4.3 - build-depends: authenticate >= 0.9 && < 0.10 - , bytestring >= 0.9.1.4 && < 0.10 - , yesod-core >= 0.8 && < 0.9 - , wai >= 0.4 && < 0.5 - , template-haskell - , pureMD5 >= 1.1 && < 2.2 - , random >= 1.0 && < 1.1 - , control-monad-attempt >= 0.3.0 && < 0.4 - , text >= 0.7 && < 0.12 - , mime-mail >= 0.3 && < 0.4 - , blaze-html >= 0.4 && < 0.5 - , yesod-persistent >= 0.1 && < 0.2 - , hamlet >= 0.8 && < 0.9 - , yesod-json >= 0.1 && < 0.2 - , containers >= 0.2 && < 0.5 - , yesod-form >= 0.1 && < 0.2 - , transformers >= 0.2 && < 0.3 - , persistent >= 0.5 && < 0.6 - , persistent-template >= 0.5 && < 0.6 - , SHA >= 1.4.1.3 && < 1.5 - , http-enumerator >= 0.6 && < 0.7 - , aeson >= 0.3.2.2 && < 0.4 - , web-routes-quasi >= 0.7 && < 0.8 - - exposed-modules: Yesod.Helpers.Auth - Yesod.Helpers.Auth.Dummy - Yesod.Helpers.Auth.Email - Yesod.Helpers.Auth.Facebook - Yesod.Helpers.Auth.OpenId - Yesod.Helpers.Auth.OAuth - Yesod.Helpers.Auth.Rpxnow - Yesod.Helpers.Auth.HashDB - ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/snoyberg/yesod-auth.git +name: yesod-auth+version: 0.5.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman, Patrick Brisbin+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Authentication for Yesod.+category: Web, Yesod+stability: Stable+cabal-version: >= 1.6.0+build-type: Simple+homepage: http://www.yesodweb.com/++flag ghc7++library+ if flag(ghc7)+ build-depends: base >= 4.3 && < 5+ cpp-options: -DGHC7+ else+ build-depends: base >= 4 && < 4.3+ build-depends: authenticate >= 0.9 && < 0.10+ , bytestring >= 0.9.1.4 && < 0.10+ , yesod-core >= 0.8.1 && < 0.9+ , wai >= 0.4 && < 0.5+ , template-haskell+ , pureMD5 >= 1.1 && < 2.2+ , random >= 1.0 && < 1.1+ , control-monad-attempt >= 0.3.0 && < 0.4+ , text >= 0.7 && < 0.12+ , mime-mail >= 0.3 && < 0.4+ , blaze-html >= 0.4 && < 0.5+ , yesod-persistent >= 0.1 && < 0.2+ , hamlet >= 0.8.1 && < 0.9+ , yesod-json >= 0.1 && < 0.2+ , containers >= 0.2 && < 0.5+ , yesod-form >= 0.1 && < 0.2+ , transformers >= 0.2 && < 0.3+ , persistent >= 0.5 && < 0.6+ , persistent-template >= 0.5 && < 0.6+ , SHA >= 1.4.1.3 && < 1.5+ , http-enumerator >= 0.6 && < 0.7+ , aeson >= 0.3.2.2 && < 0.4+ , web-routes-quasi >= 0.7 && < 0.8++ exposed-modules: Yesod.Auth+ Yesod.Auth.Dummy+ Yesod.Auth.Email+ Yesod.Auth.Facebook+ Yesod.Auth.OpenId+ Yesod.Auth.OAuth+ Yesod.Auth.Rpxnow+ Yesod.Auth.HashDB+ Yesod.Auth.Message+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/snoyberg/yesod-auth.git