Add prefetch command

.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

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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , 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

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)

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