diff --git a/Happstack/Authenticate/Core.hs b/Happstack/Authenticate/Core.hs --- a/Happstack/Authenticate/Core.hs +++ b/Happstack/Authenticate/Core.hs @@ -37,6 +37,11 @@ , isAuthAdmin , usernameAcceptable , requireEmail + , systemFromAddress + , systemReplyToAddress + , systemSendmailPath + , postLoginRedirect + , createUserCallback , HappstackAuthenticateI18N(..) , UserId(..) , unUserId @@ -364,6 +369,8 @@ , _systemFromAddress :: Maybe SimpleAddress -- ^ From: line for emails sent by the server , _systemReplyToAddress :: Maybe SimpleAddress -- ^ Reply-To: line for emails sent by the server , _systemSendmailPath :: Maybe FilePath -- ^ path to sendmail if it is not \/usr\/sbin\/sendmail + , _postLoginRedirect :: Maybe Text -- ^ path to redirect to after a successful login + , _createUserCallback :: Maybe (User -> IO ()) -- ^ a function to call when a new user is created. Useful for adding them to mailing lists or other stuff } deriving (Typeable, Generic) makeLenses ''AuthenticateConfig diff --git a/Happstack/Authenticate/OpenId/Route.hs b/Happstack/Authenticate/OpenId/Route.hs --- a/Happstack/Authenticate/OpenId/Route.hs +++ b/Happstack/Authenticate/OpenId/Route.hs @@ -2,6 +2,8 @@ module Happstack.Authenticate.OpenId.Route where import Control.Applicative ((<$>)) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (TVar, readTVar) import Control.Monad.Reader (ReaderT, runReaderT) import Control.Monad.Trans (liftIO) import Data.Acid (AcidState, closeAcidState, makeAcidic) @@ -31,26 +33,28 @@ routeOpenId :: (Happstack m) => AcidState AuthenticateState - -> AuthenticateConfig + -> TVar AuthenticateConfig -> AcidState OpenIdState -> [Text] -> RouteT AuthenticateURL (ReaderT [Lang] m) Response -routeOpenId authenticateState authenticateConfig openIdState pathSegments = +routeOpenId authenticateState authenticateConfigTV openIdState pathSegments = case parseSegments fromPathSegments pathSegments of (Left _) -> notFound $ toJSONError URLDecodeFailed (Right url) -> - case url of - (Partial u) -> - do xml <- unXMLGenT (routePartial authenticateState openIdState u) - ok $ toResponse (html4StrictFrag, xml) - (BeginDance providerURL) -> - do returnURL <- nestOpenIdURL $ showURL ReturnTo - realm <- query' openIdState GetOpenIdRealm - forwardURL <- liftIO $ do manager <- newManager tlsManagerSettings - getForwardUrl providerURL returnURL realm [] manager -- [("Email", "http://schema.openid.net/contact/email")] - seeOther forwardURL (toResponse ()) - ReturnTo -> token authenticateState authenticateConfig openIdState - Realm -> realm authenticateState openIdState + do case url of + (Partial u) -> + do xml <- unXMLGenT (routePartial authenticateState openIdState u) + ok $ toResponse (html4StrictFrag, xml) + (BeginDance providerURL) -> + do returnURL <- nestOpenIdURL $ showURL ReturnTo + realm <- query' openIdState GetOpenIdRealm + forwardURL <- liftIO $ do manager <- newManager tlsManagerSettings + getForwardUrl providerURL returnURL realm [] manager -- [("Email", "http://schema.openid.net/contact/email")] + seeOther forwardURL (toResponse ()) + ReturnTo -> + do authenticateConfig <- liftIO $ atomically $ readTVar authenticateConfigTV + token authenticateState authenticateConfig openIdState + Realm -> realm authenticateState openIdState ------------------------------------------------------------------------------ -- initOpenId @@ -58,9 +62,9 @@ initOpenId :: FilePath -> AcidState AuthenticateState - -> AuthenticateConfig + -> TVar AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) -initOpenId basePath authenticateState authenticateConfig = +initOpenId basePath authenticateState authenticateConfigTV = do openIdState <- openLocalStateFrom (combine basePath "openId") initialOpenIdState let shutdown = \normal -> if normal @@ -70,6 +74,6 @@ do langsOveride <- queryString $ lookTexts' "_LANG" langs <- bestLanguage <$> acceptLanguage mapRouteT (flip runReaderT (langsOveride ++ langs)) $ - routeOpenId authenticateState authenticateConfig openIdState pathSegments + routeOpenId authenticateState authenticateConfigTV openIdState pathSegments return (shutdown, (openIdAuthenticationMethod, authenticationHandler), openIdCtrl authenticateState openIdState) diff --git a/Happstack/Authenticate/Password/Controllers.hs b/Happstack/Authenticate/Password/Controllers.hs --- a/Happstack/Authenticate/Password/Controllers.hs +++ b/Happstack/Authenticate/Password/Controllers.hs @@ -1,22 +1,27 @@ {-# LANGUAGE QuasiQuotes #-} module Happstack.Authenticate.Password.Controllers where +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (TVar, readTVar) +import Control.Monad.Trans (MonadIO(liftIO)) +import Data.Maybe (isJust, fromJust) import Data.Text (Text) import qualified Data.Text as T -import Happstack.Authenticate.Core (AuthenticateURL) +import Happstack.Authenticate.Core (AuthenticateConfig(_postLoginRedirect), AuthenticateURL) import Happstack.Authenticate.Password.URL (PasswordURL(Account, Token, Partial, PasswordReset, PasswordRequestReset), nestPasswordURL) import Happstack.Authenticate.Password.PartialsURL (PartialURL(ChangePassword, Logout, Login, LoginInline, SignupPassword, ResetPasswordForm, RequestResetPasswordForm)) import Language.Javascript.JMacro import Web.Routes -usernamePasswordCtrl :: (Monad m) => RouteT AuthenticateURL m JStat -usernamePasswordCtrl = +usernamePasswordCtrl :: (MonadIO m) => TVar AuthenticateConfig -> RouteT AuthenticateURL m JStat +usernamePasswordCtrl authenticateConfigTV = nestPasswordURL $ do fn <- askRouteFn - return $ usernamePasswordCtrlJs fn + plr <- liftIO (_postLoginRedirect <$> (atomically $ readTVar authenticateConfigTV)) + return $ usernamePasswordCtrlJs plr fn -usernamePasswordCtrlJs :: (PasswordURL -> [(Text, Maybe Text)] -> Text) -> JStat -usernamePasswordCtrlJs showURL = [jmacro| +usernamePasswordCtrlJs :: Maybe Text -> (PasswordURL -> [(Text, Maybe Text)] -> Text) -> JStat +usernamePasswordCtrlJs postLoginRedirect showURL = [jmacro| { var usernamePassword = angular.module('usernamePassword', ['happstackAuthentication']); @@ -38,6 +43,7 @@ if (datum.jrStatus == "Ok") { $scope.username_password_error = ''; userService.updateFromToken(datum.jrData.token); + `loginRedirect postLoginRedirect` } else { userService.clearUser(); $scope.username_password_error = datum.jrData; @@ -299,3 +305,12 @@ } |] + where + loginRedirect (Just plr) = + [jmacro| + // console.log(`"loginRedirect - " ++ show plr`); + window.location.href = `plr`; + |] + loginRedirect Nothing = + BlockStat [] + diff --git a/Happstack/Authenticate/Password/Core.hs b/Happstack/Authenticate/Password/Core.hs --- a/Happstack/Authenticate/Password/Core.hs +++ b/Happstack/Authenticate/Password/Core.hs @@ -30,7 +30,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import Data.UserId (UserId) import GHC.Generics (Generic) -import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod(..), AuthenticateState(..), AuthenticateConfig, usernameAcceptable, requireEmail, AuthenticateURL, CoreError(..), CreateUser(..), Email(..), unEmail, GetUserByUserId(..), GetUserByUsername(..), HappstackAuthenticateI18N(..), SharedSecret(..), SimpleAddress(..), User(..), Username(..), GetSharedSecret(..), addTokenCookie, email, getToken, getOrGenSharedSecret, jsonOptions, userId, username, systemFromAddress, systemReplyToAddress, systemSendmailPath, toJSONSuccess, toJSONResponse, toJSONError, tokenUser) +import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod(..), AuthenticateState(..), AuthenticateConfig, usernameAcceptable, requireEmail, AuthenticateURL, CoreError(..), CreateUser(..), Email(..), unEmail, GetUserByUserId(..), GetUserByUsername(..), HappstackAuthenticateI18N(..), SharedSecret(..), SimpleAddress(..), User(..), Username(..), GetSharedSecret(..), addTokenCookie, createUserCallback, email, getToken, getOrGenSharedSecret, jsonOptions, userId, username, systemFromAddress, systemReplyToAddress, systemSendmailPath, toJSONSuccess, toJSONResponse, toJSONError, tokenUser) import Happstack.Authenticate.Password.URL (AccountURL(..)) import Happstack.Server import HSP.JMacro @@ -281,6 +281,9 @@ (Right user) -> do hashed <- mkHashedPass (_naPassword newAccount) update' passwordState (SetPassword (user ^. userId) hashed) + case (authenticateConfig ^. createUserCallback) of + Nothing -> pure () + (Just callback) -> liftIO $ callback user ok $ (Right (user ^. userId)) where validEmail :: Bool -> Maybe Email -> Maybe PasswordError diff --git a/Happstack/Authenticate/Password/Route.hs b/Happstack/Authenticate/Password/Route.hs --- a/Happstack/Authenticate/Password/Route.hs +++ b/Happstack/Authenticate/Password/Route.hs @@ -2,6 +2,9 @@ import Control.Applicative ((<$>)) import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.Trans (MonadIO(liftIO)) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar) import Data.Acid (AcidState, closeAcidState, makeAcidic) import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom) import Data.Text (Text) @@ -25,24 +28,26 @@ ------------------------------------------------------------------------------ routePassword :: (Happstack m) => - PasswordConfig + TVar PasswordConfig -> AcidState AuthenticateState - -> AuthenticateConfig + -> TVar AuthenticateConfig -> AcidState PasswordState -> [Text] -> RouteT AuthenticateURL (ReaderT [Lang] m) Response -routePassword passwordConfig authenticateState authenticateConfig passwordState pathSegments = +routePassword passwordConfigTV authenticateState authenticateConfigTV passwordState pathSegments = case parseSegments fromPathSegments pathSegments of (Left _) -> notFound $ toJSONError URLDecodeFailed (Right url) -> - case url of - Token -> token authenticateState authenticateConfig passwordState - Account mUrl -> toJSONResponse <$> account authenticateState passwordState authenticateConfig passwordConfig mUrl - (Partial u) -> do xml <- unXMLGenT (routePartial authenticateState u) - return $ toResponse (html4StrictFrag, xml) - PasswordRequestReset -> toJSONResponse <$> passwordRequestReset authenticateConfig passwordConfig authenticateState passwordState - PasswordReset -> toJSONResponse <$> passwordReset authenticateState passwordState passwordConfig - UsernamePasswordCtrl -> toResponse <$> usernamePasswordCtrl + do authenticateConfig <- liftIO $ atomically $ readTVar authenticateConfigTV + passwordConfig <- liftIO $ atomically $ readTVar passwordConfigTV + case url of + Token -> token authenticateState authenticateConfig passwordState + Account mUrl -> toJSONResponse <$> account authenticateState passwordState authenticateConfig passwordConfig mUrl + (Partial u) -> do xml <- unXMLGenT (routePartial authenticateState u) + return $ toResponse (html4StrictFrag, xml) + PasswordRequestReset -> toJSONResponse <$> passwordRequestReset authenticateConfig passwordConfig authenticateState passwordState + PasswordReset -> toJSONResponse <$> passwordReset authenticateState passwordState passwordConfig + UsernamePasswordCtrl -> toResponse <$> usernamePasswordCtrl authenticateConfigTV ------------------------------------------------------------------------------ -- initPassword @@ -51,26 +56,27 @@ initPassword :: PasswordConfig -> FilePath -> AcidState AuthenticateState - -> AuthenticateConfig + -> TVar AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) -initPassword passwordConfig basePath authenticateState authenticateConfig = +initPassword passwordConfig basePath authenticateState authenticateConfigTV = do passwordState <- openLocalStateFrom (combine basePath "password") initialPasswordState - initPassword' passwordConfig passwordState basePath authenticateState authenticateConfig + passwordConfigTV <- atomically $ newTVar passwordConfig + initPassword' passwordConfigTV passwordState basePath authenticateState authenticateConfigTV -initPassword' :: PasswordConfig +initPassword' :: TVar PasswordConfig -> AcidState PasswordState -> FilePath -> AcidState AuthenticateState - -> AuthenticateConfig + -> TVar AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) -initPassword' passwordConfig passwordState basePath authenticateState authenticateConfig = - let shutdown = \normal -> - if normal - then createCheckpointAndClose passwordState - else closeAcidState passwordState - authenticationHandler pathSegments = - do langsOveride <- queryString $ lookTexts' "_LANG" - langs <- bestLanguage <$> acceptLanguage - mapRouteT (flip runReaderT (langsOveride ++ langs)) $ - routePassword passwordConfig authenticateState authenticateConfig passwordState pathSegments - in pure (shutdown, (passwordAuthenticationMethod, authenticationHandler), usernamePasswordCtrl) +initPassword' passwordConfigTV passwordState basePath authenticateState authenticateConfigTV = + do let shutdown = \normal -> + if normal + then createCheckpointAndClose passwordState + else closeAcidState passwordState + authenticationHandler pathSegments = + do langsOveride <- queryString $ lookTexts' "_LANG" + langs <- bestLanguage <$> acceptLanguage + mapRouteT (flip runReaderT (langsOveride ++ langs)) $ + routePassword passwordConfigTV authenticateState authenticateConfigTV passwordState pathSegments + pure (shutdown, (passwordAuthenticationMethod, authenticationHandler), usernamePasswordCtrl authenticateConfigTV) diff --git a/Happstack/Authenticate/Route.hs b/Happstack/Authenticate/Route.hs --- a/Happstack/Authenticate/Route.hs +++ b/Happstack/Authenticate/Route.hs @@ -2,6 +2,8 @@ module Happstack.Authenticate.Route where import Control.Applicative ((<$>)) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (TVar, newTVar) import Control.Monad.Trans (MonadIO(liftIO)) import Data.Acid (AcidState) import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose) @@ -47,16 +49,17 @@ initAuthentication :: Maybe FilePath -> AuthenticateConfig - -> [FilePath -> AcidState AuthenticateState -> AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)] - -> IO (IO (), AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response, AcidState AuthenticateState) + -> [FilePath -> AcidState AuthenticateState -> TVar AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)] + -> IO (IO (), AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response, AcidState AuthenticateState, TVar AuthenticateConfig) initAuthentication mBasePath authenticateConfig initMethods = do let authenticatePath = combine (fromMaybe "state" mBasePath) "authenticate" authenticateState <- openLocalStateFrom (combine authenticatePath "core") initialAuthenticateState + authenticateConfigTV <- atomically $ newTVar authenticateConfig -- FIXME: need to deal with one of the initMethods throwing an exception - (cleanupPartial, handlers, javascript) <- unzip3 <$> mapM (\initMethod -> initMethod authenticatePath authenticateState authenticateConfig) initMethods + (cleanupPartial, handlers, javascript) <- unzip3 <$> mapM (\initMethod -> initMethod authenticatePath authenticateState authenticateConfigTV) initMethods let cleanup = sequence_ $ createCheckpointAndClose authenticateState : (map (\c -> c True) cleanupPartial) h = route javascript (Map.fromList handlers) - return (cleanup, h, authenticateState) + return (cleanup, h, authenticateState, authenticateConfigTV) instance (Functor m, MonadIO m) => IntegerSupply (RouteT AuthenticateURL m) where nextInteger = diff --git a/happstack-authenticate.cabal b/happstack-authenticate.cabal --- a/happstack-authenticate.cabal +++ b/happstack-authenticate.cabal @@ -1,5 +1,5 @@ Name: happstack-authenticate -Version: 2.5.1 +Version: 2.6.0 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId. Homepage: http://www.happstack.com/ @@ -11,7 +11,7 @@ Category: Web Build-type: Simple Cabal-version: >=1.10 -tested-with: GHC==8.0.1, GHC==8.2.2, GHC==8.4.1, GHC==8.6.5, GHC==8.8.3, GHC==8.10.2 +tested-with: GHC==8.0.1, GHC==8.2.2, GHC==8.4.1, GHC==8.6.5, GHC==8.8.3, GHC==8.10.7 data-files: messages/core/en.msg messages/openid/error/en.msg @@ -69,6 +69,7 @@ mtl >= 2.0 && < 2.3, lens >= 4.2 && < 4.20, pwstore-purehaskell == 2.1.*, + stm >= 2.5 && < 2.6, text >= 0.11 && < 1.3, time >= 1.2 && < 1.12, userid >= 0.1 && < 0.2,