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