From dd8ad0d062a418c3bc09ef63c6de36b5b5af908a Mon Sep 17 00:00:00 2001 From: Roman Joost Date: Tue, 9 Apr 2019 20:11:46 +1000 Subject: [PATCH] Refactor the duplication of temporary files This removes old cold of dealing with temporary files when opening and piping attachments. The patch introduces new data types for handling resources in order to be flexible enought to delete the temporary file or not after process exit. Furthermore, the patch removes any passing of commands to the shell (e.g. opening or piping). That was a very convenient way of passing additional arguments to the command which is not possible any more. However just passing arbitrary commands to the shell is inherently insecure and we better avoid it were possible. Related https://github.com/purebred-mua/purebred/issues/276 --- src/Purebred/System/Process.hs | 12 ++++ src/Types.hs | 44 ++++++++++++ src/UI/Actions.hs | 127 +++++++++++++++++++-------------- test/TestUserAcceptance.hs | 4 +- 4 files changed, 130 insertions(+), 57 deletions(-) diff --git a/src/Purebred/System/Process.hs b/src/Purebred/System/Process.hs index 8c95c2ce..5559edb0 100644 --- a/src/Purebred/System/Process.hs +++ b/src/Purebred/System/Process.hs @@ -19,6 +19,8 @@ module Purebred.System.Process , handleIOException , handleExitCode , Purebred.System.Process.readProcess + , tmpfileResource + , emptyResource -- * Re-exports from @System.Process.Typed@ , ProcessConfig @@ -33,6 +35,9 @@ import System.Exit (ExitCode(..)) import Control.Exception (try, IOException) import System.Process.Typed import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString as B +import System.IO.Temp (emptySystemTempFile) +import System.Directory (removeFile) import Control.Lens (set, (&)) import Data.Semigroup ((<>)) @@ -74,3 +79,10 @@ readProcess => ProcessConfig stdin stdoutIgnored stderrIgnored -> m (ExitCode, Tainted LB.ByteString, Tainted LB.ByteString) readProcess = (fmap . fmap) (bimap taint taint) System.Process.Typed.readProcess + + +tmpfileResource :: ResourceSpec FilePath +tmpfileResource = ResourceSpec (emptySystemTempFile "purebred") removeFile B.writeFile + +emptyResource :: ResourceSpec () +emptyResource = ResourceSpec mempty (const mempty) (const mempty) diff --git a/src/Types.hs b/src/Types.hs index f2005172..7d49eeda 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 System.Process.Typed (ProcessConfig) import Notmuch (Tag) import Data.MIME @@ -592,3 +593,46 @@ decodeLenient = T.decodeUtf8With T.lenientDecode -- | Tag operations data TagOp = RemoveTag Tag | AddTag Tag | ResetTags deriving (Show, Eq) + +-- | A bracket-style type for creating and releasing acquired resources (e.g. +-- temporary files). Note that extending this is perhaps not worth it and we +-- should perhaps look at ResourceT if necessary. +data ResourceSpec a = ResourceSpec + { _rsAcquire :: IO a + -- ^ acquire a resource (e.g. create temporary file) + , _rsFree :: a -> IO () + -- ^ release a resource (e.g. remove temporary file) + , _rsUpdate :: a -> B.ByteString -> IO () + -- ^ update the acquired resource with the ByteString obtained from serialising the WireEntity + } + +rsAcquire :: Lens' (ResourceSpec a) (IO a) +rsAcquire = lens _rsAcquire (\rs x -> rs { _rsAcquire = x }) + +rsFree :: Lens' (ResourceSpec a) (a -> IO ()) +rsFree = lens _rsFree (\rs x -> rs { _rsFree = x }) + +rsUpdate :: Lens' (ResourceSpec a) (a -> B.ByteString -> IO ()) +rsUpdate = lens _rsUpdate (\rs x -> rs { _rsUpdate = 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 + { _ccAfterExit :: AppState -> a -> IO AppState + , _ccResource :: ResourceSpec a + , _ccProcessConfig :: B.ByteString -> a -> ProcessConfig () () () + , _ccEntity :: B.ByteString + -- ^ The decoded Entity + } + +ccAfterExit :: Lens' (EntityCommand a) (AppState -> a -> IO AppState) +ccAfterExit = lens _ccAfterExit (\cc x -> cc { _ccAfterExit = x }) + +ccEntity :: Lens' (EntityCommand a) B.ByteString +ccEntity = lens _ccEntity (\cc x -> cc { _ccEntity = x }) + +ccProcessConfig :: Lens' (EntityCommand a) (B.ByteString -> a -> ProcessConfig () () ()) +ccProcessConfig = lens _ccProcessConfig (\cc x -> cc { _ccProcessConfig = x }) + +ccResource :: Lens' (EntityCommand a) (ResourceSpec a) +ccResource = lens _ccResource (\cc x -> cc { _ccResource = x }) diff --git a/src/UI/Actions.hs b/src/UI/Actions.hs index fc4e5b0b..b1b53a2e 100644 --- a/src/UI/Actions.hs +++ b/src/UI/Actions.hs @@ -84,10 +84,6 @@ import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LB import Data.Attoparsec.ByteString.Char8 (parseOnly) import Data.Vector.Lens (vector) -import System.IO (hFlush) -import GHC.IO.Handle (Handle) -import System.IO.Temp (withSystemTempFile, emptyTempFile) -import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath (takeDirectory, ()) import qualified Data.Vector as Vector import Prelude hiding (readFile, unlines) @@ -97,7 +93,7 @@ import Control.Lens filtered, set, over, preview, view, views, (&), nullOf, firstOf, Getting, Lens') import Control.Concurrent (forkIO) -import Control.Monad ((>=>), join) +import Control.Monad ((>=>)) import Control.Monad.Except (runExceptT) import Control.Exception (catch, IOException) import Control.Monad.IO.Class (liftIO, MonadIO) @@ -568,12 +564,11 @@ openAttachment = , _aAction = \s -> let match ct = firstOf (asConfig . confMailView . mvMailcap . traversed - . filtered (flip fst ct) + . filtered (`fst` ct) . _2) s maybeCommand = - join - $ match - <$> preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2 . headers . contentType) s + match + =<< preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2 . headers . contentType) s in case maybeCommand of (Just cmd) -> Brick.suspendAndResume $ liftIO $ openCommand' s cmd Nothing -> @@ -1006,48 +1001,84 @@ initialCompose mailboxes = T.empty (L.list ComposeListOfAttachments mempty 1) - +-- | Serialise the WireEntity and write it to a temporary file. If no WireEntity +-- exists (e.g. composing a new mail) just use the empty file. When the +-- serialising fails, we return an error. Once the editor exits, read the +-- contents from the temporary file, delete it and create a MIME message out of +-- it. Set it in the Appstate. invokeEditor' :: AppState -> IO AppState -invokeEditor' s = do - let editor = view (asConfig . confEditor) s +invokeEditor' s = let maybeEntity = preview (asCompose . cAttachments . to L.listSelectedElement - . _Just . _2 . to getTextPlainPart . _Just) s - tmpfile <- getTempFileForEditing maybeEntity - tryRunProcess (proc editor [tmpfile]) >>= either (handleIOException s) (updatePart tmpfile . handleExitCode s) - where - updatePart tmpf' s' = do - contents <- T.readFile tmpf' - removeIfExists tmpf' - let mail = createTextPlainMessage contents - pure $ s' & over (asCompose . cAttachments) (upsertPart mail) - + . _Just . _2 . to getTextPlainPart . _Just) s + cmd = view (asConfig . confEditor) s + updatePart s' tempfile = do + contents <- T.readFile tempfile + let mail = createTextPlainMessage contents + pure $ s' & over (asCompose . cAttachments) (upsertPart mail) + mkEntity :: Either Error B.ByteString + mkEntity = + case maybeEntity of + Nothing -> Right B.empty + Just e -> + case entityToBytes e of + Left err -> Left err + Right bytes -> Right bytes + in either + (pure . flip setError s) + (flip runEntityCommand s . + EntityCommand updatePart tmpfileResource (\_ fp -> proc cmd [fp])) + mkEntity + +-- | Write the serialised WireEntity to a temporary file. Pass the FilePath of +-- the temporary file to the command. Do not remove the temporary file, so +-- 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 = liftIO $ do + | otherwise = let maybeEntity = preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2) s - withSystemTempFile "purebred" $ \fp handle -> do - updateFileContents handle maybeEntity - tryRunProcess (shell (cmd <> " " <> fp)) >>= either (handleIOException s) (pure . handleExitCode s) - + mkConfig :: Either Error (EntityCommand FilePath) + mkConfig = + case maybeEntity of + Nothing -> Left (GenericError "No attachment selected") + Just e -> + EntityCommand (const . pure) tmpfileResource (\_ fp -> proc 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) +-- or it can not be serialised an error is returned. pipeCommand' :: AppState -> FilePath -> IO AppState pipeCommand' s cmd | null cmd = pure $ s & setError (GenericError "Empty command") | otherwise = - let maybeEntity = preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2) s - in case maybeEntity of - Nothing -> pure $ s & setError (GenericError "No attachment selected") - Just e -> case entityToBytes e of - Left err -> pure $ s & setError err - Right bytes -> liftIO $ - tryRunProcess (setStdin (byteStringInput $ LB.fromStrict bytes) (shell cmd)) - >>= either (handleIOException s) (pure . handleExitCode s) - -removeIfExists :: FilePath -> IO () -removeIfExists fp = removeFile fp `catch` handleError - where - handleError :: IOError -> IO () - handleError _ = pure () + let maybeEntity = preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2) s + mkConfig :: Either Error (EntityCommand ()) + mkConfig = + case maybeEntity of + Nothing -> Left (GenericError "No attachment selected") + Just e -> + EntityCommand + (const . pure) + emptyResource + (\b _ -> + setStdin (byteStringInput $ LB.fromStrict b) (proc cmd [])) <$> + entityToBytes e + in either (pure . flip setError s) (`runEntityCommand` s) mkConfig + +runEntityCommand :: + EntityCommand a + -> AppState + -> IO AppState +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) >>= + either + (handleIOException s) + (flip (view ccAfterExit cmd) tmpfile <$> handleExitCode s) editAttachment :: AppState -> IO AppState editAttachment s = @@ -1070,20 +1101,6 @@ upsertPart newPart l = l & over L.listElementsL (`snoc` newPart) . set L.listSelectedL (Just (view (L.listElementsL . to length) l)) --- | Helper which writes the contents of the mail into the file, otherwise --- return an empty filepath -getTempFileForEditing :: Maybe WireEntity -> IO String -getTempFileForEditing m = do - tempfile <- getTemporaryDirectory >>= \tdir -> emptyTempFile tdir "purebred" - f tempfile m - where - f fp (Just entity) = either (\_ -> pure fp) (\x -> B.writeFile fp x >> pure fp) (entityToBytes entity) - f fp _ = pure fp - -updateFileContents :: Handle -> Maybe WireEntity -> IO () -updateFileContents h (Just entity) = either (\_ -> pure ()) (\x -> B.hPut h x >> hFlush h) (entityToBytes entity) -updateFileContents _ _ = pure () - getTextPlainPart :: MIMEMessage -> Maybe WireEntity getTextPlainPart = firstOf (entities . filtered f) where diff --git a/test/TestUserAcceptance.hs b/test/TestUserAcceptance.hs index 6eb78c04..4bacfe82 100644 --- a/test/TestUserAcceptance.hs +++ b/test/TestUserAcceptance.hs @@ -176,7 +176,7 @@ testPipeEntitiesSuccessfully = withTmuxSession "pipe entities successfully" $ sendKeys "|" (Literal "Pipe to") liftIO $ step "use less" - _ <- sendLiteralKeys "less -e" + _ <- sendLiteralKeys "less" sendKeys "Enter" (Regex ("This is a test mail for purebred" <> buildAnsiRegex [] ["37"] ["40"] <> "\\s+" @@ -197,7 +197,7 @@ testOpenEntitiesSuccessfully = withTmuxSession "open entities successfully" $ liftIO $ step "open one entity" sendKeys "o" (Literal "Open With") - _ <- sendLiteralKeys "less -e" + _ <- sendLiteralKeys "less" sendKeys "Enter" (Regex ("This is a test mail for purebred" <> buildAnsiRegex [] ["37"] ["40"]