module Yesod.Auth.NoPassword (
authNoPassword
, EmailForm(..)
, NoPasswordAuth(..)
, Email
, Token
, TokenId
, Hash
, 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
pluginName :: Text
pluginName = "email"
loginPostR :: AuthRoute
loginPostR = PluginR pluginName ["login"]
type Email = Text
type Token = Text
type TokenId = Text
type Hash = Text
newtype EmailForm = EmailForm
{ efEmail :: Email
}
type Form m a = (Html -> MForm (HandlerT m IO) (FormResult a, WidgetT m IO ()))
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
loginRoute :: master -> Route master
emailSentRoute :: master -> Route master
sendLoginEmail :: Email
-> Text
-> HandlerT master IO ()
getUserByEmail :: Email -> HandlerT master IO (Maybe (AuthId master))
getEmailAndHashByTokenId :: TokenId -> HandlerT master IO (Maybe (Email, Hash))
updateLoginHashForUser :: (AuthId master) -> Maybe Hash -> TokenId -> HandlerT master IO ()
newUserWithLoginHash :: Email -> Hash -> TokenId -> HandlerT master IO ()
tokenStrength :: HandlerT master IO Int
tokenStrength = return 17
tokenParamName :: HandlerT master IO Text
tokenParamName = return "tkn"