Jo

TODO.md

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

app/ghcup-gen/Validate.hs

@@ -34,6 +34,9 @@ instance Exception ValidationError
 
 -- TODO: test that GHC is in semver
 -- 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)
          => GHCupDownloads
          -> m ExitCode

app/ghcup/Main.hs

@@ -53,6 +53,7 @@ data Options = Options
     optVerbose   :: Bool
   , optCache     :: Bool
   , optUrlSource :: Maybe URI
+  , optNoVerify  :: Bool
   -- commands
   , 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
  where
   parseUri s' =
@@ -320,6 +325,7 @@ toSettings :: Options -> Settings
 toSettings Options {..} =
   let cache     = optCache
       urlSource = maybe GHCupURL OwnSource optUrlSource
+      noVerify  = optNoVerify
   in  Settings { .. }
 
 

lib/GHCup/Download.hs

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

lib/GHCup/Platform.hs

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

lib/GHCup/Types.hs

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

lib/GHCup/Utils/Prelude.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -20,6 +21,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      ( lift )
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
+import           Data.Data
 import           Data.Monoid                    ( (<>) )
 import           Data.String
 import           Data.Text                      ( Text )
@@ -31,6 +33,7 @@ import           Language.Haskell.TH
 import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
 import           Language.Haskell.TH.Syntax     ( Exp(..)
                                                 , Lift
+                                                , dataToExpQ
                                                 )
 import           System.IO.Error
 
@@ -186,10 +189,10 @@ hideExcept _ a action =
   catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
 
 hideExcept' :: forall e es es' m
-            . (Monad m, e :< es, LiftVariant (Remove e es) es')
-           => e
-           -> Excepts es m ()
-           -> Excepts es' m ()
+             . (Monad m, e :< es, LiftVariant (Remove e es) es')
+            => e
+            -> Excepts es m ()
+            -> Excepts es' m ()
 hideExcept' _ action =
   catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
 
@@ -202,14 +205,21 @@ throwEither a = case a of
 
 
 
+deriving instance Data Versioning
 deriving instance Lift Versioning
+deriving instance Data Version
 deriving instance Lift Version
+deriving instance Data SemVer
 deriving instance Lift SemVer
+deriving instance Data Mess
 deriving instance Lift Mess
+deriving instance Data PVP
 deriving instance Lift PVP
 deriving instance Lift (NonEmpty Word)
 deriving instance Lift VSep
+deriving instance Data VSep
 deriving instance Lift VUnit
+deriving instance Data VUnit
 instance Lift Text
 
 qq :: (Text -> Q Exp) -> QuasiQuoter
@@ -227,31 +237,38 @@ vver :: QuasiQuoter
 vver = qq mkV
  where
   mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . version
+  mkV = either (fail . show) liftDataWithText . version
 
 mver :: QuasiQuoter
 mver = qq mkV
  where
   mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . mess
+  mkV = either (fail . show) liftDataWithText . mess
 
 sver :: QuasiQuoter
 sver = qq mkV
  where
   mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . semver
+  mkV = either (fail . show) liftDataWithText . semver
 
 vers :: QuasiQuoter
 vers = qq mkV
  where
   mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . versioning
+  mkV = either (fail . show) liftDataWithText . versioning
 
 pver :: QuasiQuoter
 pver = qq mkV
  where
   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