From 4566688328ddd2182acd1cb2035271d4fb16f890 Mon Sep 17 00:00:00 2001 From: Roman Joost Date: Fri, 19 Apr 2019 14:55:25 +1000 Subject: [PATCH] Make Mailcap entry aware of temporary files When opening attachments with mailcap entries, it is sometimes possible that the actual binary just sends a message to the main program and exits. Deleting the temporary file upon process exit would cause the main program upon opening the temporary file to fail since the file would have been deleted by that time. Sometimes opening the file from the main program just works, because the time difference between exiting and opening is really quick, but mostly it doesn't. Instead, make the mailcap entry flexible so that depending on the command we either keep or delete the temporary file. Fixes https://github.com/purebred-mua/purebred/issues/276 --- src/Config/Main.hs | 9 ++++--- src/Purebred/System/Process.hs | 17 +++++++++++-- src/Types.hs | 23 +++++++++++++++-- src/UI/Actions.hs | 46 ++++++++++++++++++++-------------- 4 files changed, 69 insertions(+), 26 deletions(-) diff --git a/src/Config/Main.hs b/src/Config/Main.hs index 95afacc5..f59d8780 100644 --- a/src/Config/Main.hs +++ b/src/Config/Main.hs @@ -15,6 +15,7 @@ import qualified Data.Text as T import System.Environment (lookupEnv) import System.Directory (getHomeDirectory) import Data.Maybe (fromMaybe) +import GHC.Exts (fromList) import System.Exit (ExitCode(..)) import Data.MIME (contentTypeTextPlain, matchContentType) @@ -178,9 +179,11 @@ defaultConfig = , _mvMailListOfAttachmentsKeybindings = mailAttachmentsKeybindings , _mvOpenWithKeybindings = openWithKeybindings , _mvPipeToKeybindings = pipeToKeybindings - , _mvMailcap = [ - ((matchContentType "text" (Just "html")), "elinks -force-html") - , (const True, "xdg-open") + , _mvMailcap = + [ ( matchContentType "text" (Just "html") + , MailcapHandler (Shell (fromList "elinks -force-html")) False) + , ( const True + , MailcapHandler (Process (fromList "xdg-open") []) True) ] } , _confIndexView = IndexViewSettings diff --git a/src/Purebred/System/Process.hs b/src/Purebred/System/Process.hs index 93422506..57e51b3c 100644 --- a/src/Purebred/System/Process.hs +++ b/src/Purebred/System/Process.hs @@ -22,6 +22,7 @@ module Purebred.System.Process , tmpfileResource , emptyResource , afterExitNoop + , toProcessConfigWithTempfile -- * Re-exports from @System.Process.Typed@ , ProcessConfig @@ -41,6 +42,7 @@ import System.IO.Temp (emptySystemTempFile) import System.Directory (removeFile) import Control.Lens (set, (&)) import Data.Semigroup ((<>)) +import GHC.Exts (toList) import Control.Monad.IO.Class (MonadIO) import qualified Data.Text as T @@ -82,11 +84,22 @@ readProcess readProcess = (fmap . fmap) (bimap taint taint) System.Process.Typed.readProcess -tmpfileResource :: ResourceSpec FilePath -tmpfileResource = ResourceSpec (emptySystemTempFile "purebred") removeFile B.writeFile +tmpfileResource :: + Bool -- ^ removeFile upon cleanup? + -> ResourceSpec FilePath +tmpfileResource keepTempfile = + let cleanUp = + if keepTempfile + then mempty + else removeFile + in ResourceSpec (emptySystemTempFile "purebred") cleanUp B.writeFile emptyResource :: ResourceSpec () emptyResource = ResourceSpec mempty (const mempty) (const mempty) afterExitNoop :: AppState -> a -> IO AppState afterExitNoop s _ = pure s + +toProcessConfigWithTempfile :: MakeProcess -> FilePath -> ProcessConfig () () () +toProcessConfigWithTempfile (Shell cmd) fp = shell (toList cmd <> " " <> fp) +toProcessConfigWithTempfile (Process cmd args) fp = proc (toList cmd) (args <> [fp]) diff --git a/src/Types.hs b/src/Types.hs index 7d49eeda..06904b32 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -31,6 +31,7 @@ import qualified Data.Vector as V import qualified Graphics.Vty.Input.Events as Vty import Data.Time (UTCTime) import qualified Data.CaseInsensitive as CI +import Data.List.NonEmpty (NonEmpty) import System.Process.Typed (ProcessConfig) import Notmuch (Tag) @@ -348,7 +349,7 @@ data MailViewSettings = MailViewSettings , _mvMailListOfAttachmentsKeybindings :: [Keybinding 'ViewMail 'MailListOfAttachments] , _mvOpenWithKeybindings :: [Keybinding 'ViewMail 'MailAttachmentOpenWithEditor] , _mvPipeToKeybindings :: [Keybinding 'ViewMail 'MailAttachmentPipeToEditor] - , _mvMailcap :: [(ContentType -> Bool, String)] + , _mvMailcap :: [(ContentType -> Bool, MailcapHandler)] } deriving (Generic, NFData) @@ -376,7 +377,7 @@ mvOpenWithKeybindings = lens _mvOpenWithKeybindings (\s x -> s { _mvOpenWithKeyb mvPipeToKeybindings :: Lens' MailViewSettings [Keybinding 'ViewMail 'MailAttachmentPipeToEditor] mvPipeToKeybindings = lens _mvPipeToKeybindings (\s x -> s { _mvPipeToKeybindings = x }) -mvMailcap :: Lens' MailViewSettings [(ContentType -> Bool, String)] +mvMailcap :: Lens' MailViewSettings [(ContentType -> Bool, MailcapHandler)] mvMailcap = lens _mvMailcap (\s x -> s { _mvMailcap = x }) data ViewName @@ -615,6 +616,24 @@ rsFree = lens _rsFree (\rs x -> rs { _rsFree = x }) rsUpdate :: Lens' (ResourceSpec a) (a -> B.ByteString -> IO ()) rsUpdate = lens _rsUpdate (\rs x -> rs { _rsUpdate = x }) +data MakeProcess + = Shell (NonEmpty Char) + | Process (NonEmpty Char) + [String] + deriving (Generic, NFData) + +data MailcapHandler = MailcapHandler + { _mhMakeProcess :: MakeProcess + , _mhKeepTemp :: Bool + } deriving (Generic, NFData) + +mhMakeProcess :: Lens' MailcapHandler MakeProcess +mhMakeProcess = lens _mhMakeProcess (\h x -> h { _mhMakeProcess = x }) + +mhKeepTemp :: Lens' MailcapHandler Bool +mhKeepTemp = lens _mhKeepTemp (\h x -> h { _mhKeepTemp = x }) + + -- | Command configuration which is bound to an acquired resource (e.g. a -- tempfile) which may or may not be cleaned up after exit of it's process. data EntityCommand a = EntityCommand diff --git a/src/UI/Actions.hs b/src/UI/Actions.hs index b0d9eed6..fe5cd1e1 100644 --- a/src/UI/Actions.hs +++ b/src/UI/Actions.hs @@ -67,6 +67,7 @@ module UI.Actions ( import Data.Functor.Identity (Identity(..)) +import GHC.Exts (fromList) import qualified Brick import Brick.BChan (writeBChan) import qualified Brick.Focus as Brick @@ -579,11 +580,14 @@ openAttachment = openWithCommand :: Action 'ViewMail 'MailAttachmentOpenWithEditor (T.Next AppState) openWithCommand = Action - { _aDescription = ["ask for command to open attachment"] - , _aAction = \s -> - let cmd = view (asMailView . mvOpenCommand . E.editContentsL . to (T.unpack . currentLine)) s - in Brick.suspendAndResume $ liftIO $ openCommand' s cmd - } + { _aDescription = ["ask for command to open attachment"] + , _aAction = + \s -> + let cmd = view (asMailView . mvOpenCommand . E.editContentsL . to (T.unpack . currentLine)) s + in if null cmd + then Brick.continue $ setError (GenericError "Empty command") s + else Brick.suspendAndResume $ liftIO $ openCommand' s (MailcapHandler (Process (fromList cmd) []) False) + } pipeToCommand :: Action 'ViewMail 'MailAttachmentPipeToEditor (T.Next AppState) pipeToCommand = @@ -1027,7 +1031,7 @@ invokeEditor' s = in either (pure . flip setError s) (flip runEntityCommand s . - EntityCommand updatePart tmpfileResource (\_ fp -> proc cmd [fp])) + EntityCommand updatePart (tmpfileResource True) (\_ fp -> proc cmd [fp])) mkEntity -- | Write the serialised WireEntity to a temporary file. Pass the FilePath of @@ -1035,18 +1039,20 @@ invokeEditor' s = -- programs using sub-shells will be able to read the temporary file. Return an -- error if either the WireEntity doesn't exist (e.g. not selected) or it can -- not be serialised. -openCommand' :: AppState -> FilePath -> IO AppState -openCommand' s cmd - | null cmd = pure $ s & setError (GenericError "Empty command") - | otherwise = - let maybeEntity = preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2) s - mkConfig :: Either Error (EntityCommand FilePath) - mkConfig = - case maybeEntity of - Nothing -> Left (GenericError "No attachment selected") - Just e -> - EntityCommand afterExitNoop tmpfileResource (\_ fp -> proc cmd [fp]) <$> entityToBytes e - in either (pure . flip setError s) (`runEntityCommand` s) mkConfig +openCommand' :: AppState -> MailcapHandler -> IO AppState +openCommand' s cmd = + let maybeEntity = preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2) s + mkConfig :: Either Error (EntityCommand FilePath) + mkConfig = + case maybeEntity of + Nothing -> Left (GenericError "No attachment selected") + Just e -> + EntityCommand + afterExitNoop + (tmpfileResource (view mhKeepTemp cmd)) + (\_ fp -> toProcessConfigWithTempfile (view mhMakeProcess cmd) fp) <$> + entityToBytes e + in either (pure . flip setError s) (`runEntityCommand` s) mkConfig -- | Pass the serialized WireEntity to a Bytestring as STDIN to the process. No -- temporary file is used. If either no WireEntity exists (e.g. none selected) @@ -1076,10 +1082,12 @@ runEntityCommand :: runEntityCommand cmd s = do tmpfile <- view (ccResource . rsAcquire) cmd view (ccResource . rsUpdate) cmd tmpfile (view ccEntity cmd) - tryRunProcess (view ccProcessConfig cmd (view ccEntity cmd) tmpfile) >>= + s' <- tryRunProcess (view ccProcessConfig cmd (view ccEntity cmd) tmpfile) >>= either (handleIOException s) (flip (view ccAfterExit cmd) tmpfile <$> handleExitCode s) + view (ccResource . rsFree) cmd tmpfile + pure s' editAttachment :: AppState -> IO AppState editAttachment s =