module Yesod.Auth.BCrypt
( HashDBUser(..)
, Unique (..)
, setPassword
, validateUser
, authHashDB
, getAuthIdHashDB
, Siteuser
, SiteuserGeneric (..)
, SiteuserId
, EntityField (..)
, migrateSiteusers
) where
import Yesod.Persist
import Yesod.Form
import Yesod.Auth
import Yesod.Core
import Control.Applicative ((<$>), (<*>))
import Data.Typeable
import qualified Data.ByteString.Char8 as BS (pack, unpack)
import Crypto.BCrypt
import Data.Text (Text, pack, unpack)
import Data.Maybe
import Prelude
class HashDBUser siteuser where
siteuserPasswordHash :: siteuser -> Maybe Text
setSaltAndPasswordHash :: Text
-> siteuser -> siteuser
saltedHash :: Text
-> IO (Maybe Text)
saltedHash password = do
hash <- (hashPasswordUsingPolicy (HashingPolicy 10 "$2y$") . BS.pack . unpack) password
return $ if (isJust hash)
then Just $ pack $ BS.unpack $ fromJust hash
else Nothing
setPassword :: (HashDBUser siteuser) => Text -> siteuser -> IO (siteuser)
setPassword pwd u = do
hash <- saltedHash pwd
case hash of
Nothing -> return u
Just h -> return $ setSaltAndPasswordHash h u
validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod
, PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend siteuser
, PersistUnique (b (HandlerT yesod IO))
, PersistEntity siteuser
, HashDBUser siteuser
) =>
Unique siteuser
-> Text
-> HandlerT yesod IO Bool
validateUser siteuserID passwd = do
let validate u = do hash <- siteuserPasswordHash u
return $ validatePassword (BS.pack $ unpack hash) (BS.pack $ unpack passwd)
siteuser <- runDB $ getBy siteuserID
return $ fromMaybe False $ validate . entityVal =<< siteuser
login :: AuthRoute
login = PluginR "hashdb" ["login"]
postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser siteuser, PersistEntity siteuser
, b ~ YesodPersistBackend y
, PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend siteuser
, PersistUnique (b (HandlerT y IO))
)
=> (Text -> Maybe (Unique siteuser))
-> HandlerT Auth (HandlerT y IO) TypedContent
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 $ setCredsRedirect $ Creds "hashdb" (fromMaybe "" mu) []
else do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "Invalid username/password"
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser siteuser, PersistEntity siteuser
, Key siteuser ~ AuthId master
, b ~ YesodPersistBackend master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend siteuser
, PersistUnique (b (HandlerT master IO))
)
=> (AuthRoute -> Route master)
-> (Text -> Maybe (Unique siteuser))
-> 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 -> do
_ <- loginErrorMessage (authR LoginR) "User not found"
return Nothing
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser siteuser
, PersistEntity siteuser
, b ~ YesodPersistBackend m
, PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend siteuser
, PersistUnique (b (HandlerT m IO)))
=> (Text -> Maybe (Unique siteuser)) -> 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}">
<fieldset>
<label for="username">Username
<input type="text" name="username">
<label for="password">Password
<input type="password" name="password">
<br />
<input type="submit" value="Login">
|]
where
dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
dispatch _ _ = notFound
share [mkPersist sqlSettings, mkMigrate "migrateSiteusers"]
[persistLowerCase|
Siteuser
username Text Eq
password Text
email Text Maybe
UniqueSiteuser username
deriving Typeable
|]
instance HashDBUser (SiteuserGeneric backend) where
siteuserPasswordHash = Just . siteuserPassword
setSaltAndPasswordHash h u = u { siteuserPassword = h }