From f196bf38d6a853cb084a905033e8e05b507eb80d Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 17 Mar 2018 22:16:02 +0000 Subject: [PATCH] Unverified variants of setCreds and clearCreds --- config/routes | 17 +- src/Vervis/Foundation.hs | 14 +- src/Vervis/Handler/Person.hs | 19 +- src/Yesod/Auth/Unverified.hs | 13 +- src/Yesod/Auth/Unverified/Creds.hs | 281 ++++++++++++++++++++++++++ src/Yesod/Auth/Unverified/Internal.hs | 52 +++++ vervis.cabal | 2 + 7 files changed, 373 insertions(+), 25 deletions(-) create mode 100644 src/Yesod/Auth/Unverified/Creds.hs create mode 100644 src/Yesod/Auth/Unverified/Internal.hs diff --git a/config/routes b/config/routes index fe0f117..a2be10e 100644 --- a/config/routes +++ b/config/routes @@ -24,9 +24,16 @@ -- Current user -- ---------------------------------------------------------------------------- -/ HomeR GET +/ HomeR GET -/auth AuthR Auth getAuth +/auth/!resend ResendVerifyEmailR GET +/auth AuthR Auth getAuth + +/k KeysR GET POST +/k/!new KeyNewR GET +/k/#KyIdent KeyR GET DELETE POST + +/cr ClaimRequestsPersonR GET -- ---------------------------------------------------------------------------- -- People @@ -46,12 +53,6 @@ /g/#ShrIdent/m/!new GroupMemberNewR GET /g/#ShrIdent/m/#ShrIdent GroupMemberR GET DELETE POST -/k KeysR GET POST -/k/!new KeyNewR GET -/k/#KyIdent KeyR GET DELETE POST - -/cr ClaimRequestsPersonR GET - /s/#ShrIdent/rr RepoRolesR GET POST /s/#ShrIdent/rr/!new RepoRoleNewR GET /s/#ShrIdent/rr/#RlIdent RepoRoleR GET DELETE POST diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index d529299..cdb0fee 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -420,7 +420,7 @@ instance AccountSendEmail App where sendVerifyEmail uname email url = do sent <- sendMail (Address (Just uname) email) (MailVerifyAccount url) unless sent $ do - setMessage $ "Mail sending disabed, please contact admin" + setMessage "Mail sending disabed, please contact admin" $logWarn $ T.concat [ "Verification email NOT SENT for user " , uname, " <", emailText email, ">: " @@ -429,7 +429,7 @@ instance AccountSendEmail App where sendNewPasswordEmail uname email url = do sent <- sendMail (Address (Just uname) email) (MailResetPassphrase url) unless sent $ do - setMessage $ "Mail sending disabed, please contact admin" + setMessage "Mail sending disabed, please contact admin" $logWarn $ T.concat ["Password reset email NOT SENT for user " , uname, " <", emailText email, ">: " @@ -437,7 +437,12 @@ instance AccountSendEmail App where ] instance YesodAuthAccount AccountPersistDB' App where - runAccountDB = unAccountPersistDB' + runAccountDB = unAccountPersistDB' + --unregisteredLogin u = do + -- set creds unverified + --setUnverifiedCreds True $ Creds "account" (username u) [] + -- redirect to resend form + -- ? -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -469,6 +474,9 @@ instance YesodBreadcrumbs App where RobotsR -> ("", Nothing) HomeR -> ("Home", Nothing) + ResendVerifyEmailR -> ( "Resend verification email" + , Nothing + ) AuthR _ -> ("Auth", Nothing) SharersR -> ("Sharers", Just HomeR) diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index e5d3ca0..d76bf92 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -14,7 +14,8 @@ -} module Vervis.Handler.Person - ( getPeopleR + ( getResendVerifyEmailR + , getPeopleR , postPeopleR , getPersonNewR , getPersonR @@ -28,7 +29,10 @@ import Database.Esqueleto hiding (isNothing, count) import Vervis.Form.Person --import Model import Text.Blaze.Html (toHtml) -import Yesod.Auth.Account (newAccountR) +import Yesod.Auth.Account (newAccountR, resendVerifyEmailWidget, username) +import Yesod.Auth.Account.Message (AccountMsg (MsgEmailUnverified)) + +import Yesod.Auth.Unverified (requireUnverifiedAuth) import Text.Email.Local @@ -36,6 +40,17 @@ import Vervis.Model.Ident import Vervis.Secure import Vervis.Widget (avatarW) +-- | Account verification email resend form +getResendVerifyEmailR :: Handler Html +getResendVerifyEmailR = do + person <- requireUnverifiedAuth + defaultLayout $ do + setTitleI MsgEmailUnverified + [whamlet| +

