Add --offline switch wrt #186
This commit is contained in:
parent
2c7176d998
commit
6143cdf2e0
GPG Key ID:
3786C5262ECB4A3F
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
|
||||
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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
|
||||
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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
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.|])
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
33
lib/GHCup.hs
33
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}|]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ]--
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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}|]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue