diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Auth ( -- * Subsite Auth @@ -22,19 +23,27 @@ , requireAuth ) where -import Yesod.Core -import Yesod.Persist -import Yesod.Json -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) +#include "qq.h" + +import Control.Monad (when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe + 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.Text (Text) +import qualified Data.Text as T +import qualified Data.Map as Map + +import Language.Haskell.TH.Syntax hiding (lift) + +import qualified Network.Wai as W +import Text.Hamlet (hamlet) + +import Yesod.Core +import Yesod.Persist +import Yesod.Json import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg import Yesod.Form (FormMessage) @@ -91,11 +100,7 @@ [ ClassP ''YesodAuth [VarT $ mkName "master"] ] #define STRINGS *Texts -#if GHC7 - [parseRoutes| -#else - [$parseRoutes| -#endif + [QQ(parseRoutes)| /check CheckR GET /login LoginR GET /logout LogoutR GET POST @@ -108,34 +113,21 @@ -- | FIXME: won't show up till redirect setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m () setCreds doRedirects creds = do - y <- getYesod + 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 -

Invalid login -|] + when doRedirects $ do + case authRoute y of + Nothing -> do rh <- defaultLayout [QQ(hamlet)|

Invalid login |] sendResponse rh - Just ar -> do - setMessageI Msg.InvalidLogin + Just ar -> do setMessageI Msg.InvalidLogin redirect RedirectTemporary ar - else return () Just aid -> do setSession credsKey $ toSinglePiece aid - if doRedirects - then do - setMessageI Msg.NowLoggedIn - redirectUltDest RedirectTemporary $ loginDest y - else return () + when doRedirects $ do + setMessageI Msg.NowLoggedIn + redirectUltDest RedirectTemporary $ loginDest y getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson getCheckR = do @@ -145,11 +137,7 @@ addHtml $ html creds) (json' creds) where html creds = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [QQ(hamlet)|

Authentication Status $maybe _ <- creds

Logged in. @@ -162,10 +150,10 @@ ] getLoginR :: YesodAuth m => GHandler Auth m RepHtml -getLoginR = loginHandler +getLoginR = setUltDestReferer >> loginHandler getLogoutR :: YesodAuth m => GHandler Auth m () -getLogoutR = postLogoutR -- FIXME redirect to post +getLogoutR = setUltDestReferer >> postLogoutR -- FIXME redirect to post postLogoutR :: YesodAuth m => GHandler Auth m () postLogoutR = do @@ -195,15 +183,10 @@ , 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) +maybeAuth = runMaybeT $ do + aid <- MaybeT $ maybeAuthId + a <- MaybeT $ runDB $ get aid + return (aid, a) requireAuthId :: YesodAuth m => GHandler s m (AuthId m) requireAuthId = maybeAuthId >>= maybe redirectLogin return diff --git a/Yesod/Auth/Dummy.hs b/Yesod/Auth/Dummy.hs --- a/Yesod/Auth/Dummy.hs +++ b/Yesod/Auth/Dummy.hs @@ -8,6 +8,8 @@ ( authDummy ) where +#include "qq.h" + import Yesod.Auth import Yesod.Form (runInputPost, textField, ireq) import Yesod.Handler (notFound) @@ -23,11 +25,7 @@ dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [QQ(hamlet)|

\Your new identifier is: diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -14,6 +14,8 @@ , setpassR ) where +#include "qq.h" + import Network.Mail.Mime (randomString) import Yesod.Auth import System.Random @@ -24,6 +26,8 @@ import qualified Data.Text as TS import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text (Text) +import qualified Crypto.PasswordStore as PS +import qualified Data.Text.Encoding as DTE import Yesod.Form import Yesod.Handler @@ -81,11 +85,7 @@ AuthPlugin "email" dispatch $ \tm -> do y <- lift getYesod l <- lift languages -#if GHC7 - [whamlet| -#else - [$whamlet| -#endif + [QQ(whamlet)| @@ -119,11 +119,7 @@ defaultLayout $ do setTitleI Msg.RegisterLong addWidget -#if GHC7 - [whamlet| -#else - [$whamlet| -#endif + [QQ(whamlet)|

