From 8d3d3922f253a475d444406290aded2a727657fb Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 11 May 2021 14:44:02 +0200 Subject: [PATCH] Better logging WIP --- lib/GHCup.hs | 34 +++++++++++++++++----------------- lib/GHCup/Types.hs | 15 +++++++++++++++ lib/GHCup/Utils.hs | 36 +++++++++++++++++++++++++++++++++--- lib/GHCup/Utils/File.hs | 34 +++++++++++----------------------- lib/GHCup/Utils/Logger.hs | 1 + 5 files changed, 77 insertions(+), 43 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 13016c7..09b9752 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -203,6 +203,7 @@ installUnpackedGHC :: ( MonadReader AppState m , MonadThrow m , MonadLogger m , MonadIO m + , MonadMask m ) => Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides) -> Path Abs -- ^ Path to install to @@ -211,13 +212,13 @@ installUnpackedGHC :: ( MonadReader AppState m -> Excepts '[ProcessError] m () installUnpackedGHC path inst ver PlatformRequest{..} = do lift $ $(logInfo) "Installing GHC (this may take a while)" - lEM $ execLogged "./configure" + lEM $ withConsoleRegions $ execLogged "./configure" False (("--prefix=" <> toFilePath inst) : alpineArgs) [rel|ghc-configure|] (Just path) Nothing - lEM $ make ["install"] (Just path) + lEM $ withConsoleRegions $ make ["install"] (Just path) pure () where alpineArgs @@ -1130,9 +1131,10 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR pure (workdir, tmpUnpack, tver) -- clone from git - Right GitBranch{..} -> do + Right GitBranch{..} -> withConsoleRegions $ \pState rs -> do tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing + let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing pState rs + git_fetch = execLogged [s|sh|] True ["-c", [i|git --no-pager fetch --depth 1 origin #{ref} 2>&1 | cat|]] [rel|git|] (Just tmpUnpack) Nothing pState rs tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo lift $ $(logInfo) [i|Fetching git repo #{rep} at ref #{ref} (this may take a while)|] @@ -1142,19 +1144,12 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR , "origin" , fromString rep ] - let fetch_args = - [ "fetch" - , "--depth" - , "1" - , "--quiet" - , "origin" - , fromString ref ] - lEM $ git fetch_args + lEM $ git_fetch lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] - lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing - lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing + lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs + lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs CapturedProcess {..} <- liftIO $ makeOut ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack) case _exitCode of @@ -1229,6 +1224,7 @@ HADDOCK_DOCS = YES|] , MonadLogger m , MonadIO m , MonadFail m + , MonadMask m ) => Either (Path Rel) (Path Abs) -> GHCTargetVersion @@ -1237,7 +1233,7 @@ HADDOCK_DOCS = YES|] '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError] m (Path Abs) -- ^ output path of bindist - compileBindist bghc tver workdir = do + compileBindist bghc tver workdir = withConsoleRegions $ \pState rs -> do lift $ $(logInfo) [i|configuring build|] liftE checkBuildConfig @@ -1264,6 +1260,8 @@ HADDOCK_DOCS = YES|] [rel|ghc-conf|] (Just workdir) (Just (("GHC", toFilePath bghcPath) : cEnv)) + pState + rs | otherwise -> do lEM $ execLogged "./configure" @@ -1278,6 +1276,8 @@ HADDOCK_DOCS = YES|] [rel|ghc-conf|] (Just workdir) (Just cEnv) + pState + rs case mbuildConfig of Just bc -> liftIOException @@ -1288,10 +1288,10 @@ HADDOCK_DOCS = YES|] liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf lift $ $(logInfo) [i|Building (this may take a while)...|] - lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) + lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) pState rs lift $ $(logInfo) [i|Creating bindist...|] - lEM $ make ["binary-dist"] (Just workdir) + lEM $ make ["binary-dist"] (Just workdir) pState rs [tar] <- liftIO $ findFiles workdir (makeRegexOpts compExtended diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index a381848..9d1fdd0 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -3,6 +3,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} {-| Module : GHCup.Types @@ -29,6 +32,8 @@ import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E import qualified GHC.Generics as GHC import qualified Graphics.Vty as Vty +import Haskus.Utils.Variant.Excepts +import Control.Monad.Reader @@ -418,3 +423,13 @@ instance Pretty Versioning where instance Pretty Version where pPrint = text . T.unpack . prettyVer + + + ----------------- + --[ Instances ]-- + ----------------- + +instance MonadReader r' m => MonadReader r' (Excepts es m) where + ask = lift ask + local = mapExcepts . local + reader = lift . reader diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 816e1b7..1503bb3 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -90,6 +90,10 @@ import qualified Data.Text as T #endif import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP +import System.Console.Regions +import Data.Sequence (Seq) +import qualified Data.Sequence as Sq +import Control.Concurrent @@ -760,15 +764,17 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|] -- | Calls gmake if it exists in PATH, otherwise make. -make :: (MonadThrow m, MonadIO m, MonadReader AppState m) +make :: (MonadThrow m, MonadIO m, MonadReader AppState m, MonadMask m) => [ByteString] -> Maybe (Path Abs) + -> MVar Bool + -> Seq ConsoleRegion -> m (Either ProcessError ()) -make args workdir = do +make args workdir pState rs = do 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 + execLogged mymake True args [rel|ghc-make|] workdir Nothing pState rs makeOut :: [ByteString] -> Maybe (Path Abs) @@ -890,3 +896,27 @@ traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty) -- | Gathering monoidal values forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b forFold = \t -> (`traverseFold` t) + + +withConsoleRegions :: (MonadReader AppState m, MonadIO m, MonadMask m) => (MVar Bool -> Seq ConsoleRegion -> m a) -> m a +withConsoleRegions = withConsoleRegions' Linear 6 + + +withConsoleRegions' :: (MonadReader AppState m, MonadIO m, MonadMask m) => RegionLayout -> Int -> (MVar Bool -> Seq ConsoleRegion -> m a) -> m a +withConsoleRegions' ly size action = do + AppState { settings = Settings {..} } <- ask + pState <- liftIO newEmptyMVar + if (not verbose) + then displayConsoleRegions $ + bracketIO + (fmap Sq.fromList . sequence . replicate size . openConsoleRegion $ ly) + (\rs -> uninterruptibleMask_ $ do + ps <- takeMVar pState + when ps (forM_ rs closeConsoleRegion)) + (action pState) + else + action pState mempty + + where + bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a + bracketIO setup cleanup' = bracket (liftIO setup) (liftIO . cleanup') diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index e782839..ee606b0 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -136,8 +136,10 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m) -> Path Rel -- ^ log filename (opened in append mode) -> Maybe (Path Abs) -- ^ optionally chdir into this -> Maybe [(ByteString, ByteString)] -- ^ optional environment + -> MVar Bool + -> Seq ConsoleRegion -> m (Either ProcessError ()) -execLogged exe spath args lfile chdir env = do +execLogged exe spath args lfile chdir env pState rs = do AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask logfile <- (logsDir ) <$> parseRel (toFilePath lfile <> ".log") liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms)) @@ -147,7 +149,7 @@ execLogged exe spath args lfile chdir env = do action verbose fd = do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do -- start the thread that logs to stdout - pState <- newEmptyMVar + void $ tryTakeMVar pState done <- newEmptyMVar void $ forkIO @@ -155,7 +157,7 @@ execLogged exe spath args lfile chdir env = do $ EX.finally (if verbose then tee fd stdoutRead - else printToRegion fd stdoutRead 6 pState + else printToRegion fd stdoutRead 6 ) (putMVar done ()) @@ -192,24 +194,10 @@ execLogged exe spath args lfile chdir env = do -- 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 + printToRegion :: Fd -> Fd -> Int -> IO () + printToRegion fileFd fdIn size = do + void $ + flip runStateT mempty $ readTilEOF (lineAction rs) fdIn where -- action to perform line by line @@ -218,11 +206,11 @@ execLogged exe spath args lfile chdir env = do => Seq ConsoleRegion -> ByteString -> StateT (Seq ByteString) m () - lineAction rs = \bs' -> do + 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 + liftIO $ forM_ (Sq.zip regs rs') $ \(bs, r) -> setConsoleRegion r $ do w <- consoleWidth return . T.pack diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 5f84c39..c6f286d 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -84,3 +84,4 @@ initGHCupFileLogging = do createRegularFile newFilePerms logfile pure logfile +