sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 17:04:52 +09:00
Code Issues Activity

Unverified variants of setCreds and clearCreds

Browse source
This commit is contained in:
fr33domlover 2018-03-17 22:16:02 +00:00
parent 7b39381388
commit f196bf38d6
7 changed files with 373 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
config/routes
View file

@ -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

14
src/Vervis/Foundation.hs
View file

@ -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)

19
src/Vervis/Handler/Person.hs
View file

@ -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|
<p>_{MsgEmailUnverified}
^{resendVerifyEmailWidget (username person) AuthR}
|]
-- | Get list of users
getPeopleR :: Handler Html
getPeopleR = do

13
src/Yesod/Auth/Unverified.hs
View file

@ -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
}

281
src/Yesod/Auth/Unverified/Creds.hs Normal file
View file

@ -0,0 +1,281 @@
{- This file is part of Vervis.
-
- Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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|<h1>_{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|<h1>_{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

52
src/Yesod/Auth/Unverified/Internal.hs Normal file
View file

@ -0,0 +1,52 @@
{- This file is part of Vervis.
-
- Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- | 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"

2
vervis.cabal
View file

@ -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