_{Msg.EnterEmail}

_{Msg.ConfirmationEmailSent email} -|] + [QQ(whamlet)|

_{Msg.ConfirmationEmailSent email} |] getVerifyR :: YesodAuthEmail m => AuthEmailId m -> Text -> GHandler Auth m RepHtml @@ -181,13 +171,7 @@ defaultLayout $ do setTitleI Msg.InvalidKey addWidget -#if GHC7 - [whamlet| -#else - [$whamlet| -#endif -

_{Msg.InvalidKey} -|] + [QQ(whamlet)|

_{Msg.InvalidKey} |] postLoginR :: YesodAuthEmail master => GHandler Auth master () postLoginR = do @@ -226,11 +210,7 @@ defaultLayout $ do setTitleI Msg.SetPassTitle addWidget -#if GHC7 - [whamlet| -#else - [$whamlet| -#endif + [QQ(whamlet)|

_{Msg.SetPass}

@@ -273,10 +253,9 @@ -- | 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 = fmap DTE.decodeUtf8 + . flip PS.makePassword 12 + . DTE.encodeUtf8 saltPass' :: String -> String -> String saltPass' salt pass = @@ -287,7 +266,13 @@ isValidPass :: Text -- ^ cleartext password -> SaltedPass -- ^ salted password -> Bool -isValidPass clear' salted' = +isValidPass ct salted = + PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted + +isValidPass' :: Text -- ^ cleartext password + -> SaltedPass -- ^ salted password + -> Bool +isValidPass' clear' salted' = let salt = take saltLength salted in salted == saltPass' salt clear where diff --git a/Yesod/Auth/Facebook.hs b/Yesod/Auth/Facebook.hs --- a/Yesod/Auth/Facebook.hs +++ b/Yesod/Auth/Facebook.hs @@ -6,6 +6,8 @@ , facebookUrl ) where +#include "qq.h" + import Yesod.Auth import qualified Web.Authenticate.Facebook as Facebook import Data.Aeson @@ -56,11 +58,7 @@ render <- lift getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url let furl = Facebook.getForwardUrl fb $ perms -#if GHC7 - [whamlet| -#else - [$whamlet| -#endif + [QQ(whamlet)|

