{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module GHCup.Download where import GHCup.Errors import GHCup.Platform import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Prelude import GHCup.Utils.String.QQ import Control.Applicative import Control.Exception.Safe import Control.Monad import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Resource hiding ( throwM ) import Data.Aeson import Data.ByteString ( ByteString ) import Data.ByteString.Builder import Data.IORef import Data.Maybe import Data.String.Interpolate import Data.Versions import GHC.IO.Exception import HPath import HPath.IO import Haskus.Utils.Variant.Excepts import Network.Http.Client hiding ( URL ) import OpenSSL.Digest import Optics import Prelude hiding ( abs , readFile , writeFile ) import System.IO.Error import "unix" System.Posix.IO.ByteString hiding ( fdWrite ) import "unix-bytestring" System.Posix.IO.ByteString ( fdWrite ) import System.Posix.RawFilePath.Directory.Errors ( hideError ) import URI.ByteString import URI.ByteString.QQ import qualified Data.ByteString.Lazy as L import qualified Data.Text.Encoding as E import qualified System.IO.Streams as Streams import qualified System.Posix.RawFilePath.Directory as RD ghcupURL :: URI ghcupURL = [uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|] -- | Downloads the download information! getDownloads :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo , MonadIO m , MonadCatch m , MonadReader Settings m , MonadLogger m ) => Excepts '[FileDoesNotExistError , URLException , JSONError] m GHCupDownloads getDownloads = do urlSource <- lift getUrlSource lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|] case urlSource of GHCupURL -> do bs <- liftE $ downloadBS ghcupURL lE' JSONDecodeError $ eitherDecode' bs (OwnSource url) -> do bs <- liftE $ downloadBS url lE' JSONDecodeError $ eitherDecode' bs (OwnSpec av) -> pure $ av getDownloadInfo :: ( MonadLogger m , MonadCatch m , MonadIO m , MonadReader Settings m ) => BinaryDownloads -> ToolRequest -> Maybe PlatformRequest -> Excepts '[ DistroNotFound , PlatformResultError , NoCompatibleArch , NoDownload ] m DownloadInfo getDownloadInfo bDls (ToolRequest t v) mpfReq = do (PlatformRequest arch' plat ver) <- case mpfReq of Just x -> pure x Nothing -> do (PlatformResult rp rv) <- liftE getPlatform ar <- lE getArchitecture pure $ PlatformRequest ar rp rv lE $ getDownloadInfo' t v arch' plat ver bDls getDownloadInfo' :: Tool -> Version -- ^ tool version -> Architecture -- ^ user arch -> Platform -- ^ user platform -> Maybe Versioning -- ^ optional version of the platform -> BinaryDownloads -> Either NoDownload DownloadInfo getDownloadInfo' t v a p mv dls = maybe (Left NoDownload) Right (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 :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) => DownloadInfo -> Path Abs -- ^ destination dir -> Maybe (Path Rel) -- ^ optional filename -> Excepts '[DigestError , URLException] m (Path Abs) download dli dest mfn | scheme == [s|https|] = dl True | scheme == [s|http|] = dl False | scheme == [s|file|] = cp | otherwise = throwE UnsupportedURL where scheme = view (dlUri % uriSchemeL' % schemeBSL') dli cp = do -- destination dir must exist liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest destFile <- getDestFile fromFile <- parseAbs path liftIO $ copyFile fromFile destFile Strict pure destFile dl https = do let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli)) lift $ $(logInfo) [i|downloading: #{uri'}|] host <- preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli ?? UnsupportedURL let port = preview (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL') dli -- destination dir must exist liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest destFile <- getDestFile -- download fd <- liftIO $ createRegularFileFd newFilePerms destFile let stepper = fdWrite fd liftIO $ flip finally (closeFd fd) $ downloadInternal https host path port stepper -- TODO: verify md5 during download 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 :: ( MonadResource m , MonadThrow m , MonadLogger m , MonadIO m , MonadReader Settings m ) => DownloadInfo -> Maybe (Path Rel) -- ^ optional filename -> Excepts '[DigestError , URLException] m (Path Abs) downloadCached dli mfn = do cache <- lift getCache case cache of True -> do cachedir <- liftIO $ ghcupCacheDir 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 -- | This is used for downloading the JSON. downloadBS :: (MonadCatch m, MonadIO m) => URI -> Excepts '[FileDoesNotExistError , URLException] m L.ByteString downloadBS uri' | scheme == [s|https|] = dl True | scheme == [s|http|] = dl False | scheme == [s|file|] = liftException doesNotExistErrorType (FileDoesNotExistError path) $ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString) | otherwise = throwE UnsupportedURL where scheme = view (uriSchemeL' % schemeBSL') uri' path = view pathL' uri' dl https = do host <- preview (authorityL' % _Just % authorityHostL' % hostBSL') uri' ?? UnsupportedURL let port = preview (authorityL' % _Just % authorityPortL' % _Just % portNumberL') uri' liftIO $ downloadBS' https host path port -- | Load the result of this download into memory at once. downloadBS' :: Bool -- ^ https? -> ByteString -- ^ host (e.g. "www.example.com") -> ByteString -- ^ path (e.g. "/my/file") -> Maybe Int -- ^ optional port (e.g. 3000) -> IO (L.ByteString) downloadBS' https host path port = do bref <- newIORef (mempty :: Builder) let stepper bs = modifyIORef bref (<> byteString bs) downloadInternal https host path port stepper readIORef bref <&> toLazyByteString downloadInternal :: Bool -> ByteString -> ByteString -> Maybe Int -> (ByteString -> IO a) -- ^ the consuming step function -> IO () downloadInternal https host path port consumer = do c <- case https of True -> do ctx <- baselineContextSSL openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port) False -> openConnection host (fromIntegral $ fromMaybe 80 port) let q = buildRequest1 $ http GET path sendRequest c q emptyBody receiveResponse c (\_ i' -> do outStream <- Streams.makeOutputStream (\case Just bs -> void $ consumer bs Nothing -> pure () ) Streams.connect i' outStream ) closeConnection c checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m) => DownloadInfo -> Path Abs -> Excepts '[DigestError] m () checkDigest dli file = do verify <- lift ask <&> (not . noVerify) when verify $ do let p' = toFilePath file lift $ $(logInfo) [i|veryfing digest of: #{p'}|] c <- liftIO $ readFile file let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c eDigest = view dlHash dli when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)