diff --git a/Happstack/Authenticate/Core.hs b/Happstack/Authenticate/Core.hs --- a/Happstack/Authenticate/Core.hs +++ b/Happstack/Authenticate/Core.hs @@ -60,6 +60,7 @@ , IxUser , SharedSecret(..) , unSharedSecret + , SimpleAddress(..) , genSharedSecret , genSharedSecretDevURandom , genSharedSecretSysRandom @@ -110,6 +111,9 @@ , AuthenticateURL(..) , rAuthenticationMethods , rControllers + , systemFromAddress + , systemReplyToAddress + , systemSendmailPath , authenticateURL , nestAuthenticationMethod ) where @@ -136,7 +140,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) @@ -335,14 +339,29 @@ (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 } deriving (Typeable, Generic) makeLenses ''AuthenticateConfig 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/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/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) @@ -21,7 +21,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 +30,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, GetUserByUsername(..), HappstackAuthenticateI18N(..), SharedSecret(..), SimpleAddress(..), User(..), Username(..), GetSharedSecret(..), addTokenCookie, 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 +127,7 @@ initialPasswordState :: PasswordState initialPasswordState = PasswordState - { _passwords = Map.empty + { _passwords = Map.empty } ------------------------------------------------------------------------------ @@ -338,11 +338,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 @@ -361,7 +362,8 @@ (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' + 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 -- | issueResetToken @@ -401,14 +403,22 @@ -- 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 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 @@ -40,7 +40,7 @@ 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 + PasswordRequestReset -> toJSONResponse <$> passwordRequestReset authenticateConfig passwordConfig authenticateState passwordState PasswordReset -> toJSONResponse <$> passwordReset authenticateState passwordState passwordConfig UsernamePasswordCtrl -> toResponse <$> usernamePasswordCtrl 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.4.0 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId. Homepage: http://www.happstack.com/ 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