hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add --offline switch wrt #186

Browse Source
This commit is contained in:
Julian Ospald 2021-07-18 23:29:09 +02:00
parent 2c7176d998
commit 6143cdf2e0
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
11 changed files with 193 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
app/ghcup-gen/Validate.hs
View File

@ -12,7 +12,7 @@ import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Platform import GHCup.Platform
import GHCup.Types import GHCup.Types hiding ( LeanAppState (..) )
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Logger import GHCup.Utils.Logger
@ -226,7 +226,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
, rawOutter = \_ -> pure () , rawOutter = \_ -> pure ()
} }
downloadAll dli = do downloadAll dli = do
dirs <- liftIO getDirs dirs <- liftIO getAllDirs
pfreq <- ( pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
($(logError) $ T.pack $ prettyShow e) ($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2) liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq let appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
r <- r <-
runLogger runLogger
@ -256,17 +256,17 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
case etool of case etool of
Right (Just GHCup) -> do Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing _ <- liftE $ download dli tmpUnpack Nothing
pure Nothing pure Nothing
Right _ -> do Right _ -> do
p <- liftE $ downloadCached (settings appstate) dirs dli Nothing p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head) fmap (Just . head . splitDirectories . head)
. liftE . liftE
. getArchiveFiles . getArchiveFiles
$ p $ p
Left ShimGen -> do Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing _ <- liftE $ download dli tmpUnpack Nothing
pure Nothing pure Nothing
case r of case r of
VRight (Just basePath) -> do VRight (Just basePath) -> do

16
app/ghcup/BrickMain.hs
View File

@ -13,7 +13,7 @@ module BrickMain where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe ) import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File import GHCup.Utils.File
@ -53,8 +53,6 @@ import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
import qualified GHCup.Types as GT
import qualified Data.Text as T import qualified Data.Text as T
import qualified Graphics.Vty as Vty import qualified Graphics.Vty as Vty
import qualified Data.Vector as V import qualified Data.Vector as V
@ -550,13 +548,14 @@ changelog' _ (_, ListResult {..}) = do
settings' :: IORef AppState settings' :: IORef AppState
{-# NOINLINE settings' #-} {-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do settings' = unsafePerformIO $ do
dirs <- getDirs dirs <- getAllDirs
newIORef $ AppState (Settings { cache = True newIORef $ AppState (Settings { cache = True
, noVerify = False , noVerify = False
, keepDirs = Never , keepDirs = Never
, downloader = Curl , downloader = Curl
, verbose = False , verbose = False
, urlSource = GHCupURL , urlSource = GHCupURL
, noNetwork = False
, .. , ..
}) })
dirs dirs
@ -578,9 +577,8 @@ logger' = unsafePerformIO
brickMain :: AppState brickMain :: AppState
-> LoggerConfig -> LoggerConfig
-> GHCupInfo
-> IO () -> IO ()
brickMain s l gi = do brickMain s l = do
writeIORef settings' s writeIORef settings' s
-- logger interpreter -- logger interpreter
writeIORef logger' l writeIORef logger' l
@ -588,7 +586,7 @@ brickMain s l gi = do
no_color <- isJust <$> lookupEnv "NO_COLOR" no_color <- isJust <$> lookupEnv "NO_COLOR"
eAppData <- getAppData (Just gi) eAppData <- getAppData (Just $ ghcupInfo s)
case eAppData of case eAppData of
Right ad -> Right ad ->
defaultMain defaultMain
@ -596,7 +594,7 @@ brickMain s l gi = do
(BrickState ad (BrickState ad
defaultAppSettings defaultAppSettings
(constructList ad defaultAppSettings Nothing) (constructList ad defaultAppSettings Nothing)
(keyBindings s) (keyBindings (s :: AppState))
) )
$> () $> ()
@ -620,7 +618,7 @@ getGHCupInfo = do
. flip runReaderT settings . flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError] . runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF (GT.settings settings) (GT.dirs settings) $ getDownloadsF
case r of case r of
VRight a -> pure $ Right a VRight a -> pure $ Right a

42
app/ghcup/Main.hs
View File

