Jo
This commit is contained in:
parent
16ca061ab7
commit
718442a1e7
4
TODO.md
4
TODO.md
@ -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
@ -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
|
||||||
|
@ -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 { .. }
|
||||||
|
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user