Authentication included in scaffolded site

Yesod/Helpers/Auth.hs

@@ -35,7 +35,9 @@ module Yesod.Helpers.Auth
     , EmailSettings (..)
     , FacebookSettings (..)
       -- * Functions
+    , maybeAuth
     , maybeAuthId
+    , requireAuth
     , requireAuthId
     ) where
 
@@ -47,6 +49,7 @@ import Yesod
 import Yesod.Mail (randomString)
 
 import Data.Maybe
+import Data.Int (Int64)
 import Control.Monad
 import System.Random
 import Data.Digest.Pure.MD5
@@ -56,19 +59,15 @@ import Data.ByteString.Lazy.UTF8 (fromString)
 import Data.Object
 import Language.Haskell.TH.Syntax
 
-class (Integral (AuthEmailId master), Yesod master,
+type AuthId m = Key (AuthEntity m)
-       Show (AuthId master), Read (AuthId master), Eq (AuthId master)
+type AuthEmailId m = Key (AuthEmailEntity m)
-       ) => YesodAuth master where
-    type AuthId master
-    type AuthEmailId master
 
-    showAuthId :: AuthId master -> GHandler s master String
+class ( Yesod master
-    showAuthId = return . show
+      , PersistEntity (AuthEntity master)
-
+      , PersistEntity (AuthEmailEntity master)
-    readAuthId :: String -> GHandler s master (Maybe (AuthId master))
+      ) => YesodAuth master where
-    readAuthId s = return $ case reads s of
+    type AuthEntity master
-                                [] -> Nothing
+    type AuthEmailEntity master
-                                ((x, _):_) -> Just x
 
     -- | Default destination on successful login or logout, if no other
     -- destination exists.
@@ -163,7 +162,7 @@ setCreds creds extra = do
     maid <- getAuthId creds extra
     case maid of
         Nothing -> return ()
-        Just aid -> showAuthId aid >>= setSession credsKey
+        Just aid -> setSession credsKey $ show $ fromPersistKey aid
 
 -- | Retrieves user credentials, if user is authenticated.
 maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
@@ -171,7 +170,23 @@ maybeAuthId = do
     ms <- lookupSession credsKey
     case ms of
         Nothing -> return Nothing
-        Just s -> readAuthId s
+        Just s -> case reads s of
+                    [] -> return Nothing
+                    (i, _):_ -> return $ Just $ toPersistKey i
+
+maybeAuth :: ( PersistBackend (YesodDB m (GHandler s m))
+             , YesodPersist m
+             , YesodAuth m
+             ) => GHandler s m (Maybe (AuthId m, AuthEntity m))
+maybeAuth = do
+    maid <- maybeAuthId
+    case maid of
+        Nothing -> return Nothing
+        Just aid -> do
+            ma <- runDB $ get aid
+            case ma of
+                Nothing -> return Nothing
+                Just a -> return $ Just (aid, a)
 
 mkYesodSub "Auth"
     [ ClassP ''YesodAuth [VarT $ mkName "master"]
@@ -186,7 +201,7 @@ mkYesodSub "Auth"
 /facebook                FacebookR          GET
 
 /register                EmailRegisterR     GET POST
-/verify/#Integer/#String EmailVerifyR       GET
+/verify/#Int64/#String   EmailVerifyR       GET
 /email-login             EmailLoginR        POST
 /set-password            EmailPasswordR     GET POST
 
@@ -233,7 +248,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master ()
 handleRpxnowR = do
     ay <- getYesod
     auth <- getYesod
-    apiKey <- case rpxnowApp <$> rpxnowSettings auth of
+    apiKey <- case rpxnowKey <$> rpxnowSettings auth of
                 Just x -> return x
                 Nothing -> notFound
     token1 <- lookupGetParam "token"
@@ -295,15 +310,21 @@ getLogoutR = do
 -- 'authRoute'. Sets ultimate destination to current route, so user
 -- should be sent back here after authenticating.
 requireAuthId :: YesodAuth m => GHandler sub m (AuthId m)
-requireAuthId =
+requireAuthId = maybeAuthId >>= maybe redirectLogin return
-    maybeAuthId >>= maybe redirectLogin return
+
-  where
+requireAuth :: ( PersistBackend (YesodDB m (GHandler s m))
-    redirectLogin = do
+               , YesodPersist m
-        y <- getYesod
+               , YesodAuth m
-        setUltDest'
+               ) => GHandler s m (AuthId m, AuthEntity m)
-        case authRoute y of
+requireAuth = maybeAuth >>= maybe redirectLogin return
-            Just z -> redirect RedirectTemporary z
+
-            Nothing -> permissionDenied "Please configure authRoute"
+redirectLogin :: Yesod m => GHandler s m a
+redirectLogin = do
+    y <- getYesod
+    setUltDest'
+    case authRoute y of
+        Just z -> redirect RedirectTemporary z
+        Nothing -> permissionDenied "Please configure authRoute"
 
 getEmailSettings :: YesodAuth master
                      => GHandler Auth master (EmailSettings master)
@@ -341,16 +362,16 @@ postEmailRegisterR = do
                 return (lid, key)
     render <- getUrlRender
     tm <- getRouteToMaster
-    let verUrl = render $ tm $ EmailVerifyR (fromIntegral lid) verKey
+    let verUrl = render $ tm $ EmailVerifyR (fromPersistKey lid) verKey
     sendVerifyEmail ae email verKey verUrl
     defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet|
 %p A confirmation e-mail has been sent to $email$.
 |]
 
 getEmailVerifyR :: YesodAuth master
