This commit is contained in:
Julian Ospald 2020-03-04 23:35:53 +01:00
parent 16ca061ab7
commit 718442a1e7
8 changed files with 1436 additions and 59 deletions

View File

@ -7,6 +7,10 @@
* static builds * static builds
* interoperability with old ghcup
* OS faking
## Maybe ## Maybe
* maybe: download progress * maybe: download progress

File diff suppressed because it is too large Load Diff

View File

@ -34,6 +34,9 @@ instance Exception ValidationError
-- TODO: test that GHC is in semver -- TODO: test that GHC is in semver
-- TODO: check there's LATEST tag for every tool -- TODO: check there's LATEST tag for every tool
-- TODO: check all tarballs can be downloaded
-- AND their checksum
-- TODO: check gpg keys of tarballs?
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m) validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
=> GHCupDownloads => GHCupDownloads
-> m ExitCode -> m ExitCode

View File

@ -53,6 +53,7 @@ data Options = Options
optVerbose :: Bool optVerbose :: Bool
, optCache :: Bool , optCache :: Bool
, optUrlSource :: Maybe URI , optUrlSource :: Maybe URI
, optNoVerify :: Bool
-- commands -- commands
, optCommand :: Command , optCommand :: Command
} }
@ -123,6 +124,10 @@ opts =
) )
) )
) )
<*> switch
(short 'n' <> long "no-verify" <> help
"Don't verify sha256 checksums of downloaded tarballs (default: False)"
)
<*> com <*> com
where where
parseUri s' = parseUri s' =
@ -320,6 +325,7 @@ toSettings :: Options -> Settings
toSettings Options {..} = toSettings Options {..} =
let cache = optCache let cache = optCache
urlSource = maybe GHCupURL OwnSource optUrlSource urlSource = maybe GHCupURL OwnSource optUrlSource
noVerify = optNoVerify
in Settings { .. } in Settings { .. }

View File

@ -155,7 +155,7 @@ getDownloadInfo' t v a p mv dls = maybe
-- 2. otherwise create a random file -- 2. otherwise create a random file
-- --
-- The file must not exist. -- The file must not exist.
download :: (MonadThrow m, MonadLogger m, MonadIO m) download :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> DownloadInfo => DownloadInfo
-> Path Abs -- ^ destination dir -> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename -> Maybe (Path Rel) -- ^ optional filename
@ -199,12 +199,7 @@ download dli dest mfn | scheme == [s|https|] = dl True
stepper stepper
-- TODO: verify md5 during download -- TODO: verify md5 during download
let p' = toFilePath destFile liftE $ checkDigest dli 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 pure destFile
-- Manage to find a file we can write the body into. -- Manage to find a file we can write the body into.
@ -234,17 +229,10 @@ downloadCached dli mfn = do
let cachfile = cachedir </> fn let cachfile = cachedir </> fn
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
| fileExists | fileExists -> do
-> do liftE $ checkDigest dli cachfile
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 pure $ cachfile
| otherwise | otherwise -> liftE $ download dli cachedir mfn
-> liftE $ download dli cachedir mfn
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download dli tmp mfn liftE $ download dli tmp mfn
@ -323,3 +311,19 @@ downloadInternal https host path port consumer = do
) )
closeConnection c 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)

View File

@ -96,6 +96,7 @@ getLinuxDistro = do
| hasWord name ["alpine"] -> Alpine | hasWord name ["alpine"] -> Alpine
| hasWord name ["exherbo"] -> Exherbo | hasWord name ["exherbo"] -> Exherbo
| hasWord name ["gentoo"] -> Gentoo | hasWord name ["gentoo"] -> Gentoo
| hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
| otherwise -> UnknownLinux | otherwise -> UnknownLinux
pure (distro, parsedVer) pure (distro, parsedVer)
where where

View File

@ -15,6 +15,7 @@ import qualified GHC.Generics as GHC
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
, urlSource :: URLSource , urlSource :: URLSource
, noVerify :: Bool
} }
deriving Show deriving Show
@ -77,6 +78,7 @@ data LinuxDistro = Debian
| CentOS | CentOS
| RedHat | RedHat
| Alpine | Alpine
| AmazonLinux
-- rolling -- rolling
| Gentoo | Gentoo
| Exherbo | Exherbo

View File

@ -4,6 +4,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -20,6 +21,7 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Data
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
import Data.String import Data.String
import Data.Text ( Text ) import Data.Text ( Text )
@ -31,6 +33,7 @@ import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..) import Language.Haskell.TH.Syntax ( Exp(..)
, Lift , Lift
, dataToExpQ
) )
import System.IO.Error import System.IO.Error
@ -202,14 +205,21 @@ throwEither a = case a of
deriving instance Data Versioning
deriving instance Lift Versioning deriving instance Lift Versioning
deriving instance Data Version
deriving instance Lift Version deriving instance Lift Version
deriving instance Data SemVer
deriving instance Lift SemVer deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess deriving instance Lift Mess
deriving instance Data PVP
deriving instance Lift PVP deriving instance Lift PVP
deriving instance Lift (NonEmpty Word) deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter qq :: (Text -> Q Exp) -> QuasiQuoter
@ -227,31 +237,38 @@ vver :: QuasiQuoter
vver = qq mkV vver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . version mkV = either (fail . show) liftDataWithText . version
mver :: QuasiQuoter mver :: QuasiQuoter
mver = qq mkV mver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . mess mkV = either (fail . show) liftDataWithText . mess
sver :: QuasiQuoter sver :: QuasiQuoter
sver = qq mkV sver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . semver mkV = either (fail . show) liftDataWithText . semver
vers :: QuasiQuoter vers :: QuasiQuoter
vers = qq mkV vers = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . versioning mkV = either (fail . show) liftDataWithText . versioning
pver :: QuasiQuoter pver :: QuasiQuoter
pver = qq mkV pver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . pvp mkV = either (fail . show) liftDataWithText . pvp
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
verToBS :: Version -> ByteString verToBS :: Version -> ByteString