{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# 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 : POSIX 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 import GHCup.Download.Utils #endif import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Prelude import GHCup.Version 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.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) import Data.Aeson import Data.Bifunctor import Data.ByteString ( ByteString ) #if defined(INTERNAL_DOWNLOADER) import Data.CaseInsensitive ( CI ) #endif import Data.Maybe import Data.String.Interpolate import Data.Time.Clock import Data.Time.Clock.POSIX #if defined(INTERNAL_DOWNLOADER) import Data.Time.Format #endif import Data.Versions import Data.Word8 import GHC.IO.Exception import HPath import HPath.IO as HIO hiding ( hideError ) import Haskus.Utils.Variant.Excepts import Optics import Prelude hiding ( abs , readFile , writeFile ) import System.IO.Error import System.Posix.Env.ByteString ( getEnv ) import URI.ByteString import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as L #if defined(INTERNAL_DOWNLOADER) import qualified Data.CaseInsensitive as CI import qualified Data.Map.Strict as M import qualified Data.Text as T #endif import qualified Data.Text.Encoding as E import qualified Data.Yaml as Y import qualified System.Posix.Files.ByteString as PF import qualified System.Posix.RawFilePath.Directory as RD ------------------ --[ High-level ]-- ------------------ -- | Like 'getDownloads', but tries to fall back to -- cached ~/.ghcup/cache/ghcup-.yaml getDownloadsF :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo , MonadIO m , MonadCatch m , MonadLogger m , MonadThrow m , MonadFail m , MonadReader Settings m ) => URLSource -> Excepts '[JSONError , DownloadFailed , FileDoesNotExistError] m GHCupInfo getDownloadsF urlSource = do case urlSource of GHCupURL -> liftE $ handleIO (\_ -> readFromCache) $ catchE @_ @'[JSONError , FileDoesNotExistError] (\(DownloadFailed _) -> readFromCache) $ getDownloads urlSource (OwnSource _) -> liftE $ getDownloads urlSource (OwnSpec _) -> liftE $ getDownloads urlSource where readFromCache = do Settings {dirs = Dirs {..}} <- lift ask lift $ $(logWarn) [i|Could not get download info, trying cached version (this may not be recent!)|] let path = view pathL' ghcupURL yaml_file <- (cacheDir ) <$> urlBaseName path bs <- handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file)) $ liftIO $ readFile yaml_file lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) -- | Downloads the download information! But only if we need to ;P getDownloads :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo , MonadIO m , MonadCatch m , MonadLogger m , MonadThrow m , MonadFail m , MonadReader Settings m ) => URLSource -> Excepts '[JSONError , DownloadFailed] m GHCupInfo getDownloads urlSource = do lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|] case urlSource of GHCupURL -> do bs <- reThrowAll DownloadFailed $ smartDl ghcupURL lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) (OwnSource url) -> do bs <- reThrowAll DownloadFailed $ downloadBS url lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) (OwnSpec av) -> pure $ av where -- 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 -- than the local file. -- -- Always save the local file with the mod time of the remote file. smartDl :: forall m1 . ( MonadCatch m1 , MonadIO m1 , MonadFail m1 , MonadLogger m1 , MonadReader Settings m1 ) => URI -> Excepts '[ FileDoesNotExistError , HTTPStatusError , URIParseError , UnsupportedScheme , NoLocationHeader , TooManyRedirs , ProcessError ] m1 L.ByteString smartDl uri' = do Settings {dirs = Dirs {..}} <- lift ask let path = view pathL' uri' json_file <- (cacheDir ) <$> urlBaseName path e <- liftIO $ doesFileExist json_file if e then do accessTime <- PF.accessTimeHiRes <$> (liftIO $ PF.getFileStatus (toFilePath json_file)) currentTime <- liftIO $ getPOSIXTime -- access time won't work on most linuxes, but we can try regardless if (currentTime - accessTime) > 300 then do -- no access in last 5 minutes, re-check upstream mod time getModTime >>= \case Just modTime -> do fileMod <- liftIO $ getModificationTime json_file if modTime > fileMod then dlWithMod modTime json_file else liftIO $ readFile json_file Nothing -> do lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|] dlWithoutMod json_file else -- access in less than 5 minutes, re-use file liftIO $ readFile json_file else do liftIO $ createDirRecursive' cacheDir getModTime >>= \case Just modTime -> dlWithMod modTime json_file Nothing -> do -- although we don't know last-modified, we still save -- it to a file, so we might use it in offline mode lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|] dlWithoutMod json_file where dlWithMod modTime json_file = do bs <- liftE $ downloadBS uri' liftIO $ writeFileWithModTime modTime json_file bs pure bs dlWithoutMod json_file = do bs <- liftE $ downloadBS uri' liftIO $ hideError doesNotExistErrorType $ deleteFile json_file liftIO $ writeFileL json_file (Just newFilePerms) bs liftIO $ setModificationTime json_file (fromIntegral @Int 0) pure bs getModTime = do #if !defined(INTERNAL_DOWNLOADER) pure Nothing #else 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 headers = (M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" (T.unpack . decUTF8Safe $ h) #endif writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO () writeFileWithModTime utctime path content = do let mod_time = utcTimeToPOSIXSeconds utctime writeFileL path (Just newFilePerms) content setModificationTimeHiRes path mod_time getDownloadInfo :: Tool -> Version -- ^ tool version -> PlatformRequest -> GHCupDownloads -> Either NoDownload DownloadInfo getDownloadInfo t v (PlatformRequest a p mv) dls = maybe (Left NoDownload) Right (case p of -- non-musl won't work on alpine Linux Alpine -> with_distro <|> without_distro_ver _ -> with_distro <|> without_distro_ver <|> without_distro) where with_distro = distro_preview id id without_distro_ver = distro_preview id (const Nothing) without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing) distro_preview f g = preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls -- | 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 :: ( MonadMask m , MonadReader Settings m , MonadThrow m , MonadLogger m , MonadIO m ) => DownloadInfo -> Path Abs -- ^ destination dir -> Maybe (Path Rel) -- ^ optional filename -> Excepts '[DigestError , DownloadFailed] m (Path Abs) download dli dest mfn | scheme == "https" = dl | scheme == "http" = dl | scheme == "file" = cp | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme) where scheme = view (dlUri % uriSchemeL' % schemeBSL') dli cp = do -- destination dir must exist liftIO $ createDirRecursive' dest destFile <- getDestFile fromFile <- parseAbs path liftIO $ copyFile fromFile destFile Strict pure destFile dl = do let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli)) lift $ $(logInfo) [i|downloading: #{uri'}|] -- destination dir must exist liftIO $ createDirRecursive' dest destFile <- getDestFile -- download flip onException (liftIO $ hideError doesNotExistErrorType $ deleteFile destFile) $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme] (\e -> (liftIO $ hideError doesNotExistErrorType $ deleteFile destFile) >> (throwE . DownloadFailed $ e) ) $ do lift getDownloader >>= \case Curl -> do o' <- liftIO getCurlOpts liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True (o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing Wget -> do o' <- liftIO getWgetOpts liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True (o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing #if defined(INTERNAL_DOWNLOADER) Internal -> do (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli) liftE $ downloadToFile https host fullPath port destFile #endif liftE $ checkDigest dli destFile pure destFile -- Manage to find a file we can write the body into. getDestFile :: MonadThrow m => m (Path Abs) getDestFile = maybe (urlBaseName path <&> (dest )) (pure . (dest )) mfn path = view (dlUri % pathL') dli -- | Download into tmpdir or use cached version, if it exists. If filename -- is omitted, infers the filename from the url. downloadCached :: ( MonadMask m , MonadResource m , MonadThrow m , MonadLogger m , MonadIO m , MonadReader Settings m ) => DownloadInfo -> Maybe (Path Rel) -- ^ optional filename -> Excepts '[DigestError , DownloadFailed] m (Path Abs) downloadCached dli mfn = do cache <- lift getCache case cache of True -> do Settings {dirs = Dirs {..}} <- lift ask fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn let cachfile = cacheDir fn fileExists <- liftIO $ doesFileExist cachfile if | fileExists -> do liftE $ checkDigest dli cachfile pure $ cachfile | otherwise -> liftE $ download dli cacheDir mfn False -> do tmp <- lift withGHCupTmpDir liftE $ download dli tmp mfn ------------------ --[ Low-level ]-- ------------------ -- | This is used for downloading the JSON. downloadBS :: (MonadReader Settings m, MonadCatch m, MonadIO m, MonadLogger m) => URI -> Excepts '[ FileDoesNotExistError , HTTPStatusError , URIParseError , UnsupportedScheme , NoLocationHeader , TooManyRedirs , ProcessError ] m L.ByteString downloadBS uri' | scheme == "https" = dl True | scheme == "http" = dl False | scheme == "file" = liftIOException doesNotExistErrorType (FileDoesNotExistError path) $ (liftIO $ RD.readFile path) | otherwise = throwE UnsupportedScheme where scheme = view (uriSchemeL' % schemeBSL') uri' path = view pathL' uri' #if defined(INTERNAL_DOWNLOADER) dl https = do #else dl _ = do #endif lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|] lift getDownloader >>= \case Curl -> do o' <- liftIO getCurlOpts let exe = [rel|curl|] args = o' ++ ["-sSfL", serializeURIRef' uri'] liftIO (executeOut exe args Nothing) >>= \case CapturedProcess ExitSuccess stdout _ -> do pure $ L.fromStrict stdout CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args Wget -> do o' <- liftIO getWgetOpts let exe = [rel|wget|] args = o' ++ ["-qO-", serializeURIRef' uri'] liftIO (executeOut exe args Nothing) >>= \case CapturedProcess ExitSuccess stdout _ -> do pure $ L.fromStrict stdout CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args #if defined(INTERNAL_DOWNLOADER) Internal -> do (_, host', fullPath', port') <- liftE $ uriToQuadruple uri' liftE $ downloadBS' https host' fullPath' port' #endif checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings m) => DownloadInfo -> Path Abs -> Excepts '[DigestError] m () checkDigest dli file = do verify <- lift ask <&> (not . noVerify) when verify $ do p' <- toFilePath <$> basename file lift $ $(logInfo) [i|verifying digest of: #{p'}|] c <- liftIO $ readFile file cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c let eDigest = view dlHash dli when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest) -- | Get additional curl args from env. This is an undocumented option. getCurlOpts :: IO [ByteString] getCurlOpts = getEnv "GHCUP_CURL_OPTS" >>= \case Just r -> pure $ BS.split _space r Nothing -> pure [] -- | Get additional wget args from env. This is an undocumented option. getWgetOpts :: IO [ByteString] getWgetOpts = getEnv "GHCUP_WGET_OPTS" >>= \case Just r -> pure $ BS.split _space r Nothing -> pure []