ghcup-hs/lib/GHCup/Download.hs

613 lines
24 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE TypeApplications #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE TypeFamilies #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Download
Description : Downloading
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
Module for handling all download related functions.
Generally we support downloading via:
- curl (default)
- wget
- internal downloader (only when compiled)
-}
2020-01-11 20:15:05 +00:00
module GHCup.Download where
#if defined(INTERNAL_DOWNLOADER)
import GHCup.Download.IOStreams
import GHCup.Download.Utils
#endif
2020-01-11 20:15:05 +00:00
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
2021-08-30 20:41:58 +00:00
import GHCup.Types.JSON ( )
2021-05-14 21:09:45 +00:00
import GHCup.Utils.Dirs
2020-01-11 20:15:05 +00:00
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Version
2020-01-11 20:15:05 +00:00
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
2020-08-09 15:39:02 +00:00
import Data.Bifunctor
2020-01-11 20:15:05 +00:00
import Data.ByteString ( ByteString )
2020-04-29 17:36:16 +00:00
#if defined(INTERNAL_DOWNLOADER)
2021-07-24 14:36:31 +00:00
import Data.CaseInsensitive ( mk )
2020-04-09 17:53:22 +00:00
#endif
2020-01-11 20:15:05 +00:00
import Data.Maybe
2021-08-29 17:45:26 +00:00
import Data.List
2020-01-11 20:15:05 +00:00
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Versions
2021-07-24 14:36:31 +00:00
import Data.Word8 hiding ( isSpace )
2020-01-11 20:15:05 +00:00
import Haskus.Utils.Variant.Excepts
2021-07-24 14:36:31 +00:00
#if defined(INTERNAL_DOWNLOADER)
import Network.Http.Client hiding ( URL )
#endif
2020-01-11 20:15:05 +00:00
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
2021-08-29 17:45:26 +00:00
import Safe
2021-05-14 21:09:45 +00:00
import System.Directory
import System.Environment
2021-07-24 14:36:31 +00:00
import System.Exit
2021-05-14 21:09:45 +00:00
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.IO.Error
2021-07-24 14:36:31 +00:00
import System.IO.Temp
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2020-01-11 20:15:05 +00:00
import URI.ByteString
2020-04-09 16:27:07 +00:00
import qualified Crypto.Hash.SHA256 as SHA256
2021-05-14 21:09:45 +00:00
import qualified Data.ByteString as B
2020-04-09 16:27:07 +00:00
import qualified Data.ByteString.Base16 as B16
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString.Lazy as L
2020-10-25 13:17:17 +00:00
import qualified Data.Map.Strict as M
2021-05-14 21:09:45 +00:00
import qualified Data.Text as T
2021-07-24 14:36:31 +00:00
import qualified Data.Text.IO as T
2020-01-11 20:15:05 +00:00
import qualified Data.Text.Encoding as E
2021-08-30 21:04:28 +00:00
import qualified Data.YAML.Aeson as Y
2020-01-11 20:15:05 +00:00
------------------
--[ High-level ]--
------------------
2020-10-25 13:17:17 +00:00
-- | Downloads the download information! But only if we need to ;P
2020-04-27 21:23:34 +00:00
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
2021-07-18 21:29:09 +00:00
, MonadReader env m
, HasSettings env
, HasDirs env
2020-04-27 21:23:34 +00:00
, MonadIO m
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
2020-04-27 21:23:34 +00:00
, MonadThrow m
, MonadFail m
, MonadMask m
2020-04-27 21:23:34 +00:00
)
2021-07-18 21:29:09 +00:00
=> Excepts
2020-04-27 21:23:34 +00:00
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
2021-07-18 21:29:09 +00:00
getDownloadsF = do
Settings { urlSource } <- lift getSettings
2020-04-27 21:23:34 +00:00
case urlSource of
2021-07-18 21:29:09 +00:00
GHCupURL -> liftE $ getBase ghcupURL
(OwnSource url) -> liftE $ getBase url
2020-10-25 13:17:17 +00:00
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
2021-07-18 21:29:09 +00:00
base <- liftE $ getBase ghcupURL
2020-10-25 13:17:17 +00:00
pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do
2021-07-18 21:29:09 +00:00
base <- liftE $ getBase ghcupURL
ext <- liftE $ getBase uri
2020-10-25 13:17:17 +00:00
pure (mergeGhcupInfo base ext)
where
2020-10-25 13:17:17 +00:00
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-> GHCupInfo -- ^ extension overwriting the base
-> GHCupInfo
2021-05-14 21:09:45 +00:00
mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
2020-10-25 13:17:17 +00:00
Just a' -> M.union a' a
Nothing -> a
2021-05-14 21:09:45 +00:00
) base
newGlobalTools = M.union base2 ext2
in GHCupInfo tr newDownloads newGlobalTools
2020-04-27 21:23:34 +00:00
2021-07-24 14:36:31 +00:00
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
yamlFromCache uri = do
Dirs{..} <- getDirs
pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
etagsFile :: FilePath -> FilePath
etagsFile = (<.> "etags")
2021-07-18 21:29:09 +00:00
getBase :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadMask m
2021-07-18 21:29:09 +00:00
)
=> URI
2021-09-06 20:31:07 +00:00
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
2021-07-18 21:29:09 +00:00
getBase uri = do
2021-09-06 20:31:07 +00:00
Settings { noNetwork, downloader } <- lift getSettings
-- try to download yaml... usually this writes it into cache dir,
-- but in some cases not (e.g. when using file://), so we honour
-- the return filepath, if any
mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
then pure Nothing
2021-09-06 20:31:07 +00:00
else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
. reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
. fmap Just
. smartDl
$ uri
-- if we didn't get a filepath from the download, use the cached yaml
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
2021-09-06 20:31:07 +00:00
yamlContents <- liftIOException doesNotExistErrorType (FileDoesNotExistError actualYaml) $ liftIO $ L.readFile actualYaml
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
2021-07-18 21:29:09 +00:00
liftE
. onE_ (onError actualYaml)
2021-08-30 21:04:28 +00:00
. lE' @_ @_ @'[JSONError] JSONDecodeError
. first (\(_, e) -> unlines [e, "Consider removing " <> actualYaml <> " manually."])
. Y.decode1
$ yamlContents
2021-07-18 21:29:09 +00:00
where
2021-07-24 14:36:31 +00:00
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed.
2021-08-30 20:41:58 +00:00
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
2021-07-24 14:36:31 +00:00
onError fp = do
let efp = etagsFile fp
2021-08-30 20:41:58 +00:00
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
2021-07-24 14:36:31 +00:00
(hideError doesNotExistErrorType $ rmFile efp)
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
2021-09-06 20:31:07 +00:00
warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m ()
warnCache s downloader' = do
let tryDownloder = case downloader' of
Curl -> "Wget"
Wget -> "Curl"
#if defined(INTERNAL_DOWNLOADER)
Internal -> "Curl"
#endif
logWarn $ "Could not get download info, trying cached version (this may not be recent!)" <> "\n" <>
"If this problem persists, consider switching downloader via: " <> "\n " <>
"ghcup config set downloader " <> tryDownloder
logDebug $ "Error was: " <> T.pack s
2021-07-18 21:29:09 +00:00
2020-01-11 20:15:05 +00:00
-- 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.
--
-- Always save the local file with the mod time of the remote file.
2021-07-18 21:29:09 +00:00
smartDl :: forall m1 env1
. ( MonadReader env1 m1
, HasDirs env1
, HasSettings env1
, MonadCatch m1
2020-04-29 17:12:58 +00:00
, MonadIO m1
, MonadFail m1
2021-08-30 20:41:58 +00:00
, HasLog env1
, MonadMask m1
2020-04-29 17:12:58 +00:00
)
2020-03-17 17:39:01 +00:00
=> URI
-> Excepts
2021-07-24 14:36:31 +00:00
'[ DownloadFailed
, DigestError
2020-03-17 17:39:01 +00:00
]
m1
FilePath
2020-03-09 19:49:10 +00:00
smartDl uri' = do
2021-07-24 14:36:31 +00:00
json_file <- lift $ yamlFromCache uri'
let scheme = view (uriSchemeL' % schemeBSL') uri'
2021-07-18 21:29:09 +00:00
e <- liftIO $ doesFileExist json_file
2021-07-24 14:36:31 +00:00
currentTime <- liftIO getCurrentTime
Dirs { cacheDir } <- lift getDirs
-- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing cacheDir Nothing True
| e -> do
accessTime <- liftIO $ getAccessTime json_file
-- access time won't work on most linuxes, but we can try regardless
if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) ->
-- no access in last 5 minutes, re-check upstream mod time
dlWithMod currentTime json_file
| otherwise -> pure json_file
| otherwise -> dlWithMod currentTime json_file
2020-01-11 20:15:05 +00:00
where
2020-04-27 21:23:34 +00:00
dlWithMod modTime json_file = do
2021-07-24 14:36:31 +00:00
let (dir, fn) = splitFileName json_file
f <- liftE $ download uri' Nothing dir (Just fn) True
liftIO $ setModificationTime f modTime
liftIO $ setAccessTime f modTime
pure f
2020-01-11 20:15:05 +00:00
2021-07-19 14:49:18 +00:00
getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
2020-01-11 20:15:05 +00:00
-> Version
-- ^ tool version
2021-07-19 14:49:18 +00:00
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo t v = do
(PlatformRequest a p mv) <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let distro_preview f g =
let platformVersionSpec =
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
mv' = g mv
in fmap snd
. find
(\(mverRange, _) -> maybe
(isNothing mv')
(\range -> maybe False (`versionRange` range) mv')
mverRange
)
. M.toList
=<< platformVersionSpec
with_distro = distro_preview id id
without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
maybe
(throwE NoDownload)
pure
(case p of
-- non-musl won't work on alpine
Linux Alpine -> with_distro <|> without_distro_ver
_ -> with_distro <|> without_distro_ver <|> without_distro
)
2020-01-11 20:15:05 +00:00
-- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file.
-- If the filename is not provided, then we:
-- 1. try to guess the filename from the url path
-- 2. otherwise create a random file
--
-- The file must not exist.
2021-07-18 21:29:09 +00:00
download :: ( MonadReader env m
, HasSettings env
, HasDirs env
, MonadMask m
2020-01-11 20:15:05 +00:00
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2020-01-11 20:15:05 +00:00
, MonadIO m
)
2021-07-24 14:36:31 +00:00
=> URI
-> Maybe T.Text -- ^ expected hash
-> FilePath -- ^ destination dir (ignored for file:// scheme)
2021-05-14 21:09:45 +00:00
-> Maybe FilePath -- ^ optional filename
2021-07-24 14:36:31 +00:00
-> Bool -- ^ whether to read an write etags
2021-05-14 21:09:45 +00:00
-> Excepts '[DigestError , DownloadFailed] m FilePath
2021-07-24 14:36:31 +00:00
download uri eDigest dest mfn etags
2020-03-21 21:19:37 +00:00
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
2020-01-11 20:15:05 +00:00
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where
2021-07-24 14:36:31 +00:00
scheme = view (uriSchemeL' % schemeBSL') uri
2020-01-11 20:15:05 +00:00
dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "downloading: " <> uri' <> " as file " <> T.pack destFile
2020-01-11 20:15:05 +00:00
-- destination dir must exist
liftIO $ createDirRecursive' dest
2020-01-11 20:15:05 +00:00
-- download
flip onException
2021-07-22 13:45:08 +00:00
(lift $ hideError doesNotExistErrorType $ recycleFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
2021-07-22 13:45:08 +00:00
lift (hideError doesNotExistErrorType $ recycleFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
2021-07-18 21:29:09 +00:00
Settings{ downloader, noNetwork } <- lift getSettings
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
2021-05-14 21:09:45 +00:00
case downloader of
2020-04-29 17:12:58 +00:00
Curl -> do
o' <- liftIO getCurlOpts
2021-07-24 14:36:31 +00:00
if etags
then do
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
2021-08-30 20:41:58 +00:00
metag <- lift $ readETag destFile
2021-07-24 14:36:31 +00:00
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
2021-08-25 16:54:58 +00:00
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
2021-07-24 14:36:31 +00:00
++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
headers <- liftIO $ T.readFile dh
-- this nonsense is necessary, because some older versions of curl would overwrite
-- the destination file when 304 is returned
2021-08-23 21:16:32 +00:00
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
2021-07-24 14:36:31 +00:00
Just (http':sc:_)
| sc == "304"
2021-08-30 20:41:58 +00:00
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
2021-07-24 14:36:31 +00:00
| T.pack "HTTP" `T.isPrefixOf` http' -> do
2021-08-30 20:41:58 +00:00
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
2021-07-24 14:36:31 +00:00
liftIO $ copyFile (destFile <.> "tmp") destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
2021-08-30 20:41:58 +00:00
lift $ writeEtags destFile (parseEtags headers)
2021-07-24 14:36:31 +00:00
else
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
2020-04-29 17:12:58 +00:00
Wget -> do
2021-07-24 14:36:31 +00:00
destFileTemp <- liftIO $ emptySystemTempFile "wget-tmp"
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
o' <- liftIO getWgetOpts
if etags
then do
2021-08-30 20:41:58 +00:00
metag <- lift $ readETag destFile
2021-08-25 16:54:58 +00:00
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
2021-07-24 14:36:31 +00:00
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile
2021-08-30 20:41:58 +00:00
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
2021-07-24 14:36:31 +00:00
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
2021-08-30 20:41:58 +00:00
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
2021-07-24 14:36:31 +00:00
| otherwise -> throwE (NonZeroExit i' "wget" opts)
else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
liftIO $ copyFile destFileTemp destFile
2020-04-29 17:12:58 +00:00
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
2021-07-24 14:36:31 +00:00
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri
if etags
then do
2021-08-30 20:41:58 +00:00
metag <- lift $ readETag destFile
2021-07-24 14:36:31 +00:00
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
2021-07-24 14:36:31 +00:00
$ do
r <- downloadToFile https host fullPath port destFile addHeaders
2021-08-30 20:41:58 +00:00
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
2021-07-24 14:36:31 +00:00
else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFile mempty
#endif
2020-01-11 20:15:05 +00:00
2021-07-24 14:36:31 +00:00
forM_ eDigest (liftE . flip checkDigest destFile)
2020-01-11 20:15:05 +00:00
pure destFile
2021-07-24 14:36:31 +00:00
2020-01-11 20:15:05 +00:00
-- Manage to find a file we can write the body into.
getDestFile :: Monad m => Excepts '[NoUrlBase] m FilePath
getDestFile =
case mfn of
Just fn -> pure (dest </> fn)
Nothing
| let urlBase = T.unpack (decUTF8Safe (urlBaseName path))
, not (null urlBase) -> pure (dest </> urlBase)
-- TODO: remove this once we use hpath again
| otherwise -> throwE $ NoUrlBase uri'
2020-01-11 20:15:05 +00:00
2021-07-24 14:36:31 +00:00
path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri)
2021-07-24 14:36:31 +00:00
2021-08-30 20:41:58 +00:00
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
2021-07-24 14:36:31 +00:00
parseEtags stderr = do
2021-08-23 21:16:32 +00:00
let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
2021-07-24 14:36:31 +00:00
case T.words <$> mEtag of
(Just []) -> do
2021-08-30 20:41:58 +00:00
logDebug "Couldn't parse etags, no input: "
2021-07-24 14:36:31 +00:00
pure Nothing
(Just [_, etag']) -> do
2021-08-30 20:41:58 +00:00
logDebug $ "Parsed etag: " <> etag'
2021-07-24 14:36:31 +00:00
pure (Just etag')
(Just xs) -> do
2021-08-30 20:41:58 +00:00
logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
2021-07-24 14:36:31 +00:00
pure Nothing
Nothing -> do
2021-08-30 20:41:58 +00:00
logDebug "No etags header found"
2021-07-24 14:36:31 +00:00
pure Nothing
2021-08-30 20:41:58 +00:00
writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags destFile getTags = do
2021-07-24 14:36:31 +00:00
getTags >>= \case
Just t -> do
2021-08-30 20:41:58 +00:00
logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
2021-07-24 14:36:31 +00:00
liftIO $ T.writeFile (etagsFile destFile) t
Nothing ->
2021-08-30 20:41:58 +00:00
logDebug "No etags files written"
2021-07-24 14:36:31 +00:00
2021-08-30 20:41:58 +00:00
readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
2021-07-24 14:36:31 +00:00
readETag fp = do
e <- liftIO $ doesFileExist fp
if e
then do
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
case rE of
(Right et) -> do
2021-08-30 20:41:58 +00:00
logDebug $ "Read etag: " <> et
2021-07-24 14:36:31 +00:00
pure (Just et)
(Left _) -> do
2021-08-30 20:41:58 +00:00
logDebug "Etag file doesn't exist (yet)"
2021-07-24 14:36:31 +00:00
pure Nothing
else do
2021-08-30 20:41:58 +00:00
logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
2021-07-24 14:36:31 +00:00
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
pure Nothing
2020-01-11 20:15:05 +00:00
-- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
2021-07-18 21:29:09 +00:00
downloadCached :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
2020-01-11 20:15:05 +00:00
, MonadResource m
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2020-01-11 20:15:05 +00:00
, MonadIO m
, MonadUnliftIO m
2020-01-11 20:15:05 +00:00
)
2021-07-18 21:29:09 +00:00
=> DownloadInfo
2021-05-14 21:09:45 +00:00
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
2021-07-18 21:29:09 +00:00
downloadCached dli mfn = do
Settings{ cache } <- lift getSettings
2020-01-11 20:15:05 +00:00
case cache of
2021-07-19 14:49:18 +00:00
True -> downloadCached' dli mfn Nothing
2020-01-11 20:15:05 +00:00
False -> do
tmp <- lift withGHCupTmpDir
2021-07-24 14:36:31 +00:00
liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp mfn False
2021-05-14 21:09:45 +00:00
2021-07-18 21:29:09 +00:00
downloadCached' :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
2021-05-14 21:09:45 +00:00
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-05-14 21:09:45 +00:00
, MonadIO m
, MonadUnliftIO m
)
2021-07-18 21:29:09 +00:00
=> DownloadInfo
2021-05-14 21:09:45 +00:00
-> Maybe FilePath -- ^ optional filename
2021-07-19 14:49:18 +00:00
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
2021-05-14 21:09:45 +00:00
-> Excepts '[DigestError , DownloadFailed] m FilePath
2021-07-19 14:49:18 +00:00
downloadCached' dli mfn mDestDir = do
2021-07-18 21:29:09 +00:00
Dirs { cacheDir } <- lift getDirs
2021-07-19 14:49:18 +00:00
let destDir = fromMaybe cacheDir mDestDir
2021-05-14 21:09:45 +00:00
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
2021-07-19 14:49:18 +00:00
let cachfile = destDir </> fn
2021-05-14 21:09:45 +00:00
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
2021-07-24 14:36:31 +00:00
liftE $ checkDigest (view dlHash dli) cachfile
2021-05-14 21:09:45 +00:00
pure cachfile
2021-07-24 14:36:31 +00:00
| otherwise -> liftE $ download (_dlUri dli) (Just (_dlHash dli)) destDir mfn False
2020-01-11 20:15:05 +00:00
------------------
--[ Low-level ]--
------------------
2021-07-18 21:29:09 +00:00
checkDigest :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-07-18 21:29:09 +00:00
)
2021-07-24 14:36:31 +00:00
=> T.Text -- ^ the hash
2021-05-14 21:09:45 +00:00
-> FilePath
2020-01-11 20:15:05 +00:00
-> Excepts '[DigestError] m ()
2021-07-24 14:36:31 +00:00
checkDigest eDigest file = do
2021-07-18 21:29:09 +00:00
Settings{ noVerify } <- lift getSettings
2021-05-14 21:09:45 +00:00
let verify = not noVerify
2020-01-11 20:15:05 +00:00
when verify $ do
2021-05-14 21:09:45 +00:00
let p' = takeFileName file
2021-08-30 20:41:58 +00:00
lift $ logInfo $ "verifying digest of: " <> T.pack p'
2021-05-14 21:09:45 +00:00
c <- liftIO $ L.readFile file
2020-04-17 07:30:45 +00:00
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
2020-01-11 20:15:05 +00:00
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
2020-04-29 17:12:58 +00:00
-- | Get additional curl args from env. This is an undocumented option.
2021-05-14 21:09:45 +00:00
getCurlOpts :: IO [String]
2020-04-29 17:12:58 +00:00
getCurlOpts =
2021-05-14 21:09:45 +00:00
lookupEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ splitOn " " r
2020-04-29 17:12:58 +00:00
Nothing -> pure []
-- | Get additional wget args from env. This is an undocumented option.
2021-05-14 21:09:45 +00:00
getWgetOpts :: IO [String]
2020-04-29 17:12:58 +00:00
getWgetOpts =
2021-05-14 21:09:45 +00:00
lookupEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ splitOn " " r
2020-04-29 17:12:58 +00:00
Nothing -> pure []
2021-05-14 21:09:45 +00:00
2021-08-23 21:16:32 +00:00
-- | Get the url base name.
--
-- >>> urlBaseName "/foo/bar/baz"
-- "baz"
2021-05-14 21:09:45 +00:00
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
2021-08-23 21:16:32 +00:00
-- | Curl saves all intermediate connect headers as well, not just the last one, so we make an effort to take the
-- last HTTP block only. Passing '--suppress-connect-headers' would be better, but it isn't supported by all versions,
-- also see:
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/213
--
-- >>> getLastHeader "\n\nHTTP/1.0 200 Connection established\n\nHTTP/1.1 304 Not Modified\n"
-- "HTTP/1.1 304 Not Modified\n"
2021-08-24 08:51:39 +00:00
-- >>> getLastHeader "HTTP/1.1 304 Not Modified\n"
-- "HTTP/1.1 304 Not Modified\n"
2021-08-23 21:16:32 +00:00
getLastHeader :: T.Text -> T.Text
getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [""] . fmap T.stripEnd . T.lines