ghcup-hs/lib/GHCup/Download.hs

893 lines
36 KiB
Haskell
Raw Permalink 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 qualified GHCup.Types.Stack as Stack
2020-01-11 20:15:05 +00:00
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
import GHCup.Utils.URI
import GHCup.Platform
2022-05-21 20:54:18 +00:00
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger.Internal
import GHCup.Prelude.Process
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
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
import Data.Either
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.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 URI.ByteString hiding (parseURI)
2020-01-11 20:15:05 +00:00
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-10-21 21:17:26 +00:00
import qualified Data.Yaml.Aeson as Y
2020-01-11 20:15:05 +00:00
-- $setup
-- >>> :set -XOverloadedStrings
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
)
=> PlatformRequest
-> Excepts
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
2020-04-27 21:23:34 +00:00
m
GHCupInfo
getDownloadsF pfreq@(PlatformRequest arch plat _) = do
2021-07-18 21:29:09 +00:00
Settings { urlSource } <- lift getSettings
let newUrlSources = fromURLSource urlSource
infos <- liftE $ mapM dl' newUrlSources
keys <- if any isRight infos
then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
else pure []
ghcupInfos <- fmap catMaybes $ forM infos $ \case
Left gi -> pure (Just gi)
Right si -> pure $ fromStackSetupInfo si keys
mergeGhcupInfo ghcupInfos
where
dl' :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadReader env m
, HasSettings env
, HasDirs env
, MonadIO m
, MonadCatch m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> NewURLSource
-> Excepts
'[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError]
m (Either GHCupInfo Stack.SetupInfo)
dl' NewGHCupURL = fmap Left $ liftE (getBase ghcupURL) >>= liftE . decodeMetadata @GHCupInfo
dl' NewStackSetupURL = fmap Right $ liftE (getBase stackSetupURL) >>= liftE . decodeMetadata @Stack.SetupInfo
dl' (NewGHCupInfo gi) = pure (Left gi)
dl' (NewSetupInfo si) = pure (Right si)
dl' (NewURI uri) = do
base <- liftE $ getBase uri
catchE @JSONError (\(JSONDecodeError _) -> do
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: "
Right <$> decodeMetadata @Stack.SetupInfo base)
$ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI)
fromStackSetupInfo :: MonadThrow m
=> Stack.SetupInfo
-> [String]
-> m GHCupInfo
fromStackSetupInfo (Stack.siGHCs -> ghcDli) keys = do
2024-01-20 09:50:40 +00:00
let ghcVersionsPerKey = (`M.lookup` ghcDli) . T.pack <$> keys
ghcVersions = fromMaybe mempty . listToMaybe . catMaybes $ ghcVersionsPerKey
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
pure (GHCupInfo mempty ghcupDownloads' Nothing)
where
fromDownloadInfo :: DownloadInfo -> VersionInfo
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do
url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI . E.encodeUtf8 $ downloadInfoUrl
sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
mergeGhcupInfo :: MonadFail m
=> [GHCupInfo]
-> m GHCupInfo
mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
mergeGhcupInfo xs@(GHCupInfo{}: _) =
let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
in pure $ GHCupInfo newToolReqs newDownloads Nothing
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 (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
2021-07-24 14:36:31 +00:00
etagsFile :: FilePath -> FilePath
etagsFile = (<.> "etags")
2021-07-18 21:29:09 +00:00
getBase :: forall m env . ( MonadReader env m
2021-07-18 21:29:09 +00:00
, 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
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError] m FilePath
2021-07-18 21:29:09 +00:00
getBase uri = do
Settings { noNetwork, downloader, metaMode } <- 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
else handleIO (\e -> case metaMode of
Strict -> throwIO e
Lax -> lift (warnCache (displayException e) downloader) >> pure Nothing)
. catchE @_ @_ @'[DownloadFailed] (\e@(DownloadFailed _) -> case metaMode of
Strict -> throwE e
Lax -> lift (warnCache (prettyHFError e) downloader) >> pure Nothing)
. fmap Just
. smartDl
$ uri
-- if we didn't get a filepath from the download, use the cached yaml
maybe (lift $ yamlFromCache uri) pure mYaml
2021-07-18 21:29:09 +00:00
where
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
, ContentLengthError
2021-09-18 17:45:32 +00:00
, GPGError
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
Settings { metaCache } <- lift getSettings
-- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing Nothing Nothing (fromGHCupPath cacheDir) Nothing True
| e -> do
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
let cacheInterval = fromInteger metaCache
lift $ logDebug $ "last access was " <> T.pack (show sinceLastAccess) <> " ago, cache interval is " <> T.pack (show cacheInterval)
-- access time won't work on most linuxes, but we can try regardless
if | metaCache <= 0 -> dlWithMod currentTime json_file
| (sinceLastAccess > cacheInterval) ->
-- 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' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing dir (Just fn) True
-- make these failures non-fatal, also see:
-- https://github.com/actions/runner-images/issues/7061
handleIO (\e -> logWarn $ "setModificationTime failed with: " <> T.pack (displayException e)) $ liftIO $ setModificationTime f modTime
handleIO (\e -> logWarn $ "setAccessTime failed with: " <> T.pack (displayException e)) $ liftIO $ setAccessTime f modTime
pure f
2020-01-11 20:15:05 +00:00
warnOnMetadataUpdate ::
( MonadReader env m
, MonadIO m
, HasLog env
, HasDirs env
)
=> URI
-> GHCupInfo
-> m ()
warnOnMetadataUpdate uri (GHCupInfo { _metadataUpdate = Just newUri })
| scheme' uri == "file"
, urlBase' uri /= urlBase' newUri = do
confFile <- getConfigFilePath'
logWarn $ "New metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nYou might need to update your " <> T.pack confFile
| scheme' uri /= "file"
, uri /= newUri = do
confFile <- getConfigFilePath'
logWarn $ "New metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nYou might need to update your " <> T.pack confFile
where
scheme' = view (uriSchemeL' % schemeBSL')
urlBase' = T.unpack . decUTF8Safe . urlBaseName . view pathL'
warnOnMetadataUpdate _ _ = pure ()
decodeMetadata :: forall j m env .
( MonadReader env m
, HasDirs env
, HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
, HasLog env
, MonadMask m
, FromJSON j
)
=> FilePath
-> Excepts '[JSONError, FileDoesNotExistError] m j
decodeMetadata actualYaml = do
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
liftE
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
. liftIO
. Y.decodeFileEither
$ actualYaml
where
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed.
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError fp = do
let efp = etagsFile fp
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
(hideError doesNotExistErrorType $ rmFile efp)
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
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
2023-07-07 08:41:58 +00:00
getDownloadInfo t v = getDownloadInfo' t (mkTVer v)
getDownloadInfo' :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
-> GHCTargetVersion
-- ^ tool version
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo' t v = do
pfreq@(PlatformRequest a p mv) <- lift getPlatformReq
2021-07-19 14:49:18 +00:00
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 v t (Just pfreq))
2021-07-19 14:49:18 +00:00
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
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
2021-09-18 17:45:32 +00:00
-> Maybe URI -- ^ URI for gpg sig
2021-07-24 14:36:31 +00:00
-> Maybe T.Text -- ^ expected hash
-> Maybe Integer -- ^ expected content length
-> 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
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
2022-12-03 16:15:13 +00:00
download rawUri gpgUri eDigest eCSize dest mfn etags
| scheme == "https" = liftE dl
| scheme == "http" = liftE dl
| scheme == "file" = do
2022-12-03 16:15:13 +00:00
let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
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
scheme = view (uriSchemeL' % schemeBSL') rawUri
2020-01-11 20:15:05 +00:00
dl = do
2022-12-03 16:15:13 +00:00
Settings{ mirrors } <- lift getSettings
let uri = applyMirrors mirrors rawUri
2021-09-18 17:45:32 +00:00
baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
2020-01-11 20:15:05 +00:00
-- destination dir must exist
liftIO $ createDirRecursive' dest
2020-01-11 20:15:05 +00:00
2021-09-18 17:45:32 +00:00
2020-01-11 20:15:05 +00:00
-- download
flip onException
2021-09-18 17:45:32 +00:00
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError, ContentLengthError] @'[DigestError, ContentLengthError, DownloadFailed, GPGError]
2021-09-18 17:45:32 +00:00
(\e' -> do
lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
case e' of
V e@GPGError {} -> throwE e
V e@DigestError {} -> throwE e
_ -> throwE (DownloadFailed e')
) $ do
2021-09-18 17:45:32 +00:00
Settings{ downloader, noNetwork, gpgSetting } <- lift getSettings
2021-07-18 21:29:09 +00:00
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
2021-09-18 17:45:32 +00:00
downloadAction <- case downloader of
Curl -> do
o' <- liftIO getCurlOpts
if etags
then pure $ curlEtagsDL o'
else pure $ curlDL o'
Wget -> do
o' <- liftIO getWgetOpts
if etags
then pure $ wgetEtagsDL o'
else pure $ wgetDL o'
2020-04-29 17:12:58 +00:00
#if defined(INTERNAL_DOWNLOADER)
2021-09-18 17:45:32 +00:00
Internal -> do
if etags
then pure (\fp -> liftE . internalEtagsDL fp)
else pure (\fp -> liftE . internalDL fp)
#endif
2021-09-18 17:45:32 +00:00
liftE $ downloadAction baseDestFile uri
case (gpgUri, gpgSetting) of
(_, GPGNone) -> pure ()
(Just gpgUri', _) -> do
gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing
liftE $ flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
) $ do
o' <- liftIO getGpgOpts
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
liftE $ downloadAction gpgDestFile gpgUri'
lift $ logInfo $ "verifying signature of: " <> T.pack baseDestFile
let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, baseDestFile]
cp <- lift $ executeOut "gpg" args Nothing
case cp of
CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
lift $ logDebug $ decUTF8Safe' _stdErr
throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
_ -> pure ()
forM_ eCSize (liftE . flip checkCSize baseDestFile)
forM_ eDigest (liftE . flip checkDigest baseDestFile)
2021-09-18 17:45:32 +00:00
pure baseDestFile
curlDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
2021-09-18 17:45:32 +00:00
curlDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']
++ maybe [] (\s -> ["--max-filesize", show s]) eCSize
) Nothing Nothing
2021-09-18 17:45:32 +00:00
liftIO $ renameFile destFileTemp destFile
curlEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
2021-09-18 17:45:32 +00:00
curlEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
++ ["-fL", "-o", destFileTemp, 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
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
Just (http':sc:_)
| sc == "304"
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ renameFile destFileTemp destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
lift $ writeEtags destFile (parseEtags headers)
wgetDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
2021-09-18 17:45:32 +00:00
wgetDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
liftIO $ renameFile destFileTemp destFile
wgetEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
2021-09-18 17:45:32 +00:00
wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
2020-01-11 20:15:05 +00:00
2021-09-18 17:45:32 +00:00
#if defined(INTERNAL_DOWNLOADER)
internalDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
2021-09-18 17:45:32 +00:00
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFileTemp mempty eCSize
2021-09-18 17:45:32 +00:00
liftIO $ renameFile destFileTemp destFile
internalEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
2021-09-18 17:45:32 +00:00
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalEtagsDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
metag <- lift $ readETag destFile
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))
$ do
r <- downloadToFile https host fullPath port destFileTemp addHeaders eCSize
2021-09-18 17:45:32 +00:00
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
#endif
2020-01-11 20:15:05 +00:00
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.
2021-09-18 17:45:32 +00:00
getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
getDestFile uri' mfn' =
2021-09-18 17:45:32 +00:00
let path = view pathL' uri'
in 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
2021-09-18 17:45:32 +00:00
| otherwise -> throwE $ NoUrlBase (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, ContentLengthError, DownloadFailed, GPGError] 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
True -> downloadCached' dli mfn Nothing
2020-01-11 20:15:05 +00:00
False -> do
tmp <- lift withGHCupTmpDir
2023-05-14 11:33:04 +00:00
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False
where
outputFileName = mfn <|> _dlOutput dli
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)
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] 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
let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
2023-05-14 11:33:04 +00:00
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) outputFileName
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
forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile
2021-07-24 14:36:31 +00:00
liftE $ checkDigest (view dlHash dli) cachfile
2021-05-14 21:09:45 +00:00
pure cachfile
2023-05-14 11:33:04 +00:00
| otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir outputFileName False
where
outputFileName = mfn <|> _dlOutput dli
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
2021-09-19 19:24:21 +00:00
when ((cDigest /= eDigest) && verify) $ throwE (DigestError file cDigest eDigest)
checkCSize :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m
, HasLog env
)
=> Integer
-> FilePath
-> Excepts '[ContentLengthError] m ()
checkCSize eCSize file = do
Settings{ noVerify } <- lift getSettings
let verify = not noVerify
when verify $ do
let p' = takeFileName file
lift $ logInfo $ "verifying content length of: " <> T.pack p'
cSize <- liftIO $ getFileSize file
when ((eCSize /= cSize) && verify) $ throwE (ContentLengthError (Just file) (Just cSize) eCSize)
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-09-18 17:45:32 +00:00
-- | Get additional gpg args from env. This is an undocumented option.
getGpgOpts :: IO [String]
getGpgOpts =
lookupEnv "GHCUP_GPG_OPTS" >>= \case
Just r -> pure $ splitOn " " r
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)
2021-05-14 21:09:45 +00:00
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
2021-09-18 17:45:32 +00:00
tmpFile :: FilePath -> FilePath
tmpFile = (<.> "tmp")
2022-12-03 16:15:13 +00:00
applyMirrors :: DownloadMirrors -> URI -> URI
applyMirrors (DM ms) uri@(URI { uriAuthority = Just (Authority { authorityHost = Host host }) }) =
case M.lookup (decUTF8Safe host) ms of
Nothing -> uri
Just (DownloadMirror auth (Just prefix)) ->
uri { uriAuthority = Just auth
, uriPath = E.encodeUtf8 $ T.pack ("/" <> T.unpack prefix <> (T.unpack . decUTF8Safe . uriPath $ uri))
}
Just (DownloadMirror auth Nothing) ->
uri { uriAuthority = Just auth }
applyMirrors _ uri = uri