diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 3c468e1..a8f414d 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -12,7 +12,7 @@ import GHCup import GHCup.Download import GHCup.Errors import GHCup.Platform -import GHCup.Types +import GHCup.Types hiding ( LeanAppState (..) ) import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.Logger @@ -226,7 +226,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do , rawOutter = \_ -> pure () } downloadAll dli = do - dirs <- liftIO getDirs + dirs <- liftIO getAllDirs pfreq <- ( runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest @@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do ($(logError) $ T.pack $ prettyShow e) 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 <- runLogger @@ -256,17 +256,17 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do case etool of Right (Just GHCup) -> do tmpUnpack <- lift mkGhcupTmpDir - _ <- liftE $ download (settings appstate) dli tmpUnpack Nothing + _ <- liftE $ download dli tmpUnpack Nothing pure Nothing Right _ -> do - p <- liftE $ downloadCached (settings appstate) dirs dli Nothing + p <- liftE $ downloadCached dli Nothing fmap (Just . head . splitDirectories . head) . liftE . getArchiveFiles $ p Left ShimGen -> do tmpUnpack <- lift mkGhcupTmpDir - _ <- liftE $ download (settings appstate) dli tmpUnpack Nothing + _ <- liftE $ download dli tmpUnpack Nothing pure Nothing case r of VRight (Just basePath) -> do diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 0ae2389..ba6d8bc 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -13,7 +13,7 @@ module BrickMain where import GHCup import GHCup.Download import GHCup.Errors -import GHCup.Types +import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils import GHCup.Utils.Prelude ( decUTF8Safe ) import GHCup.Utils.File @@ -53,8 +53,6 @@ import System.IO.Unsafe import Text.PrettyPrint.HughesPJClass ( prettyShow ) import URI.ByteString -import qualified GHCup.Types as GT - import qualified Data.Text as T import qualified Graphics.Vty as Vty import qualified Data.Vector as V @@ -550,13 +548,14 @@ changelog' _ (_, ListResult {..}) = do settings' :: IORef AppState {-# NOINLINE settings' #-} settings' = unsafePerformIO $ do - dirs <- getDirs + dirs <- getAllDirs newIORef $ AppState (Settings { cache = True , noVerify = False , keepDirs = Never , downloader = Curl , verbose = False , urlSource = GHCupURL + , noNetwork = False , .. }) dirs @@ -578,9 +577,8 @@ logger' = unsafePerformIO brickMain :: AppState -> LoggerConfig - -> GHCupInfo -> IO () -brickMain s l gi = do +brickMain s l = do writeIORef settings' s -- logger interpreter writeIORef logger' l @@ -588,7 +586,7 @@ brickMain s l gi = do no_color <- isJust <$> lookupEnv "NO_COLOR" - eAppData <- getAppData (Just gi) + eAppData <- getAppData (Just $ ghcupInfo s) case eAppData of Right ad -> defaultMain @@ -596,7 +594,7 @@ brickMain s l gi = do (BrickState ad defaultAppSettings (constructList ad defaultAppSettings Nothing) - (keyBindings s) + (keyBindings (s :: AppState)) ) $> () @@ -620,7 +618,7 @@ getGHCupInfo = do . flip runReaderT settings . runE @'[JSONError , DownloadFailed , FileDoesNotExistError] $ liftE - $ getDownloadsF (GT.settings settings) (GT.dirs settings) + $ getDownloadsF case r of VRight a -> pure $ Right a diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index e43e41e..a7224d4 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -91,6 +91,7 @@ data Options = Options , optNoVerify :: Maybe Bool , optKeepDirs :: Maybe KeepDirs , optsDownloader :: Maybe Downloader + , optNoNetwork :: Maybe Bool -- commands , optCommand :: Command } @@ -277,6 +278,7 @@ opts = #endif <> hidden )) + <*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.") <*> com where parseUri s' = @@ -943,13 +945,19 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar tagCompleter :: Tool -> [String] -> Completer tagCompleter tool add = listIOCompleter $ do dirs' <- liftIO getAllDirs + let appState = LeanAppState + (Settings True False Never Curl False GHCupURL True) + dirs' + defaultKeyBindings + let loggerConfig = LoggerConfig { lcPrintDebug = False , colorOutter = mempty , rawOutter = mempty } let runLogger = myLoggerT loggerConfig - mGhcUpInfo <- runLogger . runE $ readFromCache dirs' + + mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF case mGhcUpInfo of VRight ghcupInfo -> do let allTags = filter (\t -> t /= Old) @@ -969,12 +977,17 @@ versionCompleter criteria tool = listIOCompleter $ do , rawOutter = mempty } let runLogger = myLoggerT loggerConfig - mGhcUpInfo <- runLogger . runE $ readFromCache dirs' - mpFreq <- runLogger . runE $ platformRequest - forFold mpFreq $ \pfreq -> + settings = Settings True False Never Curl False GHCupURL True + let leanAppState = LeanAppState + 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 let appState = AppState - (Settings True False Never Curl False GHCupURL) + settings dirs' defaultKeyBindings ghcupInfo @@ -1123,6 +1136,7 @@ toSettings options = do downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource + noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork in (Settings {..}, keyBindings) #if defined(INTERNAL_DOWNLOADER) defaultDownloader = Internal @@ -1168,7 +1182,9 @@ describe_result = $( LitE . StringL <$> runIO (do CapturedProcess{..} <- do 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 case _exitCode of ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut @@ -1259,9 +1275,10 @@ Report bugs at |] ghcupInfo <- ( runLogger + . flip runReaderT leanAppstate . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] $ liftE - $ getDownloadsF settings dirs + $ getDownloadsF ) >>= \case VRight r -> pure r @@ -1285,7 +1302,13 @@ Report bugs at |] pure s' +#if defined(IS_WINDOWS) + -- FIXME: windows needs 'ensureGlobalTools', which requires + -- full appstate + runLeanAppState = runAppState +#else runLeanAppState = flip runReaderT leanAppstate +#endif runAppState action' = do s' <- liftIO appState flip runReaderT s' action' @@ -1299,7 +1322,7 @@ Report bugs at |] let runInstTool' appstate' mInstPlatform = runLogger - . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x }) mInstPlatform) + . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) . runResourceT . runE @'[ AlreadyInstalled @@ -1733,7 +1756,8 @@ Report bugs at |] res <- case optCommand of #if defined(BRICK) Interactive -> do - liftIO $ brickMain appstate loggerConfig ghcupInfo >> pure ExitSuccess + s' <- appState + liftIO $ brickMain s' loggerConfig >> pure ExitSuccess #endif Install (Right iopts) -> do runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) diff --git a/ghcup.cabal b/ghcup.cabal index 86b166a..1237bf6 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -116,7 +116,7 @@ library , megaparsec >=8.0.0 && <9.1 , monad-logger ^>=0.3.31 , mtl ^>=2.2 - , optics >=0.2 && <0.5 + , optics ^>=0.4 , optics-vl ^>=0.2 , os-release ^>=1.0.0 , parsec ^>=3.1 @@ -279,7 +279,7 @@ executable ghcup-gen , haskus-utils-variant >=3.0 && <3.2 , monad-logger ^>=0.3.31 , mtl ^>=2.2 - , optics >=0.2 && <0.5 + , optics ^>=0.4 , optparse-applicative >=0.15.1.0 && <0.17 , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 4a8b248..8a8e3e0 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -133,15 +133,12 @@ installGHCBindist :: ( MonadFail m m () installGHCBindist dlinfo ver = do - dirs <- lift getDirs - settings <- lift getSettings - let tver = mkTVer ver lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- prepare paths ghcdir <- lift $ ghcupGHCDir tver @@ -328,8 +325,7 @@ installCabalBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] PlatformRequest {..} <- lift getPlatformReq - dirs@Dirs {..} <- lift getDirs - settings <- lift getSettings + Dirs {..} <- lift getDirs whenM (lift (cabalInstalled ver) >>= \a -> liftIO $ @@ -341,10 +337,10 @@ installCabalBindist dlinfo ver = do (throwE $ AlreadyInstalled Cabal ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- unpack - tmpUnpack <- lift withGHCupTmpDir + tmpUnpack <- lift withGHCupTmpDir liftE $ unpackToDir tmpUnpack dl void $ lift $ darwinNotarization _rPlatform tmpUnpack @@ -451,17 +447,16 @@ installHLSBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install hls version #{ver}|] PlatformRequest {..} <- lift getPlatformReq - dirs@Dirs {..} <- lift getDirs - settings <- lift getSettings + Dirs {..} <- lift getDirs whenM (lift (hlsInstalled ver)) (throwE $ AlreadyInstalled HLS ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- unpack - tmpUnpack <- lift withGHCupTmpDir + tmpUnpack <- lift withGHCupTmpDir liftE $ unpackToDir tmpUnpack dl void $ lift $ darwinNotarization _rPlatform tmpUnpack @@ -623,17 +618,16 @@ installStackBindist dlinfo ver = do lift $ $(logDebug) [i|Requested to install stack version #{ver}|] PlatformRequest {..} <- lift getPlatformReq - dirs@Dirs {..} <- lift getDirs - settings <- lift getSettings + Dirs {..} <- lift getDirs whenM (lift (stackInstalled ver)) (throwE $ AlreadyInstalled Stack ver) -- download (or use cached version) - dl <- liftE $ downloadCached settings dirs dlinfo Nothing + dl <- liftE $ downloadCached dlinfo Nothing -- unpack - tmpUnpack <- lift withGHCupTmpDir + tmpUnpack <- lift withGHCupTmpDir liftE $ unpackToDir tmpUnpack dl void $ lift $ darwinNotarization _rPlatform tmpUnpack @@ -1634,8 +1628,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - settings <- lift getSettings - dirs <- lift getDirs (workdir, tmpUnpack, tver) <- case targetGhc of -- unpack from version tarball @@ -1646,7 +1638,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs dlInfo <- preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls ?? NoDownload - dl <- liftE $ downloadCached settings dirs dlInfo Nothing + dl <- liftE $ downloadCached dlInfo Nothing -- unpack tmpUnpack <- lift mkGhcupTmpDir @@ -1931,7 +1923,6 @@ upgradeGHCup :: ( MonadMask m upgradeGHCup mtarget force' = do Dirs {..} <- lift getDirs pfreq <- lift getPlatformReq - settings <- lift getSettings GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo lift $ $(logInfo) [i|Upgrading GHCup...|] @@ -1940,7 +1931,7 @@ upgradeGHCup mtarget force' = do dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls tmp <- lift withGHCupTmpDir let fn = "ghcup" <> exeExt - p <- liftE $ download settings dli tmp (Just fn) + p <- liftE $ download dli tmp (Just fn) let destDir = takeDirectory destFile destFile = fromMaybe (binDir fn <> exeExt) mtarget lift $ $(logDebug) [i|mkdir -p #{destDir}|] diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 76a5d30..54a60e4 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -107,32 +107,31 @@ import qualified Data.Yaml as Y getDownloadsF :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo + , MonadReader env m + , HasSettings env + , HasDirs env , MonadIO m , MonadCatch m , MonadLogger m , MonadThrow m , MonadFail m ) - => Settings - -> Dirs - -> Excepts + => Excepts '[JSONError , DownloadFailed , FileDoesNotExistError] m GHCupInfo -getDownloadsF settings@Settings{ urlSource } dirs = do +getDownloadsF = do + Settings { urlSource } <- lift getSettings case urlSource of - GHCupURL -> liftE $ getBase dirs settings - (OwnSource url) -> do - bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url - lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs) + GHCupURL -> liftE $ getBase ghcupURL + (OwnSource url) -> liftE $ getBase url (OwnSpec av) -> pure av (AddSource (Left ext)) -> do - base <- liftE $ getBase dirs settings + base <- liftE $ getBase ghcupURL pure (mergeGhcupInfo base ext) (AddSource (Right uri)) -> do - base <- liftE $ getBase dirs settings - bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri - ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt) + base <- liftE $ getBase ghcupURL + ext <- liftE $ getBase uri pure (mergeGhcupInfo base ext) where @@ -149,33 +148,49 @@ getDownloadsF settings@Settings{ urlSource } dirs = do in GHCupInfo tr newDownloads newGlobalTools -readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m) - => Dirs - -> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo -readFromCache Dirs {..} = do - lift $ $(logWarn) - [i|Could not get download info, trying cached version (this may not be recent!)|] - let path = view pathL' ghcupURL - let yaml_file = cacheDir (T.unpack . decUTF8Safe . urlBaseName $ path) - bs <- - handleIO' NoSuchThing - (\_ -> throwE $ FileDoesNotExistError yaml_file) - $ liftIO - $ L.readFile yaml_file - lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs) +readFromCache :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadCatch m) + => URI + -> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString +readFromCache uri = do + Dirs{..} <- lift getDirs + let yaml_file = cacheDir (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri) + handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file) + . liftIO + . L.readFile + $ yaml_file -getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m) - => Dirs - -> Settings +getBase :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadLogger m + ) + => URI -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo -getBase dirs@Dirs{..} Settings{ downloader } = - handleIO (\_ -> readFromCache dirs) - $ catchE @_ @'[JSONError, FileDoesNotExistError] - (\(DownloadFailed _) -> readFromCache dirs) - (reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL) - >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict)) - where +getBase uri = do + Settings { noNetwork } <- lift getSettings + bs <- if noNetwork + then readFromCache uri + else handleIO (\_ -> warnCache >> readFromCache uri) + . catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri) + . 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 -- and check it's access time. If it has been accessed within the -- last 5 minutes, just reuse it. @@ -185,8 +200,11 @@ getBase dirs@Dirs{..} Settings{ downloader } = -- than the local file. -- -- Always save the local file with the mod time of the remote file. - smartDl :: forall m1 - . ( MonadCatch m1 + smartDl :: forall m1 env1 + . ( MonadReader env1 m1 + , HasDirs env1 + , HasSettings env1 + , MonadCatch m1 , MonadIO m1 , MonadFail m1 , MonadLogger m1 @@ -200,13 +218,15 @@ getBase dirs@Dirs{..} Settings{ downloader } = , NoLocationHeader , TooManyRedirs , ProcessError + , NoNetwork ] m1 L.ByteString smartDl uri' = do + Dirs{..} <- lift getDirs let path = view pathL' uri' let json_file = cacheDir (T.unpack . decUTF8Safe . urlBaseName $ path) - e <- liftIO $ doesFileExist json_file + e <- liftIO $ doesFileExist json_file if e then do accessTime <- liftIO $ getAccessTime json_file @@ -237,11 +257,11 @@ getBase dirs@Dirs{..} Settings{ downloader } = where dlWithMod modTime json_file = do - bs <- liftE $ downloadBS downloader uri' + bs <- liftE $ downloadBS uri' liftIO $ writeFileWithModTime modTime json_file bs pure bs dlWithoutMod json_file = do - bs <- liftE $ downloadBS downloader uri' + bs <- liftE $ downloadBS uri' liftIO $ hideError doesNotExistErrorType $ rmFile json_file liftIO $ L.writeFile json_file bs 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 -- -- The file must not exist. -download :: ( MonadMask m +download :: ( MonadReader env m + , HasSettings env + , HasDirs env + , MonadMask m , MonadThrow m , MonadLogger m , MonadIO m ) - => Settings - -> DownloadInfo + => DownloadInfo -> FilePath -- ^ destination dir -> Maybe FilePath -- ^ optional filename -> Excepts '[DigestError , DownloadFailed] m FilePath -download settings@Settings{ downloader } dli dest mfn +download dli dest mfn | scheme == "https" = dl | scheme == "http" = dl | scheme == "file" = cp @@ -362,6 +384,8 @@ download settings@Settings{ downloader } dli dest mfn liftIO (hideError doesNotExistErrorType $ rmFile destFile) >> (throwE . DownloadFailed $ e) ) $ do + Settings{ downloader, noNetwork } <- lift getSettings + when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork])) case downloader of Curl -> do o' <- liftIO getCurlOpts @@ -377,58 +401,64 @@ download settings@Settings{ downloader } dli dest mfn liftE $ downloadToFile https host fullPath port destFile #endif - liftE $ checkDigest settings dli destFile + liftE $ checkDigest dli destFile pure destFile -- Manage to find a file we can write the body into. 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 -- is omitted, infers the filename from the url. -downloadCached :: ( MonadMask m +downloadCached :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadMask m , MonadResource m , MonadThrow m , MonadLogger m , MonadIO m , MonadUnliftIO m ) - => Settings - -> Dirs - -> DownloadInfo + => DownloadInfo -> Maybe FilePath -- ^ optional filename -> Excepts '[DigestError , DownloadFailed] m FilePath -downloadCached settings@Settings{ cache } dirs dli mfn = do +downloadCached dli mfn = do + Settings{ cache } <- lift getSettings case cache of - True -> downloadCached' settings dirs dli mfn + True -> downloadCached' dli mfn False -> do 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 , MonadLogger m , MonadIO m , MonadUnliftIO m ) - => Settings - -> Dirs - -> DownloadInfo + => DownloadInfo -> Maybe FilePath -- ^ optional filename -> 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 cachfile = cacheDir fn fileExists <- liftIO $ doesFileExist cachfile if | fileExists -> do - liftE $ checkDigest settings dli cachfile + liftE $ checkDigest dli 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. -downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m) - => Downloader - -> URI +downloadBS :: ( MonadReader env m + , HasSettings env + , MonadCatch m + , MonadIO m + , MonadLogger m + ) + => URI -> Excepts '[ FileDoesNotExistError , HTTPStatusError @@ -452,10 +486,11 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m) , NoLocationHeader , TooManyRedirs , ProcessError + , NoNetwork ] m L.ByteString -downloadBS downloader uri' +downloadBS uri' | scheme == "https" = dl True | scheme == "http" @@ -475,6 +510,8 @@ downloadBS downloader uri' dl _ = do #endif lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|] + Settings{ downloader, noNetwork } <- lift getSettings + when noNetwork $ throwE NoNetwork case downloader of Curl -> do o' <- liftIO getCurlOpts @@ -499,12 +536,18 @@ downloadBS downloader uri' #endif -checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m) - => Settings - -> DownloadInfo +checkDigest :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadIO m + , MonadThrow m + , MonadLogger m + ) + => DownloadInfo -> FilePath -> Excepts '[DigestError] m () -checkDigest Settings{ noVerify } dli file = do +checkDigest dli file = do + Settings{ noVerify } <- lift getSettings let verify = not noVerify when verify $ do let p' = takeFileName file diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index de9576c..a1366d7 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -233,6 +233,13 @@ instance Pretty NoToolVersionSet where pPrint (NoToolVersionSet 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 ]-- diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 98ab2af..79ea220 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -297,11 +297,12 @@ data UserSettings = UserSettings , uDownloader :: Maybe Downloader , uKeyBindings :: Maybe UserKeyBindings , uUrlSource :: Maybe URLSource + , uNoNetwork :: Maybe Bool } deriving (Show, GHC.Generic) defaultUserSettings :: UserSettings -defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing data UserKeyBindings = UserKeyBindings { kUp :: Maybe Key @@ -353,13 +354,16 @@ data AppState = AppState , pfreq :: PlatformRequest } deriving (Show, GHC.Generic) +instance NFData AppState + data LeanAppState = LeanAppState { settings :: Settings , dirs :: Dirs , keyBindings :: KeyBindings } deriving (Show, GHC.Generic) -instance NFData AppState +instance NFData LeanAppState + data Settings = Settings { cache :: Bool @@ -368,6 +372,7 @@ data Settings = Settings , downloader :: Downloader , verbose :: Bool , urlSource :: URLSource + , noNetwork :: Bool } deriving (Show, GHC.Generic) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index c8885c3..9f7165a 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1071,7 +1071,7 @@ ensureGlobalTools = do dirs <- lift getDirs shimDownload <- liftE $ lE @_ @'[NoDownload] $ 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 lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|] lift $ $(logDebug) [i|rm -f #{shimDownload}|] diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index b8af657..dd4db4b 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -19,6 +19,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) import GHCup.Utils.Dirs import GHCup.Utils.File.Common import GHCup.Types +import GHCup.Types.Optics import Control.Concurrent import Control.DeepSeq diff --git a/stack.yaml b/stack.yaml index 38685ba..a4a83c6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,10 @@ extra-deps: - libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - 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 - regex-posix-clib-2.7 - streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421