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             (msum, void)
  17 import           Control.Monad.Catch       (bracket_, finally)
  18 import           Control.Monad.State       (State, put, runState)
  19 import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
  20 import           Data.Char                 (isAlphaNum)
  21 import           Data.List                 (uncons)
  22 import           System.Environment        (lookupEnv, setEnv, unsetEnv)
  23 import           System.Exit               (ExitCode)
  24 import           System.IO
  25 import           System.IO.Temp            (withTempFile)
  26 import           System.Process
  27
  28 import qualified Data.ByteString.Lazy      as BL
  29
  30 import           ANSIColour
  31 import           Mundanities
  32 import           Prompt
  33 import           Util
  34
  35 -- |Wrapper to ensure we don't accidentally allow use of shell commands in
  36 -- restricted mode!
  37 newtype RestrictedIO a = RestrictedIO (IO a)
  38     deriving (Functor,Applicative,Monad)
  39
  40 runRestrictedIO :: RestrictedIO a -> IO a
  41 runRestrictedIO (RestrictedIO m) = m
  42
  43
  44 subPercentOrAppend :: String -> String -> String
  45 subPercentOrAppend sub str =
  46     let (s',subbed) = subPercent str `runState` False
  47     in if subbed then s' else s' ++ (' ':shellQuote sub)
  48     where
  49     -- |based on specification for $BROWSER in 'man 1 man'
  50     subPercent :: String -> State Bool String
  51     subPercent ""          = return []
  52     subPercent ('%':'%':s) = ('%':) <$> subPercent s
  53     subPercent ('%':'c':s) = (':':) <$> subPercent s
  54     subPercent ('%':'s':s) = put True >> (sub ++) <$> subPercent s
  55     subPercent (c:s)       = (c:) <$> subPercent s
  56     shellQuote s
  57         | all shellSafe s && not (null s) = s
  58         | otherwise = '\'' : substAll '\'' "'\\''" s <> "'"
  59     shellSafe c = isAlphaNum c || c `elem` ".,_-+="
  60     substAll c r s
  61         | (s',_:t) <- break (== c) s = s' <> r <> substAll c r t
  62         | otherwise = s
  63
  64 confirmShell :: String -> String -> IO Bool
  65 confirmShell desc cmd = promptYN True False $
  66     desc ++ " following shell command?: " ++ withBoldStr cmd
  67
  68 pipeToCmdLazily :: String -> [String] -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  69 pipeToCmdLazily cmd cArgs = pipeLazily $ proc cmd cArgs
  70
  71 pipeToShellLazily :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  72 pipeToShellLazily = pipeLazily . shell
  73
  74 filterShell :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString
  75 filterShell = filterProcess . shell
  76
  77 withExtraEnv :: [(String,String)] -> IO a -> IO a
  78 withExtraEnv envir = bracket_
  79     (mapM_ (uncurry setEnv) envir)
  80     (mapM_ (unsetEnv . fst) envir)
  81
  82 pipeLazily :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
  83 pipeLazily cp envir b = RestrictedIO . withExtraEnv envir $ do
  84     (Just inp, _, _, pid) <- createProcess $
  85         cp { std_in = CreatePipe , std_out = Inherit }
  86     hSetBuffering inp NoBuffering
  87     ignoreIOErr . finally (BL.hPut inp b) . void $ do
  88         hClose inp
  89         waitForProcess pid
  90
  91 filterProcess :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString
  92 filterProcess cp envir b = RestrictedIO . withExtraEnv envir $ do
  93     (Just inp, Just outp, _, pid) <- createProcess $
  94         cp { std_in = CreatePipe , std_out = CreatePipe }
  95     hSetBuffering inp NoBuffering
  96     hSetBuffering outp NoBuffering
  97     _ <- forkIO $ ignoreIOErr . finally (BL.hPut inp b) . void $ do
  98         hClose inp
  99         waitForProcess pid
 100     BL.hGetContents outp
 101
 102 runMailcap :: Bool -> String -> String -> String -> BL.ByteString -> RestrictedIO ()
 103 runMailcap noConfirm action dir mimetype b =
 104     RestrictedIO . withTempFile dir "runtmp" $ \path h -> do
 105         BL.hPut h b
 106         hClose h
 107         let cArgs = ["--action=" ++ action, mimetype ++ ":" ++ path]
 108         rawSystem "run-mailcap" ("--norun":cArgs) >>
 109             (if noConfirm then return True else promptYN True False "Run this command?") >>?
 110             void $ rawSystem "run-mailcap" cArgs
 111
 112 runShellCmd :: String -> [(String,String)] -> RestrictedIO ExitCode
 113 runShellCmd cmd envir = RestrictedIO . withExtraEnv envir $ spawnCommand cmd >>= waitForProcess
 114
 115 editInteractively :: String -> String -> RestrictedIO String
 116 editInteractively dir s =
 117     RestrictedIO . withTempFile dir "runtmp" $ \path h -> do
 118         hPutStr h s
 119         hClose h
 120         mEditor <- runMaybeT . msum $ MaybeT <$>
 121             [ lookupEnv "EDITOR", lookupEnv "VISUAL" ]
 122         case mEditor of
 123             Nothing -> hPutStrLn stderr "EDITOR environment variable unset" >> pure s
 124             Just editor -> do
 125                 void $ rawSystem editor [path]
 126                 (stripNewline <$>) $ openFile path ReadMode >>= hGetContents
 127     where
 128         stripNewline :: String -> String
 129         stripNewline = (. reverse) $ reverse . \cs ->
 130             case uncons cs of
 131                 Just ('\n',cs') -> cs'
 132                 _               -> cs
 133
 134 shellOnData :: Bool -> String -> FilePath -> [(String,String)] -> BL.ByteString -> RestrictedIO ()
 135 shellOnData noConfirm cmd dir envir b = RestrictedIO . withTempFile dir "runtmp" $ \path h ->
 136     let cmd' = subPercentOrAppend path cmd
 137     in (if noConfirm then return True else confirmShell "Run" cmd') >>? void $ do
 138         BL.hPut h b >> hClose h
 139         runRestrictedIO $ runShellCmd cmd' envir