Fall back to cached ghcup-<..>.json

This commit is contained in:
Julian Ospald 2020-04-27 23:23:34 +02:00
parent 1ed6e49a81
commit 56c439d716
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
2 changed files with 63 additions and 14 deletions

View File

@ -789,9 +789,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(GHCupInfo treq dls) <- (GHCupInfo treq dls) <-
( runLogger ( runLogger
. flip runReaderT settings . flip runReaderT settings
. runE @'[JSONError , DownloadFailed] . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE $ liftE
$ getDownloads (maybe GHCupURL OwnSource optUrlSource) $ getDownloadsF (maybe GHCupURL OwnSource optUrlSource)
) )
>>= \case >>= \case
VRight r -> pure r VRight r -> pure r

View File

@ -82,6 +82,47 @@ import qualified System.Posix.RawFilePath.Directory
------------------ ------------------
-- | Like 'getDownloads', but tries to fall back to
-- cached ~/.ghcup/cache/ghcup-<format-ver>.json
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadFail m
)
=> URLSource
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF urlSource = do
case urlSource of
GHCupURL ->
liftE
$ handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError , FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache)
$ getDownloads urlSource
(OwnSource _) -> liftE $ getDownloads urlSource
(OwnSpec _) -> liftE $ getDownloads urlSource
where
readFromCache = do
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
cacheDir <- liftIO $ ghcupCacheDir
json_file <- (cacheDir </>) <$> urlBaseName path
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath json_file))
$ liftIO
$ readFile json_file
lE' JSONDecodeError $ eitherDecode' bs
-- | Downloads the download information! But only if we need to ;P -- | Downloads the download information! But only if we need to ;P
getDownloads :: ( FromJSONKey Tool getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version , FromJSONKey Version
@ -148,29 +189,36 @@ getDownloads urlSource = do
Just modTime -> do Just modTime -> do
fileMod <- liftIO $ getModificationTime json_file fileMod <- liftIO $ getModificationTime json_file
if modTime > fileMod if modTime > fileMod
then do then dlWithMod modTime json_file
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
else liftIO $ readFile json_file else liftIO $ readFile json_file
Nothing -> do Nothing -> do
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|] lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
liftIO $ deleteFile json_file dlWithoutMod json_file
liftE $ downloadBS uri'
else -- access in less than 5 minutes, re-use file else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file liftIO $ readFile json_file
else do else do
liftIO $ createDirIfMissing newDirPerms cacheDir liftIO $ createDirIfMissing newDirPerms cacheDir
getModTime >>= \case getModTime >>= \case
Just modTime -> do Just modTime -> dlWithMod modTime json_file
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
Nothing -> do Nothing -> do
-- although we don't know last-modified, we still save
-- it to a file, so we might use it in offline mode
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|] lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
liftE $ downloadBS uri' dlWithoutMod json_file
where where
dlWithMod modTime json_file = do
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ deleteFile json_file
liftIO $ writeFileL json_file (Just newFilePerms) bs
liftIO $ setModificationTime json_file (fromIntegral @Int 0)
pure bs
getModTime = do getModTime = do
#if defined(CURL) #if defined(CURL)
pure Nothing pure Nothing
@ -329,7 +377,7 @@ downloadCached dli mfn = do
-- | This is used for downloading the JSON. -- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m) downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
=> URI => URI
-> Excepts -> Excepts
'[ FileDoesNotExistError '[ FileDoesNotExistError
@ -358,6 +406,7 @@ downloadBS uri'
path = view pathL' uri' path = view pathL' uri'
#if defined(CURL) #if defined(CURL)
dl _ = do dl _ = do
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
let exe = [rel|curl|] let exe = [rel|curl|]
args = ["-sSfL", serializeURIRef' uri'] args = ["-sSfL", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case liftIO (executeOut exe args Nothing) >>= \case