Feature to forward mail

This patch implements forwarding of e-mails. Mails which are forwarded
are encapsulated as inline mails. The subject is set to a combination of
from address and subject of the encapsulated mail.

Fixes #314

src/Config/Main.hs

@@ -47,7 +47,8 @@ import UI.Index.Keybindings
 import UI.Mail.Keybindings
        (displayMailKeybindings, mailViewManageMailTagsKeybindings,
         mailAttachmentsKeybindings, openWithKeybindings,
-        pipeToKeybindings, findWordEditorKeybindings, saveToDiskKeybindings)
+        pipeToKeybindings, findWordEditorKeybindings,
+        saveToDiskKeybindings, mailviewComposeToKeybindings)
 import UI.Help.Keybindings (helpKeybindings)
 import UI.ComposeEditor.Keybindings
        (listOfAttachmentsKeybindings, composeFromKeybindings,
@@ -221,6 +222,7 @@ defaultConfig =
       , _mvPipeToKeybindings = pipeToKeybindings
       , _mvFindWordEditorKeybindings = findWordEditorKeybindings
       , _mvSaveToDiskKeybindings = saveToDiskKeybindings
+      , _mvToKeybindings = mailviewComposeToKeybindings
       , _mvMailcap =
           [ ( matchContentType "text" (Just "html")
             , MailcapHandler (Shell (fromList "elinks -force-html")) CopiousOutput DiscardTempfile)

src/Storage/ParsedMail.hs

@@ -31,6 +31,7 @@ module Storage.ParsedMail (
   -- ** Header data
   , getTo
   , getSubject
+  , getForwardedSubject
   , getFrom
   , toQuotedMail
   , takeFileName
@@ -100,6 +101,13 @@ getSubject = getHeader "subject"
 getTo :: Message s a -> T.Text
 getTo = getHeader "to"
 
+-- | Returns the subject line formatted for forwarding.
+--
+getForwardedSubject ::
+     Message s a -- ^ the encapsulated mail
+  -> T.Text
+getForwardedSubject m = "[" <> getFrom m <> ": " <> getSubject m <> "]"
+
 -- | Create a list of steps to record which absolute positions
 -- brick/the terminal should scroll.
 makeScrollSteps :: MailBody -> [ScrollStep]

src/Types.hs

@@ -500,6 +500,8 @@ data MailViewSettings = MailViewSettings
     , _mvFindWordEditorKeybindings :: [Keybinding 'ViewMail 'ScrollingMailViewFindWordEditor]
     , _mvMailcap :: [(ContentType -> Bool, MailcapHandler)]
     , _mvSaveToDiskKeybindings :: [Keybinding 'ViewMail 'SaveToDiskPathEditor]
+    -- used for forwarding mails
+    , _mvToKeybindings :: [Keybinding 'ViewMail 'ComposeTo]
     }
     deriving (Generic, NFData)
 
@@ -539,6 +541,9 @@ mvMailcap = lens _mvMailcap (\s x -> s { _mvMailcap = x })
 mvSaveToDiskKeybindings :: Lens' MailViewSettings [Keybinding 'ViewMail 'SaveToDiskPathEditor]
 mvSaveToDiskKeybindings = lens _mvSaveToDiskKeybindings (\s x -> s { _mvSaveToDiskKeybindings = x })
 
+mvToKeybindings :: Lens' MailViewSettings [Keybinding 'ViewMail 'ComposeTo]
+mvToKeybindings = lens _mvToKeybindings (\s x -> s { _mvToKeybindings = x })
+
 hasCopiousoutput :: Traversal' [(ContentType -> Bool, MailcapHandler)] (ContentType -> Bool, MailcapHandler)
 hasCopiousoutput = traversed . filtered (view (_2 . mhCopiousoutput . to isCopiousOutput))
 

src/UI/Actions.hs

@@ -1,5 +1,5 @@
 -- This file is part of purebred
--- Copyright (C) 2017-2019 Róman Joost and Fraser Tweedale
+-- Copyright (C) 2017-2020 Róman Joost and Fraser Tweedale
 --
 -- purebred is free software: you can redistribute it and/or modify
 -- it under the terms of the GNU Affero General Public License as published by
@@ -72,6 +72,7 @@ module UI.Actions (
   , toggleHeaders
   , switchComposeEditor
   , replyMail
+  , encapsulateMail
   , selectNextUnread
   , composeAsNew
   , createAttachments
@@ -145,12 +146,12 @@ import Data.MIME
         contentDisposition, dispositionType, headers, filename,
         parseContentType, attachments, entities, matchContentType,
         contentType, mailboxList, renderMailboxes, addressList, renderAddresses,
-        renderRFC5422Date, MIMEMessage, WireEntity, DispositionType(..),
+        renderRFC5422Date, encapsulate, MIMEMessage, WireEntity, DispositionType(..),
         ContentType(..), Mailbox(..),
         CharsetLookup)
 import qualified Storage.Notmuch as Notmuch
 import Storage.ParsedMail
-       ( parseMail, getTo, getFrom, getSubject, toQuotedMail
+       ( parseMail, getTo, getFrom, getSubject, getForwardedSubject, toQuotedMail
        , entityToBytes, toMIMEMessage, takeFileName, bodyToDisplay
        , removeMatchingWords, findMatchingWords, makeScrollSteps
        , writeEntityToPath)
@@ -308,8 +309,11 @@ completeMailTags s =
                       <$> selectedItemHelper (asMailIndex . miListOfMails) s (manageMailTags s ops')
 
 instance Completable 'ComposeTo where
-  complete _ = pure . set (asViews . vsViews . at ComposeView . _Just
-                           . vLayers . ix 1 . ix ComposeTo . veState) Hidden
+  complete _ = pure
+               . set (asViews . vsViews . at ComposeView . _Just
+                      . vLayers . ix 1 . ix ComposeTo . veState) Hidden
+               . set (asViews . vsViews . at ViewMail . _Just
+                      . vLayers . ix 0 . ix ComposeTo . veState) Hidden
 
 instance Completable 'ComposeFrom where
   complete _ = pure . set (asViews . vsViews . at ComposeView . _Just
@@ -448,6 +452,12 @@ instance Resetable 'ViewMail 'SaveToDiskPathEditor where
             . set (asViews . vsViews . at ViewMail . _Just . vLayers . ix 0
                    . ix SaveToDiskPathEditor . veState) Hidden
 
+instance Resetable 'ViewMail 'ComposeTo where
+  reset _ _ s = pure $ s & over (asCompose . cTo . E.editContentsL) (revertEditorContents s)
+                . set (asViews . vsViews . at ViewMail . _Just . vLayers . ix 0
+                       . ix ComposeTo . veState) Hidden
+                . clearMailComposition
+
 -- | Reset the composition state for a new mail
 --
 clearMailComposition :: AppState -> AppState
@@ -536,6 +546,11 @@ instance Focusable 'ViewMail 'SaveToDiskPathEditor where
                        . over (asMailView . mvSaveToDiskPath . E.editContentsL) (insertMany fname . clearZipper)
     in switch s
 
+instance Focusable 'ViewMail 'ComposeTo where
+  switchFocus _ _ = pure . set (asViews . vsViews . at ViewMail . _Just . vFocus) ComposeTo
+                    . set (asViews . vsViews . at ViewMail . _Just . vLayers . ix 0
+                           . ix ComposeTo . veState) Visible
+
 instance Focusable 'Help 'ScrollingHelpView where
   switchFocus _ _ = pure . over (asViews . vsFocusedView) (Brick.focusSetCurrent Help)
 
@@ -966,6 +981,24 @@ switchComposeEditor =
                           else pure s
     }
 
+-- | Update the AppState with a 'MIMEMessage'. The instance will have
+-- the current selected 'MIMEMessage' encapsulated as an @inline@
+-- message.
+encapsulateMail :: Action 'ViewMail 'ScrollingMailView AppState
+encapsulateMail =
+  Action
+    { _aDescription = ["forward selected e-mail"]
+    , _aAction =
+        \s ->
+          let createForwarded s' m = s'
+                & over (asCompose . cAttachments)
+                (L.listInsert 1 (encapsulate m) . L.listInsert 0 (createTextPlainMessage mempty))
+                . over (asCompose . cSubject . E.editContentsL)
+                (insertMany (getForwardedSubject m) . clearZipper)
+              handleError = setError (GenericError "No mail selected for forwarding")
+          in pure $ maybe (handleError s) (createForwarded s) $ view (asMailView . mvMail) s
+    }
+
 -- | Update the 'AppState' with a quoted form of the first preferred
 -- entity in order to reply to the e-mail.
 --

src/UI/App.hs

@@ -123,6 +123,7 @@ handleViewEvent = f where
   f ViewMail MailAttachmentPipeToEditor = dispatch eventHandlerMailAttachmentPipeToEditor
   f ViewMail ScrollingMailViewFindWordEditor = dispatch eventHandlerScrollingMailViewFind
   f ViewMail SaveToDiskPathEditor = dispatch eventHandlerSaveToDiskEditor
+  f ViewMail ComposeTo = dispatch eventHandlerViewMailComposeTo
   f ViewMail _ = dispatch eventHandlerScrollingMailView
   f _ ScrollingHelpView = dispatch eventHandlerScrollingHelpView
   f _ ListOfFiles = dispatch eventHandlerComposeFileBrowser

src/UI/Keybindings.hs

@@ -1,5 +1,5 @@
 -- This file is part of purebred
--- Copyright (C) 2017-2019 Róman Joost and Fraser Tweedale
+-- Copyright (C) 2017-2020 Róman Joost and Fraser Tweedale
 --
 -- purebred is free software: you can redistribute it and/or modify
 -- it under the terms of the GNU Affero General Public License as published by
@@ -43,6 +43,7 @@ module UI.Keybindings (
   , eventHandlerComposeFileBrowser
   , eventHandlerScrollingMailViewFind
   , eventHandlerSaveToDiskEditor
+  , eventHandlerViewMailComposeTo
   ) where
 
 import Control.Monad ((<=<))
@@ -241,3 +242,8 @@ eventHandlerManageFileBrowserSearchPath :: EventHandler 'FileBrowser 'ManageFile
 eventHandlerManageFileBrowserSearchPath = EventHandler
   (asConfig . confFileBrowserView . fbSearchPathKeybindings)
   (\s -> Brick.continue <=< Brick.handleEventLensed s (asFileBrowser . fbSearchPath) E.handleEditorEvent)
+
+eventHandlerViewMailComposeTo :: EventHandler 'ViewMail 'ComposeTo
+eventHandlerViewMailComposeTo = EventHandler
+  (asConfig . confMailView . mvToKeybindings)
+  composeToHandler

src/UI/Mail/Keybindings.hs

@@ -1,5 +1,5 @@
 -- This file is part of purebred
--- Copyright (C) 2017-2019 Róman Joost and Fraser Tweedale
+-- Copyright (C) 2017-2020 Róman Joost and Fraser Tweedale
 --
 -- purebred is free software: you can redistribute it and/or modify
 -- it under the terms of the GNU Affero General Public License as published by
@@ -53,6 +53,10 @@ displayMailKeybindings =
     , Keybinding (V.EvKey (V.KChar 'e') []) (composeAsNew `chain'` (focus :: Action 'ComposeView 'ComposeListOfAttachments AppState) `chain` continue)
     , Keybinding (V.EvKey (V.KChar '/') []) (noop `chain'` (focus :: Action 'ViewMail 'ScrollingMailViewFindWordEditor AppState) `chain` continue)
     , Keybinding (V.EvKey (V.KChar 'n') []) (scrollNextWord `chain` continue)
+    , Keybinding (V.EvKey (V.KChar 'f') []) (noop
+                                             `chain` encapsulateMail
+                                             `chain'` (focus :: Action 'ViewMail 'ComposeTo AppState)
+                                             `chain` continue)
     , Keybinding (V.EvKey V.KEnter []) (removeHighlights `chain` continue)
     ]
 
@@ -104,3 +108,10 @@ saveToDiskKeybindings =
   , Keybinding (V.EvKey (V.KChar 'g') [V.MCtrl]) (abort `chain'` (focus :: Action 'ViewMail 'MailListOfAttachments AppState) `chain` continue)
   , Keybinding (V.EvKey V.KEnter []) (done `chain'` (focus :: Action 'ViewMail 'MailListOfAttachments AppState) `chain` saveAttachmentToPath `chain` continue)
   ]
+
+mailviewComposeToKeybindings :: [Keybinding 'ViewMail 'ComposeTo]
+mailviewComposeToKeybindings =
+    [ Keybinding (V.EvKey V.KEsc []) (abort `chain'` (focus :: Action 'ViewMail 'ScrollingMailView AppState) `chain` continue)
+    , Keybinding (V.EvKey (V.KChar 'g') [V.MCtrl]) (abort `chain'` (focus :: Action 'ViewMail 'ScrollingMailView AppState) `chain` continue)
+    , Keybinding (V.EvKey V.KEnter []) (done `chain'` (focus :: Action 'ComposeView 'ComposeListOfAttachments AppState) `chain` invokeEditor)
+    ]

src/UI/Views.hs

@@ -116,6 +116,7 @@ mailView =
               , Tile Hidden MailAttachmentPipeToEditor
               , Tile Hidden ScrollingMailViewFindWordEditor
               , Tile Hidden SaveToDiskPathEditor
+              , Tile Hidden ComposeTo
               ]
           ]
     , _vFocus = ListOfMails

