From eaad2caf2520115d274c599dfa63ca3446e50202 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 19 Jul 2021 16:49:18 +0200 Subject: [PATCH] Add prefetch command --- .gitlab/script/ghcup_version.sh | 10 ++- app/ghcup/Main.hs | 132 ++++++++++++++++++++++++++++++++ lib/GHCup.hs | 96 +++++++++++++++++------ lib/GHCup/Download.hs | 75 ++++++++++-------- 4 files changed, 252 insertions(+), 61 deletions(-) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 3da1a0f..cd14874 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -107,17 +107,19 @@ else # test installing new ghc doesn't mess with currently set GHC # https://gitlab.haskell.org/haskell/ghcup-hs/issues/7 if [ "${OS}" = "LINUX" ] ; then - eghcup --downloader=wget install 8.10.3 + eghcup --downloader=wget prefetch ghc 8.10.3 + eghcup --offline install ghc 8.10.3 else # test wget a bit - eghcup install 8.10.3 + eghcup prefetch ghc 8.10.3 + eghcup --offline install ghc 8.10.3 fi [ "$(ghc --numeric-version)" = "${ghc_ver}" ] - eghcup set 8.10.3 + eghcup --offline set 8.10.3 eghcup set 8.10.3 [ "$(ghc --numeric-version)" = "8.10.3" ] eghcup set ${GHC_VERSION} [ "$(ghc --numeric-version)" = "${ghc_ver}" ] - eghcup rm 8.10.3 + eghcup --offline rm 8.10.3 [ "$(ghc --numeric-version)" = "${ghc_ver}" ] if [ "${OS}" = "DARWIN" ] ; then diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index a7224d4..389dc8a 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -112,6 +112,7 @@ data Command #if defined(BRICK) | Interactive #endif + | Prefetch PrefetchCommand data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal | ToolTag Tag @@ -201,6 +202,21 @@ data WhereisOptions = WhereisOptions { directory :: Bool } +data PrefetchOptions = PrefetchOptions { + pfCacheDir :: Maybe FilePath +} + +data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion) + | PrefetchCabal PrefetchOptions (Maybe ToolVersion) + | PrefetchHLS PrefetchOptions (Maybe ToolVersion) + | PrefetchStack PrefetchOptions (Maybe ToolVersion) + | PrefetchMetadata + +data PrefetchGHCOptions = PrefetchGHCOptions { + pfGHCSrc :: Bool + , pfGHCCacheDir :: Maybe FilePath +} + -- https://github.com/pcapriotti/optparse-applicative/issues/148 @@ -359,6 +375,16 @@ com = (progDesc "Find a tools location" <> footerDoc ( Just $ text whereisFooter )) ) + <> command + "prefetch" + (info + ( (Prefetch + <$> prefetchP + ) <**> helper + ) + (progDesc "Prefetch assets" + <> footerDoc ( Just $ text prefetchFooter )) + ) <> commandGroup "Main commands:" ) <|> subparser @@ -442,6 +468,17 @@ Examples: # outputs ~/.ghcup/bin/ ghcup whereis --directory cabal 3.4.0.0|] + prefetchFooter :: String + prefetchFooter = [s|Discussion: + Prefetches tools or assets into "~/.ghcup/cache" directory. This can + be then combined later with '--offline' flag, ensuring all assets that + are required for offline use have been prefetched. + +Examples: + ghcup prefetch metadata + ghcup prefetch ghc 8.10.5 + ghcup --offline install ghc 8.10.5|] + installCabalFooter :: String installCabalFooter = [s|Discussion: @@ -827,6 +864,55 @@ Examples: ghcup whereis --directory stack 2.7.1|] +prefetchP :: Parser PrefetchCommand +prefetchP = subparser + ( command + "ghc" + (info + (PrefetchGHC + <$> (PrefetchGHCOptions + <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) + <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just GHC)) )) + ( progDesc "Download GHC assets for installation") + ) + <> + command + "cabal" + (info + (PrefetchCabal + <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )) + ( progDesc "Download cabal assets for installation") + ) + <> + command + "hls" + (info + (PrefetchHLS + <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )) + ( progDesc "Download HLS assets for installation") + ) + <> + command + "stack" + (info + (PrefetchStack + <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)"))) + <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )) + ( progDesc "Download stack assets for installation") + ) + <> + command + "metadata" + (const PrefetchMetadata <$> info + helper + ( progDesc "Download ghcup's metadata, needed for various operations") + ) + ) + + ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = GHCCompileOptions @@ -1478,6 +1564,21 @@ Report bugs at |] , DownloadFailed ] + let runPrefetch = + runLogger + . runAppState + . runResourceT + . runE + @'[ TagNotFound + , NextVerNotFound + , NoToolVersionSet + , NoDownload + , DigestError + , DownloadFailed + , JSONError + , FileDoesNotExistError + ] + ----------------------- -- Command functions -- @@ -1994,6 +2095,37 @@ Make sure to clean up #{tmpdir} afterwards.|]) VLeft e -> do runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 15 + Prefetch pfCom -> + runPrefetch (do + case pfCom of + PrefetchGHC + (PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt GHC + if pfGHCSrc + then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir + else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir + PrefetchCabal (PrefetchOptions {pfCacheDir}) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt Cabal + liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir + PrefetchHLS (PrefetchOptions {pfCacheDir}) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt HLS + liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir + PrefetchStack (PrefetchOptions {pfCacheDir}) mt -> do + forM_ pfCacheDir (liftIO . createDirRecursive') + (v, _) <- liftE $ fromVersion mt Stack + liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir + PrefetchMetadata -> do + _ <- liftE $ getDownloadsF + pure "" + ) >>= \case + VRight _ -> do + pure ExitSuccess + VLeft e -> do + runLogger $ $(logError) $ T.pack $ prettyShow e + pure $ ExitFailure 15 case res of diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8a8e3e0..9d0cbff 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -95,6 +95,69 @@ import GHCup.Utils.MegaParsec import Control.Concurrent (threadDelay) + --------------------- + --[ Tool fetching ]-- + --------------------- + + +fetchToolBindist :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Tool + -> Maybe FilePath + -> Excepts + '[ DigestError + , DownloadFailed + , NoDownload + ] + m + FilePath +fetchToolBindist v t mfp = do + dlinfo <- liftE $ getDownloadInfo t v + liftE $ downloadCached' dlinfo Nothing mfp + + +fetchGHCSrc :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , MonadLogger m + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Maybe FilePath + -> Excepts + '[ DigestError + , DownloadFailed + , NoDownload + ] + m + FilePath +fetchGHCSrc v mfp = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlInfo <- + preview (ix GHC % ix v % viSourceDL % _Just) dls + ?? NoDownload + liftE $ downloadCached' dlInfo Nothing mfp + + ------------------------- --[ Tool installation ]-- @@ -284,9 +347,7 @@ installGHCBin :: ( MonadFail m m () installGHCBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - dlinfo <- lE $ getDownloadInfo GHC ver pfreq dls + dlinfo <- liftE $ getDownloadInfo GHC ver installGHCBindist dlinfo ver @@ -405,10 +466,7 @@ installCabalBin :: ( MonadMask m m () installCabalBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - dlinfo <- lE $ getDownloadInfo Cabal ver pfreq dls + dlinfo <- liftE $ getDownloadInfo Cabal ver installCabalBindist dlinfo ver @@ -536,10 +594,7 @@ installHLSBin :: ( MonadMask m m () installHLSBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - dlinfo <- lE $ getDownloadInfo HLS ver pfreq dls + dlinfo <- liftE $ getDownloadInfo HLS ver installHLSBindist dlinfo ver @@ -576,10 +631,7 @@ installStackBin :: ( MonadMask m m () installStackBin ver = do - pfreq <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - dlinfo <- lE $ getDownloadInfo Stack ver pfreq dls + dlinfo <- liftE $ getDownloadInfo Stack ver installStackBindist dlinfo ver @@ -1128,12 +1180,9 @@ listVersions lt' criteria = do -> (Version, [Tag]) -> m ListResult toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do - pfreq <- getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - case t of GHC -> do - let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v let tver = mkTVer v lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing lInstalled <- ghcInstalled tver @@ -1141,7 +1190,7 @@ listVersions lt' criteria = do hlsPowered <- fmap (elem v) hlsGHCVersions pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } Cabal -> do - let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v let lSet = cSet == Just v let lInstalled = elem v $ rights cabals pure ListResult { lVer = v @@ -1167,7 +1216,7 @@ listVersions lt' criteria = do , .. } HLS -> do - let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v let lSet = hlsSet' == Just v let lInstalled = elem v $ rights hlses pure ListResult { lVer = v @@ -1180,7 +1229,7 @@ listVersions lt' criteria = do , .. } Stack -> do - let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq dls + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v let lSet = stackSet' == Just v let lInstalled = elem v $ rights stacks pure ListResult { lVer = v @@ -1922,13 +1971,12 @@ upgradeGHCup :: ( MonadMask m Version upgradeGHCup mtarget force' = do Dirs {..} <- lift getDirs - pfreq <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ fst <$> getLatest dls GHCup when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate - dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls + dli <- liftE $ getDownloadInfo GHCup latestVer tmp <- lift withGHCupTmpDir let fn = "ghcup" <> exeExt p <- liftE $ download dli tmp (Just fn) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 54a60e4..b9f0125 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -299,39 +299,46 @@ getBase uri = do setModificationTime path utctime -getDownloadInfo :: Tool +getDownloadInfo :: ( MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + ) + => Tool -> Version -- ^ tool version - -> PlatformRequest - -> GHCupDownloads - -> Either NoDownload DownloadInfo -getDownloadInfo t v (PlatformRequest a p mv) dls = maybe - (Left NoDownload) - Right - (case p of - -- non-musl won't work on alpine - Linux Alpine -> with_distro <|> without_distro_ver - _ -> with_distro <|> without_distro_ver <|> without_distro - ) + -> Excepts + '[NoDownload] + m + DownloadInfo +getDownloadInfo t v = do + (PlatformRequest a p mv) <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - where - with_distro = distro_preview id id - without_distro_ver = distro_preview id (const Nothing) - without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) + let distro_preview f g = + let platformVersionSpec = + preview (ix t % ix v % viArch % ix a % ix (f p)) dls + mv' = g mv + in fmap snd + . find + (\(mverRange, _) -> maybe + (isNothing mv') + (\range -> maybe False (`versionRange` range) mv') + mverRange + ) + . M.toList + =<< platformVersionSpec + with_distro = distro_preview id id + without_distro_ver = distro_preview id (const Nothing) + without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) - distro_preview f g = - let platformVersionSpec = - preview (ix t % ix v % viArch % ix a % ix (f p)) dls - mv' = g mv - in fmap snd - . find - (\(mverRange, _) -> maybe - (isNothing mv') - (\range -> maybe False (`versionRange` range) mv') - mverRange - ) - . M.toList - =<< platformVersionSpec + maybe + (throwE NoDownload) + pure + (case p of + -- non-musl won't work on alpine + Linux Alpine -> with_distro <|> without_distro_ver + _ -> with_distro <|> without_distro_ver <|> without_distro + ) -- | Tries to download from the given http or https url @@ -431,7 +438,7 @@ downloadCached :: ( MonadReader env m downloadCached dli mfn = do Settings{ cache } <- lift getSettings case cache of - True -> downloadCached' dli mfn + True -> downloadCached' dli mfn Nothing False -> do tmp <- lift withGHCupTmpDir liftE $ download dli tmp mfn @@ -448,17 +455,19 @@ downloadCached' :: ( MonadReader env m ) => DownloadInfo -> Maybe FilePath -- ^ optional filename + -> Maybe FilePath -- ^ optional destination dir (default: cacheDir) -> Excepts '[DigestError , DownloadFailed] m FilePath -downloadCached' dli mfn = do +downloadCached' dli mfn mDestDir = do Dirs { cacheDir } <- lift getDirs + let destDir = fromMaybe cacheDir mDestDir let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn - let cachfile = cacheDir fn + let cachfile = destDir fn fileExists <- liftIO $ doesFileExist cachfile if | fileExists -> do liftE $ checkDigest dli cachfile pure cachfile - | otherwise -> liftE $ download dli cacheDir mfn + | otherwise -> liftE $ download dli destDir mfn