{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
-------------------------------------------------------------------------------
-- |
-- Module : Yesod.Auth.BCryptDB
-- Copyright : (c) Yusent Chig 2017
-- License : MIT
--
-- Maintainer : Yusent Chig <yusent@protonmail.com>
-- Stability : Stable
-- Portability : Portable
--
-- A Yesod authentication plugin designed to look users up in a Persistent
-- database where the salted hash of their password is stored. This is based
-- on Yesod.Auth.HashDB plugin, but it uses BCrypt to hash and salt the
-- passwords.
--
-- To use this in a Yesod application, the foundation data type must be an
-- instance of YesodPersist, and the username and hashed passwords should
-- be added to the database. The following steps give an outline of what
-- is required.
--
-- You need a database table to store user records: in a scaffolded site it
-- might look like:
--
-- > User
-- > name Text -- user name used to uniquely identify users
-- > password Text Maybe -- password hash for BCryptDB
-- > UniqueUser name
--
-- Create an instance of 'BCryptDBUser' for this data type:
--
-- > import Yesod.Auth.BcryptDB (BcryptDBUser(..))
-- > ....
-- > instance BcryptDBUser User where
-- > userPasswordSaltedHash = userPassword
-- > setPasswordSaltedHash h u = u { userPassword = h }
--
-- In the YesodAuth instance declaration for your app, include 'authBcryptDB'
-- like so:
--
-- > import Yesod.Auth.BcryptDB (authBcryptDB)
-- > ....
-- > instance YesodAuth App where
-- > ....
-- > authPlugins _ = [ authBcryptDB UniqueUser, .... ]
--
-- The argument to 'authBcryptDB' is a function which takes a 'Text' and
-- produces a 'Unique' value to look up in the User table. The example
-- @UniqueUser@ shown here works for the model outlined above.
--
-- For a real application, the developer should provide some sort of
-- of administrative interface for setting passwords; it needs to call
-- 'setPassword' and save the result in the database. However, if you
-- need to initialise the database by hand, you can generate the correct
-- password hash as follows:
--
-- > ghci -XOverloadedStrings
-- > > import Crypto.BCrypt
-- > > hashPasswordUsingPolicy slowerBcryptHashingPolicy "mypassword"
--
-- == Custom Login Form
--
-- Instead of using the built-in HTML form, a custom one can be supplied
-- by using 'authBcryptDBWithForm' instead of 'authBcryptDB'.
--
-- The custom form needs to be given as a function returning a Widget, since
-- it has to build in the supplied "action" URL, and it must provide two text
-- fields called "username" and "password". For example, the following
-- modification of the outline code given above would replace the default
-- form with a very minimal one which has no labels and a simple layout.
--
-- > instance YesodAuth App where
-- > ....
-- > authPlugins _ = [ authBcryptDBWithForm myform UniqueUser, .... ]
-- >
-- > myform :: Route App -> Widget
-- > myform action = $(whamletFile "templates/loginform.hamlet")
--
-- where templates/loginform.hamlet contains
--
-- > <form method="post" action="@{action}">
-- > <input name="username">
-- > <input type="password" name="password">
-- > <input type="submit" value="Login">
--
-- If a CSRF token needs to be embedded in a custom form, code must be
-- included in the widget to add it - see @defaultForm@ in the source
-- code of this module for an example.
--
-- == JSON Interface
--
-- This plugin provides sufficient tools to build a complete JSON-based
-- authentication flow. We assume that a design goal is to avoid URLs
-- being built into the client, so all of the URLs needed are passed in
-- JSON data.
--
-- To start the process, Yesod's defaultErrorHandler produces a JSON
-- response if the HTTP Accept header gives \"application/json\"
-- precedence over HTML. For a NotAuthenticated error, the status is
-- 401 and the response contains the URL to use for authentication: this
-- is the route which will be handled by the loginHandler method of the
-- YesodAuth instance, which normally returns a login form.
--
-- Leaving the loginHandler aside for a moment, the final step - supported
-- by this plugin since version 1.6 - is to POST the credentials for
-- authentication in a JSON object. This object must include the
-- properties "username" and "password". In the HTML case this would be
-- the form submission, but here we want to use JSON instead.
--
-- In a JSON interface, the purpose of the loginHandler is to tell the
-- client the URL for submitting the credentials. This requires a
-- custom loginHandler, since the default one generates HTML only.
-- It can find the correct URL by using the 'submitRouteBcryptDB'
-- function defined in this module.
--
-- Writing the loginHandler is made a little messy by the fact that its
-- type allows only HTML content. A work-around is to send JSON as a
-- short-circuit response, but we still make the choice using selectRep
-- so as to get its matching of content types. Here is an example which
-- is geared around using BcryptDB on its own, supporting both JSON and HTML
-- clients:
--
-- > instance YesodAuth App where
-- > ....
-- > loginHandler = do
-- > submission <- submitRouteBcryptDB
-- > render <- lift getUrlRender
-- > typedContent@(TypedContent ct _) <- selectRep $ do
-- > provideRepType typeHtml $ return emptyContent
-- > -- Dummy: the real Html version is at the end
-- > provideJson $ object [("loginUrl", toJSON $ render submission)]
-- > when (ct == typeJson) $
-- > sendResponse typedContent -- Short-circuit JSON response
-- > defaultLoginHandler -- Html response
--
-------------------------------------------------------------------------------
module Yesod.Auth.BCryptDB
( BCryptDBUser(..)
, setPassword
, setPasswordWithHashingPolicy
-- * Interface to database and Yesod.Auth
, authBCryptDB
, authBCryptDBWithForm
, submitRouteBcryptDB
, validateCreds
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>), pure)
#endif
import Crypto.BCrypt
import Data.Aeson ((.:?))
import qualified Data.ByteString.Char8 as BS (pack, unpack)
import Data.Text (Text, pack, unpack)
import Data.Maybe (fromMaybe)
import Yesod.Auth
import Yesod.Core
import Yesod.Form
import Yesod.Persist
import Yesod.Auth.Message (AuthMessage(InvalidUsernamePass))
#if !MIN_VERSION_yesod_core(1,4,14)
defaultCsrfParamName :: Text
defaultCsrfParamName = "_token"
#endif
-- | The type representing user information stored in the database should
-- be an instance of this class. It just provides the getter and setter
-- used by the functions in this module.
class BCryptDBUser user where
-- | Setter used by 'setPassword' and 'upgradePasswordHash'. Produces a
-- version of the user data with the hash set to the new value.
--
setPasswordSaltedHash
:: Text -- ^ Password hash
-> user
-> user
-- | Getter used by 'validatePass' and 'upgradePasswordHash' to
-- retrieve the password hash from user data
--
userPasswordSaltedHash :: user -> Text
{-# MINIMAL setPasswordSaltedHash, userPasswordSaltedHash #-}
-- | Calculate salted hash using Bcrypt.
saltAndHashPassword :: Text -> HashingPolicy -> IO (Maybe Text)
saltAndHashPassword password hashingPolicy = do
hash <- hashPasswordUsingPolicy hashingPolicy . BS.pack $ unpack password
return $ pack . BS.unpack <$> hash
-- | Set password for user. This function should be used for setting
-- passwords. It generates random salt and calculates proper hashes.
setPassword
:: BCryptDBUser user
=> Text -- ^ Password
-> user
-> IO user
setPassword = setPasswordWithHashingPolicy slowerBcryptHashingPolicy
-- | Set password for user. This function should be used for setting passwords
-- with an specified hashing policy. It generates random salt and calculates
-- proper hashes.
setPasswordWithHashingPolicy
:: BCryptDBUser user
=> HashingPolicy
-> Text -- ^ Password
-> user
-> IO user
setPasswordWithHashingPolicy hashingPolicy password user = do
mHash <- saltAndHashPassword password hashingPolicy
return $ case mHash of
Nothing -> user
Just hash -> setPasswordSaltedHash hash user
----------------------------------------------------------------
-- Authentication
----------------------------------------------------------------
-- | Given a user ID and password in plain text, validate them against
-- the database values.
validateCreds
:: BCryptDBPersist master user
=> Unique user -- ^ User unique identifier
-> Text -- ^ Password given
-> HandlerT master IO Bool
validateCreds userID password = do
-- Checks that hash and password match
mUser <- runDB $ getBy userID
return $ case mUser of
Nothing -> False
Just (Entity _ user) ->
validatePassword
(BS.pack . unpack $ userPasswordSaltedHash user)
(BS.pack $ unpack password)
----------------------------------------------------------------
-- Interface to database and Yesod.Auth
----------------------------------------------------------------
-- | Constraint for types of interface functions in this module
--
type BCryptDBPersist master user =
( YesodAuthPersist master
, PersistUnique (YesodPersistBackend master)
, AuthEntity master ~ user
#if MIN_VERSION_persistent(2,5,0)
, PersistEntityBackend user ~ BaseBackend (YesodPersistBackend master)
#else
, PersistEntityBackend user ~ YesodPersistBackend master
#endif
, BCryptDBUser user
, PersistEntity user
)
-- Internal data type for receiving JSON encoded username and password
data UserPass = UserPass (Maybe Text) (Maybe Text)
instance FromJSON UserPass where
parseJSON (Object v) = UserPass <$> v .:? "username" <*> v .:? "password"
parseJSON _ = pure $ UserPass Nothing Nothing
login :: AuthRoute
login = PluginR "bcryptdb" ["login"]
-- | Handle the login form. First parameter is function which maps
-- username (whatever it might be) to unique user ID.
postLoginR
:: BCryptDBPersist master user
=> (Text -> Unique user)
-> HandlerT Auth (HandlerT master IO) TypedContent
postLoginR uniq = do
jsonContent <- fmap ((== "application/json") . simpleContentType)
<$> lookupHeader "Content-Type"
UserPass mUser mPass <-
case jsonContent of
Just True -> requireJsonBody
_ -> lift . runInputPost $ UserPass
<$> iopt textField "username"
<*> iopt textField "password"
isValid <- lift . fromMaybe (return False)
$ validateCreds <$> fmap uniq mUser <*> mPass
if isValid
then lift . setCredsRedirect $ Creds "bcryptdb" (fromMaybe "" mUser) []
else loginErrorMessageI LoginR InvalidUsernamePass
-- | Prompt for username and password, validate that against a database
-- which holds the username and a salted hash of the password
authBCryptDB
:: BCryptDBPersist master user
=> (Text -> Unique user)
-> AuthPlugin master
authBCryptDB = authBCryptDBWithForm defaultForm
-- | Like 'authBCryptDB', but with an extra parameter to supply a custom HTML
-- form.
--
-- The custom form should be specified as a function which takes a route to
-- use as the form action, and returns a Widget containing the form. The
-- form must use the supplied route as its action URL, and, when submitted,
-- it must send two text fields called "username" and "password".
--
-- Please see the example in the documentation at the head of this module.
--
authBCryptDBWithForm
:: BCryptDBPersist master user
=> (Route master -> WidgetT master IO ())
-> (Text -> Unique user)
-> AuthPlugin master
authBCryptDBWithForm form uniq =
AuthPlugin "bcryptdb" dispatch $ \tm -> form (tm login)
where
dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
dispatch _ _ = notFound
defaultForm :: Yesod app => Route app -> WidgetT app IO ()
defaultForm loginRoute = do
request <- getRequest
let mtok = reqToken request
toWidget [hamlet|
$newline never
<div id="header">
<h1>Login
<div id="login">
<form method="post" action="@{loginRoute}">
$maybe tok <- mtok
<input type=hidden name=#{defaultCsrfParamName} value=#{tok}>
<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();
}
|]
-- | The route, in the parent site, to which the username and password
-- should be sent in order to log in. This function is particularly
-- useful in constructing a 'loginHandler' function which provides a
-- JSON response. See the \"JSON Interface\" section above for more
-- details.
--
submitRouteBcryptDB
:: YesodAuth site
=> HandlerT Auth (HandlerT site IO) (Route site)
submitRouteBcryptDB = do
toParent <- getRouteToParent
return $ toParent login