test/TestUserAcceptance.hs

@@ -115,8 +115,54 @@ main = defaultMain $ testTmux pre post tests
       , testSubstringMatchesAreCleared
       , testAutoview
       , testSavesEntitySuccessfully
+      , testForwardsMailSuccessfully
       ]
 
+testForwardsMailSuccessfully :: PurebredTestCase
+testForwardsMailSuccessfully = purebredTmuxSession "forwards mail successfully" $
+  \step -> do
+    startApplication
+
+    let subject = "[<frase@host.example>: Testmail with whitespace in the subject]"
+
+    step "view mail"
+    sendKeys "Enter" (Substring "This is a test mail")
+
+    step "Start forwarding composition"
+    sendKeys "f" (Regex $ "To: " <> buildAnsiRegex [] ["37"] [] <> "\\s+$")
+
+    step "enter receipient address"
+    sendLine "to_user@foo.test" (Substring "~")
+
+    step "enter mail body"
+    sendKeys "iFind attached a forwarded mail" (Substring "mail")
+
+    step "exit insert mode in vim"
+    sendKeys "Escape" (Substring "mail")
+
+    step "exit vim"
+    sendKeys ": x\r" (Substring "Attachments") >>= put
+
+    assertRegexS "From: \"Joe Bloggs\" <joe@foo.test>\\s+$"
+    assertSubstringS "To: to_user@foo.test"
+    assertSubstringS ("Subject: " <> subject)
+    assertSubstringS "text/plain"
+    assertSubstringS "message/rfc822"
+
+    step "send mail"
+    sendKeys "y" (Substring "Query")
+
+    testdir <- view effectiveDir
+    let fpath = testdir </> "sentMail"
+
+    assertMailSuccessfullyParsed fpath
+
+    contents <- liftIO $ B.readFile fpath
+    let decoded = chr . fromEnum <$> B.unpack contents
+    assertSubstr subject decoded
+    assertSubstr "This is a test mail" decoded
+    assertSubstr "Find attached a forwarded mail" decoded
+
 testSavesEntitySuccessfully :: PurebredTestCase
 testSavesEntitySuccessfully = purebredTmuxSession "saves entity to disk successfully" $
   \step -> do