This commit is contained in:
Julian Ospald 2020-03-09 00:34:04 +01:00
parent b87d252fec
commit 673bfef443

View File

@ -71,6 +71,7 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified System.IO.Streams as Streams import qualified System.IO.Streams as Streams
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory import qualified System.Posix.RawFilePath.Directory
as RD as RD
@ -111,10 +112,15 @@ getDownloads = do
(OwnSpec av) -> pure $ av (OwnSpec av) -> pure $ av
where where
-- First send a HEAD request and check for modification time. -- 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.
--
-- If not, then send a HEAD request and check for modification time.
-- Only download the file if the modification time is newer -- Only download the file if the modification time is newer
-- than the local file. Always save the local file with the -- than the local file.
-- mod time of the remote file. --
-- Always save the local file with the mod time of the remote file.
dl :: forall m1 dl :: forall m1
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1) . (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
=> URI => URI
@ -132,34 +138,34 @@ getDownloads = do
let path = view pathL' uri' let path = view pathL' uri'
json_file <- (liftIO $ ghcupCacheDir) json_file <- (liftIO $ ghcupCacheDir)
>>= \cacheDir -> (cacheDir </>) <$> urlBaseName path >>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
headers <-
handleIO (\_ -> pure mempty)
$ liftE
$ ( catchAllE
(\_ ->
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
)
$ getHead uri'
)
let mModT = parseModifiedHeader headers
e <- liftIO $ doesFileExist json_file e <- liftIO $ doesFileExist json_file
if e if e
then do then do
case mModT of accessTime <-
Just modTime -> do PF.accessTimeHiRes
fileMod <- liftIO $ getModificationTime json_file <$> (liftIO $ PF.getFileStatus (toFilePath json_file))
if modTime > fileMod currentTime <- liftIO $ getPOSIXTime
then do
bs <- liftE $ downloadBS uri' -- access time won't work on most linuxes, but we can try regardless
liftIO $ writeFileWithModTime modTime json_file bs if (currentTime - accessTime) > 300
pure bs then do -- no access in last 5 minutes, re-check upstream mod time
else liftIO $ readFile json_file getModTime >>= \case
Nothing -> do Just modTime -> do
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|] fileMod <- liftIO $ getModificationTime json_file
liftIO $ deleteFile json_file if modTime > fileMod
liftE $ downloadBS uri' then do
bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
else liftIO $ readFile json_file
Nothing -> do
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
liftIO $ deleteFile json_file
liftE $ downloadBS uri'
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
else do else do
case mModT of getModTime >>= \case
Just modTime -> do Just modTime -> do
bs <- liftE $ downloadBS uri' bs <- liftE $ downloadBS uri'
liftIO $ writeFileWithModTime modTime json_file bs liftIO $ writeFileWithModTime modTime json_file bs
@ -168,6 +174,20 @@ getDownloads = do
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|] lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
liftE $ downloadBS uri' liftE $ downloadBS uri'
where
getModTime = do
headers <-
handleIO (\_ -> pure mempty)
$ liftE
$ ( catchAllE
(\_ ->
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
)
$ getHead uri'
)
pure $ parseModifiedHeader headers
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
parseModifiedHeader headers = parseModifiedHeader headers =
(M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM (M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM