module Yesod.Auth.HashDB
( HashDBUser(..)
, Unique (..)
, setPassword
, validateUser
, authHashDB
, getAuthIdHashDB
, User
, UserGeneric (..)
, UserId
, migrateUsers
) where
import Yesod.Persist
import Yesod.Handler
import Yesod.Form
import Yesod.Auth
import Yesod.Widget (toWidget)
import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>))
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, 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
#if MIN_VERSION_persistent(1, 1, 0)
, b ~ YesodPersistBackend yesod
, PersistMonadBackend (b (GHandler sub yesod)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler sub yesod))
#else
, b ~ YesodPersistBackend yesod
, b ~ PersistEntityBackend user
, PersistStore b (GHandler sub yesod)
, PersistUnique b (GHandler sub yesod)
#endif
, PersistEntity user
, HashDBUser user
) =>
#if MIN_VERSION_persistent(1, 1, 0)
Unique user
#else
Unique user b
#endif
-> Text
-> GHandler sub yesod 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
#if MIN_VERSION_persistent(1, 1, 0)
, b ~ YesodPersistBackend y
, PersistMonadBackend (b (GHandler Auth y)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler Auth y))
#else
, b ~ YesodPersistBackend y
, b ~ PersistEntityBackend user
, PersistStore b (GHandler Auth y)
, PersistUnique b (GHandler Auth y)
#endif
)
#if MIN_VERSION_persistent(1, 1, 0)
=> (Text -> Maybe (Unique user))
#else
=> (Text -> Maybe (Unique user b))
#endif
-> GHandler Auth y ()
postLoginR uniq = do
(mu,mp) <- runInputPost $ (,)
<$> iopt textField "username"
<*> iopt textField "password"
isValid <- fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp)
if isValid
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do setMessage "Invalid username/password"
toMaster <- getRouteToMaster
redirect $ toMaster LoginR
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user
#if MIN_VERSION_persistent(1, 1, 0)
, Key user ~ AuthId master
, b ~ YesodPersistBackend master
, PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler sub master))
#else
, Key b user ~ AuthId master
, b ~ YesodPersistBackend master
, b ~ PersistEntityBackend user
, PersistUnique b (GHandler sub master)
, PersistStore b (GHandler sub master)
#endif
)
=> (AuthRoute -> Route master)
#if MIN_VERSION_persistent(1, 1, 0)
-> (Text -> Maybe (Unique user))
#else
-> (Text -> Maybe (Unique user b))
#endif
-> Creds master
-> GHandler sub master (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 -> do
setMessage "User not found"
redirect $ authR LoginR
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user
, PersistEntity user
#if MIN_VERSION_persistent(1, 1, 0)
, b ~ YesodPersistBackend m
, PersistMonadBackend (b (GHandler Auth m)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler Auth m)))
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
#else
, b ~ YesodPersistBackend m
, b ~ PersistEntityBackend user
, PersistStore b (GHandler Auth m)
, PersistUnique b (GHandler Auth m))
=> (Text -> Maybe (Unique user b)) -> AuthPlugin m
#endif
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
}