From 9f0ac0ee196b698f1f40a8d47ff860780ea59918 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 28 Apr 2021 18:45:48 +0200 Subject: [PATCH 1/4] Allow to compile from git repo --- CHANGELOG.md | 6 ++ app/ghcup/Main.hs | 82 +++++++++--------- lib/GHCup.hs | 156 ++++++++++++++++++++++------------ lib/GHCup/Types.hs | 5 ++ lib/GHCup/Utils.hs | 9 ++ lib/GHCup/Utils/MegaParsec.hs | 9 ++ 6 files changed, 170 insertions(+), 97 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 97a2272..5289a98 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for ghcup +## 0.1.15 -- ????-??-?? + +* Add date to GHC bindist names created by ghcup +* Warn when /tmp doesn't have 5GB or more of disk space +* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126) + ## 0.1.14.1 -- 2021-04-11 * Make internal symlink target parser more lax, fixes [#119](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 6541799..567da7d 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -165,9 +165,8 @@ data RmOptions = RmOptions data CompileCommand = CompileGHC GHCCompileOptions - data GHCCompileOptions = GHCCompileOptions - { targetVer :: Version + { targetGhc :: Either Version GitBranch , bootstrapGhc :: Either Version (Path Abs) , jobs :: Maybe Int , buildConfig :: Maybe (Path Abs) @@ -177,14 +176,6 @@ data GHCCompileOptions = GHCCompileOptions , setCompile :: Bool } -data CabalCompileOptions = CabalCompileOptions - { targetVer :: Version - , bootstrapGhc :: Either Version (Path Abs) - , jobs :: Maybe Int - , buildConfig :: Maybe (Path Abs) - , patchDir :: Maybe (Path Abs) - } - data UpgradeOpts = UpgradeInplace | UpgradeAt (Path Abs) | UpgradeGHCupDir @@ -659,7 +650,10 @@ ENV variables: such as: CC, LD, OBJDUMP, NM, AR, RANLIB. Examples: + # compile from known version ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 + # compile from git commit/reference + ghcup compile ghc -j 4 -g master -b 8.2.2 # specify path to bootstrap ghc ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2 # build cross compiler @@ -668,34 +662,22 @@ Examples: ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = - (\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. } - ) - <$> cabalCompileOpts - <*> optional - (option - str - (short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help - "Build cross-compiler for this platform" - ) - ) - <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)")) - <*> flag - False - True - (long "set" <> help - "Set as active version after install" - ) - -cabalCompileOpts :: Parser CabalCompileOptions -cabalCompileOpts = - CabalCompileOptions - <$> option + GHCCompileOptions + <$> ((Left <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) ) (short 'v' <> long "version" <> metavar "VERSION" <> help "The tool version to compile" ) + ) <|> + (Right <$> (GitBranch <$> option + str + (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help + "The git commit/branch/ref to build from" + ) <*> + optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)")) + ))) <*> option (eitherReader (\x -> @@ -742,6 +724,20 @@ cabalCompileOpts = "Absolute path to patch directory (applied in order, uses -p1)" ) ) + <*> optional + (option + str + (short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help + "Build cross-compiler for this platform" + ) + ) + <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)")) + <*> flag + False + True + (long "set" <> help + "Set as active version after install" + ) toolVersionParser :: Parser ToolVersion @@ -1470,22 +1466,26 @@ Report bugs at |] Compile (CompileGHC GHCCompileOptions {..}) -> runCompileGHC (do - let vi = getVersionInfo targetVer GHC dls - forM_ (_viPreCompile =<< vi) $ \msg -> do - lift $ $(logInfo) msg - lift $ $(logInfo) - "...waiting for 5 seconds, you can still abort..." - liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - liftE $ compileGHC dls - (GHCTargetVersion crossTarget targetVer) + case targetGhc of + Left targetVer -> do + let vi = getVersionInfo targetVer GHC dls + forM_ (_viPreCompile =<< vi) $ \msg -> do + lift $ $(logInfo) msg + lift $ $(logInfo) + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene + Right _ -> pure () + targetVer <- liftE $ compileGHC dls + (first (GHCTargetVersion crossTarget) targetGhc) bootstrapGhc jobs buildConfig patchDir addConfArgs pfreq + let vi = getVersionInfo (_tvVersion targetVer) GHC dls when setCompile $ void $ liftE $ - setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly + setGHC targetVer SetGHCOnly pure vi ) >>= \case diff --git a/lib/GHCup.hs b/lib/GHCup.hs index b9936ca..029d323 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -59,6 +59,7 @@ import Data.ByteString ( ByteString ) import Data.Either import Data.List import Data.Maybe +import Data.String ( fromString ) import Data.String.Interpolate import Data.Text ( Text ) import Data.Time.Clock @@ -88,6 +89,8 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding as E +import qualified Text.Megaparsec as MP +import GHCup.Utils.MegaParsec @@ -1075,7 +1078,7 @@ compileGHC :: ( MonadMask m , MonadFail m ) => GHCupDownloads - -> GHCTargetVersion -- ^ version to install + -> Either GHCTargetVersion GitBranch -- ^ version to install -> Either Version (Path Abs) -- ^ version to bootstrap with -> Maybe Int -- ^ jobs -> Maybe (Path Abs) -- ^ build config @@ -1099,38 +1102,81 @@ compileGHC :: ( MonadMask m #endif ] m - () -compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..} + GHCTargetVersion +compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..} = do - lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] + (workdir, tmpUnpack, tver) <- case targetGhc of + -- unpack from version tarball + Left tver -> do + lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] + + -- download source tarball + dlInfo <- + preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ unpackToDir tmpUnpack dl + void $ liftIO $ darwinNotarization _rPlatform tmpUnpack + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + + pure (workdir, tmpUnpack, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing + 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)|] + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + 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 + CapturedProcess {..} <- liftIO $ makeOut + ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack) + case _exitCode of + ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe $ _stdOut + ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe _stdErr)) + + void $ liftIO $ darwinNotarization _rPlatform tmpUnpack + + pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) alreadyInstalled <- lift $ ghcInstalled tver alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver) - -- download source tarball - dlInfo <- - preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls - ?? NoDownload - dl <- liftE $ downloadCached dlInfo Nothing - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ unpackToDir tmpUnpack dl - void $ liftIO $ darwinNotarization _rPlatform tmpUnpack + ghcdir <- lift $ ghcupGHCDir tver bghc <- case bstrap of Right g -> pure $ Right g Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver) - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - (view dlSubdir dlInfo) - ghcdir <- lift $ ghcupGHCDir tver (bindist, bmk) <- liftE $ runBuildAction tmpUnpack Nothing (do - b <- compileBindist bghc ghcdir workdir + b <- compileBindist bghc tver workdir bmk <- liftIO $ readFileStrict (build_mk workdir) pure (b, bmk) ) @@ -1139,7 +1185,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformReques lift $ $(logInfo) [i|Deleting existing installation|] liftE $ rmGHCVer tver liftE $ installPackedGHC bindist - (view dlSubdir dlInfo) + (Just $ RegexDir "ghc-.*") ghcdir (tver ^. tvVersion) pfreq @@ -1151,21 +1197,23 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformReques -- restore when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly + pure tver + where - defaultConf = case _tvTarget tver of - Nothing -> [s| -V=0 -BUILD_MAN = NO -BUILD_SPHINX_HTML = NO -BUILD_SPHINX_PDF = NO -HADDOCK_DOCS = YES|] - Just _ -> [s| + defaultConf = case targetGhc of + Left (GHCTargetVersion (Just _) _) -> [s| V=0 BUILD_MAN = NO BUILD_SPHINX_HTML = NO BUILD_SPHINX_PDF = NO HADDOCK_DOCS = NO Stage1Only = YES|] + _ -> [s| +V=0 +BUILD_MAN = NO +BUILD_SPHINX_HTML = NO +BUILD_SPHINX_PDF = NO +HADDOCK_DOCS = YES|] compileBindist :: ( MonadReader AppState m , MonadThrow m @@ -1175,13 +1223,13 @@ Stage1Only = YES|] , MonadFail m ) => Either (Path Rel) (Path Abs) - -> Path Abs + -> GHCTargetVersion -> Path Abs -> Excepts '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError] m (Path Abs) -- ^ output path of bindist - compileBindist bghc ghcdir workdir = do + compileBindist bghc tver workdir = do lift $ $(logInfo) [i|configuring build|] liftE checkBuildConfig @@ -1191,31 +1239,28 @@ Stage1Only = YES|] cEnv <- liftIO getEnvironment - if - | _tvVersion tver >= [vver|8.8.0|] -> do - bghcPath <- case bghc of - Right ghc' -> pure ghc' - Left bver -> do - spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath - liftIO (searchPath spaths bver) !? NotFoundInPATH bver + if | _tvVersion tver >= [vver|8.8.0|] -> do + bghcPath <- case bghc of + Right ghc' -> pure ghc' + Left bver -> do + spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath + liftIO (searchPath spaths bver) !? NotFoundInPATH bver + lEM $ execLogged + "./configure" + False + ( maybe mempty + (\x -> ["--target=" <> E.encodeUtf8 x]) + (_tvTarget tver) + ++ fmap E.encodeUtf8 aargs + ) + [rel|ghc-conf|] + (Just workdir) + (Just (("GHC", toFilePath bghcPath) : cEnv)) + | otherwise -> do lEM $ execLogged "./configure" False - ( ["--prefix=" <> toFilePath ghcdir] - ++ maybe mempty - (\x -> ["--target=" <> E.encodeUtf8 x]) - (_tvTarget tver) - ++ fmap E.encodeUtf8 aargs - ) - [rel|ghc-conf|] - (Just workdir) - (Just (("GHC", toFilePath bghcPath) : cEnv)) - | otherwise -> do - lEM $ execLogged - "./configure" - False - ( [ "--prefix=" <> toFilePath ghcdir - , "--with-ghc=" <> either toFilePath toFilePath bghc + ( [ "--with-ghc=" <> either toFilePath toFilePath bghc ] ++ maybe mempty (\x -> ["--target=" <> E.encodeUtf8 x]) @@ -1283,12 +1328,12 @@ Stage1Only = YES|] let lines' = fmap T.strip . T.lines $ decUTF8Safe c -- for cross, we need Stage1Only - case _tvTarget tver of - Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE + case targetGhc of + Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE (InvalidBuildConfig [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] ) - Nothing -> pure () + _ -> pure () @@ -1381,4 +1426,3 @@ postGHCInstall ver@GHCTargetVersion {..} = do $ getMajorMinorV _tvVersion forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY) - diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 4775dd8..a381848 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -379,6 +379,11 @@ data GHCTargetVersion = GHCTargetVersion } deriving (Ord, Eq, Show) +data GitBranch = GitBranch + { ref :: String + , repo :: Maybe String + } + deriving (Ord, Eq, Show) mkTVer :: Version -> GHCTargetVersion mkTVer = GHCTargetVersion Nothing diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 41a93d7..26fed41 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -770,6 +770,15 @@ make args workdir = do let mymake = if has_gmake then "gmake" else "make" execLogged mymake True args [rel|ghc-make|] workdir Nothing +makeOut :: [ByteString] + -> Maybe (Path Abs) + -> IO CapturedProcess +makeOut args workdir = do + spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath + has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|]) + let mymake = if has_gmake then [rel|gmake|] else [rel|make|] + liftIO $ executeOut mymake args workdir + -- | Try to apply patches in order. Fails with 'PatchFailed' -- on first failure. diff --git a/lib/GHCup/Utils/MegaParsec.hs b/lib/GHCup/Utils/MegaParsec.hs index 02bd009..c92762c 100644 --- a/lib/GHCup/Utils/MegaParsec.hs +++ b/lib/GHCup/Utils/MegaParsec.hs @@ -67,6 +67,15 @@ ghcTargetBinP t = <*> (MP.chunk t <* MP.eof) +-- | Extracts the version from @ProjectVersion="8.10.5"@. +ghcProjectVersion :: MP.Parsec Void Text Version +ghcProjectVersion = do + _ <- MP.chunk "ProjectVersion=\"" + ver <- parseUntil1 $ MP.chunk "\"" + MP.setInput ver + version' + + -- | Extracts target triple and version from e.g. -- * armv7-unknown-linux-gnueabihf-8.8.3 -- * armv7-unknown-linux-gnueabihf-8.8.3 From 49ccadd4705f0a7fd89eaeb0adacda84f43798cc Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 29 Apr 2021 14:46:45 +0200 Subject: [PATCH 2/4] Warn when overwriting current GHC due to compile --- lib/GHCup.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 029d323..13016c7 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -80,6 +80,7 @@ import System.IO.Error import System.Posix.Env.ByteString ( getEnvironment, getEnv ) import System.Posix.FilePath ( getSearchPath, takeExtension ) import System.Posix.Files.ByteString +import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix import qualified Crypto.Hash.SHA256 as SHA256 @@ -91,6 +92,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import GHCup.Utils.MegaParsec +import Control.Concurrent (threadDelay) @@ -1160,11 +1162,17 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe _stdErr)) void $ liftIO $ darwinNotarization _rPlatform tmpUnpack + lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|] pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) alreadyInstalled <- lift $ ghcInstalled tver alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver) + when alreadyInstalled $ do + lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|] + lift $ $(logWarn) + "...waiting for 10 seconds before continuing, you can still abort..." + liftIO $ threadDelay 10000000 -- give the user a sec to intervene ghcdir <- lift $ ghcupGHCDir tver From a905c6322caed7b9d76f9b8ea78a7f90f52e5f29 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 29 Apr 2021 14:47:22 +0200 Subject: [PATCH 3/4] Fix spelling --- lib/GHCup/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 26fed41..816e1b7 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -187,7 +187,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do ----------------------------------- --- | Whethe the given GHC versin is installed. +-- | Whether the given GHC versin is installed. ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver From 5a86a28d67cde69c81bb7d7dd108554a6adec903 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 29 Apr 2021 14:47:30 +0200 Subject: [PATCH 4/4] Smarter logging --- app/ghcup/Main.hs | 2 +- lib/GHCup/Utils/File.hs | 6 +++--- lib/GHCup/Utils/Logger.hs | 21 ++++++++++++++++----- 3 files changed, 20 insertions(+), 9 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 567da7d..538f2ca 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1069,7 +1069,7 @@ Report bugs at |] createDirRecursive' baseDir -- logger interpreter - logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|] + logfile <- flip runReaderT appstate $ initGHCupFileLogging let loggerConfig = LoggerConfig { lcPrintDebug = verbose settings , colorOutter = B.hPut stderr diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 408fec5..e782839 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -50,7 +50,7 @@ import System.Posix.Directory.ByteString import System.Posix.FD as FD import System.Posix.FilePath hiding ( () ) import System.Posix.Files.ByteString -import System.Posix.Foreign ( oExcl ) +import System.Posix.Foreign ( oExcl, oAppend ) import "unix" System.Posix.IO.ByteString hiding ( openFd ) import System.Posix.Process ( ProcessStatus(..) ) @@ -133,14 +133,14 @@ execLogged :: (MonadReader AppState 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 + -> Path Rel -- ^ log filename (opened in append mode) -> Maybe (Path Abs) -- ^ optionally chdir into this -> Maybe [(ByteString, ByteString)] -- ^ optional environment -> m (Either ProcessError ()) execLogged exe spath args lfile chdir env = do AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask logfile <- (logsDir ) <$> parseRel (toFilePath lfile <> ".log") - liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) + liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms)) closeFd (action verbose) where diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 58fd542..5f84c39 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} {-| Module : GHCup.Utils.Logger @@ -15,6 +16,8 @@ module GHCup.Utils.Logger where import GHCup.Types import GHCup.Utils +import GHCup.Utils.File +import GHCup.Utils.String.QQ import Control.Monad import Control.Monad.IO.Class @@ -25,6 +28,7 @@ import HPath.IO import Prelude hiding ( appendFile ) import System.Console.Pretty import System.IO.Error +import Text.Regex.Posix import qualified Data.ByteString as B @@ -64,12 +68,19 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger rawOutter outr -initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => Path Rel -> m (Path Abs) -initGHCupFileLogging context = do +initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m (Path Abs) +initGHCupFileLogging = do AppState {dirs = Dirs {..}} <- ask - let logfile = logsDir context + let logfile = logsDir [rel|ghcup.log|] liftIO $ do createDirRecursive' logsDir - hideError doesNotExistErrorType $ deleteFile logfile + logFiles <- findFiles + logsDir + (makeRegexOpts compExtended + execBlank + ([s|^.*\.log$|] :: B.ByteString) + ) + forM_ logFiles $ hideError doesNotExistErrorType . deleteFile . (logsDir ) + createRegularFile newFilePerms logfile pure logfile