Merged EmailAuth into Auth

Yesod/Helpers/Auth.hs

@@ -30,6 +30,8 @@ module Yesod.Helpers.Auth
     , Creds (..)
     , maybeCreds
     , requireCreds
+    , AuthEmailSettings (..)
+    , inMemoryEmailSettings
     ) where
 
 import qualified Web.Authenticate.Rpxnow as Rpxnow
@@ -40,6 +42,11 @@ import Yesod
 import Control.Monad.Attempt
 import Data.Maybe
 import Control.Monad
+import System.Random
+import Data.Digest.Pure.MD5
+import Control.Applicative
+import Control.Concurrent.MVar
+import System.IO
 
 class Yesod master => YesodAuth master where
     -- | Default destination on successful login or logout, if no other
@@ -56,20 +63,47 @@ class Yesod master => YesodAuth master where
     onLogin :: Creds -> [(String, String)] -> GHandler Auth master ()
     onLogin _ _ = return ()
 
+    -- | Generate a random alphanumeric string.
+    --
+    -- This is used for verify string in email authentication.
+    randomKey :: master -> IO String
+    randomKey _ = do
+        stdgen <- newStdGen
+        return $ take 10 $ randomRs ('A', 'Z') stdgen
+
 data Auth = Auth
     { authIsOpenIdEnabled :: Bool
     , authRpxnowApiKey :: Maybe String
+    , authEmailSettings :: Maybe AuthEmailSettings
     }
 
-data AuthType = AuthOpenId | AuthRpxnow
+data AuthType = AuthOpenId | AuthRpxnow | AuthEmail
     deriving (Show, Read, Eq)
 
+type Email = String
+type VerKey = String
+type VerUrl = String
+type EmailId = Integer
+type SaltedPass = String
+type VerStatus = Bool
+data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey
+data AuthEmailSettings = AuthEmailSettings
+    { addUnverified :: Email -> VerKey -> IO EmailId
+    , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO ()
+    , getVerifyKey :: EmailId -> IO (Maybe VerKey)
+    , verifyAccount :: EmailId -> IO ()
+    , setPassword :: EmailId -> String -> IO ()
+    , getEmailCreds :: Email -> IO (Maybe EmailCreds)
+    , getEmail :: EmailId -> IO (Maybe Email)
+    }
+
 -- | User credentials
 data Creds = Creds
     { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'.
     , credsAuthType :: AuthType -- ^ How the user was authenticated
     , credsEmail :: Maybe String -- ^ Verified e-mail address.
     , credsDisplayName :: Maybe String -- ^ Display name.
+    , credsId :: Maybe Integer -- ^ Numeric ID, if used.
     }
     deriving (Show, Read, Eq)
 
@@ -98,6 +132,11 @@ mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|
 /openid/forward        OpenIdForward      GET
 /openid/complete       OpenIdComplete     GET
 /login/rpxnow          RpxnowR
+
+/register              EmailRegisterR     GET POST
+/verify/#/$            EmailVerifyR       GET
+/login                 EmailLoginR        GET POST
+/set-password          EmailPasswordR     GET POST
 |]
 
 testOpenId :: GHandler Auth master ()
@@ -153,7 +192,7 @@ getOpenIdComplete = do
         redirect RedirectTemporary $ toMaster OpenIdR
     let onSuccess (OpenId.Identifier ident) = do
         y <- getYesod
-        setCreds (Creds ident AuthOpenId Nothing Nothing) []
+        setCreds (Creds ident AuthOpenId Nothing Nothing Nothing) []
         redirectUltDest RedirectTemporary $ defaultDest y
     attempt onFailure onSuccess res
 
@@ -175,6 +214,7 @@ handleRpxnowR = do
                     AuthRpxnow
                     (lookup "verifiedEmail" extra)
                     (getDisplayName extra)
+                    Nothing
     setCreds creds extra
     either (redirect RedirectTemporary) (redirectString RedirectTemporary) $
         case pp "dest" of
@@ -234,3 +274,205 @@ identKey = "IDENTIFIER"
 
 displayNameKey :: String
 displayNameKey = "DISPLAY_NAME"
