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 System.Environment (setEnv, unsetEnv)
  20 import System.Exit (ExitCode)
  21 import System.IO
  22 import System.IO.Temp (withTempFile)
  23 import System.Process
  24
  25 import qualified Data.ByteString.Lazy as BL
  26
  27 import ANSIColour
  28 import Mundanities
  29 import Prompt
  30 import Util
  31
  32 -- |Wrapper to ensure we don't accidentally allow use of shell commands in
  33 -- restricted mode!
  34 newtype RestrictedIO a = RestrictedIO (IO a)
  35     deriving (Functor,Applicative,Monad)
  36
  37 runRestrictedIO :: RestrictedIO a -> IO a
  38 runRestrictedIO (RestrictedIO m) = m
  39
  40
  41 subPercentOrAppend :: String -> String -> String
  42 subPercentOrAppend sub str =
  43     let (s',subbed) = subPercent str `runState` False
  44     in if subbed then s' else s' ++ (' ':sub)
  45     where
  46     -- |based on specification for $BROWSER in 'man 1 man'
  47     subPercent :: String -> State Bool String
  48     subPercent "" = return []
  49     subPercent ('%':'%':s) = ('%':) <$> subPercent s
  50     subPercent ('%':'c':s) = (':':) <$> subPercent s
  51     subPercent ('%':'s':s) = put True >> (sub ++) <$> subPercent s
  52     subPercent (c:s) = (c:) <$> subPercent s
  53
  54 confirmShell :: String -> String -> IO Bool
  55 confirmShell desc cmd = promptYN True False $
  56     desc ++ " following shell command?: " ++ withBoldStr cmd
  57
  58 pipeToCmdLazily :: String -> [String] -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  59 pipeToCmdLazily cmd cArgs = pipeLazily $ proc cmd cArgs
  60
  61 pipeToShellLazily :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  62 pipeToShellLazily = pipeLazily . shell
  63
  64 filterShell :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString
  65 filterShell = filterProcess . shell
  66
  67 withExtraEnv :: [(String,String)] -> IO a -> IO a
  68 withExtraEnv envir = bracket_
  69     (mapM_ (uncurry setEnv) envir)
  70     (mapM_ (unsetEnv . fst) envir)
  71
  72 pipeLazily :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  73 pipeLazily cp envir b = RestrictedIO . withExtraEnv envir $ do
  74     (Just inp, _, _, pid) <- createProcess $
  75         cp { std_in = CreatePipe , std_out = Inherit }
  76     hSetBuffering inp NoBuffering
  77     ignoreIOErr . finally (BL.hPut inp b) . void $ do
  78         hClose inp
  79         waitForProcess pid
  80
  81 filterProcess :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString
  82 filterProcess cp envir b = RestrictedIO . withExtraEnv envir $ do
  83     (Just inp, Just outp, _, pid) <- createProcess $
  84         cp { std_in = CreatePipe , std_out = CreatePipe }
  85     hSetBuffering inp NoBuffering
  86     hSetBuffering outp NoBuffering
  87     _ <- forkIO $ ignoreIOErr . finally (BL.hPut inp b) . void $ do
  88         hClose inp
  89         waitForProcess pid
  90     BL.hGetContents outp
  91
  92 runMailcap :: Bool -> String -> String -> String -> BL.ByteString -> RestrictedIO ()
  93 runMailcap noConfirm action dir mimetype b =
  94     RestrictedIO . withTempFile dir "runtmp" $ \path h -> do
  95         BL.hPut h b
  96         hClose h
  97         let cArgs = ["--action=" ++ action, mimetype ++ ":" ++ path]
  98         rawSystem "run-mailcap" ("--norun":cArgs) >>
  99             (if noConfirm then return True else promptYN True False "Run this command?") >>?
 100             void $ rawSystem "run-mailcap" cArgs
 101
 102 runShellCmd :: String -> [(String,String)] -> RestrictedIO ExitCode
 103 runShellCmd cmd envir = RestrictedIO . withExtraEnv envir $ spawnCommand cmd >>= waitForProcess
 104
 105 shellOnData :: Bool -> String -> FilePath -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
 106 shellOnData noConfirm cmd dir envir b = RestrictedIO . withTempFile dir "runtmp" $ \path h ->
 107     let cmd' = subPercentOrAppend path cmd
 108     in (if noConfirm then return True else confirmShell "Run" cmd') >>? void $ do
 109         BL.hPut h b >> hClose h
 110         runRestrictedIO $ runShellCmd cmd' envir