* Parametrize all functions by user data type. So it's possible to

use custom data type for users. (So it's possible to store additional
  data).

* Add type class for custom user data type

* Export User data type there is no point in hiding it. It becomes possible
  to manipulate user database from withint yesod application

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
+class HashDBUser user where
-sha1String :: String -> String
+  -- | Retrieve password hash from user data
-sha1String = showDigest . sha1 . pack
+  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
+-- | Generate random salt. Length of 8 is chosen arbitrarily
-share2 mkPersist (mkMigrate "migrateUsers")
+randomSalt :: IO Text
-         [QQ(persist)|
+randomSalt = pack <$> replicateM 8 (randomRIO ('0','z'))
-User
+
-    username Text Eq
+-- | Calculate salted hash using SHA1.
-    password Text
+saltedHash :: Text              -- ^ Salt
-    UniqueUser username
+           -> 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,
+-- | Handle the login form. First parameter is function which username
-               YesodPersist y, 
+--   (whatever it might be) to unique user ID.
-               PersistBackend (YesodDB y (GGHandler Auth y IO)))
+postLoginR :: ( YesodAuth y, YesodPersist y
-           => GHandler Auth y ()
+              , HashDBUser user, PersistEntity user
-postLoginR = do
+              , 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
+    isValid <- fromMaybe (return False) 
-        (Nothing, _      ) -> return False
+                 (validateUser <$> (uniq =<< mu) <*> mp)
-        (_      , Nothing) -> return False
+    if isValid 
-        (Just u , Just p ) -> validateUser (u,p)
+       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,
+getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
-                    PersistBackend (YesodDB master (GGHandler sub master IO)),
+                   , HashDBUser user, PersistEntity user
-                    YesodPersist master,
+                   , Key user ~ AuthId master
-                    YesodAuth master)
+                   , PersistBackend (YesodDB master (GGHandler sub master IO)))
-                => (AuthRoute -> Route master) -- ^ your site's Auth Route
+                => (AuthRoute -> Route master)   -- ^ your site's Auth Route
-                -> Creds m                     -- ^ the creds argument
+                -> (Text -> Maybe (Unique user)) -- ^ gets user ID
-                -> GHandler sub master (Maybe UserId)
+                -> Creds m                       -- ^ the creds argument
-getAuthIdHashDB authR creds = do
+                -> 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,
+authHashDB :: ( YesodAuth m, YesodPersist m
-               YesodPersist y, 
+              , HashDBUser user
-               PersistBackend (YesodDB y (GGHandler Auth y IO)))
+              , PersistEntity user
-           => AuthPlugin y
+              , PersistBackend (YesodDB m (GGHandler Auth m IO))) 
-authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
+           => (Text -> Maybe (Unique user)) -> AuthPlugin m
+authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm ->
     [QQ(hamlet)|
     <div id="header">
         <h1>Login
@@ -187,5 +213,27 @@ authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
 
 |]
     where
-        dispatch "POST" ["login"] = postLoginR >>= sendResponse
+        dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
         dispatch _ _              = notFound
+
+
+----------------------------------------------------------------
+-- Predefined datatype
+----------------------------------------------------------------
+
+-- | Generate data base instances for a valid user
+share2 mkPersist (mkMigrate "migrateUsers")
+         [QQ(persist)|
+User
+    username Text Eq
+    password Text
+    salt     Text
+    UniqueUser username
+|]
+
+instance HashDBUser User where
+  userPasswordHash = Just . userPassword
+  userPasswordSalt = Just . userSalt
+  setUserHashAndSalt s h u = u { userSalt     = s
+                               , userPassword = h
+                               }