{-# LANGUAGE QuasiQuotes, TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Auth.Email ( -- * Plugin authEmail , YesodAuthEmail (..) , EmailCreds (..) , saltPass -- * Routes , loginR , registerR , setpassR , isValidPass ) where import Network.Mail.Mime (randomString) import Yesod.Auth import System.Random import Control.Monad (when) import Control.Applicative ((<$>), (<*>)) import Data.Digest.Pure.MD5 import qualified Data.Text.Lazy as T import qualified Data.Text as TS import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text (Text) import qualified Crypto.PasswordStore as PS import qualified Data.Text.Encoding as DTE import Yesod.Form import Yesod.Handler import Yesod.Content import Yesod.Core (PathPiece, fromPathPiece, whamlet, defaultLayout, setTitleI, toPathPiece) import Control.Monad.IO.Class (liftIO) import qualified Yesod.Auth.Message as Msg loginR, registerR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] registerR = PluginR "email" ["register"] setpassR = PluginR "email" ["set-password"] verify :: Text -> Text -> AuthRoute -- FIXME verify eid verkey = PluginR "email" ["verify", eid, verkey] type Email = Text type VerKey = Text type VerUrl = Text type SaltedPass = Text type VerStatus = Bool -- | Data stored in a database for each e-mail address. data EmailCreds m = EmailCreds { emailCredsId :: AuthEmailId m , emailCredsAuthId :: Maybe (AuthId m) , emailCredsStatus :: VerStatus , emailCredsVerkey :: Maybe VerKey } class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where type AuthEmailId m addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) -- | Generate a random alphanumeric string. randomKey :: m -> IO Text randomKey _ = do stdgen <- newStdGen return $ TS.pack $ fst $ randomString 10 stdgen authEmail :: YesodAuthEmail m => AuthPlugin m authEmail = AuthPlugin "email" dispatch $ \tm -> [whamlet| $newline never