@ -91,6 +91,7 @@ data Options = Options
, optNoVerify :: Maybe Bool , optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs , optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader , optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool
-- commands -- commands
, optCommand :: Command , optCommand :: Command
} }
@ -277,6 +278,7 @@ opts =
#endif #endif
<> hidden <> hidden
)) ))
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
<*> com <*> com
where where
parseUri s' = parseUri s' =
@ -943,13 +945,19 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs dirs' <- liftIO getAllDirs
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
, colorOutter = mempty , colorOutter = mempty
, rawOutter = mempty , rawOutter = mempty
} }
let runLogger = myLoggerT loggerConfig let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs'
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of case mGhcUpInfo of
VRight ghcupInfo -> do VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old) let allTags = filter (\t -> t /= Old)
@ -969,12 +977,17 @@ versionCompleter criteria tool = listIOCompleter $ do
, rawOutter = mempty , rawOutter = mempty
} }
let runLogger = myLoggerT loggerConfig let runLogger = myLoggerT loggerConfig
mGhcUpInfo <- runLogger . runE $ readFromCache dirs' settings = Settings True False Never Curl False GHCupURL True
mpFreq <- runLogger . runE $ platformRequest let leanAppState = LeanAppState
forFold mpFreq $ \pfreq -> settings
dirs'
defaultKeyBindings
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do
forFold mGhcUpInfo $ \ghcupInfo -> do forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState let appState = AppState
(Settings True False Never Curl False GHCupURL) settings
dirs' dirs'
defaultKeyBindings defaultKeyBindings
ghcupInfo ghcupInfo
@ -1123,6 +1136,7 @@ toSettings options = do
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal defaultDownloader = Internal
@ -1168,7 +1182,9 @@ describe_result = $( LitE . StringL <$>
runIO (do runIO (do
CapturedProcess{..} <- do CapturedProcess{..} <- do
dirs <- liftIO getAllDirs dirs <- liftIO getAllDirs
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings let settings = AppState (Settings True False Never Curl False GHCupURL False)
dirs
defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing flip runReaderT settings $ executeOut "git" ["describe"] Nothing
case _exitCode of case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
@ -1259,9 +1275,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
ghcupInfo <- ghcupInfo <-
( runLogger ( runLogger
. flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError] . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF settings dirs $ getDownloadsF
) )
>>= \case >>= \case
VRight r -> pure r VRight r -> pure r
@ -1285,7 +1302,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure s' pure s'
#if defined(IS_WINDOWS)
-- FIXME: windows needs 'ensureGlobalTools', which requires
-- full appstate
runLeanAppState = runAppState
#else
runLeanAppState = flip runReaderT leanAppstate runLeanAppState = flip runReaderT leanAppstate
#endif
runAppState action' = do runAppState action' = do
s' <- liftIO appState s' <- liftIO appState
flip runReaderT s' action' flip runReaderT s' action'
@ -1299,7 +1322,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runInstTool' appstate' mInstPlatform = let runInstTool' appstate' mInstPlatform =
runLogger runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform) . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1733,7 +1756,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of res <- case optCommand of
#if defined(BRICK) #if defined(BRICK)
Interactive -> do Interactive -> do
liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess s' <- appState
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
#endif #endif
Install (Right iopts) -> do Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])

4
ghcup.cabal
View File

@ -116,7 +116,7 @@ library
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31 , monad-logger ^>=0.3.31
, mtl ^>=2.2 , mtl ^>=2.2
, optics >=0.2 && <0.5 , optics ^>=0.4
, optics-vl ^>=0.2 , optics-vl ^>=0.2
, os-release ^>=1.0.0 , os-release ^>=1.0.0
, parsec ^>=3.1 , parsec ^>=3.1
@ -279,7 +279,7 @@ executable ghcup-gen
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant >=3.0 && <3.2
, monad-logger ^>=0.3.31 , monad-logger ^>=0.3.31
, mtl ^>=2.2 , mtl ^>=2.2
, optics >=0.2 && <0.5 , optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.17 , optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1 , pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0 , pretty-terminal ^>=0.1.0.0

33
lib/GHCup.hs
View File