_{MsgEmailUnverified} + ^{resendVerifyEmailWidget (username person) AuthR} + |] + -- | Get list of users getPeopleR :: Handler Html getPeopleR = do diff --git a/src/Yesod/Auth/Unverified.hs b/src/Yesod/Auth/Unverified.hs index e53ff08..0b3b804 100644 --- a/src/Yesod/Auth/Unverified.hs +++ b/src/Yesod/Auth/Unverified.hs @@ -70,7 +70,6 @@ import Prelude import Control.Applicative ((<|>)) import Control.Monad (when) import Control.Monad.Trans.Maybe -import Data.Text (Text) import Data.Typeable (Typeable) import Database.Persist.Class import Database.Persist.Types (Entity) @@ -81,19 +80,9 @@ import Yesod.Core.Handler import Yesod.Core.Json (acceptsJson) import Yesod.Persist.Core (YesodPersist (YesodPersistBackend)) +import Yesod.Auth.Unverified.Internal import Yesod.SessionEntity -class YesodAuth site => YesodAuthVerify site where - -- | If the user is logged in unverified, and browses to a page that - -- requires a verified account, this is where they will be redirected to - -- for verifying their account. For example, it can be a page containing - -- the verification email resend form. - verificationRoute :: site -> Route site - --- | Session key used to hold the ID of the unverified logged-in user -unverifiedLoginKey :: Text -unverifiedLoginKey = "_ID_UNVERIFIED" - newtype CachedUnverifiedLogin a = CachedUnverifiedLogin { unCachedUnverifiedLogin :: Maybe a } diff --git a/src/Yesod/Auth/Unverified/Creds.hs b/src/Yesod/Auth/Unverified/Creds.hs new file mode 100644 index 0000000..04b2054 --- /dev/null +++ b/src/Yesod/Auth/Unverified/Creds.hs @@ -0,0 +1,281 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - This module is under MIT license because it's adapted from code taken from + - the yesod-auth library, which is: + - + - Copyright (c) 2012-2018 Michael Snoyman, http://www.yesodweb.com/ + - + - Permission is hereby granted, free of charge, to any person obtaining + - a copy of this software and associated documentation files (the + - "Software"), to deal in the Software without restriction, including + - without limitation the rights to use, copy, modify, merge, publish, + - distribute, sublicense, and/or sell copies of the Software, and to + - permit persons to whom the Software is furnished to do so, subject to + - the following conditions: + - + - The above copyright notice and this permission notice shall be + - included in all copies or substantial portions of the Software. + - + - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + -} + +-- # LANGUAGE CPP #-} +-- # LANGUAGE ViewPatterns #-} +-- # LANGUAGE ConstraintKinds #-} +-- # LANGUAGE DefaultSignatures #-} +-- # LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +-- # LANGUAGE FlexibleContexts #-} +-- # LANGUAGE FlexibleInstances #-} +-- # LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +-- # LANGUAGE OverloadedStrings #-} +-- # LANGUAGE DeriveDataTypeable #-} +-- # LANGUAGE UndecidableInstances #-} +-- # OPTIONS_GHC -fno-warn-orphans #-} + +-- | All the code below is for my custom setCreds and is copied from yesod-auth +-- Yesod.Auth because right now there's no better way to reuse it +-- unfortunately, maybe in the future I'll figure out something. +-- +-- Changes made after copying the code from yesod-auth-1.6.2: +-- +-- * Comment out the extensions, uncommenting one by one as needed +-- * Comment out the imports, uncommenting one by one as needed +-- * Comment out functions already exported from Yesod.Auth or ones that exist +-- in the chunk I copied but aren't used anywhere in that chunk so I don't +-- need them but keeping them just to have the chunk complete and easy to +-- recognize in Yesod.Auth source the exact part I copied +-- * Define a symbol credsKey to unverifiedLoginKey +-- * Add "Unverified" to the name of the 3 functions I'm exporting here +-- * Uncomment a few functions and paste older versions of them because of +-- changes from yesod-auth 1.4.13.2, which is in LTS 6.5, to 1.6.2, which is +-- the latest release and where I copied from +-- * Instead of loginDest and onLogin, use my custom unverified counterparts +module Yesod.Auth.Unverified.Creds + ( setUnverifiedCreds + , setUnverifiedCredsRedirect + , clearUnverifiedCreds + ) +where + +-- First, here are the imports copied from Yesod.Auth + +import Control.Monad (when) +-- import Control.Monad.Trans.Maybe +-- import UnliftIO (withRunInIO, MonadUnliftIO) + +-- import Yesod.Auth.Routes +import Data.Aeson hiding (json) +-- import Data.Text.Encoding (decodeUtf8With) +-- import Data.Text.Encoding.Error (lenientDecode) +import Data.Text (Text) +-- import qualified Data.Text as T +-- import qualified Data.HashMap.Lazy as Map +-- import Data.Monoid (Endo) +-- import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader) +-- import Network.HTTP.Client.TLS (getGlobalManager) + +-- import qualified Network.Wai as W + +import Yesod.Core +-- import Yesod.Persist +import Yesod.Auth.Message (AuthMessage, defaultMessage) +import qualified Yesod.Auth.Message as Msg +-- import Yesod.Form (FormMessage) +-- import Data.Typeable (Typeable) +-- import Control.Exception (Exception) +import Network.HTTP.Types (Status, internalServerError500, unauthorized401) +-- import qualified Control.Monad.Trans.Writer as Writer +import Control.Monad (void) + +-- Now come imports that I added + +import Prelude + +import Control.Monad.Trans.Resource (MonadResourceBase) +import Yesod.Auth hiding (credsKey) + +import Yesod.Auth.Unverified.Internal + +credsKey = unverifiedLoginKey + +{- +loginErrorMessageI + :: Route Auth + -> AuthMessage + -> AuthHandler master TypedContent +loginErrorMessageI dest msg = do + toParent <- getRouteToParent + loginErrorMessageMasterI (toParent dest) msg +-} +loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) + => Route child + -> AuthMessage + -> HandlerT child (HandlerT master m) TypedContent +loginErrorMessageI dest msg = do + toParent <- getRouteToParent + lift $ loginErrorMessageMasterI (toParent dest) msg + +{- +loginErrorMessageMasterI + :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master) + => Route master + -> AuthMessage + -> m TypedContent +loginErrorMessageMasterI dest msg = do + mr <- getMessageRender + loginErrorMessage dest (mr msg) +-} +loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage) + => Route master + -> AuthMessage + -> HandlerT master m TypedContent +loginErrorMessageMasterI dest msg = do + mr <- getMessageRender + loginErrorMessage dest (mr msg) + +{- +-- | For HTML, set the message and redirect to the route. +-- For JSON, send the message and a 401 status +loginErrorMessage + :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Route (HandlerSite m) + -> Text + -> m TypedContent +loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) +-} + +{- +messageJson401 + :: MonadHandler m + => Text + -> m Html + -> m TypedContent +messageJson401 = messageJsonStatus unauthorized401 +-} + +messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent +messageJson500 = messageJsonStatus internalServerError500 + +messageJsonStatus + :: MonadHandler m + => Status + -> Text + -> m Html + -> m TypedContent +messageJsonStatus status msg html = selectRep $ do + provideRep html + provideRep $ do + let obj = object ["message" .= msg] + void $ sendResponseStatus status obj + return obj + +{- +provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () +provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] +-} + +{- +setUnverifiedCredsRedirect + :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Creds (HandlerSite m) -- ^ new credentials + -> m TypedContent +-} +setUnverifiedCredsRedirect :: YesodAuthVerify master + => Creds master -- ^ new credentials + -> HandlerT master IO TypedContent +setUnverifiedCredsRedirect creds = do + y <- getYesod + auth <- authenticate creds + case auth of + Authenticated aid -> do + setSession credsKey $ toPathPiece aid + onUnverifiedLogin + res <- selectRep $ do + provideRepType typeHtml $ + fmap asHtml $ redirectUltDest $ unverifiedLoginDest y + provideJsonMessage "Login Successful" + sendResponse res + + UserError msg -> + case authRoute y of + Nothing -> do + msg' <- renderMessage' msg + messageJson401 msg' $ authLayout $ -- TODO + toWidget [whamlet|