-           => Integer -> String -> GHandler Auth master RepHtml
+           => Int64 -> String -> GHandler Auth master RepHtml
 getEmailVerifyR lid' key = do
-    let lid = fromInteger lid'
+    let lid = toPersistKey lid'
     ae <- getEmailSettings
     realKey <- getVerifyKey ae lid
     memail <- getEmail ae lid

scaffold.hs

@@ -173,13 +173,19 @@ module ~sitearg~
     , ~sitearg~Route (..)
     , resources~sitearg~
     , Handler
+    , maybeAuth
+    , requireAuth
     , module Yesod
     , module Settings
     , module Model
+    , StaticRoute (..)
+    , AuthRoute (..)
     ) where
 
 import Yesod
+import Yesod.Mail
 import Yesod.Helpers.Static
+import Yesod.Helpers.Auth
 import qualified Settings
 import System.Directory
 import qualified Data.ByteString.Lazy as L
@@ -187,6 +193,8 @@ import Yesod.WebRoutes
 import Database.Persist.GenericSql
 import Settings (hamletFile, cassiusFile, juliusFile)
 import Model
+import Control.Monad (join)
+import Data.Maybe (isJust)
 
 data ~sitearg~ = ~sitearg~
     { getStatic :: Static
@@ -196,10 +204,13 @@ data ~sitearg~ = ~sitearg~
 type Handler = GHandler ~sitearg~ ~sitearg~
 
 mkYesodData "~sitearg~" [$parseRoutes|
-/ RootR GET POST
 /static StaticR Static getStatic
+/auth   AuthR   Auth   getAuth
+
 /favicon.ico FaviconR GET
 /robots.txt RobotsR GET
+
+/ RootR GET
 |~~]
 
 instance Yesod ~sitearg~ where
@@ -217,6 +228,7 @@ instance Yesod ~sitearg~ where
         ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep))
         ss = getSubSite
     urlRenderOverride _ _ = Nothing
+    authRoute _ = Just $ AuthR LoginR
     addStaticContent ext' _ content = do
         let fn = base64md5 content ++ '.' : ext'
         let statictmp = Settings.staticdir ++ "/tmp/"
@@ -227,6 +239,76 @@ instance Yesod ~sitearg~ where
 instance YesodPersist ~sitearg~ where
     type YesodDB ~sitearg~ = SqlPersist
     runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db
+
+instance YesodAuth ~sitearg~ where
+    type AuthEntity ~sitearg~ = User
+    type AuthEmailEntity ~sitearg~ = Email
+
+    defaultDest _ = RootR
+
+    getAuthId creds _extra = runDB $ do
+        x <- getBy $ UniqueUser $ credsIdent creds
+        case x of
+            Just (uid, _) -> return $ Just uid
+            Nothing -> do
+                fmap Just $ insert $ User (credsIdent creds) Nothing
+
+    openIdEnabled _ = True
+
+    emailSettings _ = Just EmailSettings
+        { addUnverified = \email verkey ->
+            runDB $ insert $ Email email Nothing (Just verkey)
+        , sendVerifyEmail = sendVerifyEmail'
+        , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
+        , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]
+        , verifyAccount = \eid -> runDB $ do
+            me <- get eid
+            case me of
+                Nothing -> return Nothing
+                Just e -> do
+                    let email = emailEmail e
+                    case emailUser e of
+                        Just uid -> return $ Just uid
+                        Nothing -> do
+                            uid <- insert $ User email Nothing
+                            update eid [EmailUser $ Just uid]
+                            return $ Just uid
+        , getPassword = runDB . fmap (join . fmap userPassword) . get
+        , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]
+        , getEmailCreds = \email -> runDB $ do
+            me <- getBy $ UniqueEmail email
+            case me of
+                Nothing -> return Nothing
+                Just (eid, e) -> return $ Just EmailCreds
+                    { emailCredsId = eid
+                    , emailCredsAuthId = emailUser e
+                    , emailCredsStatus = isJust $ emailUser e
+                    , emailCredsVerkey = emailVerkey e
+                    }
+        , getEmail = runDB . fmap (fmap emailEmail) . get
+        }
+
+sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
+sendVerifyEmail' email _ verurl =
+    liftIO $ renderSendMail Mail
+            { mailHeaders =
+                [ ("From", "noreply")
+                , ("To", email)
+                , ("Subject", "Verify your email address")
+                ]
+            , mailPlain = verurl
+            , mailParts = return Part
+                { partType = "text/html; charset=utf-8"
+                , partEncoding = None
+                , partDisposition = Inline
+                , partContent = renderHamlet id [$hamlet|
+%p Please confirm your email address by clicking on the link below.
+%p
+    %a!href=$verurl$ $verurl$
+%p Thank you
+|~~]
+                }
+            }
 |]
 
     writeFile' "Controller.hs" [$codegen|
