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