diff --git a/Yesod/Auth/HashDB.hs b/Yesod/Auth/HashDB.hs index 30837793..9655cea2 100644 --- a/Yesod/Auth/HashDB.hs +++ b/Yesod/Auth/HashDB.hs @@ -58,8 +58,12 @@ -- ------------------------------------------------------------------------------- module Yesod.Auth.HashDB - ( authHashDB + ( HashDBUser(..) + , authHashDB + , validateUser , getAuthIdHashDB + -- * Predefined data type + , User(..) , UserId , migrateUsers ) where @@ -73,79 +77,100 @@ import Yesod.Auth import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) -import Data.ByteString.Lazy.Char8 (pack) +import Control.Monad (replicateM) + +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 +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 --- | Generate data base instances for a valid user -share2 mkPersist (mkMigrate "migrateUsers") - [QQ(persist)| -User - username Text Eq - password Text - UniqueUser username -|] +-- | Generate random salt. Length of 8 is chosen arbitrarily +randomSalt :: IO Text +randomSalt = pack <$> 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 + + +-- | 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 --- | 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 + +-- | Handle the login form. First parameter is function which 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 - [QQ(hamlet)| 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 m -- ^ 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 @@ -155,11 +180,12 @@ getAuthIdHashDB authR creds = do -- | 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 -> +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)|