ghcup-hs/lib-opt/GHCup/OptParse/Prefetch.hs

225 lines
6.9 KiB
Haskell
Raw Permalink Normal View History

2021-10-15 20:24:23 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Prefetch where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
2021-10-15 20:24:23 +00:00
import GHCup.OptParse.Common
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Download (getDownloadsF)
----------------
--[ Commands ]--
----------------
data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
| PrefetchCabal PrefetchOptions (Maybe ToolVersion)
| PrefetchHLS PrefetchOptions (Maybe ToolVersion)
| PrefetchStack PrefetchOptions (Maybe ToolVersion)
| PrefetchMetadata
---------------
--[ Options ]--
---------------
data PrefetchOptions = PrefetchOptions {
pfCacheDir :: Maybe FilePath
}
data PrefetchGHCOptions = PrefetchGHCOptions {
pfGHCSrc :: Bool
, pfGHCCacheDir :: Maybe FilePath
}
---------------
--[ Parsers ]--
---------------
2021-10-15 20:24:23 +00:00
prefetchP :: Parser PrefetchCommand
prefetchP = subparser
( command
"ghc"
(info
2021-10-15 20:24:23 +00:00
(PrefetchGHC
<$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
2022-03-04 23:46:37 +00:00
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> optional (toolVersionTagArgument [] (Just GHC)) )
2021-10-15 20:24:23 +00:00
( progDesc "Download GHC assets for installation")
)
<>
command
"cabal"
(info
2021-10-15 20:24:23 +00:00
(PrefetchCabal
2022-03-04 23:46:37 +00:00
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument [] (Just Cabal)) <**> helper ))
2021-10-15 20:24:23 +00:00
( progDesc "Download cabal assets for installation")
)
<>
command
"hls"
(info
2021-10-15 20:24:23 +00:00
(PrefetchHLS
2022-03-04 23:46:37 +00:00
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument [] (Just HLS)) <**> helper ))
2021-10-15 20:24:23 +00:00
( progDesc "Download HLS assets for installation")
)
<>
command
"stack"
(info
2021-10-15 20:24:23 +00:00
(PrefetchStack
2022-03-04 23:46:37 +00:00
<$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
<*> ( optional (toolVersionTagArgument [] (Just Stack)) <**> helper ))
2021-10-15 20:24:23 +00:00
( progDesc "Download stack assets for installation")
)
<>
command
"metadata"
(PrefetchMetadata <$ info
helper
( progDesc "Download ghcup's metadata, needed for various operations")
)
)
--------------
--[ Footer ]--
--------------
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|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type PrefetchEffects = '[ TagNotFound
, DayNotFound
2021-10-15 20:24:23 +00:00
, NextVerNotFound
, NoToolVersionSet
, NoDownload
, DigestError
, ContentLengthError
2021-10-15 20:24:23 +00:00
, GPGError
, DownloadFailed
, JSONError
, FileDoesNotExistError
, StackPlatformDetectError
]
2021-10-15 20:24:23 +00:00
runPrefetch :: MonadUnliftIO m
=> (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
-> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither PrefetchEffects a)
runPrefetch runAppState =
runAppState
. runResourceT
. runE
@PrefetchEffects
------------------
--[ Entrypoint ]--
------------------
prefetch :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> PrefetchCommand
-> (forall a. ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
prefetch prefetchCommand runAppState runLogger =
runPrefetch runAppState (do
case prefetchCommand of
PrefetchGHC
(PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc
2023-07-07 08:41:58 +00:00
then liftE $ fetchGHCSrc v pfCacheDir
2023-11-12 10:21:49 +00:00
else liftE $ fetchToolBindist v GHC pfCacheDir
2021-10-15 20:24:23 +00:00
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Cabal
2023-11-12 10:21:49 +00:00
liftE $ fetchToolBindist v Cabal pfCacheDir
2021-10-15 20:24:23 +00:00
PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt HLS
2023-11-12 10:21:49 +00:00
liftE $ fetchToolBindist v HLS pfCacheDir
2021-10-15 20:24:23 +00:00
PrefetchStack PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Stack
2023-11-12 10:21:49 +00:00
liftE $ fetchToolBindist v Stack pfCacheDir
2021-10-15 20:24:23 +00:00
PrefetchMetadata -> do
pfreq <- lift getPlatformReq
_ <- liftE $ getDownloadsF pfreq
2021-10-15 20:24:23 +00:00
pure ""
) >>= \case
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
2021-10-15 20:24:23 +00:00
pure $ ExitFailure 15