@ -133,15 +133,12 @@ installGHCBindist :: ( MonadFail m
m m
() ()
installGHCBindist dlinfo ver = do installGHCBindist dlinfo ver = do
dirs <- lift getDirs
settings <- lift getSettings
let tver = mkTVer ver let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- prepare paths -- prepare paths
ghcdir <- lift $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
@ -328,8 +325,7 @@ installCabalBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
dirs@Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
settings <- lift getSettings
whenM whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $ (lift (cabalInstalled ver) >>= \a -> liftIO $
@ -341,10 +337,10 @@ installCabalBindist dlinfo ver = do
(throwE $ AlreadyInstalled Cabal ver) (throwE $ AlreadyInstalled Cabal ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack -- unpack
tmpUnpack <- lift withGHCupTmpDir tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack void $ lift $ darwinNotarization _rPlatform tmpUnpack
@ -451,17 +447,16 @@ installHLSBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|] lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
dirs@Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
settings <- lift getSettings
whenM (lift (hlsInstalled ver)) whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver) (throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack -- unpack
tmpUnpack <- lift withGHCupTmpDir tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack void $ lift $ darwinNotarization _rPlatform tmpUnpack
@ -623,17 +618,16 @@ installStackBindist dlinfo ver = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|] lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
dirs@Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
settings <- lift getSettings
whenM (lift (stackInstalled ver)) whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver) (throwE $ AlreadyInstalled Stack ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached settings dirs dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack -- unpack
tmpUnpack <- lift withGHCupTmpDir tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack void $ lift $ darwinNotarization _rPlatform tmpUnpack
@ -1634,8 +1628,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
= do = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
settings <- lift getSettings
dirs <- lift getDirs
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
@ -1646,7 +1638,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
dlInfo <- dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload
dl <- liftE $ downloadCached settings dirs dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
@ -1931,7 +1923,6 @@ upgradeGHCup :: ( MonadMask m
upgradeGHCup mtarget force' = do upgradeGHCup mtarget force' = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
pfreq <- lift getPlatformReq pfreq <- lift getPlatformReq
settings <- lift getSettings
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
@ -1940,7 +1931,7 @@ upgradeGHCup mtarget force' = do
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
let fn = "ghcup" <> exeExt let fn = "ghcup" <> exeExt
p <- liftE $ download settings dli tmp (Just fn) p <- liftE $ download dli tmp (Just fn)
let destDir = takeDirectory destFile let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn <> exeExt) mtarget destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
lift $ $(logDebug) [i|mkdir -p #{destDir}|] lift $ $(logDebug) [i|mkdir -p #{destDir}|]

183
lib/GHCup/Download.hs
View File

@ -107,32 +107,31 @@ import qualified Data.Yaml as Y
getDownloadsF :: ( FromJSONKey Tool getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version , FromJSONKey Version
, FromJSON VersionInfo , FromJSON VersionInfo
, MonadReader env m
, HasSettings env
, HasDirs env
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
) )
=> Settings => Excepts
-> Dirs
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError] '[JSONError , DownloadFailed , FileDoesNotExistError]
m m
GHCupInfo GHCupInfo
getDownloadsF settings@Settings{ urlSource } dirs = do getDownloadsF = do
Settings { urlSource } <- lift getSettings
case urlSource of case urlSource of
GHCupURL -> liftE $ getBase dirs settings GHCupURL -> liftE $ getBase ghcupURL
(OwnSource url) -> do (OwnSource url) -> liftE $ getBase url
bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av (OwnSpec av) -> pure av
(AddSource (Left ext)) -> do (AddSource (Left ext)) -> do
base <- liftE $ getBase dirs settings base <- liftE $ getBase ghcupURL
pure (mergeGhcupInfo base ext) pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do (AddSource (Right uri)) -> do
base <- liftE $ getBase dirs settings base <- liftE $ getBase ghcupURL
bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri ext <- liftE $ getBase uri
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext) pure (mergeGhcupInfo base ext)
where where
@ -149,33 +148,49 @@ getDownloadsF settings@Settings{ urlSource } dirs = do
in GHCupInfo tr newDownloads newGlobalTools in GHCupInfo tr newDownloads newGlobalTools
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m) readFromCache :: ( MonadReader env m
=> Dirs , HasDirs env
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo , MonadIO m
readFromCache Dirs {..} = do , MonadCatch m)
lift $ $(logWarn) => URI
[i|Could not get download info, trying cached version (this may not be recent!)|] -> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
let path = view pathL' ghcupURL readFromCache uri = do
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path) Dirs{..} <- lift getDirs
bs <- let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
handleIO' NoSuchThing handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
(\_ -> throwE $ FileDoesNotExistError yaml_file) . liftIO
$ liftIO . L.readFile
$ L.readFile yaml_file $ yaml_file
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m) getBase :: ( MonadReader env m
=> Dirs , HasDirs env
-> Settings , HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadLogger m
)
=> URI
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase dirs@Dirs{..} Settings{ downloader } = getBase uri = do
handleIO (\_ -> readFromCache dirs) Settings { noNetwork } <- lift getSettings
$ catchE @_ @'[JSONError, FileDoesNotExistError] bs <- if noNetwork
(\(DownloadFailed _) -> readFromCache dirs) then readFromCache uri
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL) else handleIO (\_ -> warnCache >> readFromCache uri)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict)) . catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
where . reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
$ smartDl uri
liftE
. lE' @_ @_ @'[JSONError] JSONDecodeError
. first show
. Y.decodeEither'
. L.toStrict
$ bs
where
warnCache = lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
-- First check if the json file is in the ~/.ghcup/cache dir -- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the -- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it. -- last 5 minutes, just reuse it.
@ -185,8 +200,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
-- than the local file. -- than the local file.
-- --
-- Always save the local file with the mod time of the remote file. -- Always save the local file with the mod time of the remote file.
smartDl :: forall m1 smartDl :: forall m1 env1
. ( MonadCatch m1 . ( MonadReader env1 m1
, HasDirs env1
, HasSettings env1
, MonadCatch m1
, MonadIO m1 , MonadIO m1
, MonadFail m1 , MonadFail m1
, MonadLogger m1 , MonadLogger m1
@ -200,13 +218,15 @@ getBase dirs@Dirs{..} Settings{ downloader } =
, NoLocationHeader , NoLocationHeader
, TooManyRedirs , TooManyRedirs
, ProcessError , ProcessError
, NoNetwork
] ]
m1 m1
L.ByteString L.ByteString
smartDl uri' = do smartDl uri' = do
Dirs{..} <- lift getDirs
let path = view pathL' uri' let path = view pathL' uri'
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path) let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
if e if e
then do then do
accessTime <- liftIO $ getAccessTime json_file accessTime <- liftIO $ getAccessTime json_file
@ -237,11 +257,11 @@ getBase dirs@Dirs{..} Settings{ downloader } =
where where
dlWithMod modTime json_file = do dlWithMod modTime json_file = do
bs <- liftE $ downloadBS downloader uri' bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs liftIO $ writeFileWithModTime modTime json_file bs
pure bs pure bs
dlWithoutMod json_file = do dlWithoutMod json_file = do
bs <- liftE $ downloadBS downloader uri' bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ rmFile json_file liftIO $ hideError doesNotExistErrorType $ rmFile json_file
liftIO $ L.writeFile json_file bs liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0)) liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
@ -321,17 +341,19 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
-- 2. otherwise create a random file -- 2. otherwise create a random file
-- --
-- The file must not exist. -- The file must not exist.
download :: ( MonadMask m download :: ( MonadReader env m
, HasSettings env
, HasDirs env
, MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
) )
=> Settings => DownloadInfo
-> DownloadInfo
-> FilePath -- ^ destination dir -> FilePath -- ^ destination dir
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath -> Excepts '[DigestError , DownloadFailed] m FilePath
download settings@Settings{ downloader } dli dest mfn download dli dest mfn
| scheme == "https" = dl | scheme == "https" = dl
| scheme == "http" = dl | scheme == "http" = dl
| scheme == "file" = cp | scheme == "file" = cp
@ -362,6 +384,8 @@ download settings@Settings{ downloader } dli dest mfn
liftIO (hideError doesNotExistErrorType $ rmFile destFile) liftIO (hideError doesNotExistErrorType $ rmFile destFile)
>> (throwE . DownloadFailed $ e) >> (throwE . DownloadFailed $ e)
) $ do ) $ do
Settings{ downloader, noNetwork } <- lift getSettings
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
case downloader of case downloader of
Curl -> do Curl -> do
o' <- liftIO getCurlOpts o' <- liftIO getCurlOpts
@ -377,58 +401,64 @@ download settings@Settings{ downloader } dli dest mfn
liftE $ downloadToFile https host fullPath port destFile liftE $ downloadToFile https host fullPath port destFile
#endif #endif
liftE $ checkDigest settings dli destFile liftE $ checkDigest dli destFile
pure destFile pure destFile
-- Manage to find a file we can write the body into. -- Manage to find a file we can write the body into.
getDestFile :: FilePath getDestFile :: FilePath
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
(dest </>)
mfn
path = view (dlUri % pathL') dli path = view (dlUri % pathL') dli
-- | Download into tmpdir or use cached version, if it exists. If filename -- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url. -- is omitted, infers the filename from the url.
downloadCached :: ( MonadMask m downloadCached :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadResource m , MonadResource m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Settings => DownloadInfo
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath -> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached settings@Settings{ cache } dirs dli mfn = do downloadCached dli mfn = do
Settings{ cache } <- lift getSettings
case cache of case cache of
True -> downloadCached' settings dirs dli mfn True -> downloadCached' dli mfn
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download settings dli tmp mfn liftE $ download dli tmp mfn
downloadCached' :: ( MonadMask m downloadCached' :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Settings => DownloadInfo
-> Dirs
-> DownloadInfo
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath -> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached' settings Dirs{..} dli mfn = do downloadCached' dli mfn = do
Dirs { cacheDir } <- lift getDirs
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = cacheDir </> fn let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
| fileExists -> do | fileExists -> do
liftE $ checkDigest settings dli cachfile liftE $ checkDigest dli cachfile
pure cachfile pure cachfile
| otherwise -> liftE $ download settings dli cacheDir mfn | otherwise -> liftE $ download dli cacheDir mfn
@ -441,9 +471,13 @@ downloadCached' settings Dirs{..} dli mfn = do
-- | This is used for downloading the JSON. -- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m) downloadBS :: ( MonadReader env m
=> Downloader , HasSettings env
-> URI , MonadCatch m
, MonadIO m
, MonadLogger m
)
=> URI
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
, HTTPStatusError , HTTPStatusError
@ -452,10 +486,11 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
, NoLocationHeader , NoLocationHeader
, TooManyRedirs , TooManyRedirs
, ProcessError , ProcessError
, NoNetwork
] ]
m m
L.ByteString L.ByteString
downloadBS downloader uri' downloadBS uri'
| scheme == "https" | scheme == "https"
= dl True = dl True
| scheme == "http" | scheme == "http"
@ -475,6 +510,8 @@ downloadBS downloader uri'
dl _ = do dl _ = do
#endif #endif
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|] lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
Settings{ downloader, noNetwork } <- lift getSettings
when noNetwork $ throwE NoNetwork
case downloader of case downloader of
Curl -> do Curl -> do
o' <- liftIO getCurlOpts o' <- liftIO getCurlOpts
@ -499,12 +536,18 @@ downloadBS downloader uri'
#endif #endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m) checkDigest :: ( MonadReader env m
=> Settings , HasDirs env
-> DownloadInfo , HasSettings env
, MonadIO m
, MonadThrow m
, MonadLogger m
)
=> DownloadInfo
-> FilePath -> FilePath
-> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
checkDigest Settings{ noVerify } dli file = do checkDigest dli file = do
Settings{ noVerify } <- lift getSettings
let verify = not noVerify let verify = not noVerify
when verify $ do when verify $ do
let p' = takeFileName file let p' = takeFileName file

