diff --git a/src/Yesod/Auth/Unverified.hs b/src/Yesod/Auth/Unverified.hs new file mode 100644 index 0000000..e53ff08 --- /dev/null +++ b/src/Yesod/Auth/Unverified.hs @@ -0,0 +1,349 @@ +{- 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. + -} + +-- | 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 diff --git a/src/Yesod/SessionEntity.hs b/src/Yesod/SessionEntity.hs new file mode 100644 index 0000000..acbf36b --- /dev/null +++ b/src/Yesod/SessionEntity.hs @@ -0,0 +1,158 @@ +{- 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 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) diff --git a/vervis.cabal b/vervis.cabal index 2f88316..1794061 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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