{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-------------------------------------------------------------------------------
-- |
-- Module : Yesod.Auth.BCrypt
-- Copyright : (c) Patrick Brisbin 2010
-- License : as-is
--
-- Maintainer : pbrisbin@gmail.com
-- Stability : Stable
-- Portability : Portable
--
-- A yesod-auth AuthPlugin designed to look users up in Persist where
-- their user ID and a Bcrypt hash + salt of their password is stored.
--
-- Example usage:
--
-- > -- import the function
-- > import Auth.HashDB
-- >
-- > -- make sure you have an auth route
-- > mkYesodData "MyApp" [$parseRoutes|
-- > / RootR GET
-- > /auth AuthR Auth getAuth
-- > |]
-- >
-- >
-- > -- make your app an instance of YesodAuth using this plugin
-- > instance YesodAuth MyApp where
-- > type AuthId MyApp = UserId
-- >
-- > loginDest _ = RootR
-- > logoutDest _ = RootR
-- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser)
-- > authPlugins = [authHashDB (Just . UniqueUser)]
-- >
-- >
-- > -- include the migration function in site startup
-- > withServer :: (Application -> IO a) -> IO a
-- > withServer f = withConnectionPool $ \p -> do
-- > runSqlPool (runMigration migrateUsers) p
-- > let h = DevSite p
--
-- Note that function which converts username to unique identifier must be same.
--
-- Your app must be an instance of YesodPersist. and the username,
-- salted-and-hashed-passwords should be added to the database.
--
--
-------------------------------------------------------------------------------
module Yesod.Auth.BCrypt
( HashDBUser(..)
, Unique (..)
, setPassword
-- * Authentification
, validateUser
, authHashDB
, getAuthIdHashDB
-- * Predefined data type
, Siteuser (..)
, 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
-- | Interface for data type which holds user info. It's just a
-- collection of getters and setters
class HashDBUser siteuser where
-- | Retrieve password hash from user data
siteuserPasswordHash :: siteuser -> Maybe Text
-- | a callback for setPassword
setSaltAndPasswordHash :: Text -- ^ Hash and Salt
-> siteuser -> siteuser
-- | Calculate salted hash using Bcrypt.
saltedHash :: Text -- ^ Password
-> 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
-- | Set password for user. This function should be used for setting
-- passwords. It generates random salt and calculates proper hashes.
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
----------------------------------------------------------------
-- Authentification
----------------------------------------------------------------
-- | Given a user ID and password in plaintext, validate them against
-- the database values.
validateUser :: ( YesodPersist yesod
, PersistEntity siteuser
, HashDBUser siteuser
, PersistEntityBackend siteuser ~ YesodPersistBackend yesod
, PersistUnique (YesodPersistBackend yesod)
) =>
Unique siteuser -- ^ User unique identifier
-> Text -- ^ Password in plaint-text
-> HandlerT yesod IO Bool
validateUser siteuserID passwd = do
-- Checks that hash and password match
let validate u = do hash <- siteuserPasswordHash u
return $ validatePassword (BS.pack $ unpack hash) (BS.pack $ unpack passwd)
-- Get user data
siteuser <- runDB $ getBy siteuserID
return $ fromMaybe False $ validate . entityVal =<< siteuser
login :: AuthRoute
login = PluginR "hashdb" ["login"]
-- | Handle the login form. First parameter is function which maps
-- username (whatever it might be) to unique user ID.
postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser siteuser, PersistEntity siteuser
, PersistEntityBackend siteuser ~ YesodPersistBackend y
, PersistUnique (YesodPersistBackend y)
)
=> (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"
-- | A drop in for the getAuthId method of your YesodAuth instance which
-- can be used if authHashDB is the only plugin in use.
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser siteuser, PersistEntity siteuser
, Key siteuser ~ AuthId master
, PersistEntityBackend siteuser ~ YesodPersistBackend master
, PersistUnique (YesodPersistBackend master)
)
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
-> (Text -> Maybe (Unique siteuser)) -- ^ gets user ID
-> Creds master -- ^ the creds argument
-> HandlerT master IO (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do
muid <- maybeAuthId
case muid of
-- user already authenticated
Just uid -> return $ Just uid
Nothing -> do
x <- case uniq (credsIdent creds) of
Nothing -> return Nothing
Just u -> runDB (getBy u)
case x of
-- user exists
Just (Entity uid _) -> return $ Just uid
Nothing -> do
_ <- loginErrorMessage (authR LoginR) "User not found"
return Nothing
-- | Prompt for username and password, validate that against a database
-- which holds the username and a hash of the password
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser siteuser
, PersistEntity siteuser
, PersistEntityBackend siteuser ~ YesodPersistBackend m
, PersistUnique (YesodPersistBackend m)
)
=> (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
----------------------------------------------------------------
-- Predefined datatype
----------------------------------------------------------------
-- | Generate data base instances for a valid user
share [mkPersist sqlSettings, mkMigrate "migrateSiteusers"]
[persistLowerCase|
Siteuser
username Text Eq
password Text
email Text Maybe
UniqueSiteuser username
deriving Typeable
|]
instance HashDBUser Siteuser where
siteuserPasswordHash = Just . siteuserPassword
setSaltAndPasswordHash h u = u { siteuserPassword = h }