-- | This auth plugin for Yesod enabled simple passwordless authentication.
--
-- The only detail required from a user is an email address, and accounts are
-- either updated or created, depending on whether the account exists or not.
-- To actually log in, users are sent an email containing a link that
-- authenticates them and logs them in.
--
-- This plugin provides:
--
-- * Token generation
-- * Orchestration of the login process and email sending
-- * Receiving of the login form data via HTTP POST.
-- * Authentication of users once they return to the site from an email
--
-- This plugin /does not/ provide:
--
-- * A login form
-- * Email rendering or sending
-- * An account model
-- * A viewable interface (i.e. via HTTP GET) for the login form
--
-- These are left for the user of the plugin to implement so that they can
-- retain control over form functionality, account models, email design and
-- email service provider.
--
-- Implementation checklist:
--
-- 1. Implement an instance of 'NoPasswordAuth' for your Yesod application.
-- 2. Implement a Yesod form that resolves to an 'EmailForm'.
-- 3. Add `authNoPassword` to your authentication plugins in your instance of
-- `YesodAuth`, passing the form you wish to use for authentication. This
-- typeclass provides a number of methods for customisation of behaviour,
-- but the minimal implementation is:
--
-- * 'loginRoute'
-- * 'emailSentRoute'
-- * 'sendLoginEmail'
-- * 'getUserByEmail'
-- * 'getEmailAndHashByTokenId'
-- * 'updateLoginHashForUser'
-- * 'newUserWithLoginHash'
module Yesod.Auth.NoPassword (
-- * Plugin
authNoPassword
-- * Form Type
, EmailForm(..)
-- * Typeclass
, NoPasswordAuth(..)
-- * Types
, Email
, Token
, TokenId
, Hash
-- ** Utility
, loginPostR
) where
import Prelude
import Data.Monoid ((<>))
import Data.Text
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Text.Blaze as B
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import Network.HTTP.Types.URI (urlEncode, urlDecode)
import Yesod.Core
import Yesod.Form
import Yesod.Auth
import Crypto.PasswordStore
-- Constants
pluginName :: Text
pluginName = "email"
-- | Route to which the site should POST the email form form.
loginPostR :: AuthRoute
loginPostR = PluginR pluginName ["login"]
type Email = Text
type Token = Text
type TokenId = Text
type Hash = Text
-- | Data type required for the Yesod form.
newtype EmailForm = EmailForm
{ efEmail :: Email
}
-- Convenience alias for forms
type Form m a = (Html -> MForm (HandlerT m IO) (FormResult a, WidgetT m IO ()))
-- | Function to create the Yesod Auth plugin. Must be used by a type with an
-- instance for 'NoPasswordAuth', and must be given a form to use.
authNoPassword :: NoPasswordAuth m
=> Form m EmailForm
-> AuthPlugin m
authNoPassword form = AuthPlugin pluginName dispatch login
where
login _ = error "NoPasswordAuth does not provide a login widget"
dispatch "POST" ["login"] = postEmailR form
dispatch "GET" ["login"] = getLoginR
dispatch _ _ = notFound
postEmailR :: NoPasswordAuth m
=> Form m EmailForm
-> HandlerT Auth (HandlerT m IO) TypedContent
postEmailR form = do
((result, _), _) <- lift $ runFormPost form
master <- lift getYesod
case result of
FormMissing -> do
setMessage "Something went wrong, please try again"
lift $ redirect (emailSentRoute master)
FormFailure as -> do
mapM_ (setMessage . B.text) as
lift $ redirect (emailSentRoute master)
FormSuccess e -> do
let email = efEmail e
strength <- lift $ tokenStrength
(hash, token) <- liftIO $ genToken strength
muser <- lift $ getUserByEmail (efEmail e)
tid <- liftIO genTokenId
case muser of
Just user ->
lift $ updateLoginHashForUser user (Just hash) tid
Nothing ->
lift $ newUserWithLoginHash email hash tid
url <- genUrl token tid
lift $ sendLoginEmail email url
lift $ redirect (emailSentRoute master)
getLoginR :: NoPasswordAuth m => HandlerT Auth (HandlerT m IO) TypedContent
getLoginR = do
paramName <- lift tokenParamName
loginParam <- lookupGetParam paramName
case (unpackTokenParam loginParam) of
Nothing -> permissionDenied "Missing login token"
Just (tid, loginToken) -> do
muser <- lift $ getEmailAndHashByTokenId tid
case muser of
Nothing -> permissionDenied "No login token sent"
Just (email, hash) ->
if (verifyToken hash loginToken)
then lift $ setCredsRedirect (Creds pluginName email [])
else permissionDenied "Incorrect login token"
unpackTokenParam :: Maybe Text -> Maybe (TokenId, Token)
unpackTokenParam param = do
p <- param
case (splitOn ":" p) of
(tid:tkn:[]) -> Just (tid, tkn)
_ -> Nothing
genToken :: Int -> IO (Hash, Token)
genToken strength = do
tokenSalt <- genSaltIO
let token = exportSalt tokenSalt
hash <- makePassword token strength
return (decodeUtf8 hash, decodeUtf8 (urlEncode True token))
verifyToken :: Hash -> Token -> Bool
verifyToken hash token = verifyPassword t h
where
h = encodeUtf8 hash
t = urlDecode False (encodeUtf8 token)
genTokenId :: IO TokenId
genTokenId = U.toText <$> U.nextRandom
genUrl :: NoPasswordAuth m => Token -> TokenId -> HandlerT Auth (HandlerT m IO) Text
genUrl token tid = do
tm <- getRouteToParent
render <- lift getUrlRender
paramName <- lift tokenParamName
let query = "?" <> paramName <> "=" <> tid <> ":" <> token
return $ (render $ tm loginPostR) <> query
class YesodAuthPersist master => NoPasswordAuth master where
-- | Route to a page that dispays a login form. This is not provided by
-- the plugin.
loginRoute :: master -> Route master
-- | Route to which the user should be sent after entering an email
-- address. This is not provided by the plugin.
--
-- __Note__: the user will not be authenticated when they reach the page.
emailSentRoute :: master -> Route master
-- | Send a login email.
sendLoginEmail :: Email -- ^ The email to send to
-> Text -- ^ The URL that will log the user in
-> HandlerT master IO ()
-- | Get a user by their email address. Used to determine if the user exists or not.
getUserByEmail :: Email -> HandlerT master IO (Maybe (AuthId master))
-- | Get a Hash by a TokenId.
--
-- Invoked when the user returns to the site from an email. We don't know
-- who the user is at this point as they may open the link from the email
-- on another device or in another browser, so session data can't be used.
-- Equally we do not want to pass the user's ID or email address in a URL
-- if we don't have to, so instead we look up users by the 'TokenId' that
-- we issued them earlier in the process.
getEmailAndHashByTokenId :: TokenId -> HandlerT master IO (Maybe (Email, Hash))
-- | Update a user's login hash
--
-- This is also used to blank out the hash once the user has logged in, or
-- can be used to prevent the user from logging in, so must accept a value
-- of `Nothing`.
--
-- /It is recommended that the/ 'TokenId' /storage be enforced as unique/.
-- For this reason, the token is not passed as a maybe, as some storage
-- backends treat `NULL` values as the same.
updateLoginHashForUser :: (AuthId master) -> Maybe Hash -> TokenId -> HandlerT master IO ()
-- | Create a new user with an email address and hash.
newUserWithLoginHash :: Email -> Hash -> TokenId -> HandlerT master IO ()
-- | __Optional__ – return a custom token strength.
--
-- A token strength of @x@ equates to @2^x@ hash rounds.
tokenStrength :: HandlerT master IO Int
tokenStrength = return 17
-- | __Optional__ – return a custom token param name.
tokenParamName :: HandlerT master IO Text
tokenParamName = return "tkn"
{-
MINIMAL loginRoute
, emailSentRoute
, sendLoginEmail
, getUserByEmail
, getEmailAndHashByTokenId
, updateLoginHashForUser
, newUserWithLoginHash
-}