Write unverified login user functions

src/Yesod/Auth/Unverified.hs

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

src/Yesod/SessionEntity.hs

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

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