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.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

16
app/ghcup/BrickMain.hs
View File

@ -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

42
app/ghcup/Main.hs
View File

@ -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.|])

4
ghcup.cabal
View File

@ -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
View File

@ -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}|]

183
lib/GHCup/Download.hs
View File

@ -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

7
lib/GHCup/Errors.hs
View 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 ]--

9
lib/GHCup/Types.hs
View File

@ -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)

2
lib/GHCup/Utils.hs
View File

@ -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}|]

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.File.Common
import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent
import Control.DeepSeq

4
stack.yaml
View File

@ -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