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 Data.Typeable
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 do
tm <- getRouteToParent
lift $ loginErrorMessage (tm 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
deriving Typeable
|]
instance HashDBUser (UserGeneric backend) where
userPasswordHash = Just . userPassword
userPasswordSalt = Just . userSalt
setSaltAndPasswordHash s h u = u { userSalt = s
, userPassword = h
}