_{msg}|] + Just ar -> loginErrorMessageMasterI ar msg + + ServerError msg -> do + $(logError) msg + + case authRoute y of + Nothing -> do + msg' <- renderMessage' Msg.AuthError + messageJson500 msg' $ authLayout $ + toWidget [whamlet|

_{Msg.AuthError}|] + Just ar -> loginErrorMessageMasterI ar Msg.AuthError + + where + renderMessage' msg = do + langs <- languages + master <- getYesod + return $ renderAuthMessage master langs msg + +-- | Sets user credentials for the session after checking them with authentication backends. +{- +setUnverifiedCreds :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Bool -- ^ if HTTP redirects should be done + -> Creds (HandlerSite m) -- ^ new credentials + -> m () +-} +setUnverifiedCreds :: YesodAuthVerify master + => Bool -- ^ if HTTP redirects should be done + -> Creds master -- ^ new credentials + -> HandlerT master IO () +setUnverifiedCreds doRedirects creds = + if doRedirects + then void $ setUnverifiedCredsRedirect creds + else do auth <- authenticate creds + case auth of + Authenticated aid -> setSession credsKey $ toPathPiece aid + _ -> return () + +{- +-- | same as defaultLayoutJson, but uses authLayout +authLayoutJson + :: (ToJSON j, MonadAuthHandler master m) + => WidgetFor master () -- ^ HTML + -> m j -- ^ JSON + -> m TypedContent +authLayoutJson w json = selectRep $ do + provideRep $ authLayout w + provideRep $ fmap toJSON json +-} + +-- | Clears current user credentials for the session. +-- +-- @since 1.1.7 +{- +clearUnverifiedCreds :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Bool -- ^ if HTTP redirect to 'logoutDest' should be done + -> m () +-} +clearUnverifiedCreds :: YesodAuth master + => Bool -- ^ if HTTP redirect to 'logoutDest' should be done + -> HandlerT master IO () +clearUnverifiedCreds doRedirects = do + y <- getYesod + onLogout + deleteSession credsKey + when doRedirects $ do + redirectUltDest $ logoutDest y diff --git a/src/Yesod/Auth/Unverified/Internal.hs b/src/Yesod/Auth/Unverified/Internal.hs new file mode 100644 index 0000000..669e681 --- /dev/null +++ b/src/Yesod/Auth/Unverified/Internal.hs @@ -0,0 +1,52 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | This is a module for things used by both the @Unverified@ and +-- @Unverified.Creds@ modules. If they are merged into a single module, +-- everything here can move there. +module Yesod.Auth.Unverified.Internal + ( YesodAuthVerify (..) + , unverifiedLoginKey + ) +where + +import Prelude + +import Data.Text (Text) +import Yesod.Auth (YesodAuth (..)) +import Yesod.Core (Route) +import Yesod.Core.Handler (HandlerT) + +class YesodAuth site => YesodAuthVerify site where + + -- | If the user is logged in unverified, and browses to a page that + -- requires a verified account, this is where they will be redirected to + -- for verifying their account. For example, it can be a page containing + -- the verification email resend form. + verificationRoute :: site -> Route site + + -- | Default destination on successful unverified login, if no other + -- destination exists. Default: 'loginDest' + unverifiedLoginDest :: site -> Route site + unverifiedLoginDest = loginDest + + -- | Called on a successful unverified login. Default: 'onLogin' + --onUnverifiedLogin :: (MonadHandler m, site ~ HandlerSite m) => m () + onUnverifiedLogin :: HandlerT site IO () + onUnverifiedLogin = onLogin + +-- | Session key used to hold the ID of the unverified logged-in user +unverifiedLoginKey :: Text +unverifiedLoginKey = "_ID_UNVERIFIED" diff --git a/vervis.cabal b/vervis.cabal index 660c810..0e2ce90 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -99,6 +99,8 @@ library Text.Jasmine.Local Web.PathPieces.Local Yesod.Auth.Unverified + Yesod.Auth.Unverified.Creds + Yesod.Auth.Unverified.Internal Yesod.Mail.Send Yesod.Paginate.Local Yesod.SessionEntity