@@ -240,6 +322,7 @@ module Controller
 import ~sitearg~
 import Settings
 import Yesod.Helpers.Static
+import Yesod.Helpers.Auth
 import Database.Persist.GenericSql
 
 import Handler.Root
@@ -255,7 +338,8 @@ getRobotsR = return $ RepPlain $ toContent "User-agent: *"
 with~sitearg~ :: (Application -> IO a) -> IO a
 with~sitearg~ f = Settings.withConnectionPool $ \p -> do
     flip runConnectionPool p $ runMigration $ do
-        migrate (undefined :: Message)
+        migrate (undefined :: User)
+        migrate (undefined :: Email)
     let h = ~sitearg~ s p
     toWaiApp h >>= f
   where
@@ -269,30 +353,15 @@ module Handler.Root where
 import ~sitearg~
 import Control.Applicative
 
-messageFormlet :: Formlet sub master Message
-messageFormlet x = fieldsToTable
-    $ Message <$> textareaField "Message"
-                                (fmap messageContent x)
-
 getRootR :: Handler RepHtml
 getRootR = do
-    messages <- runDB $ selectList [] [] 10 0
+    mu <- maybeAuth
-    (_, wform, _) <- runFormGet $ messageFormlet Nothing
     defaultLayout $ do
+        h2id <- newIdent
         setTitle "~project~ homepage"
-        ident <- newIdent
-        form <- extractBody wform
         addBody $(hamletFile "homepage")
         addStyle $(cassiusFile "homepage")
         addJavascript $(juliusFile "homepage")
-
-postRootR :: Handler ()
-postRootR = do
-    (res, _, _) <- runFormPost $ messageFormlet Nothing
-    case res of
-        FormSuccess message -> runDB (insert message) >> return ()
-        _ -> return ()
-    redirect RedirectTemporary RootR
 |]
 
     writeFile' "Model.hs" [$codegen|
@@ -302,8 +371,15 @@ module Model where
 import Yesod
 
 mkPersist [$persist|
-Message
+User
-    content Textarea
+    ident String
+    password String null update
+    UniqueUser ident
+Email
+    email String
+    user UserId null update
+    verkey String null update
+    UniqueEmail email
 |~~]
 |]
 
@@ -399,21 +475,17 @@ body
 
     writeFile' "hamlet/homepage.hamlet" [$codegen|
 %h1 Hello
-%p#$ident$ Welcome.
+%h2#$h2id$ You do not have Javascript enabled.
-%h3 Messages
+$maybe mu u
-$if null.messages
+    %p
-    %p No messages.
+        You are logged in as $userIdent.snd.u$. $
-$else
+        %a!href=@AuthR.LogoutR@ Logout
-    %ul
+        \.
-        $forall messages m
+$nothing
-            %li $messageContent.snd.m$
+    %p
-%h3 Add Message
+        You are not logged in. $
-%form!method=post!action=@RootR@
+        %a!href=@AuthR.LoginR@ Login now
-    %table
+        \.
-        ^form^
-        %tr
-            %td!colspan=2
-                %input!type=submit!value="Add Message"
 |]
 
     writeFile' "cassius/homepage.cassius" [$codegen|
@@ -421,11 +493,13 @@ body
     font-family: sans-serif
 h1
     text-align: center
+h2#$h2id$
+    color: #990
 |]
 
     writeFile' "julius/homepage.julius" [$codegen|
 window.onload = function(){
-    document.getElementById("%ident%").innerHTML = "<i>Added from JavaScript.</i>";
+    document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>";
 }
 |]