ghcup-hs/app/ghcup/GHCup/OptParse/Prefetch.hs

220 lines
6.7 KiB
Haskell
Raw 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.Utils.Logger
import GHCup.OptParse.Common
import GHCup.Utils.String.QQ
#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 Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Utils.Prelude
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 ]--
---------------
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"
(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
, NextVerNotFound
, NoToolVersionSet
, NoDownload
, DigestError
, GPGError
, DownloadFailed
, JSONError
, FileDoesNotExistError ]
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
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