RunExternal.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  12
  13 module RunExternal where
  14
  15 import           Control.Concurrent   (forkIO)
  16 import           Control.Monad        (void)
  17 import           Control.Monad.Catch  (bracket_, finally)
  18 import           Control.Monad.State  (State, put, runState)
  19 import           Data.Char            (isAlphaNum)
  20 import           System.Environment   (setEnv, unsetEnv)
  21 import           System.Exit          (ExitCode)
  22 import           System.IO
  23 import           System.IO.Temp       (withTempFile)
  24 import           System.Process
  25
  26 import qualified Data.ByteString.Lazy as BL
  27
  28 import           ANSIColour
  29 import           Mundanities
  30 import           Prompt
  31 import           Util
  32
  33 -- |Wrapper to ensure we don't accidentally allow use of shell commands in
  34 -- restricted mode!
  35 newtype RestrictedIO a = RestrictedIO (IO a)
  36     deriving (Functor,Applicative,Monad)
  37
  38 runRestrictedIO :: RestrictedIO a -> IO a
  39 runRestrictedIO (RestrictedIO m) = m
  40
  41
  42 subPercentOrAppend :: String -> String -> String
  43 subPercentOrAppend sub str =
  44     let (s',subbed) = subPercent str `runState` False
  45     in if subbed then s' else s' ++ (' ':shellQuote sub)
  46     where
  47     -- |based on specification for $BROWSER in 'man 1 man'
  48     subPercent :: String -> State Bool String
  49     subPercent ""          = return []
  50     subPercent ('%':'%':s) = ('%':) <$> subPercent s
  51     subPercent ('%':'c':s) = (':':) <$> subPercent s
  52     subPercent ('%':'s':s) = put True >> (sub ++) <$> subPercent s
  53     subPercent (c:s)       = (c:) <$> subPercent s
  54     shellQuote s
  55         | all shellSafe s && not (null s) = s
  56         | otherwise = '\'' : substAll '\'' "'\\''" s <> "'"
  57     shellSafe c = isAlphaNum c || c `elem` ".,_-+="
  58     substAll c r s
  59         | (s',_:t) <- break (== c) s = s' <> r <> substAll c r t
  60         | otherwise = s
  61
  62 confirmShell :: String -> String -> IO Bool
  63 confirmShell desc cmd = promptYN True False $
  64     desc ++ " following shell command?: " ++ withBoldStr cmd
  65
  66 pipeToCmdLazily :: String -> [String] -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  67 pipeToCmdLazily cmd cArgs = pipeLazily $ proc cmd cArgs
  68
  69 pipeToShellLazily :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  70 pipeToShellLazily = pipeLazily . shell
  71
  72 filterShell :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString
  73 filterShell = filterProcess . shell
  74
  75 withExtraEnv :: [(String,String)] -> IO a -> IO a
  76 withExtraEnv envir = bracket_
  77     (mapM_ (uncurry setEnv) envir)
  78     (mapM_ (unsetEnv . fst) envir)
  79
  80 pipeLazily :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  81 pipeLazily cp envir b = RestrictedIO . withExtraEnv envir $ do
  82     (Just inp, _, _, pid) <- createProcess $
  83         cp { std_in = CreatePipe , std_out = Inherit }
  84     hSetBuffering inp NoBuffering
  85     ignoreIOErr . finally (BL.hPut inp b) . void $ do
  86         hClose inp
  87         waitForProcess pid
  88
  89 filterProcess :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString
  90 filterProcess cp envir b = RestrictedIO . withExtraEnv envir $ do
  91     (Just inp, Just outp, _, pid) <- createProcess $
  92         cp { std_in = CreatePipe , std_out = CreatePipe }
  93     hSetBuffering inp NoBuffering
  94     hSetBuffering outp NoBuffering
  95     _ <- forkIO $ ignoreIOErr . finally (BL.hPut inp b) . void $ do
  96         hClose inp
  97         waitForProcess pid
  98     BL.hGetContents outp
  99
 100 runMailcap :: Bool -> String -> String -> String -> BL.ByteString -> RestrictedIO ()
 101 runMailcap noConfirm action dir mimetype b =
 102     RestrictedIO . withTempFile dir "runtmp" $ \path h -> do
 103         BL.hPut h b
 104         hClose h
 105         let cArgs = ["--action=" ++ action, mimetype ++ ":" ++ path]
 106         rawSystem "run-mailcap" ("--norun":cArgs) >>
 107             (if noConfirm then return True else promptYN True False "Run this command?") >>?
 108             void $ rawSystem "run-mailcap" cArgs
 109
 110 runShellCmd :: String -> [(String,String)] -> RestrictedIO ExitCode
 111 runShellCmd cmd envir = RestrictedIO . withExtraEnv envir $ spawnCommand cmd >>= waitForProcess
 112
 113 shellOnData :: Bool -> String -> FilePath -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
 114 shellOnData noConfirm cmd dir envir b = RestrictedIO . withTempFile dir "runtmp" $ \path h ->
 115     let cmd' = subPercentOrAppend path cmd
 116     in (if noConfirm then return True else confirmShell "Run" cmd') >>? void $ do
 117         BL.hPut h b >> hClose h
 118         runRestrictedIO $ runShellCmd cmd' envir