ghcup-0.2.1.0: lib/GHCup/Download.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module : GHCup.Download
Description : Downloading
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : portable
Module for handling all download related functions.
Generally we support downloading via:
- curl (default)
- wget
- internal downloader (only when compiled)
-}
module GHCup.Download where
#if defined(INTERNAL_DOWNLOADER)
import GHCup.Download.IOStreams
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON
()
import GHCup.Types.Optics
#if defined(DHALL)
import GHCup.Types.Dhall
()
#endif
import GHCup.Hardcoded.URLs
import GHCup.Input.Parsers.URI
import GHCup.Prelude
import GHCup.Prelude.Process
import GHCup.Query.GHCupDirs
import GHCup.Query.System
import GHCup.System.Directory
import qualified GHCup.Types.Stack as Stack
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding ( throwM )
import Data.Aeson
#if defined(DHALL)
import qualified Data.ByteString.Lazy as BL
import Data.Void ( Void )
import qualified Dhall
import qualified Dhall.Binary as Dhall
#endif
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( mk )
#endif
import Data.Either
import Data.List
import Data.Maybe
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Variant.Excepts
import Data.Versions
import Data.Word8 hiding ( isSpace )
#if defined(INTERNAL_DOWNLOADER)
import Network.Http.Client hiding ( URL )
#endif
import Optics
import Prelude hiding ( abs, readFile, writeFile )
import Safe
import System.Environment
import System.Exit
import System.FilePath
import System.IO.Error
import System.IO.Temp
import URI.ByteString hiding ( parseURI )
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.IO as T
import qualified Data.Yaml.Aeson as Y
-- $setup
-- >>> :set -XOverloadedStrings
------------------
--[ High-level ]--
------------------
getDownloadsF ::
( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadIOish m
)
=> PlatformRequest
-> Excepts
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError, UnsupportedMetadataFormat]
m
GHCupInfo
getDownloadsF pfreq = do
Settings { urlSource } <- lift getSettings
getDownloadsF' pfreq urlSource
-- | Downloads the download information! But only if we need to ;P
--
-- This ignores the 'urlSource' from 'Settings'.
getDownloadsF' ::
( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadIOish m
)
=> PlatformRequest
-> [NewURLSource]
-> Excepts
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError, UnsupportedMetadataFormat]
m
GHCupInfo
getDownloadsF' pfreq@(PlatformRequest arch plat _) urlSource = do
infos <- liftE $ mapM dl' urlSource
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, UnsupportedMetadataFormat]
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' (NewChannelAlias StackChannel) = fmap Right $ liftE (getBase $ channelURL StackChannel) >>= liftE . decodeMetadata @Stack.SetupInfo
dl' (NewChannelAlias c) = fmap Left $ liftE (getBase $ channelURL c) >>= liftE . decodeMetadata @GHCupInfo
dl' (NewGHCupInfo gi) = pure (Left gi)
dl' (NewSetupInfo si) = pure (Right si)
dl' (NewURI uri) = do
base <- liftE $ getBase uri
gr <- runE $ decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI
case gr of
VRight r -> pure $ Left r
VLeft (V (JSONDecodeError ge)) -> do
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: " <> T.pack ge
sr <- runE $ decodeMetadata @Stack.SetupInfo base
case sr of
VRight r -> pure $ Right r
VLeft (V (JSONDecodeError se)) -> do
throwE $ JSONDecodeError $ "\nError decoding as GHCupInfo:\n"
<> (unlines . fmap (" " <>) . lines $ ge)
<> "\nError decoding as StackSetupURL:\n"
<> (unlines . fmap (" " <>) . lines $ se)
VLeft err -> throwSomeE err
VLeft err -> throwSomeE err
fromStackSetupInfo :: MonadThrow m
=> Stack.SetupInfo
-> [String]
-> m GHCupInfo
fromStackSetupInfo (Stack.siGHCs -> ghcDli) keys = do
let ghcVersionsPerKey = (`M.lookup` ghcDli) . T.pack <$> keys
ghcVersions = fromMaybe mempty . listToMaybe . catMaybes $ ghcVersionsPerKey
(ghcupInfo' :: M.Map TargetVersion DownloadInfo) <-
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\v a -> pure $ fromStackDownloadInfo v a) ghcVersions
let ghcupDownloads' = GHCupDownloads $ M.singleton ghc (ToolInfo (ToolVersionSpec $ M.map fromDownloadInfo ghcupInfo') Nothing)
pure (GHCupInfo mempty ghcupDownloads' Nothing)
where
fromDownloadInfo :: DownloadInfo -> VersionMetadata
fromDownloadInfo dli = let aspec = ArchitectureSpec $ MapIgnoreUnknownKeys $ M.singleton arch (PlatformSpec $ MapIgnoreUnknownKeys $ M.singleton plat (PlatformVersionSpec $ M.singleton Nothing dli))
in VersionMetadata [] Nothing Nothing Nothing Nothing Nothing Nothing (RevisionSpec . M.singleton (Rev 0) . VersionInfo Nothing Nothing $ aspec)
fromStackDownloadInfo :: MonadThrow m => Version -> Stack.GHCDownloadInfo -> m DownloadInfo
fromStackDownloadInfo ver (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do
sha256 <- maybe (throwM $ DigestMissing downloadInfoUrl) (pure . E.decodeUtf8) downloadInfoSha256
pure $ DownloadInfo downloadInfoUrl (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing Nothing (Just $ toInstallationInputSpec $ defaultGHCInstallSpec pfreq $ mkTVer ver)
mergeGhcupInfo :: MonadFail m
=> [GHCupInfo]
-> m GHCupInfo
mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
mergeGhcupInfo xs@(GHCupInfo{}: _) =
let newDownloads =
M.unionsWith
(\(ToolInfo (ToolVersionSpec a) td) (ToolInfo (ToolVersionSpec a') td') ->
ToolInfo (ToolVersionSpec (M.unionWith (\_ b2 -> b2) a a')) (td <|> td'))
(unGHCupDownloads . _ghcupDownloads <$> xs)
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
in pure $ GHCupInfo newToolReqs (GHCupDownloads newDownloads) Nothing
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
yamlFromCache uri = do
Dirs{..} <- getDirs
pure (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
etagsFile :: FilePath -> FilePath
etagsFile = (<.> "etags")
getBase :: forall m env . ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
, HasLog env
, MonadMask m
)
=> URI
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError] m FilePath
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
where
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
-- 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.
smartDl :: forall m1 env1
. ( MonadReader env1 m1
, HasDirs env1
, HasSettings env1
, MonadCatch m1
, MonadIO m1
, MonadFail m1
, HasLog env1
, MonadMask m1
)
=> URI
-> Excepts
'[ DownloadFailed
, DigestError
, ContentLengthError
, GPGError
]
m1
FilePath
smartDl uri' = do
json_file <- lift $ yamlFromCache uri'
let scheme = view (uriSchemeL' % schemeBSL') uri'
e <- liftIO $ doesFileExist json_file
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
where
dlWithMod modTime json_file = do
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
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 available metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nRun 'ghcup upgrade' first. If the waring persists, then you might need to update your " <> T.pack confFile
| scheme' uri /= "file"
, uri /= newUri = do
confFile <- getConfigFilePath'
logWarn $ "New available metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nRun 'ghcup upgrade' first. If the waring persists, then you 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
#if defined(DHALL)
, Dhall.FromDhall j
#endif
)
=> FilePath
-> Excepts '[JSONError, FileDoesNotExistError, UnsupportedMetadataFormat] m j
decodeMetadata metadata
| takeExtension metadata `elem` [".yaml", ".yml"]= do
lift $ logDebug $ "Decoding yaml at: " <> T.pack metadata
liftE $ yamlMeta metadata
| takeExtension metadata == ".json" = do
lift $ logDebug $ "Decoding json at: " <> T.pack metadata
liftE $ jsonMeta metadata
#if defined(DHALL)
| takeExtension metadata == ".dhall" = do
lift $ logDebug $ "Decoding dhall at: " <> T.pack metadata
liftE $ dhallMeta metadata
| takeExtension metadata `elem` [".dhallb", ".dhall-binary"] = do
lift $ logDebug $ "Decoding dhall binary at: " <> T.pack metadata
liftE $ dhallbMeta metadata
#endif
| otherwise = throwE $ UnsupportedMetadataFormat (takeExtension metadata)
where
#if defined(DHALL)
dhallbMeta f =
onE_ (onError f)
. handleIO (\(displayException -> e) -> throwE @_ @'[JSONError] $ JSONDecodeError $ unlines [e, "Consider removing " <> f <> " manually."])
. liftIO
$ BL.readFile f >>= either (fail . show) pure . Dhall.decodeExpression @Void @Void >>= Dhall.rawInput Dhall.auto
dhallMeta f =
onE_ (onError f)
. handleIO (\(displayException -> e) -> throwE @_ @'[JSONError] $ JSONDecodeError $ unlines [e, "Consider removing " <> f <> " manually."])
. liftIO
. Dhall.inputFile Dhall.auto
$ f
#endif
jsonMeta f =
onE_ (onError f)
. lEM' @_ @_ @'[JSONError] (\e -> JSONDecodeError $ unlines [e, "Consider removing " <> f <> " manually."])
. liftIO
. eitherDecodeFileStrict
$ f
yamlMeta f =
onE_ (onError f)
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> f <> " manually."])
. liftIO
. Y.decodeFileEither
$ f
-- 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))
-- | 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.
download :: ( MonadReader env m
, HasSettings env
, HasDirs env
, MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
)
=> URI
-> Maybe URI -- ^ URI for gpg sig
-> Maybe T.Text -- ^ expected hash
-> Maybe Integer -- ^ expected content length
-> FilePath -- ^ destination dir (ignored for file:// scheme)
-> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
download rawUri gpgUri eDigest eCSize dest mfn etags
| scheme == "https" = liftE dl
| scheme == "http" = liftE dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where
scheme = view (uriSchemeL' % schemeBSL') rawUri
dl = do
Settings{ mirrors } <- lift getSettings
let uri = applyMirrors mirrors rawUri
baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
-- destination dir must exist
liftIO $ createDirRecursive' dest
-- download
flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
$ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError, ContentLengthError] @'[DigestError, ContentLengthError, DownloadFailed, GPGError]
(\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
Settings{ downloader, noNetwork, gpgSetting } <- lift getSettings
when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
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'
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
if etags
then pure (\fp -> liftE . internalEtagsDL fp)
else pure (\fp -> liftE . internalDL fp)
#endif
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)
pure baseDestFile
curlDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
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
liftIO $ renameFile destFileTemp destFile
curlEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
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 ()
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 ()
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)
#if defined(INTERNAL_DOWNLOADER)
internalDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> 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
liftIO $ renameFile destFileTemp destFile
internalEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> 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
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
#endif
-- Manage to find a file we can write the body into.
getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
getDestFile uri' mfn' =
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
| otherwise -> throwE $ NoUrlBase (decUTF8Safe . serializeURIRef' $ uri')
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do
let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
case T.words <$> mEtag of
(Just []) -> do
logDebug "Couldn't parse etags, no input: "
pure Nothing
(Just [_, etag']) -> do
logDebug $ "Parsed etag: " <> etag'
pure (Just etag')
(Just xs) -> do
logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
pure Nothing
Nothing -> do
logDebug "No etags header found"
pure Nothing
writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags destFile getTags = do
getTags >>= \case
Just t -> do
logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
liftIO $ T.writeFile (etagsFile destFile) t
Nothing ->
logDebug "No etags files written"
readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
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
logDebug $ "Read etag: " <> et
pure (Just et)
(Left _) -> do
logDebug "Etag file doesn't exist (yet)"
pure Nothing
else do
logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
pure Nothing
-- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
downloadCached :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadResource m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Excepts '[URIParseError, DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
downloadCached dli mfn = do
Settings{ cache } <- lift getSettings
dlu <- lE $ parseURI' (_dlUri dli)
let scheme = view (uriSchemeL' % schemeBSL') dlu
if cache && scheme /= "file"
then downloadCached' dli mfn Nothing
else do
tmp <- lift withGHCupTmpDir
liftE $ download dlu Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False
where
outputFileName = mfn <|> _dlOutput dli
downloadCached' :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
=> DownloadInfo
-> Maybe FilePath -- ^ optional filename
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir)
-> Excepts '[URIParseError, DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs
dlu <- lE $ parseURI' (_dlUri dli)
let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view pathL' dlu) outputFileName
let cachfile = destDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> do
forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile
liftE $ checkDigest (view dlHash dli) cachfile
pure cachfile
| otherwise -> liftE $ download dlu Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir outputFileName False
where
outputFileName = mfn <|> _dlOutput dli
------------------
--[ Low-level ]--
------------------
checkDigest :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m
, HasLog env
)
=> T.Text -- ^ the hash
-> FilePath
-> Excepts '[DigestError] m ()
checkDigest eDigest file = do
Settings{ noVerify } <- lift getSettings
let verify = not noVerify
when verify $ do
let p' = takeFileName file
lift $ logInfo $ "verifying digest of: " <> T.pack p'
cDigest <- liftIO $ getFileDigest file
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)
-- | Get additional curl args from env. This is an undocumented option.
getCurlOpts :: IO [String]
getCurlOpts =
lookupEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get additional wget args from env. This is an undocumented option.
getWgetOpts :: IO [String]
getWgetOpts =
lookupEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | 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 []
-- | Get the url base name.
--
-- >>> urlBaseName "/foo/bar/baz"
-- "baz"
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash)
-- | 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"
-- >>> getLastHeader "HTTP/1.1 304 Not Modified\n"
-- "HTTP/1.1 304 Not Modified\n"
getLastHeader :: T.Text -> T.Text
getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [""] . fmap T.stripEnd . T.lines
tmpFile :: FilePath -> FilePath
tmpFile = (<.> "tmp")
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
getFileDigest :: FilePath -> IO T.Text
getFileDigest file = do
c <- liftIO $ L.readFile file
throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c