Write unverified login user functions
This commit is contained in:
parent
d026cf0656
commit
139cc996d6
3 changed files with 510 additions and 1 deletions
349
src/Yesod/Auth/Unverified.hs
Normal file
349
src/Yesod/Auth/Unverified.hs
Normal file
|
@ -0,0 +1,349 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
||||
-- | This module provides login for users with unverified accounts. It's simply
|
||||
-- a separate login, implemented by copying what @yesod-auth@ does, except
|
||||
-- using a different session key to store the user ID.
|
||||
--
|
||||
-- Implementing unverified logins this way allows control the requirement of
|
||||
-- unverified login for authentication related features, or requirement of *at
|
||||
-- least* unverified login, without asking the web app developer to do extra
|
||||
-- work changing many other things in their code to adapt. With the method used
|
||||
-- here, regular @yesod-auth@ login is by default verified, and if the only web
|
||||
-- app features supporting unverified login are the authentication related
|
||||
-- routes, the developer doesn't need to worry about unverified logins at all.
|
||||
--
|
||||
-- It's possibe that implementing unverified logins using @yesod-auth@ login
|
||||
-- and a boolean session key to specify whether verified or not, would turn out
|
||||
-- to be nice too, maybe even better. I haven't tried yet, and chose the
|
||||
-- approach used below because it's less intrusive in the default case where
|
||||
-- unverified login is used only for securing the verification features
|
||||
-- themselves (asking to resend the verification link, and opening that link to
|
||||
-- verify your account).
|
||||
module Yesod.Auth.Unverified
|
||||
( YesodAuthVerify (..)
|
||||
, maybeUnverifiedAuthId
|
||||
, maybeUnverifiedAuth
|
||||
, maybeAuthIdAllowUnverified
|
||||
, maybeAuthAllowUnverified
|
||||
, maybeVerifiedAuthId
|
||||
, maybeVerifiedAuth
|
||||
, requireUnverifiedAuthId
|
||||
, requireUnverifiedAuth
|
||||
, requireAuthIdAllowUnverified
|
||||
, requireAuthAllowUnverified
|
||||
, requireVerifiedAuthId
|
||||
, requireVerifiedAuth
|
||||
)
|
||||
where
|
||||
|
||||
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)
|
||||
import Web.PathPieces (PathPiece)
|
||||
import Yesod.Auth
|
||||
import Yesod.Core (Yesod (authRoute), MonadHandler (HandlerSite))
|
||||
import Yesod.Core.Handler
|
||||
import Yesod.Core.Json (acceptsJson)
|
||||
import Yesod.Persist.Core (YesodPersist (YesodPersistBackend))
|
||||
|
||||
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
|
||||
}
|
||||
deriving Typeable
|
||||
|
||||
maybeUnverifiedAuthId
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuth master
|
||||
, AuthId master ~ Key record
|
||||
, PersistRecordBackend record backend
|
||||
, PathPiece (Key record)
|
||||
, Typeable record
|
||||
)
|
||||
=> m (Maybe (Key record))
|
||||
maybeUnverifiedAuthId =
|
||||
maybeKey unverifiedLoginKey CachedUnverifiedLogin unCachedUnverifiedLogin
|
||||
|
||||
maybeUnverifiedAuth
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuth master
|
||||
, AuthId master ~ Key record
|
||||
, PersistRecordBackend record backend
|
||||
, PathPiece (Key record)
|
||||
, Typeable record
|
||||
)
|
||||
=> m (Maybe (Entity record))
|
||||
maybeUnverifiedAuth =
|
||||
maybeEntity unverifiedLoginKey CachedUnverifiedLogin unCachedUnverifiedLogin
|
||||
|
||||
-- TODO fix signatures when moving to GHC 8
|
||||
maybeAuthIdAllowUnverified
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuth master
|
||||
, AuthId master ~ Key record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Maybe (Key record, Bool))
|
||||
=> HandlerT master IO (Maybe (Key record, Bool))
|
||||
maybeAuthIdAllowUnverified = runMaybeT $
|
||||
(, True) <$> MaybeT maybeVerifiedAuthId
|
||||
<|> (, False) <$> MaybeT maybeUnverifiedAuthId
|
||||
|
||||
maybeAuthAllowUnverified
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuthPersist master
|
||||
, AuthId master ~ Key record
|
||||
, AuthEntity master ~ record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Maybe (Entity record, Bool))
|
||||
=> HandlerT master IO (Maybe (Entity record, Bool))
|
||||
maybeAuthAllowUnverified = runMaybeT $
|
||||
(, True) <$> MaybeT maybeVerifiedAuth
|
||||
<|> (, False) <$> MaybeT maybeUnverifiedAuth
|
||||
|
||||
maybeVerifiedAuthId
|
||||
{-
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodAuth master
|
||||
)
|
||||
=> m (Maybe (AuthId master))
|
||||
-}
|
||||
:: YesodAuth master => HandlerT master IO (Maybe (AuthId master))
|
||||
maybeVerifiedAuthId = maybeAuthId
|
||||
|
||||
maybeVerifiedAuth
|
||||
{-
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodAuthPersist master
|
||||
, AuthId master ~ Key record
|
||||
, AuthEntity master ~ record
|
||||
, PersistEntity record
|
||||
, Typeable record
|
||||
)
|
||||
=> m (Maybe (Entity record))
|
||||
-}
|
||||
:: ( YesodAuthPersist master
|
||||
, AuthId master ~ Key record
|
||||
, AuthEntity master ~ record
|
||||
, PersistEntity record
|
||||
, Typeable record
|
||||
)
|
||||
=> HandlerT master IO (Maybe (Entity record))
|
||||
maybeVerifiedAuth = maybeAuth
|
||||
|
||||
redirectToCurrent = const True
|
||||
|
||||
-- handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
|
||||
handleAuthLack :: Yesod master => HandlerT master IO a
|
||||
handleAuthLack = do
|
||||
aj <- acceptsJson
|
||||
if aj
|
||||
then notAuthenticated
|
||||
else do
|
||||
y <- getYesod
|
||||
when (redirectToCurrent y) setUltDestCurrent
|
||||
case authRoute y of
|
||||
Just z -> redirect z
|
||||
Nothing -> permissionDenied "Please configure authRoute"
|
||||
|
||||
handleUnverified
|
||||
:: YesodAuthVerify master => (a, Bool) -> HandlerT master IO a
|
||||
handleUnverified (v, True) = return v
|
||||
handleUnverified (_v, False) = do
|
||||
aj <- acceptsJson
|
||||
if aj
|
||||
then permissionDenied "Please verify your account first"
|
||||
else do
|
||||
setMessage "Please verify your account first"
|
||||
y <- getYesod
|
||||
when (redirectToCurrent y) setUltDestCurrent
|
||||
redirect $ verificationRoute y
|
||||
|
||||
handleVerified :: YesodAuth master => (a, Bool) -> HandlerT master IO a
|
||||
handleVerified (v, False) = return v
|
||||
handleVerified (_v, True) = do
|
||||
aj <- acceptsJson
|
||||
if aj
|
||||
then permissionDenied "This route is only for unverified users"
|
||||
else do
|
||||
setMessage "This page is only for unverified users"
|
||||
y <- getYesod
|
||||
redirectUltDest $ loginDest y
|
||||
|
||||
-- | Similar to 'maybeAuthId', but redirects to a login page if user is not
|
||||
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
|
||||
--
|
||||
-- @since 1.1.0
|
||||
|
||||
requireUnverifiedAuthId
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuth master
|
||||
, AuthId master ~ Key record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Key record)
|
||||
=> HandlerT master IO (Key record)
|
||||
requireUnverifiedAuthId =
|
||||
maybeAuthIdAllowUnverified >>= maybe handleAuthLack handleVerified
|
||||
|
||||
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
|
||||
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
|
||||
--
|
||||
-- @since 1.1.0
|
||||
|
||||
requireUnverifiedAuth
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuthPersist master
|
||||
, AuthId master ~ Key record
|
||||
, AuthEntity master ~ record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Entity record)
|
||||
=> HandlerT master IO (Entity record)
|
||||
requireUnverifiedAuth =
|
||||
maybeAuthAllowUnverified >>= maybe handleAuthLack handleVerified
|
||||
|
||||
requireAuthIdAllowUnverified
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuth master
|
||||
, AuthId master ~ Key record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Key record, Bool)
|
||||
=> HandlerT master IO (Key record, Bool)
|
||||
requireAuthIdAllowUnverified =
|
||||
maybeAuthIdAllowUnverified >>= maybe handleAuthLack return
|
||||
|
||||
requireAuthAllowUnverified
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuthPersist master
|
||||
, AuthId master ~ Key record
|
||||
, AuthEntity master ~ record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Entity record, Bool)
|
||||
=> HandlerT master IO (Entity record, Bool)
|
||||
requireAuthAllowUnverified =
|
||||
maybeAuthAllowUnverified >>= maybe handleAuthLack return
|
||||
|
||||
requireVerifiedAuthId
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuthVerify master
|
||||
, AuthId master ~ Key record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Key record)
|
||||
=> HandlerT master IO (Key record)
|
||||
requireVerifiedAuthId =
|
||||
maybeAuthIdAllowUnverified >>= maybe handleAuthLack handleUnverified
|
||||
|
||||
requireVerifiedAuth
|
||||
:: ( -- MonadHandler m
|
||||
-- , HandlerSite m ~ master
|
||||
YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, YesodAuthPersist master
|
||||
, YesodAuthVerify master
|
||||
, AuthId master ~ Key record
|
||||
, AuthEntity master ~ record
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable record
|
||||
)
|
||||
-- => m (Entity record)
|
||||
=> HandlerT master IO (Entity record)
|
||||
requireVerifiedAuth =
|
||||
maybeAuthAllowUnverified >>= maybe handleAuthLack handleUnverified
|
158
src/Yesod/SessionEntity.hs
Normal file
158
src/Yesod/SessionEntity.hs
Normal file
|
@ -0,0 +1,158 @@
|
|||
{- 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 ConstraintKinds #-}
|
||||
|
||||
-- | This module allows you to keep a @persistent@ key in the client session,
|
||||
-- and to hold the record for that key in a per-request cache, such that it is
|
||||
-- read from the database exactly once, even if you need to access it in
|
||||
-- multiple places during request handling.
|
||||
--
|
||||
-- Motivation: This is how @yesod-auth@ works, with the ID and record of the
|
||||
-- logged-in user. My use case is to allow my web app to support a few
|
||||
-- operations in unverified login (i.e. log in while the user's email address
|
||||
-- isn't verified yet), that is separate from the regular @yesod-auth@ login.
|
||||
module Yesod.SessionEntity
|
||||
( maybeKey
|
||||
, maybeEntity
|
||||
-- * Remove later when we upgrade to GHC 8
|
||||
, PersistStoreRead
|
||||
, PersistRecordBackend
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.Persist.Class
|
||||
import Database.Persist.Types (Entity (..))
|
||||
import Web.PathPieces (PathPiece (fromPathPiece))
|
||||
import Yesod.Core (MonadHandler (..))
|
||||
import Yesod.Core.Handler (cached, lookupSession)
|
||||
import Yesod.Persist.Core (YesodPersist (..))
|
||||
|
||||
type PersistStoreRead = PersistStore
|
||||
|
||||
type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ backend)
|
||||
|
||||
cachedRecord
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, PersistRecordBackend record backend
|
||||
, Typeable wrapper
|
||||
)
|
||||
=> (Maybe record -> wrapper)
|
||||
-> (wrapper -> Maybe record)
|
||||
-> Key record
|
||||
-> m (Maybe record)
|
||||
cachedRecord wrap unwrap
|
||||
= fmap unwrap
|
||||
. cached
|
||||
. fmap wrap
|
||||
. liftHandlerT
|
||||
. runDB
|
||||
. get
|
||||
|
||||
-- | If the user is logged in via unverified login, grab the user ID from the
|
||||
-- session. Also make sure the user account still exists in the database, and
|
||||
-- cache the record so that further usage doesn't read from the database again.
|
||||
|
||||
maybeKey
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, PersistRecordBackend record backend
|
||||
, PathPiece (Key record)
|
||||
, Typeable wrapper
|
||||
)
|
||||
=> Text
|
||||
-> (Maybe record -> wrapper)
|
||||
-> (wrapper -> Maybe record)
|
||||
-> m (Maybe (Key record))
|
||||
maybeKey key wrap unwrap = runMaybeT $ do
|
||||
s <- MaybeT $ lookupSession key
|
||||
k <- MaybeT $ return $ fromPathPiece s
|
||||
_ <- MaybeT $ cachedRecord wrap unwrap k
|
||||
return k
|
||||
|
||||
-- | Similar to 'maybeAuthId', but additionally look up the value associated
|
||||
-- with the user\'s database identifier to get the value in the database. This
|
||||
-- assumes that you are using a Persistent database.
|
||||
--
|
||||
-- @since 1.1.0
|
||||
|
||||
maybeEntity
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, PersistRecordBackend record backend
|
||||
, PathPiece (Key record)
|
||||
, Typeable wrapper
|
||||
)
|
||||
=> Text
|
||||
-> (Maybe record -> wrapper)
|
||||
-> (wrapper -> Maybe record)
|
||||
-> m (Maybe (Entity record))
|
||||
maybeEntity key wrap unwrap =
|
||||
fmap (uncurry Entity) <$> maybePair key wrap unwrap
|
||||
|
||||
-- | Similar to 'maybeAuth', but doesn’t assume that you are using a
|
||||
-- Persistent database.
|
||||
--
|
||||
-- @since 1.4.0
|
||||
|
||||
maybePair
|
||||
:: ( MonadHandler m
|
||||
, HandlerSite m ~ master
|
||||
, YesodPersist master
|
||||
, YesodPersistBackend master ~ backend
|
||||
, PersistStoreRead backend
|
||||
, PersistRecordBackend record backend
|
||||
, PathPiece (Key record)
|
||||
, Typeable wrapper
|
||||
)
|
||||
=> Text
|
||||
-> (Maybe record -> wrapper)
|
||||
-> (wrapper -> Maybe record)
|
||||
-> m (Maybe (Key record, record))
|
||||
maybePair key wrap unwrap = runMaybeT $ do
|
||||
k <- MaybeT $ maybeKey key wrap unwrap
|
||||
r <- MaybeT $ cachedRecord wrap unwrap k
|
||||
return (k, r)
|
|
@ -93,8 +93,10 @@ library
|
|||
Text.FilePath.Local
|
||||
Text.Jasmine.Local
|
||||
Web.PathPieces.Local
|
||||
Yesod.Auth.Unverified
|
||||
Yesod.Mail.Send
|
||||
Yesod.Paginate.Local
|
||||
Yesod.SessionEntity
|
||||
|
||||
Vervis.Application
|
||||
Vervis.Avatar
|
||||
|
@ -326,7 +328,7 @@ executable vervis
|
|||
build-depends: base, vervis
|
||||
hs-source-dirs: app
|
||||
default-language: Haskell2010
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
|
||||
if flag(library-only)
|
||||
buildable: False
|
||||
|
|
Loading…
Reference in a new issue