7
lib/GHCup/Errors.hs
View File

@ -233,6 +233,13 @@ instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) = pPrint (NoToolVersionSet tool) =
text [i|No version is set for tool "#{tool}".|] text [i|No version is set for tool "#{tool}".|]
data NoNetwork = NoNetwork
deriving Show
instance Pretty NoNetwork where
pPrint NoNetwork =
text [i|A download was required or requested, but '--offline' was specified.|]
------------------------- -------------------------
--[ High-level errors ]-- --[ High-level errors ]--

9
lib/GHCup/Types.hs
View File

@ -297,11 +297,12 @@ data UserSettings = UserSettings
, uDownloader :: Maybe Downloader , uDownloader :: Maybe Downloader
, uKeyBindings :: Maybe UserKeyBindings , uKeyBindings :: Maybe UserKeyBindings
, uUrlSource :: Maybe URLSource , uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data UserKeyBindings = UserKeyBindings data UserKeyBindings = UserKeyBindings
{ kUp :: Maybe Key { kUp :: Maybe Key
@ -353,13 +354,16 @@ data AppState = AppState
, pfreq :: PlatformRequest , pfreq :: PlatformRequest
} deriving (Show, GHC.Generic) } deriving (Show, GHC.Generic)
instance NFData AppState
data LeanAppState = LeanAppState data LeanAppState = LeanAppState
{ settings :: Settings { settings :: Settings
, dirs :: Dirs , dirs :: Dirs
, keyBindings :: KeyBindings , keyBindings :: KeyBindings
} deriving (Show, GHC.Generic) } deriving (Show, GHC.Generic)
instance NFData AppState instance NFData LeanAppState
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
@ -368,6 +372,7 @@ data Settings = Settings
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
, urlSource :: URLSource , urlSource :: URLSource
, noNetwork :: Bool
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)

2
lib/GHCup/Utils.hs
View File

@ -1071,7 +1071,7 @@ ensureGlobalTools = do
dirs <- lift getDirs dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload] shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' settings dirs shimDownload (Just "gs.exe") let dl = downloadCached' shimDownload (Just "gs.exe")
void $ (\(DigestError _ _) -> do void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|] lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|] lift $ $(logDebug) [i|rm -f #{shimDownload}|]

1
lib/GHCup/Utils/File/Windows.hs
View File

@ -19,6 +19,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.File.Common import GHCup.Utils.File.Common
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent import Control.Concurrent
import Control.DeepSeq import Control.DeepSeq

4
stack.yaml
View File

@ -31,6 +31,10 @@ extra-deps:
- libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990 - libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716 - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
- optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432
- optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728 - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
- regex-posix-clib-2.7 - regex-posix-clib-2.7
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421 - streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421