ghcup-hs/lib/GHCup/Download.hs
2020-03-03 23:34:25 +01:00

326 lines
11 KiB
Haskell

{-# 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 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.String.QQ
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 :: (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
let p' = toFilePath destFile
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
c <- liftIO $ readFile destFile
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
eDigest = view dlHash dli
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
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
let cachfile' = toFilePath cachfile
lift $ $(logInfo) [i|veryfing digest of: #{cachfile'}|]
c <- liftIO $ readFile cachfile
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
eDigest = view dlHash dli
when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
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