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 @@ -60,6 +65,7 @@ , IxUser , SharedSecret(..) , unSharedSecret + , SimpleAddress(..) , genSharedSecret , genSharedSecretDevURandom , genSharedSecretSysRandom @@ -87,6 +93,8 @@ , GetUserByUsername(..) , GetUserByUserId(..) , GetUserByEmail(..) + , GetUsers(..) + , GetUsersByEmail(..) , GetAuthenticateState(..) , getOrGenSharedSecret , Token(..) @@ -110,6 +118,9 @@ , AuthenticateURL(..) , rAuthenticationMethods , rControllers + , systemFromAddress + , systemReplyToAddress + , systemSendmailPath , authenticateURL , nestAuthenticationMethod ) where @@ -136,7 +147,7 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, maybeToList) import Data.Monoid ((<>), mconcat, mempty) -import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) +import Data.SafeCopy (SafeCopy, Migrate(..), base, deriveSafeCopy, extension) import Data.IxSet.Typed import qualified Data.IxSet.Typed as IxSet import Data.Set (Set) @@ -157,6 +168,7 @@ import Text.Boomerang.TH (makeBoomerangs) import Text.Shakespeare.I18N (RenderMessage(renderMessage), mkMessageFor) import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, secondsSinceEpoch, intDate, verify) +import qualified Web.JWT as JWT #if MIN_VERSION_jwt(0,8,0) import Web.JWT (ClaimsMap(..), hmacSecret) #else @@ -335,14 +347,31 @@ (ixFun $ maybeToList . view email) ------------------------------------------------------------------------------ +-- SimpleAddress +------------------------------------------------------------------------------ + +data SimpleAddress = SimpleAddress + { _saName :: Maybe Text + , _saEmail :: Email + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +deriveSafeCopy 0 'base ''SimpleAddress +makeLenses ''SimpleAddress + +------------------------------------------------------------------------------ -- AuthenticateConfig ------------------------------------------------------------------------------ -- | Various configuration options that apply to all authentication methods data AuthenticateConfig = AuthenticateConfig - { _isAuthAdmin :: UserId -> IO Bool -- ^ can user administrate the authentication system? - , _usernameAcceptable :: Username -> Maybe CoreError -- ^ enforce username policies, valid email, etc. 'Nothing' == ok, 'Just Text' == error message - , _requireEmail :: Bool + { _isAuthAdmin :: UserId -> IO Bool -- ^ can user administrate the authentication system? + , _usernameAcceptable :: Username -> Maybe CoreError -- ^ enforce username policies, valid email, etc. 'Nothing' == ok, 'Just Text' == error message + , _requireEmail :: Bool -- ^ require use to supply an email address when creating an account + , _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 @@ -556,6 +585,13 @@ do us <- view users return $ getOne $ us @= userId +-- | find all 'Users' +-- +getUsers :: Query AuthenticateState (Set User) +getUsers = + do us <- view users + return $ toSet $ us + -- | look up a 'User' by their 'Email' -- -- NOTE: if the email is associated with more than one account this will return 'Nothing' @@ -565,6 +601,14 @@ do us <- view users return $ getOne $ us @= email +-- | find all 'Users' which match 'Email' +-- +getUsersByEmail :: Email + -> Query AuthenticateState (Set User) +getUsersByEmail email = + do us <- view users + return $ toSet $ us @= email + -- | get the entire AuthenticateState value getAuthenticateState :: Query AuthenticateState AuthenticateState getAuthenticateState = ask @@ -582,7 +626,9 @@ , 'deleteUser , 'getUserByUsername , 'getUserByUserId + , 'getUsers , 'getUserByEmail + , 'getUsersByEmail , 'getAuthenticateState ] @@ -689,7 +735,9 @@ Nothing -> return Nothing (Just ssecret) -> -- finally we can verify all the claims -#if MIN_VERSION_jwt(0,8,0) +#if MIN_VERSION_jwt(0,11,0) + case verify (JWT.toVerify $ hmacSecret (_unSharedSecret ssecret)) unverified of +#elif MIN_VERSION_jwt(0,8,0) case verify (hmacSecret (_unSharedSecret ssecret)) unverified of #else case verify (secret (_unSharedSecret ssecret)) unverified of diff --git a/Happstack/Authenticate/OpenId/Controllers.hs b/Happstack/Authenticate/OpenId/Controllers.hs --- a/Happstack/Authenticate/OpenId/Controllers.hs +++ b/Happstack/Authenticate/OpenId/Controllers.hs @@ -11,7 +11,7 @@ import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, getToken, tokenIsAuthAdmin) import Happstack.Authenticate.OpenId.Core (GetOpenIdRealm(..), OpenIdState) import Happstack.Authenticate.OpenId.URL (OpenIdURL(BeginDance, Partial, ReturnTo), nestOpenIdURL) -import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(UsingGoogle, UsingYahoo, RealmForm)) +import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(UsingYahoo, RealmForm)) import Happstack.Server (Happstack) import Language.Javascript.JMacro import Web.Routes @@ -70,14 +70,6 @@ error(callback); }; }]); - - openId.directive('openidGoogle', ['$rootScope', function ($rootScope) { - return { - restrict: 'E', - replace: true, - templateUrl: `(showURL (Partial UsingGoogle) [])` - }; - }]); openId.directive('openidYahoo', ['$rootScope', function ($rootScope) { return { diff --git a/Happstack/Authenticate/OpenId/Core.hs b/Happstack/Authenticate/OpenId/Core.hs --- a/Happstack/Authenticate/OpenId/Core.hs +++ b/Happstack/Authenticate/OpenId/Core.hs @@ -82,12 +82,14 @@ , _openIdRealm :: Maybe Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) -deriveSafeCopy 2 'extension ''OpenIdState -makeLenses ''OpenIdState instance Migrate OpenIdState where type MigrateFrom OpenIdState = OpenIdState_1 migrate (OpenIdState_1 ids) = OpenIdState ids Nothing + +deriveSafeCopy 2 'extension ''OpenIdState +makeLenses ''OpenIdState + initialOpenIdState :: OpenIdState initialOpenIdState = OpenIdState diff --git a/Happstack/Authenticate/OpenId/Partials.hs b/Happstack/Authenticate/OpenId/Partials.hs --- a/Happstack/Authenticate/OpenId/Partials.hs +++ b/Happstack/Authenticate/OpenId/Partials.hs @@ -26,7 +26,7 @@ import HSP.JMacro () import Prelude hiding ((.), id) import Text.Shakespeare.I18N (Lang, mkMessageFor, renderMessage) -import Web.Authenticate.OpenId.Providers (google, yahoo) +import Web.Authenticate.OpenId.Providers (yahoo) import Web.Routes import Web.Routes.XMLGenT () import Web.Routes.TH (derivePathInfo) @@ -35,8 +35,7 @@ type Partial m = XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) data PartialMsgs - = UsingGoogleMsg - | UsingYahooMsg + = UsingYahooMsg | SetRealmMsg | OpenIdRealmMsg @@ -60,24 +59,15 @@ -> Partial m XML routePartial authenticateState openIdState url = case url of - UsingGoogle -> usingGoogle UsingYahoo -> usingYahoo RealmForm -> realmForm openIdState -usingGoogle :: (Functor m, Monad m) => - Partial m XML -usingGoogle = - do danceURL <- lift $ nestOpenIdURL $ showURL (BeginDance (Text.pack google)) - [hsx| - danceURL <> "')")>UsingGoogleMsg - |] - usingYahoo :: (Functor m, Monad m) => Partial m XML usingYahoo = do danceURL <- lift $ nestOpenIdURL $ showURL (BeginDance (Text.pack yahoo)) [hsx| - danceURL <> "')")>UsingYahooMsg + danceURL <> "')")>UsingYahooMsg |] realmForm diff --git a/Happstack/Authenticate/OpenId/PartialsURL.hs b/Happstack/Authenticate/OpenId/PartialsURL.hs --- a/Happstack/Authenticate/OpenId/PartialsURL.hs +++ b/Happstack/Authenticate/OpenId/PartialsURL.hs @@ -10,8 +10,7 @@ import Web.Routes.Boomerang (Router, (:-), (<>), boomerangFromPathSegments, boomerangToPathSegments) data PartialURL - = UsingGoogle - | UsingYahoo + = UsingYahoo | RealmForm deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) @@ -19,8 +18,7 @@ partialURL :: Router () (PartialURL :- ()) partialURL = - ( "using-google" . rUsingGoogle - <> "using-yahoo" . rUsingYahoo + ( "using-yahoo" . rUsingYahoo <> "realm" . rRealmForm ) 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings, StandaloneDeriving #-} module Happstack.Authenticate.Password.Core where import Control.Applicative ((<$>), optional) @@ -13,6 +13,9 @@ import qualified Data.Aeson as Aeson import Data.Aeson (Value(..), Object(..), Result(..), decode, encode, fromJSON) import Data.Aeson.Types (ToJSON(..), FromJSON(..), Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KM +#endif import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as B import Data.Data (Data, Typeable) @@ -21,7 +24,7 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, fromJust) import Data.Monoid ((<>), mempty) -import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) +import Data.SafeCopy (SafeCopy, Migrate(..), base, extension, deriveSafeCopy) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -30,13 +33,13 @@ 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, GetUserByUsername(..), HappstackAuthenticateI18N(..), SharedSecret(..), User(..), Username(..), GetSharedSecret(..), addTokenCookie, email, getToken, getOrGenSharedSecret, jsonOptions, userId, username, 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 import Language.Javascript.JMacro import Network.HTTP.Types (toQuery, renderQuery) -import Network.Mail.Mime (Address(..), Mail, simpleMail', renderMail', renderSendMail, sendmail) +import Network.Mail.Mime (Address(..), Mail(..), simpleMail', renderMail', renderSendMail, renderSendMailCustom, sendmail) import System.FilePath (combine) import qualified Text.Email.Validate as Email import Text.Shakespeare.I18N (RenderMessage(..), Lang, mkMessageFor) @@ -127,7 +130,7 @@ initialPasswordState :: PasswordState initialPasswordState = PasswordState - { _passwords = Map.empty + { _passwords = Map.empty } ------------------------------------------------------------------------------ @@ -220,7 +223,11 @@ if not valid then unauthorized $ toJSONError InvalidUsernamePassword else do token <- addTokenCookie authenticateState authenticateConfig u +#if MIN_VERSION_aeson(2,0,0) + resp 201 $ toJSONSuccess (Object $ KM.fromList [("token", toJSON token)]) -- toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)] +#else resp 201 $ toJSONSuccess (Object $ HashMap.fromList [("token", toJSON token)]) -- toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)] +#endif ------------------------------------------------------------------------------ -- account @@ -281,6 +288,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 @@ -338,11 +348,12 @@ -- | request reset password passwordRequestReset :: (Happstack m) => - PasswordConfig + AuthenticateConfig + -> PasswordConfig -> AcidState AuthenticateState -> AcidState PasswordState -> m (Either PasswordError Text) -passwordRequestReset passwordConfig authenticateState passwordState = +passwordRequestReset authenticateConfig passwordConfig authenticateState passwordState = do method POST ~(Just (Body body)) <- takeRequestBody =<< askRq case Aeson.decode body of @@ -355,28 +366,39 @@ case user ^. email of Nothing -> return $ Left NoEmailAddress (Just toEm) -> - do eResetToken <- issueResetToken authenticateState user - case eResetToken of - (Left err) -> return (Left err) - (Right resetToken) -> - do let resetLink' = (passwordConfig ^. resetLink) <> (Text.decodeUtf8 $ renderQuery True $ toQuery [("reset_token"::Text, resetToken)]) - liftIO $ Text.putStrLn resetLink' -- FIXME: don't print to stdout - sendResetEmail toEm (Email ("no-reply@" <> (passwordConfig ^. domain))) resetLink' - return (Right "password reset request email sent.") -- FIXME: I18N + do resetToken <- issueResetToken authenticateState user + let resetLink' = resetTokenLink (passwordConfig ^. resetLink) resetToken + -- liftIO $ Text.putStrLn resetLink' -- FIXME: don't print to stdout + let from = fromMaybe (SimpleAddress Nothing (Email ("no-reply@" <> (passwordConfig ^. domain)))) (authenticateConfig ^. systemFromAddress) + sendResetEmail (authenticateConfig ^. systemSendmailPath) toEm from (authenticateConfig ^. systemReplyToAddress) resetLink' + return (Right "password reset request email sent.") -- FIXME: I18N +-- | generate a reset token for a UserId +resetTokenForUserId :: Text -> AcidState AuthenticateState -> AcidState PasswordState -> UserId -> IO (Either PasswordError Text) +resetTokenForUserId resetLink authenticateState passwordState userId = + do mUser <- query' authenticateState (GetUserByUserId userId) + case mUser of + Nothing -> pure $ Left (CoreError InvalidUserId) + (Just user) -> + do resetToken <- issueResetToken authenticateState user + pure $ Right $ resetTokenLink resetLink resetToken + +-- | create a link for a reset token +resetTokenLink :: Text -- ^ base URI + -> Text -- ^ reset token + -> Text +resetTokenLink baseURI resetToken = baseURI <> (Text.decodeUtf8 $ renderQuery True $ toQuery [("reset_token"::Text, resetToken)]) + -- | issueResetToken issueResetToken :: (MonadIO m) => AcidState AuthenticateState -> User - -> m (Either PasswordError Text) + -> m Text issueResetToken authenticateState user = - case user ^. email of - Nothing -> return (Left NoEmailAddress) - (Just addr) -> - do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) - -- FIXME: add expiration time - now <- liftIO getPOSIXTime - let claims = JWT.JWTClaimsSet + do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) + -- FIXME: add expiration time + now <- liftIO getPOSIXTime + let claims = JWT.JWTClaimsSet { JWT.iss = Nothing , JWT.sub = Nothing , JWT.aud = Nothing @@ -391,24 +413,32 @@ Map.singleton "reset-password" (toJSON user) } #if MIN_VERSION_jwt(0,10,0) - return $ Right $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) mempty claims + return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) mempty claims #elif MIN_VERSION_jwt(0,9,0) - return $ Right $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) claims + return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) claims #else - return $ Right $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims + return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims #endif -- FIXME: I18N -- FIXME: call renderSendMail sendResetEmail :: (MonadIO m) => - Email + Maybe FilePath -> Email + -> SimpleAddress + -> Maybe SimpleAddress -> Text -> m () -sendResetEmail (Email toEm) (Email fromEm) resetLink = liftIO $ - do mailBS <- renderMail' $ simpleMail' (Address Nothing toEm) (Address (Just "no-reply") fromEm) "Reset Password Request" (LT.fromStrict resetLink) - -- B.putStr mailBS - sendmail mailBS +sendResetEmail mSendmailPath (Email toEm) (SimpleAddress fromNm (Email fromEm)) mReplyTo resetLink = liftIO $ + do let mail = addReplyTo mReplyTo $ simpleMail' (Address Nothing toEm) (Address fromNm fromEm) "Reset Password Request" (LT.fromStrict resetLink) + case mSendmailPath of + Nothing -> renderSendMail mail + (Just sendmailPath) -> renderSendMailCustom sendmailPath ["-t"] mail + where + addReplyTo :: Maybe SimpleAddress -> Mail -> Mail + addReplyTo Nothing m = m + addReplyTo (Just (SimpleAddress rplyToNm rplyToEm)) m = + let m' = m { mailHeaders = (mailHeaders m) } in m' -- | JSON record for new account data data ResetPasswordData = ResetPasswordData @@ -487,7 +517,9 @@ case mssecret of Nothing -> return Nothing (Just ssecret) -> -#if MIN_VERSION_jwt(0,8,0) +#if MIN_VERSION_jwt(0,11,0) + case verify (JWT.toVerify $ hmacSecret (_unSharedSecret ssecret)) unverified of +#elif MIN_VERSION_jwt(0,8,0) case verify (hmacSecret (_unSharedSecret ssecret)) unverified of #else case verify (secret (_unSharedSecret ssecret)) unverified of 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 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,17 +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 - 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 - return (shutdown, (passwordAuthenticationMethod, authenticationHandler), usernamePasswordCtrl) + passwordConfigTV <- atomically $ newTVar passwordConfig + initPassword' passwordConfigTV passwordState basePath authenticateState authenticateConfigTV + +initPassword' :: TVar PasswordConfig + -> AcidState PasswordState + -> FilePath + -> AcidState AuthenticateState + -> TVar AuthenticateConfig + -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) +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.3.4.16 +Version: 2.6.1 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId. Homepage: http://www.happstack.com/ @@ -10,8 +10,8 @@ Copyright: 2011-2015 SeeReason Partners, LLC Category: Web Build-type: Simple -Cabal-version: >=1.8 -tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.6.3 +Cabal-version: >=1.10 +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2 data-files: messages/core/en.msg messages/openid/error/en.msg @@ -24,6 +24,7 @@ location: https://github.com/Happstack/happstack-authenticate.git Library + Default-language: Haskell2010 Exposed-modules: Happstack.Authenticate.Core Happstack.Authenticate.Controller Happstack.Authenticate.Route @@ -42,36 +43,37 @@ Build-depends: base > 4 && < 5, - acid-state >= 0.6 && < 0.16, - aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.5), + acid-state >= 0.6 && < 0.17, + aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.6) || (>= 2.0 && < 2.1), authenticate == 1.3.*, - base64-bytestring >= 1.0 && < 1.1, + base64-bytestring >= 1.0 && < 1.3, boomerang >= 1.4 && < 1.5, - bytestring >= 0.9 && < 0.11, + bytestring >= 0.9 && < 0.12, containers >= 0.4 && < 0.7, data-default >= 0.5 && < 0.8, email-validate >= 2.1 && < 2.4, filepath >= 1.3 && < 1.5, hsx2hs >= 0.13 && < 0.15, jmacro >= 0.6.11 && < 0.7, - jwt >= 0.3 && < 0.11, - ixset-typed >= 0.3 && < 0.5, + jwt >= 0.3 && < 0.12, + ixset-typed >= 0.3 && < 0.6, happstack-jmacro >= 7.0 && < 7.1, - happstack-server >= 6.0 && < 7.6, + happstack-server >= 6.0 && < 7.8, happstack-hsp >= 7.3 && < 7.4, http-conduit >= 2.1.0 && < 2.4, http-types >= 0.6 && < 0.13, hsp >= 0.10 && < 0.11, hsx-jmacro >= 7.3 && < 7.4, - safecopy >= 0.8 && < 0.10, + safecopy >= 0.8 && < 0.11, mime-mail >= 0.4 && < 0.6, mtl >= 2.0 && < 2.3, - lens >= 4.2 && < 4.18, + lens >= 4.2 && < 5.2, pwstore-purehaskell == 2.1.*, - text >= 0.11 && < 1.3, - time >= 1.2 && < 1.10, + stm >= 2.4 && < 2.6, + text >= 0.11 && < 2.1, + time >= 1.2 && < 1.14, userid >= 0.1 && < 0.2, - random >= 1.0 && < 1.2, + random >= 1.0 && < 1.3, shakespeare >= 2.0 && < 2.1, unordered-containers == 0.2.*, web-routes >= 0.26 && < 0.28, diff --git a/messages/openid/partials/en.msg b/messages/openid/partials/en.msg --- a/messages/openid/partials/en.msg +++ b/messages/openid/partials/en.msg @@ -1,4 +1,3 @@ -UsingGoogleMsg: Google OpenId UsingYahooMsg: Yahoo OpenId SetRealmMsg: Update OpenId Realm OpenIdRealmMsg: OpenId Realm