_{Msg.Facebook} |] diff --git a/Yesod/Auth/HashDB.hs b/Yesod/Auth/HashDB.hs --- a/Yesod/Auth/HashDB.hs +++ b/Yesod/Auth/HashDB.hs @@ -16,8 +16,7 @@ -- 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. +-- their user id's and a salted SHA1 hash of their password is stored. -- -- Example usage: -- @@ -37,10 +36,8 @@ -- > -- > loginDest _ = RootR -- > logoutDest _ = RootR --- > getAuthId = getAuthIdHashDB AuthR --- > showAuthId _ = showIntegral --- > readAuthId _ = readIntegral --- > authPlugins = [authHashDB] +-- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser) +-- > authPlugins = [authHashDB (Just . UniqueUser)] -- > -- > -- > -- include the migration function in site startup @@ -49,21 +46,31 @@ -- > 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. +-- Note that function which converts username to unique identifier must be same. -- --- > echo -n 'MyPassword' | sha1sum +-- Your app must be an instance of YesodPersist. and the username, +-- salt and hashed-passwords should be added to the database. -- +-- > echo -n 'MySaltMyPassword' | sha1sum +-- -- can be used to get the hash from the commandline. -- ------------------------------------------------------------------------------- module Yesod.Auth.HashDB - ( authHashDB + ( HashDBUser(..) + , setPassword + -- * Authentification + , validateUser + , authHashDB , getAuthIdHashDB + -- * Predefined data type + , User(..) , UserId , migrateUsers ) where +#include "qq.h" + import Yesod.Persist import Yesod.Handler import Yesod.Form @@ -71,115 +78,130 @@ import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) -import Data.ByteString.Lazy.Char8 (pack) +import Control.Monad (replicateM,liftM) +import Control.Monad.IO.Class (MonadIO, liftIO) + +import qualified Data.ByteString.Lazy.Char8 as BS (pack) import Data.Digest.Pure.SHA (sha1, showDigest) -import Data.Text (Text, unpack) +import Data.Text (Text, pack, unpack, append) import Data.Maybe (fromMaybe) +import System.Random (randomRIO) --- | 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 -|] +-- | Interface for data type which holds user info. It's just a +-- collection of getters and setters +class HashDBUser user where + -- | Retrieve password hash from user data + userPasswordHash :: user -> Maybe Text + -- | Retrieve salt for password + userPasswordSalt :: user -> Maybe Text + -- | Set hash and password + setUserHashAndSalt :: Text -- ^ Salt + -> Text -- ^ Password hash + -> user -> user --- | 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) +-- | Generate random salt. Length of 8 is chosen arbitrarily +randomSalt :: MonadIO m => m Text +randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z'))) +-- | Calculate salted hash using SHA1. +saltedHash :: Text -- ^ Salt + -> Text -- ^ Password + -> Text +saltedHash salt = + pack . showDigest . sha1 . BS.pack . unpack . append salt + +-- | Set password for user. This function should be used for setting +-- passwords. It generates random salt and calculates proper hashes. +setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user +setPassword pwd u = do salt <- randomSalt + return $ setUserHashAndSalt salt (saltedHash salt pwd) u + + +---------------------------------------------------------------- +-- Authentification +---------------------------------------------------------------- + +-- | Given a user ID and password in plaintext, validate them against +-- the database values. +validateUser :: ( YesodPersist yesod + , PersistBackend (YesodDB yesod (GGHandler sub yesod IO)) + , PersistEntity user + , HashDBUser user + ) => + Unique user -- ^ User unique identifier + -> Text -- ^ Password in plaint-text + -> GHandler sub yesod Bool +validateUser userID passwd = do + -- Checks that hash and password match + let validate u = do hash <- userPasswordHash u + salt <- userPasswordSalt u + return $ hash == saltedHash salt passwd + -- Get user data + user <- runDB $ getBy userID + return $ fromMaybe False $ validate . snd =<< user + + 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 + +-- | Handle the login form. First parameter is function which maps +-- username (whatever it might be) to unique user ID. +postLoginR :: ( YesodAuth y, YesodPersist y + , HashDBUser user, PersistEntity user + , PersistBackend (YesodDB y (GGHandler Auth y IO))) + => (Text -> Maybe (Unique user)) + -> GHandler Auth y () +postLoginR uniq = do (mu,mp) <- runInputPost $ (,) <$> iopt textField "username" <*> iopt textField "password" - isValid <- case (mu,mp) of - (Nothing, _ ) -> return False - (_ , Nothing) -> return False - (Just u , Just p ) -> validateUser (u,p) + isValid <- fromMaybe (return False) + (validateUser <$> (uniq =<< mu) <*> mp) + if isValid + then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] + else do setMessage [QQ(hamlet)| Invalid username/password |] + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster LoginR - 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 +getAuthIdHashDB :: ( YesodAuth master, YesodPersist master + , HashDBUser user, PersistEntity user + , Key user ~ AuthId master + , PersistBackend (YesodDB master (GGHandler sub master IO))) + => (AuthRoute -> Route master) -- ^ your site's Auth Route + -> (Text -> Maybe (Unique user)) -- ^ gets user ID + -> Creds master -- ^ the creds argument + -> GHandler sub master (Maybe (AuthId master)) +getAuthIdHashDB authR uniq creds = do muid <- maybeAuth case muid of -- user already authenticated Just (uid, _) -> return $ Just uid Nothing -> do - x <- runDB $ getBy $ UniqueUser (credsIdent creds) + x <- case uniq (credsIdent creds) of + Nothing -> return Nothing + Just u -> runDB (getBy u) case x of -- user exists Just (uid, _) -> return $ Just uid Nothing -> do - setMessage -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - User not found -|] + setMessage [QQ(hamlet)| 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 +authHashDB :: ( YesodAuth m, YesodPersist m + , HashDBUser user + , PersistEntity user + , PersistBackend (YesodDB m (GGHandler Auth m IO))) + => (Text -> Maybe (Unique user)) -> AuthPlugin m +authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> + [QQ(hamlet)|