diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index a06fc74..bd1ee0e 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -179,7 +179,7 @@ validateTarballs dls = do where downloadAll dli = do - let settings = Settings True False Never Curl + let settings = Settings True False Never Curl False let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True , colorOutter = B.hPut stderr , rawOutter = (\_ -> pure ()) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index a8d8840..f47fd64 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -299,6 +299,7 @@ settings' = unsafePerformIO , noVerify = False , keepDirs = Never , downloader = Curl + , verbose = False } ) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 68d73fb..c03cc8d 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -808,6 +808,7 @@ toSettings Options {..} = noVerify = optNoVerify keepDirs = optKeepDirs downloader = optsDownloader + verbose = optVerbose in Settings { .. } diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 80d46ea..e9e7bad 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -133,19 +133,19 @@ installGHCBin bDls ver mpfReq = do where -- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else. - installGHC' :: (MonadLogger m, MonadIO m) + installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) => Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides) -> Path Abs -- ^ Path to install to -> Excepts '[ProcessError] m () installGHC' path inst = do lift $ $(logInfo) "Installing GHC (this may take a while)" - lEM $ liftIO $ execLogged "./configure" + lEM $ execLogged "./configure" False ["--prefix=" <> toFilePath inst] [rel|ghc-configure|] (Just path) Nothing - lEM $ liftIO $ make ["install"] (Just path) + lEM $ make ["install"] (Just path) pure () @@ -672,7 +672,7 @@ BUILD_SPHINX_PDF = NO HADDOCK_DOCS = NO Stage1Only = YES|] - compile :: (MonadCatch m, MonadLogger m, MonadIO m) + compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m) => Either (Path Rel) (Path Abs) -> Path Abs -> Path Abs @@ -700,7 +700,7 @@ Stage1Only = YES|] Left bver -> do spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath (liftIO $ searchPath spaths bver) !? NotFoundInPATH bver - lEM $ liftIO $ execLogged + lEM $ execLogged "./configure" False ( ["--prefix=" <> toFilePath ghcdir] @@ -714,7 +714,7 @@ Stage1Only = YES|] (Just workdir) (Just (("GHC", toFilePath bghcPath) : cEnv)) | otherwise -> do - lEM $ liftIO $ execLogged + lEM $ execLogged "./configure" False ( [ "--prefix=" <> toFilePath ghcdir @@ -739,11 +739,11 @@ Stage1Only = YES|] liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf lift $ $(logInfo) [i|Building (this may take a while)...|] - lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) + lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) lift $ $(logInfo) [i|Installing...|] - lEM $ liftIO $ make ["install"] (Just workdir) + lEM $ make ["install"] (Just workdir) markSrcBuilt ghcdir workdir = do let dest = (ghcdir ghcUpSrcBuiltFile) @@ -848,7 +848,7 @@ compileCabal dls tver bghc jobs patchdir = do pure () where - compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m) + compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m) => Path Abs -> Excepts '[ProcessError , PatchFailed] m (Path Abs) compile workdir = do @@ -881,7 +881,7 @@ compileCabal dls tver bghc jobs patchdir = do newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv) lift $ $(logDebug) [i|Environment: #{newEnv}|] - lEM $ liftIO $ execLogged "./bootstrap.sh" + lEM $ execLogged "./bootstrap.sh" False (maybe [] (\j -> ["-j", fS (show j)]) jobs) [rel|cabal-bootstrap|] diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 5fda585..5e2a7b2 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -152,6 +152,7 @@ data Settings = Settings , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader + , verbose :: Bool } deriving Show diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e137b63..8a9f5f3 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -473,10 +473,13 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|] -- | Calls gmake if it exists in PATH, otherwise make. -make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ()) +make :: (MonadThrow m, MonadIO m, MonadReader Settings m) + => [ByteString] + -> Maybe (Path Abs) + -> m (Either ProcessError ()) make args workdir = do - spaths <- catMaybes . fmap parseAbs <$> getSearchPath - has_gmake <- isJust <$> searchPath spaths [rel|gmake|] + spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath) + has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|]) let mymake = if has_gmake then "gmake" else "make" execLogged mymake True args [rel|ghc-make|] workdir Nothing diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 52a8c3e..90f2b28 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -1,16 +1,19 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} module GHCup.Utils.File where import GHCup.Utils.Dirs import GHCup.Utils.Prelude +import GHCup.Types import Control.Concurrent import Control.Exception ( evaluate ) import Control.Exception.Safe import Control.Monad +import Control.Monad.Reader import Data.ByteString ( ByteString ) import Data.Foldable import Data.Functor @@ -101,19 +104,21 @@ executeOut path args chdir = captureOutStreams $ do SPPB.executeFile (toFilePath path) True args Nothing -execLogged :: ByteString -- ^ thing to execute +execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m) + => ByteString -- ^ thing to execute -> Bool -- ^ whether to search PATH for the thing -> [ByteString] -- ^ args for the thing -> Path Rel -- ^ log filename -> Maybe (Path Abs) -- ^ optionally chdir into this -> Maybe [(ByteString, ByteString)] -- ^ optional environment - -> IO (Either ProcessError ()) + -> m (Either ProcessError ()) execLogged exe spath args lfile chdir env = do - ldir <- ghcupLogsDir + Settings{..} <- ask + ldir <- liftIO ghcupLogsDir logfile <- (ldir ) <$> parseRel (toFilePath lfile <> ".log") - bracket (createFile (toFilePath logfile) newFilePerms) closeFd action + liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd (action verbose) where - action fd = do + action verbose fd = do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do -- start the thread that logs to stdout in a region done <- newEmptyMVar @@ -122,7 +127,7 @@ execLogged exe spath args lfile chdir env = do $ EX.handle (\(_ :: StopThread) -> pure ()) $ EX.handle (\(_ :: IOException) -> pure ()) $ flip finally (putMVar done ()) - $ printToRegion fd stdoutRead 6 + $ (if verbose then tee fd stdoutRead else printToRegion fd stdoutRead 6) -- fork our subprocess pid <- SPPB.forkProcess $ do @@ -151,6 +156,17 @@ execLogged exe spath args lfile chdir env = do closeFd stdoutRead pure e + tee fileFd fdIn = do + flip finally (readTilEOF lineAction fdIn) -- make sure the last few lines don't get cut off + $ do + hideError eofErrorType $ readTilEOF lineAction fdIn + forever (threadDelay 5000) + + where + 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 fileFd fdIn size = do @@ -170,6 +186,7 @@ execLogged exe spath args lfile chdir env = do where -- action to perform line by line + -- TODO: do this with vty for efficiency lineAction ref rs bs' = do modifyIORef' ref (swapRegs bs') regs <- readIORef ref @@ -193,18 +210,18 @@ execLogged exe spath args lfile chdir env = do trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..." | otherwise = bs - -- read an entire line from the file descriptor (removes the newline char) - readLine fd' = do - bs <- SPIB.fdRead fd' 1 - if - | bs == "\n" -> pure "" - | bs == "" -> pure "" - | otherwise -> fmap (bs <>) $ readLine fd' + -- read an entire line from the file descriptor (removes the newline char) + readLine fd' = do + bs <- SPIB.fdRead fd' 1 + if + | bs == "\n" -> pure "" + | bs == "" -> pure "" + | otherwise -> fmap (bs <>) $ readLine fd' - readTilEOF action' fd' = do - bs <- readLine fd' - void $ action' bs - readTilEOF action' fd' + readTilEOF action' fd' = do + bs <- readLine fd' + void $ action' bs + readTilEOF action' fd' -- | Capture the stdout and stderr of the given action, which