+
+getAuthEmailSettings :: GHandler Auth master AuthEmailSettings
+getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings
+
+getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml
+getEmailRegisterR = do
+    _ae <- getAuthEmailSettings
+    toMaster <- getRouteToMaster
+    applyLayout "Register a new account" (return ()) [$hamlet|
+%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
+%form!method=post!action=@toMaster.EmailRegisterR@
+    %label!for=email E-mail
+    %input#email!type=email!name=email!width=150
+    %input!type=submit!value=Register
+|]
+
+postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
+postEmailRegisterR = do
+    ae <- getAuthEmailSettings
+    email <- runFormPost $ checkEmail $ required $ input "email"
+    y <- getYesod
+    mecreds <- liftIO $ getEmailCreds ae email
+    (lid, verKey) <-
+        case mecreds of
+            Nothing -> liftIO $ do
+                key <- randomKey y
+                lid <- addUnverified ae email key
+                return (lid, key)
+            Just (EmailCreds lid _ _ key) -> return (lid, key)
+    render <- getUrlRender
+    tm <- getRouteToMaster
+    let verUrl = render $ tm $ EmailVerifyR lid verKey
+    liftIO $ sendVerifyEmail ae email verKey verUrl
+    applyLayout "Confirmation e-mail sent" (return ()) [$hamlet|
+%p A confirmation e-mail has been sent to $cs.email$.
+|]
+
+checkEmail :: Form ParamValue -> Form ParamValue
+checkEmail = notEmpty -- FIXME
+
+getEmailVerifyR :: YesodAuth master
+           => Integer -> String -> GHandler Auth master RepHtml
+getEmailVerifyR lid key = do
+    ae <- getAuthEmailSettings
+    realKey <- liftIO $ getVerifyKey ae lid
+    memail <- liftIO $ getEmail ae lid
+    case (realKey == Just key, memail) of
+        (True, Just email) -> do
+            liftIO $ verifyAccount ae lid
+            setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []
+            toMaster <- getRouteToMaster
+            redirect RedirectTemporary $ toMaster EmailPasswordR
+        _ -> applyLayout "Invalid verification key" (return ()) [$hamlet|
+%p I'm sorry, but that was an invalid verification key.
+        |]
+
+getEmailLoginR :: Yesod master => GHandler Auth master RepHtml
+getEmailLoginR = do
+    _ae <- getAuthEmailSettings
+    toMaster <- getRouteToMaster
+    msg <- getMessage
+    applyLayout "Login" (return ()) [$hamlet|
+$maybe msg ms
+    %p.message $ms$
+%p Please log in to your account.
+%p
+    %a!href=@toMaster.EmailRegisterR@ I don't have an account
+%form!method=post!action=@toMaster.EmailLoginR@
+    %table
+        %tr
+            %th E-mail
+            %td
+                %input!type=email!name=email
+        %tr
+            %th Password
+            %td
+                %input!type=password!name=password
+        %tr
+            %td!colspan=2
+                %input!type=submit!value=Login
+|]
+
+postEmailLoginR :: YesodAuth master => GHandler Auth master ()
+postEmailLoginR = do
+    ae <- getAuthEmailSettings
+    (email, pass) <- runFormPost $ (,)
+        <$> checkEmail (required $ input "email")
+        <*> required (input "password")
+    y <- getYesod
+    mecreds <- liftIO $ getEmailCreds ae email
+    let mlid =
+            case mecreds of
+                Just (EmailCreds lid (Just realpass) True _) ->
+                    if isValidPass pass realpass then Just lid else Nothing
+                _ -> Nothing
+    case mlid of
+        Just lid -> do
+            setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []
+            redirectUltDest RedirectTemporary $ defaultDest y
+        Nothing -> do
+            setMessage $ cs "Invalid email/password combination"
+            toMaster <- getRouteToMaster
+            redirect RedirectTemporary $ toMaster EmailLoginR
+
+getEmailPasswordR :: Yesod master => GHandler Auth master RepHtml
+getEmailPasswordR = do
+    _ae <- getAuthEmailSettings
+    toMaster <- getRouteToMaster
+    mcreds <- maybeCreds
+    case mcreds of
+        Just (Creds _ AuthEmail _ _ (Just _)) -> return ()
+        _ -> do
+            setMessage $ cs "You must be logged in to set a password"
+            redirect RedirectTemporary $ toMaster EmailLoginR
+    msg <- getMessage
+    applyLayout "Set password" (return ()) [$hamlet|
+$maybe msg ms
+    %p.message $ms$
+%h3 Set a new password
+%form!method=post!action=@toMaster.EmailPasswordR@
+    %table
+        %tr
+            %th New password
+            %td
+                %input!type=password!name=new
+        %tr
+            %th Confirm
+            %td
+                %input!type=password!name=confirm
+        %tr
+            %td!colspan=2
+                %input!type=submit!value=Submit
+|]
+
+postEmailPasswordR :: YesodAuth master => GHandler Auth master ()
+postEmailPasswordR = do
+    ae <- getAuthEmailSettings
+    (new, confirm) <- runFormPost $ (,)
+        <$> notEmpty (required $ input "new")
+        <*> notEmpty (required $ input "confirm")
+    toMaster <- getRouteToMaster
+    when (new /= confirm) $ do
+        setMessage $ cs "Passwords did not match, please try again"
+        redirect RedirectTemporary $ toMaster EmailPasswordR
+    mcreds <- maybeCreds
+    lid <- case mcreds of
+            Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid
+            _ -> do
+                setMessage $ cs "You must be logged in to set a password"
+                redirect RedirectTemporary $ toMaster EmailLoginR
+    salted <- liftIO $ saltPass new
+    liftIO $ setPassword ae lid salted
+    setMessage $ cs "Password updated"
+    redirect RedirectTemporary $ toMaster EmailLoginR
+
+saltLength :: Int
+saltLength = 5
+
+isValidPass :: String -- ^ cleartext password
+            -> String -- ^ salted password
+            -> Bool
+isValidPass clear salted =
+    let salt = take saltLength salted
+     in salted == saltPass' salt clear
+
+saltPass :: String -> IO String
+saltPass pass = do
+    stdgen <- newStdGen
+    let salt = take saltLength $ randomRs ('A', 'Z') stdgen
+    return $ saltPass' salt pass
+
+saltPass' :: String -> String -> String -- FIXME better salting scheme?
+saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass)
+
+inMemoryEmailSettings :: IO AuthEmailSettings
+inMemoryEmailSettings = do
+    mm <- newMVar []
+    return $ AuthEmailSettings
+        { addUnverified = \email verkey -> modifyMVar mm $ \m -> do
+            let helper (_, EmailCreds x _ _ _) = x
+            let newId = 1 + maximum (0 : map helper m)
+            let ec = EmailCreds newId Nothing False verkey
+            return ((email, ec) : m, newId)
+        , sendVerifyEmail = \_email _verkey verurl ->
+            hPutStrLn stderr $ "Please go to: " ++ verurl
+        , getVerifyKey = \eid -> withMVar mm $ \m -> return $
+            lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m
+        , verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid)
+        , setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass)
+        , getEmailCreds = \email -> withMVar mm $ return . lookup email
+        , getEmail = \eid -> withMVar mm $ \m -> return $
+            case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of
+                ((email, _):_) -> Just email
+                _ -> Nothing
+        }
+  where
+    vago eid (email, EmailCreds eid' pass status key)
+        | eid == eid' = (email, EmailCreds eid pass True key)
+        | otherwise = (email, EmailCreds eid' pass status key)
+    spgo eid pass (email, EmailCreds eid' pass' status key)
+        | eid == eid' = (email, EmailCreds eid (Just pass) status key)
+        | otherwise = (email, EmailCreds eid' pass' status key)

Yesod/Helpers/EmailAuth.hs

@@ -1,263 +0,0 @@
-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
-module Yesod.Helpers.EmailAuth
-    ( getEmailAuth
-    , EmailAuth
-    , siteEmailAuth
-    , EmailAuthRoutes (..)
-    , YesodEmailAuth (..)
-    ) where
-
-import Yesod
-import Yesod.Helpers.Auth
-import System.Random
-import Data.Maybe
-import Control.Applicative
-import Control.Monad
-import Data.Digest.Pure.MD5
-
-class Yesod y => YesodEmailAuth y where
-    addUnverified :: y
-                  -> String -- ^ email
-                  -> String -- ^ verification key
-                  -> IO Integer -- ^ login_id
-    sendVerifyEmail :: y
-                    -> String -- ^ email
-                    -> String -- ^ verification key
-                    -> String -- ^ verify URL
-                    -> IO ()
-    getVerifyKey :: y
-                 -> Integer -- ^ login_id
-                 -> IO (Maybe String)
-    verifyAccount :: y
-                  -> Integer -- ^ login_id
-                  -> IO ()
-    setPassword :: y
-                -> Integer -- ^ login_id
-                -> String -- ^ salted password
-                -> IO ()
-    getCreds :: y
-             -> String -- ^ email address
-             -> IO (Maybe (Integer, Maybe String, Bool, String)) -- ^ id, salted pass, is verified, verify key
-    getEmail :: y -> Integer -> IO (Maybe String)
-
-    randomKey :: y -> IO String
-    randomKey _ = do
-        stdgen <- newStdGen
-        return $ take 10 $ randomRs ('A', 'Z') stdgen
-
-    onSuccessfulLogin :: y -> Routes y
-    onSuccessfulLogout :: y -> Routes y
-
-    onEmailAuthLogin :: y
-                     -> String -- ^ email
-                     -> Integer -- ^ login_id
-                     -> IO ()
-
-data EmailAuth = EmailAuth
-
-getEmailAuth :: a -> EmailAuth
-getEmailAuth _ = EmailAuth
-
-mkYesodSub "EmailAuth" [''YesodEmailAuth] [$parseRoutes|
-/register       RegisterR      GET POST
-/verify/#/$     VerifyR        GET
-/login          LoginR         GET POST
-/set-password   PasswordR      GET POST
-/logout         LogoutR        GET
-|]
-
-getRegisterR :: Yesod master => GHandler EmailAuth master RepHtml
-getRegisterR = do
-    toMaster <- getRouteToMaster
-    applyLayout "Register a new account" (return ()) [$hamlet|
-%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
-%form!method=post!action=@toMaster.RegisterR@
-    %label!for=email E-mail
-    %input#email!type=email!name=email!width=150
-    %input!type=submit!value=Register
-|]
-
-postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml
-postRegisterR = do
-    email <- runFormPost $ checkEmail $ required $ input "email"
-    y <- getYesod
-    creds <- liftIO $ getCreds y email
-    (lid, verKey) <-
-        case creds of
-            Nothing -> liftIO $ do
-                key <- randomKey y
-                lid <- addUnverified y email key
-                return (lid, key)
-            Just (lid, _, _, key) -> return (lid, key)
-    render <- getUrlRender
-    tm <- getRouteToMaster
-    let verUrl = render $ tm $ VerifyR lid verKey
-    liftIO $ sendVerifyEmail y email verKey verUrl
-    applyLayout "Confirmation e-mail sent" (return ()) [$hamlet|
-%p A confirmation e-mail has been sent to $cs.email$.
-|]
-
-checkEmail :: Form ParamValue -> Form ParamValue
-checkEmail = notEmpty -- FIXME
-
-getVerifyR :: YesodEmailAuth master
-           => Integer -> String -> GHandler EmailAuth master RepHtml
-getVerifyR lid key = do
-    y <- getYesod
-    realKey <- liftIO $ getVerifyKey y lid
-    memail <- liftIO $ getEmail y lid
-    case (realKey == Just key, memail) of
-        (True, Just email) -> do
-            liftIO $ verifyAccount y lid
-            setLoginSession email lid
-            toMaster <- getRouteToMaster
-            redirect RedirectTemporary $ toMaster PasswordR
-        _ -> applyLayout "Invalid verification key" (return ()) [$hamlet|
-%p I'm sorry, but that was an invalid verification key.
-        |]
-
-getLoginR :: Yesod master => GHandler EmailAuth master RepHtml
-getLoginR = do
-    toMaster <- getRouteToMaster
-    msg <- getMessage
-    applyLayout "Login" (return ()) [$hamlet|
-$maybe msg ms
-    %p.message $ms$
-%p Please log in to your account.
-%p
-    %a!href=@toMaster.RegisterR@ I don't have an account
-%form!method=post!action=@toMaster.LoginR@
-    %table
-        %tr
-            %th E-mail
-            %td
-                %input!type=email!name=email
-        %tr
-            %th Password
-            %td
-                %input!type=password!name=password
-        %tr
-            %td!colspan=2
-                %input!type=submit!value=Login
-|]
-
-postLoginR :: YesodEmailAuth master => GHandler EmailAuth master ()
-postLoginR = do
-    (email, pass) <- runFormPost $ (,)
-        <$> checkEmail (required $ input "email")
-        <*> required (input "password")
-    y <- getYesod
-    creds <- liftIO $ getCreds y email
-    let mlid =
-            case creds of
-                Just (lid, Just realpass, True, _) ->
-                    if isValidPass pass realpass then Just lid else Nothing
-                _ -> Nothing
-    case mlid of
-        Just lid -> do
-            setLoginSession email lid
-            redirect RedirectTemporary $ onSuccessfulLogin y
-        Nothing -> do
-            setMessage $ cs "Invalid email/password combination"
-            toMaster <- getRouteToMaster
-            redirect RedirectTemporary $ toMaster LoginR
-
-getPasswordR :: Yesod master => GHandler EmailAuth master RepHtml
-getPasswordR = do
-    l <- isJust <$> isLoggedIn
-    toMaster <- getRouteToMaster
-    unless l $ do
-        setMessage $ cs "You must be logged in to set a password"
-        redirect RedirectTemporary $ toMaster LoginR
-    msg <- getMessage
-    applyLayout "Set password" (return ()) [$hamlet|
-$maybe msg ms
-    %p.message $ms$
-%h3 Set a new password
-%form!method=post!action=@toMaster.PasswordR@
-    %table
-        %tr
-            %th New password
-            %td
-                %input!type=password!name=new
-        %tr
-            %th Confirm
-            %td
-                %input!type=password!name=confirm
-        %tr
-            %td!colspan=2
-                %input!type=submit!value=Submit
-|]
-
-postPasswordR :: YesodEmailAuth master => GHandler EmailAuth master ()
-postPasswordR = do
-    (new, confirm) <- runFormPost $ (,)
-        <$> notEmpty (required $ input "new")
-        <*> notEmpty (required $ input "confirm")
-    toMaster <- getRouteToMaster
-    when (new /= confirm) $ do
-        setMessage $ cs "Passwords did not match, please try again"
-        redirect RedirectTemporary $ toMaster PasswordR
-    mlid <- isLoggedIn
-    lid <- case mlid of
-            Just lid -> return lid
-            Nothing -> do
-                setMessage $ cs "You must be logged in to set a password"
-                redirect RedirectTemporary $ toMaster LoginR
-    salted <- liftIO $ saltPass new
-    y <- getYesod
-    liftIO $ setPassword y lid salted
-    setMessage $ cs "Password updated"
-    redirect RedirectTemporary $ toMaster LoginR
-
-getLogoutR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml
-getLogoutR = do
-    clearSession identKey
-    clearSession displayNameKey
-    clearSession emailAuthIdKey
-    y <- getYesod
-    redirect RedirectTemporary $ onSuccessfulLogout y
-
-saltLength :: Int
-saltLength = 5
-
-isValidPass :: String -- ^ cleartext password
-            -> String -- ^ salted password
-            -> Bool
-isValidPass clear salted =
-    let salt = take saltLength salted
-     in salted == saltPass' salt clear
-
-saltPass :: String -> IO String
-saltPass pass = do
-    stdgen <- newStdGen
-    let salt = take saltLength $ randomRs ('A', 'Z') stdgen
-    return $ saltPass' salt pass
-
-saltPass' :: String -> String -> String -- FIXME better salting scheme?
-saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass)
-
-emailAuthIdKey :: String
-emailAuthIdKey = "EMAIL_AUTH_ID"
-
-setLoginSession :: YesodEmailAuth master
-                => String -> Integer -> GHandler sub master ()
-setLoginSession email lid = do
-    setSession identKey email
-    setSession displayNameKey email
-    setSession emailAuthIdKey $ show lid
-    y <- getYesod
-    liftIO $ onEmailAuthLogin y email lid
-
-isLoggedIn :: GHandler sub master (Maybe Integer)
-isLoggedIn = do
-    s <- session
-    return $
-        if null (s identKey)
-            then Nothing
-            else listToMaybe (s emailAuthIdKey) >>= readMay
-
-readMay :: String -> Maybe Integer
-readMay s = case reads s of
-                [] -> Nothing
-                ((i, _):_) -> Just i

yesod.cabal

@@ -50,7 +50,6 @@ library
                      Yesod.Helpers.Auth
                      Yesod.Helpers.Sitemap
                      Yesod.Helpers.Static
-                     Yesod.Helpers.EmailAuth
                      Web.Mime
     ghc-options:     -Wall