Windows support

lib/GHCup/Utils/File/Common.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
+
+module GHCup.Utils.File.Common where
+
+import           GHCup.Utils.Prelude
+
+import           Control.Monad.Extra
+import           Control.Monad.Reader
+import           Data.Maybe
+import           Data.String.Interpolate
+import           GHC.IO.Exception
+import           Optics                  hiding ((<|), (|>))
+import           System.Directory
+import           System.FilePath
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
+import           Text.Regex.Posix
+
+import qualified Data.ByteString.Lazy          as BL
+
+
+
+data ProcessError = NonZeroExit Int FilePath [String]
+                  | PTerminated FilePath [String]
+                  | PStopped FilePath [String]
+                  | NoSuchPid FilePath [String]
+                  deriving Show
+
+instance Pretty ProcessError where
+  pPrint (NonZeroExit e exe args) =
+    text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
+  pPrint (PTerminated exe args) =
+    text [i|Process "#{exe}" with arguments #{args} terminated.|]
+  pPrint (PStopped exe args) =
+    text [i|Process "#{exe}" with arguments #{args} stopped.|]
+  pPrint (NoSuchPid exe args) =
+    text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
+
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
+  , _stdOut   :: BL.ByteString
+  , _stdErr   :: BL.ByteString
+  }
+  deriving (Eq, Show)
+
+makeLenses ''CapturedProcess
+
+
+
+-- | Search for a file in the search paths.
+--
+-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
+searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+searchPath paths needle = go paths
+ where
+  go [] = pure Nothing
+  go (x : xs) =
+    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
+      $ do
+          contents <- listDirectory x
+          findM (isMatch x) contents >>= \case
+            Just _ -> pure $ Just (x </> needle)
+            Nothing -> go xs
+  isMatch basedir p = do
+    if p == needle
+      then isExecutable (basedir </> needle)
+      else pure False
+
+  isExecutable :: FilePath -> IO Bool
+  isExecutable file = executable <$> getPermissions file
+
+
+-- | Check wether a binary is shadowed by another one that comes before
+-- it in PATH. Returns the path to said binary, if any.
+isShadowed :: FilePath -> IO (Maybe FilePath)
+isShadowed p = do
+  let dir = takeDirectory p
+  let fn = takeFileName p
+  spaths <- liftIO getSearchPath
+  if dir `elem` spaths
+  then do
+    let shadowPaths = takeWhile (/= dir) spaths
+    searchPath shadowPaths fn
+  else pure Nothing
+
+
+-- | Check whether the binary is in PATH. This returns only `True`
+-- if the directory containing the binary is part of PATH.
+isInPath :: FilePath -> IO Bool
+isInPath p = do
+  let dir = takeDirectory p
+  let fn = takeFileName p
+  spaths <- liftIO getSearchPath
+  if dir `elem` spaths
+  then isJust <$> searchPath [dir] fn
+  else pure False
+
+
+findFiles :: FilePath -> Regex -> IO [FilePath]
+findFiles path regex = do
+  contents <- listDirectory path
+  pure $ filter (match regex) contents
+

lib/GHCup/Utils/File/Posix.hs

@@ -0,0 +1,386 @@
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
+
+{-|
+Module      : GHCup.Utils.File.Posix
+Description : File and unix APIs
+Copyright   : (c) Julian Ospald, 2020
+License     : LGPL-3.0
+Maintainer  : hasufell@hasufell.de
+Stability   : experimental
+Portability : POSIX
+
+This module handles file and executable handling.
+Some of these functions use sophisticated logging.
+-}
+module GHCup.Utils.File.Posix where
+
+import           GHCup.Utils.File.Common
+import           GHCup.Utils.Prelude
+import           GHCup.Types
+
+import           Control.Concurrent
+import           Control.Concurrent.Async
+import           Control.Exception              ( evaluate )
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.State.Strict
+import           Data.ByteString                ( ByteString )
+import           Data.Foldable
+import           Data.IORef
+import           Data.Sequence                  ( Seq, (|>) )
+import           Data.String.Interpolate
+import           Data.List
+import           Data.Word8
+import           GHC.IO.Exception
+import           System.Console.Pretty   hiding ( Pretty )
+import           System.Console.Regions
+import           System.IO.Error
+import           System.FilePath
+import           System.Directory
+import           System.Posix.Directory
+import           System.Posix.Files
+import           System.Posix.IO
+import           System.Posix.Process           ( ProcessStatus(..) )
+import           System.Posix.Types
+
+
+import qualified Control.Exception             as EX
+import qualified Data.Sequence                 as Sq
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import qualified System.Posix.Process          as SPP
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as BL
+import qualified "unix-bytestring" System.Posix.IO.ByteString
+                                               as SPIB
+
+
+
+-- | Execute the given command and collect the stdout, stderr and the exit code.
+-- The command is run in a subprocess.
+executeOut :: MonadIO m
+           => FilePath          -- ^ command as filename, e.g. 'ls'
+           -> [String]          -- ^ arguments to the command
+           -> Maybe FilePath    -- ^ chdir to this path
+           -> m CapturedProcess
+executeOut path args chdir = liftIO $ captureOutStreams $ do
+  maybe (pure ()) changeWorkingDirectory chdir
+  SPP.executeFile path True args Nothing
+
+
+execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
+           => FilePath         -- ^ thing to execute
+           -> [String]         -- ^ args for the thing
+           -> Maybe FilePath   -- ^ optionally chdir into this
+           -> FilePath         -- ^ log filename (opened in append mode)
+           -> Maybe [(String, String)] -- ^ optional environment
+           -> m (Either ProcessError ())
+execLogged exe args chdir lfile env = do
+  AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
+  let logfile = logsDir </> lfile <> ".log"
+  liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
+                   closeFd
+                   (action verbose)
+ where
+  action verbose fd = do
+    actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
+      -- start the thread that logs to stdout
+      pState <- newEmptyMVar
+      done   <- newEmptyMVar
+      void
+        $ forkIO
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ EX.finally
+            (if verbose
+              then tee fd stdoutRead
+              else printToRegion fd stdoutRead 6 pState
+            )
+            (putMVar done ())
+
+      -- fork the subprocess
+      pid <- SPP.forkProcess $ do
+        void $ dupTo stdoutWrite stdOutput
+        void $ dupTo stdoutWrite stdError
+        closeFd stdoutRead
+        closeFd stdoutWrite
+
+        -- execute the action
+        maybe (pure ()) changeWorkingDirectory chdir
+        void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
+
+      closeFd stdoutWrite
+
+      -- wait for the subprocess to finish
+      e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
+      putMVar pState (either (const False) (const True) e)
+
+      void $ race (takeMVar done) (threadDelay (1000000 * 3))
+      closeFd stdoutRead
+
+      pure e
+
+  tee :: Fd -> Fd -> IO ()
+  tee fileFd fdIn = readTilEOF lineAction fdIn
+
+   where
+    lineAction :: ByteString -> IO ()
+    lineAction bs' = do
+      void $ SPIB.fdWrite fileFd (bs' <> "\n")
+      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
+
+  -- Reads fdIn and logs the output in a continous scrolling area
+  -- of 'size' terminal lines. Also writes to a log file.
+  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
+  printToRegion fileFd fdIn size pState = do
+    void $ displayConsoleRegions $ do
+      rs <-
+        liftIO
+        . fmap Sq.fromList
+        . sequence
+        . replicate size
+        . openConsoleRegion
+        $ Linear
+      flip runStateT mempty
+        $ handle
+            (\(ex :: SomeException) -> do
+              ps <- liftIO $ takeMVar pState
+              when ps (forM_ rs (liftIO . closeConsoleRegion))
+              throw ex
+            )
+        $ readTilEOF (lineAction rs) fdIn
+
+   where
+    -- action to perform line by line
+    -- TODO: do this with vty for efficiency
+    lineAction :: (MonadMask m, MonadIO m)
+               => Seq ConsoleRegion
+               -> ByteString
+               -> StateT (Seq ByteString) m ()
+    lineAction rs = \bs' -> do
+      void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
+      modify (swapRegs bs')
+      regs <- get
+      liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
+        w <- consoleWidth
+        return
+          . T.pack
+          . color Blue
+          . T.unpack
+          . decUTF8Safe
+          . trim w
+          . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
+          $ bs
+
+    swapRegs :: a -> Seq a -> Seq a
+    swapRegs bs = \regs -> if
+      | Sq.length regs < size -> regs |> bs
+      | otherwise             -> Sq.drop 1 regs |> bs
+
+    -- trim output line to terminal width
+    trim :: Int -> ByteString -> ByteString
+    trim w = \bs -> if
+      | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
+      | otherwise                 -> bs
+
+  -- Consecutively read from Fd in 512 chunks until we hit
+  -- newline or EOF.
+  readLine :: MonadIO m
+           => Fd          -- ^ input file descriptor
+           -> ByteString  -- ^ rest buffer (read across newline)
+           -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
+  readLine fd = go
+   where
+    go inBs = do
+      -- if buffer is not empty, process it first
+      mbs <- if BS.length inBs == 0
+               -- otherwise attempt read
+               then liftIO
+                    $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
+                    $ fmap Just
+                    $ SPIB.fdRead fd 512
+               else pure $ Just inBs
+      case mbs of
+        Nothing -> pure ("", "", True)
+        Just bs -> do
+          -- split on newline
+          let (line, rest) = BS.span (/= _lf) bs
+          if
+            | BS.length rest /= 0 -> pure (line, BS.tail rest, False)
+            -- if rest is empty, then there was no newline, process further
+            | otherwise           -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
+
+  readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
+  readTilEOF ~action' fd' = go mempty
+   where
+    go bs' = do
+      (bs, rest, eof) <- readLine fd' bs'
+      if eof
+         then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
+         else void (action' bs) >> go rest
+
+
+-- | Capture the stdout and stderr of the given action, which
+-- is run in a subprocess. Stdin is closed. You might want to
+-- 'race' this to make sure it terminates.
+captureOutStreams :: IO a
+                     -- ^ the action to execute in a subprocess
+                  -> IO CapturedProcess
+captureOutStreams action = do
+  actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
+    actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
+      pid <- SPP.forkProcess $ do
+        -- dup stdout
+        void $ dupTo childStdoutWrite stdOutput
+        closeFd childStdoutWrite
+        closeFd parentStdoutRead
+
+        -- dup stderr
+        void $ dupTo childStderrWrite stdError
+        closeFd childStderrWrite
+        closeFd parentStderrRead
+
+        -- execute the action
+        a <- action
+        void $ evaluate a
+
+      -- close everything we don't need
+      closeFd childStdoutWrite
+      closeFd childStderrWrite
+
+      -- start thread that writes the output
+      refOut <- newIORef BL.empty
+      refErr <- newIORef BL.empty
+      done   <- newEmptyMVar
+      _      <-
+        forkIO
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ flip EX.finally (putMVar done ())
+        $ writeStds parentStdoutRead parentStderrRead refOut refErr
+
+      status <- SPP.getProcessStatus True True pid
+      void $ race (takeMVar done) (threadDelay (1000000 * 3))
+
+      case status of
+        -- readFd will take care of closing the fd
+        Just (SPP.Exited es) -> do
+          stdout' <- readIORef refOut
+          stderr' <- readIORef refErr
+          pure $ CapturedProcess { _exitCode = es
+                                 , _stdOut   = stdout'
+                                 , _stdErr   = stderr'
+                                 }
+
+        _ -> throwIO $ userError ("No such PID " ++ show pid)
+
+ where
+  writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
+  writeStds pout perr rout rerr = do
+    doneOut <- newEmptyMVar
+    void
+      $ forkIO
+      $ hideError eofErrorType
+      $ flip EX.finally (putMVar doneOut ())
+      $ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
+    doneErr <- newEmptyMVar
+    void
+      $ forkIO
+      $ hideError eofErrorType
+      $ flip EX.finally (putMVar doneErr ())
+      $ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
+    takeMVar doneOut
+    takeMVar doneErr
+
+  readTilEOF ~action' fd' = do
+    bs <- SPIB.fdRead fd' 512
+    void $ action' bs
+    readTilEOF action' fd'
+
+
+actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
+actionWithPipes a =
+  createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
+
+cleanup :: [Fd] -> IO ()
+cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
+
+
+
+-- | Create a new regular file in write-only mode. The file must not exist.
+createRegularFileFd :: FileMode -> FilePath -> IO Fd
+createRegularFileFd fm dest =
+  openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
+
+
+-- | Thin wrapper around `executeFile`.
+exec :: MonadIO m
+     => String           -- ^ thing to execute
+     -> [String]         -- ^ args for the thing
+     -> Maybe FilePath   -- ^ optionally chdir into this
+     -> Maybe [(String, String)] -- ^ optional environment
+     -> m (Either ProcessError ())
+exec exe args chdir env = liftIO $ do
+  pid <- SPP.forkProcess $ do
+    maybe (pure ()) changeWorkingDirectory chdir
+    SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
+
+  fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
+
+
+toProcessError :: FilePath
+               -> [String]
+               -> Maybe ProcessStatus
+               -> Either ProcessError ()
+toProcessError exe args mps = case mps of
+  Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
+  Just (SPP.Exited ExitSuccess    ) -> Right ()
+  Just (Terminated _ _             ) -> Left $ PTerminated exe args
+  Just (Stopped _                  ) -> Left $ PStopped exe args
+  Nothing                            -> Left $ NoSuchPid exe args
+
+
+
+chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m ()
+chmod_755 fp = do
+  let exe_mode =
+          nullFileMode
+            `unionFileModes` ownerExecuteMode
+            `unionFileModes` ownerReadMode
+            `unionFileModes` ownerWriteMode
+            `unionFileModes` groupExecuteMode
+            `unionFileModes` groupReadMode
+            `unionFileModes` otherExecuteMode
+            `unionFileModes` otherReadMode
+  $(logDebug) [i|chmod 755 #{fp}|]
+  liftIO $ setFileMode fp exe_mode
+
+
+-- |Default permissions for a new file.
+newFilePerms :: FileMode
+newFilePerms =
+  ownerWriteMode
+    `unionFileModes` ownerReadMode
+    `unionFileModes` groupWriteMode
+    `unionFileModes` groupReadMode
+    `unionFileModes` otherWriteMode
+    `unionFileModes` otherReadMode
+
+
+-- | Checks whether the binary is a broken link.
+isBrokenSymlink :: FilePath -> IO Bool
+isBrokenSymlink fp = do
+  try (pathIsSymbolicLink fp) >>= \case
+    Right True -> do
+      let symDir = takeDirectory fp
+      tfp <- getSymbolicLinkTarget fp
+      not <$> doesPathExist
+        -- this drops 'symDir' if 'tfp' is absolute
+        (symDir </> tfp)
+    Right b -> pure b
+    Left e | isDoesNotExistError e -> pure False
+           | otherwise -> throwIO e

lib/GHCup/Utils/File/Windows.hs

@@ -0,0 +1,240 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts  #-}
+
+{-|
+Module      : GHCup.Utils.File.Windows
+Description : File and windows APIs
+Copyright   : (c) Julian Ospald, 2020
+License     : LGPL-3.0
+Maintainer  : hasufell@hasufell.de
+Stability   : experimental
+Portability : Windows
+
+This module handles file and executable handling.
+Some of these functions use sophisticated logging.
+-}
+module GHCup.Utils.File.Windows where
+
+import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
+import           GHCup.Utils.Dirs
+import           GHCup.Utils.File.Common
+import           GHCup.Types
+
+import           Control.Concurrent
+import           Control.DeepSeq
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Reader
+import           Data.List
+import           Foreign.C.Error
+import           GHC.IO.Exception
+import           GHC.IO.Handle
+import           System.Directory
+import           System.Environment
+import           System.FilePath
+import           System.IO
+import           System.Process
+ 
+import qualified Control.Exception             as EX
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as BL
+import qualified Data.Map.Strict               as Map
+
+
+
+toProcessError :: FilePath
+               -> [FilePath]
+               -> ExitCode
+               -> Either ProcessError ()
+toProcessError exe args exitcode = case exitcode of
+  (ExitFailure xi) -> Left $ NonZeroExit xi exe args
+  ExitSuccess -> Right ()
+
+
+-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
+-- lets you pass 'CreateProcess' giving better flexibility.
+--
+-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
+-- record will be ignored.
+--
+-- @since 1.2.3.0
+readCreateProcessWithExitCodeBS
+    :: CreateProcess
+    -> BL.ByteString
+    -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
+readCreateProcessWithExitCodeBS cp input = do
+    let cp_opts = cp {
+                    std_in  = CreatePipe,
+                    std_out = CreatePipe,
+                    std_err = CreatePipe
+                  }
+    withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
+      \mb_inh mb_outh mb_errh ph ->
+        case (mb_inh, mb_outh, mb_errh) of
+          (Just inh, Just outh, Just errh) -> do
+
+            out <- BS.hGetContents outh
+            err <- BS.hGetContents errh
+
+            -- fork off threads to start consuming stdout & stderr
+            withForkWait  (EX.evaluate $ rnf out) $ \waitOut ->
+             withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
+
+              -- now write any input
+              unless (BL.null input) $
+                ignoreSigPipe $ BL.hPut inh input
+              -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+              ignoreSigPipe $ hClose inh
+
+              -- wait on the output
+              waitOut
+              waitErr
+
+              hClose outh
+              hClose errh
+
+            -- wait on the process
+            ex <- waitForProcess ph
+            return (ex, BL.fromStrict out, BL.fromStrict err)
+
+          (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
+          (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
+          (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
+ where
+  ignoreSigPipe :: IO () -> IO ()
+  ignoreSigPipe = EX.handle $ \e -> case e of
+                                     IOError { ioe_type  = ResourceVanished
+                                             , ioe_errno = Just ioe }
+                                       | Errno ioe == ePIPE -> return ()
+                                     _ -> throwIO e
+  -- wrapper so we can get exceptions with the appropriate function name.
+  withCreateProcess_
+    :: String
+    -> CreateProcess
+    -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
+    -> IO a
+  withCreateProcess_ fun c action =
+      EX.bracketOnError (createProcess_ fun c) cleanupProcess
+                       (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
+
+-- | Fork a thread while doing something else, but kill it if there's an
+-- exception.
+--
+-- This is important in the cases above because we want to kill the thread
+-- that is holding the Handle lock, because when we clean up the process we
+-- try to close that handle, which could otherwise deadlock.
+--
+withForkWait :: IO () -> (IO () ->  IO a) -> IO a
+withForkWait async' body = do
+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
+  mask $ \restore -> do
+    tid <- forkIO $ try (restore async') >>= putMVar waitVar
+    let wait' = takeMVar waitVar >>= either throwIO return
+    restore (body wait') `EX.onException` killThread tid
+
+
+-- | Execute the given command and collect the stdout, stderr and the exit code.
+-- The command is run in a subprocess.
+executeOut :: MonadIO m
+           => FilePath          -- ^ command as filename, e.g. 'ls'
+           -> [String]          -- ^ arguments to the command
+           -> Maybe FilePath    -- ^ chdir to this path
+           -> m CapturedProcess
+executeOut path args chdir = do
+  cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
+  (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
+  pure $ CapturedProcess exit out err
+
+
+execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
+           => FilePath         -- ^ thing to execute
+           -> [String]         -- ^ args for the thing
+           -> Maybe FilePath   -- ^ optionally chdir into this
+           -> FilePath         -- ^ log filename (opened in append mode)
+           -> Maybe [(String, String)] -- ^ optional environment
+           -> m (Either ProcessError ())
+execLogged exe args chdir lfile env = do
+  AppState { dirs = Dirs {..} } <- ask
+  let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
+      stderrLogfile = logsDir </> lfile <> ".stderr.log"
+  cp <- createProcessWithMingwPath ((proc exe args)
+    { cwd = chdir
+    , env = env
+    , std_in = CreatePipe
+    , std_out = CreatePipe
+    , std_err = CreatePipe
+    })
+  fmap (toProcessError exe args)
+    $ liftIO
+    $ withCreateProcess cp
+    $ \_ mout merr ph ->
+        case (mout, merr) of
+          (Just cStdout, Just cStderr) -> do
+            withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
+              withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
+                waitOut
+                waitErr
+            waitForProcess ph
+          _ -> fail "Could not acquire out/err handle"
+
+ where
+  tee :: FilePath -> Handle -> IO ()
+  tee logFile handle' = go
+    where
+      go = do
+        some <- BS.hGetSome handle' 512
+        if BS.null some
+          then pure ()
+          else do
+            void $ BS.appendFile logFile some
+            void $ BS.hPut stdout some
+            go
+        
+
+-- | Thin wrapper around `executeFile`.
+exec :: MonadIO m
+     => FilePath       -- ^ thing to execute
+     -> [FilePath]     -- ^ args for the thing
+     -> Maybe FilePath   -- ^ optionally chdir into this
+     -> Maybe [(String, String)] -- ^ optional environment
+     -> m (Either ProcessError ())
+exec exe args chdir env = do
+  cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
+  exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
+  pure $ toProcessError exe args exit_code
+
+
+chmod_755 :: MonadIO m => FilePath -> m ()
+chmod_755 fp =
+  let perm = setOwnerWritable True emptyPermissions
+  in liftIO $ setPermissions fp perm
+
+
+createProcessWithMingwPath :: MonadIO m
+                          => CreateProcess
+                          -> m CreateProcess
+createProcessWithMingwPath cp = do
+  baseDir <- liftIO ghcupBaseDir
+  cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
+  let mingWPaths = [baseDir </> "msys64" </> "usr" </> "bin"
+                   ,baseDir </> "msys64" </> "mingw64" </> "bin"]
+      paths = ["PATH", "Path"]
+      curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
+      newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
+      envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
+      envWithNewPath = Map.insert "Path" newPath envWithoutPath
+  liftIO $ setEnv "Path" newPath
+  pure $ cp { env = Just $ Map.toList envWithNewPath }
+
+
+-- | Checks whether the binary is a broken link.
+isBrokenSymlink :: FilePath -> IO Bool
+isBrokenSymlink fp = do
+  b <- pathIsLink fp
+  if b
+  then do
+    tfp <- getLinkTarget fp
+    not <$> doesPathExist
+      -- this drops 'symDir' if 'tfp' is absolute
+      (takeDirectory fp </> tfp)
+  else pure False