diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 479e50a97..32e0f0ec9 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -245,7 +245,7 @@ instance RenderMessage UniWorX HelpIdentOptions where data HelpForm = HelpForm { hfReferer:: Maybe Text - , hfUserId :: Either (Maybe Email) UserId + , hfUserId :: Either (Maybe Address) UserId , hfRequest:: Text } @@ -256,13 +256,13 @@ helpForm mReferer mUid = HelpForm <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) <* submitButton where - identActions :: Map _ (AForm _ (Either (Maybe Email) UserId)) + identActions :: Map _ (AForm _ (Either (Maybe Address) UserId)) identActions = Map.fromList $ case mUid of (Just uid) -> (HIUser, pure $ Right uid):defaultActions Nothing -> defaultActions defaultActions = - [ (HIEmail, Left . Just <$> apreq emailField (fslI MsgEMail) Nothing) + [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing)) , (HIAnonymous, pure $ Left Nothing) ] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9d80282a3..6983ce3de 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -42,6 +42,8 @@ import Control.Monad.Morph as Import (MFunctor(..)) import Control.Monad.Trans.Resource as Import (ReleaseKey) +import Network.Mail.Mime.Instances as Import () + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index d1f98d5ad..1ec904e2b 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -14,7 +14,7 @@ import Utils.Lens import Data.Bitraversable -dispatchJobHelpRequest :: Either (Maybe Email) UserId +dispatchJobHelpRequest :: Either (Maybe Address) UserId -> UTCTime -> Text -- ^ Help Request -> Maybe Text -- ^ Referer @@ -22,9 +22,10 @@ dispatchJobHelpRequest :: Either (Maybe Email) UserId dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do supportAddress <- getsYesod $ appMailSupport . appSettings userInfo <- bitraverse return (runDB . getEntity) jSender - let userAddress = either (fmap $ Address Nothing) - (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) - userInfo + let userAddress = either + id + (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) + userInfo mailT def $ do _mailTo .= [supportAddress] whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 6a6e65109..b07fcaf52 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -15,7 +15,7 @@ import Data.List.NonEmpty (NonEmpty) data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } | JobQueueNotification { jNotification :: Notification } - | JobHelpRequest { jSender :: Either (Maybe Email) UserId + | JobHelpRequest { jSender :: Either (Maybe Address) UserId , jRequestTime :: UTCTime , jHelpRequest :: Text, jReferer :: Maybe Text } | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs new file mode 100644 index 000000000..b7d1b26d6 --- /dev/null +++ b/src/Network/Mail/Mime/Instances.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.Mail.Mime.Instances + ( + ) where + +import ClassyPrelude +import Network.Mail.Mime +import Data.Hashable (Hashable) + +import Data.Aeson +import Data.Aeson.TH + +import Utils.PathPiece + + +deriving instance Read Address +deriving instance Ord Address +deriving instance Generic Address + +instance Hashable Address + +deriveJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''Address diff --git a/src/Settings.hs b/src/Settings.hs index b91a2b6a4..b05ae3c5d 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -49,6 +49,7 @@ import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, Auth import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) import Network.Mail.Mime (Address) +import Network.Mail.Mime.Instances () import Mail (VerpMode) @@ -255,12 +256,6 @@ deriveFromJSON } ''SmtpAuthConf -deriveFromJSON - defaultOptions - { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } - ''Address - instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do diff --git a/templates/mail/support.hamlet b/templates/mail/support.hamlet index 1b3d7e1f7..da915339e 100644 --- a/templates/mail/support.hamlet +++ b/templates/mail/support.hamlet @@ -6,9 +6,12 @@ $newline never