module Yesod.Auth.HashDB
( HashDBUser(..)
, Unique (..)
, setPassword
, validateUser
, authHashDB
, getAuthIdHashDB
, User
, UserGeneric (..)
, UserId
, EntityField (..)
, migrateUsers
) where
import Yesod.Persist
import Yesod.Form
import Yesod.Auth
import Yesod.Core
import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM)
import qualified Data.ByteString.Lazy.Char8 as BS (pack)
import Data.Digest.Pure.SHA (sha1, showDigest)
import Data.Text (Text, pack, unpack, append)
import Data.Maybe (fromMaybe)
import System.Random (randomRIO)
class HashDBUser user where
userPasswordHash :: user -> Maybe Text
userPasswordSalt :: user -> Maybe Text
setUserHashAndSalt :: Text
-> Text
-> user -> user
setUserHashAndSalt = setSaltAndPasswordHash
setSaltAndPasswordHash :: Text
-> Text
-> user -> user
setSaltAndPasswordHash = setUserHashAndSalt
randomSalt :: MonadIO m => m Text
randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
saltedHash :: Text
-> Text
-> Text
saltedHash salt =
pack . showDigest . sha1 . BS.pack . unpack . append salt
setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
setPassword pwd u = do salt <- randomSalt
return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u
validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod
, PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT yesod IO))
, PersistEntity user
, HashDBUser user
) =>
Unique user
-> Text
-> HandlerT yesod IO Bool
validateUser userID passwd = do
let validate u = do hash <- userPasswordHash u
salt <- userPasswordSalt u
return $ hash == saltedHash salt passwd
user <- runDB $ getBy userID
return $ fromMaybe False $ validate . entityVal =<< user
login :: AuthRoute
login = PluginR "hashdb" ["login"]
postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser user, PersistEntity user
, b ~ YesodPersistBackend y
, PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT y IO))
)
=> (Text -> Maybe (Unique user))
-> HandlerT Auth (HandlerT y IO) ()
postLoginR uniq = do
(mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username"
<*> iopt textField "password"
isValid <- lift $ fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp)
if isValid
then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else loginErrorMessage LoginR "Invalid username/password"
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user
, Key user ~ AuthId master
, b ~ YesodPersistBackend master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT master IO))
)
=> (AuthRoute -> Route master)
-> (Text -> Maybe (Unique user))
-> Creds master
-> HandlerT master IO (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do
muid <- maybeAuthId
case muid of
Just uid -> return $ Just uid
Nothing -> do
x <- case uniq (credsIdent creds) of
Nothing -> return Nothing
Just u -> runDB (getBy u)
case x of
Just (Entity uid _) -> return $ Just uid
Nothing -> loginErrorMessage (authR LoginR) "User not found"
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user
, PersistEntity user
, b ~ YesodPersistBackend m
, PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT m IO)))
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
$newline never
<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 uniq >>= sendResponse
dispatch _ _ = notFound
share [mkPersist sqlSettings, mkMigrate "migrateUsers"]
[persistUpperCase|
User
username Text Eq
password Text
salt Text
UniqueUser username
|]
instance HashDBUser (UserGeneric backend) where
userPasswordHash = Just . userPassword
userPasswordSalt = Just . userSalt
setSaltAndPasswordHash s h u = u { userSalt = s
, userPassword = h
}