diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 2279004..83f362c 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -1,17 +1,27 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Validate where import GHCup import GHCup.Download +import GHCup.Errors import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.Dirs +import GHCup.Utils import GHCup.Utils.Logger import GHCup.Utils.Version.QQ +#if defined(TAR) +import qualified Codec.Archive.Tar as Tar +#else +import Codec.Archive +#endif import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class @@ -27,10 +37,12 @@ import Data.IORef import Data.List import Data.String.Interpolate import Data.Versions +import HPath ( toFilePath ) import Haskus.Utils.Variant.Excepts import Optics import System.Exit import System.IO +import System.Posix.FilePath import Text.ParserCombinators.ReadP import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix @@ -213,10 +225,43 @@ validateTarballs (TarballFilter tool versionRegex) dls = do runLogger . flip runReaderT settings . runResourceT - . runE - $ downloadCached dli Nothing + . runE @'[DigestError + , DownloadFailed + , UnknownArchive +#if defined(TAR) + , Tar.FormatError +#else + , ArchiveResult +#endif + ] + $ do + p <- liftE $ downloadCached dli Nothing + fmap (head . splitDirectories . head) + . liftE + . getArchiveFiles + $ p case r of - VRight _ -> pure () + VRight basePath -> do + case _dlSubdir dli of + Just (RealDir (toFilePath -> prel)) -> do + lift $ $(logInfo) + [i|verifying subdir: #{prel}|] + when (basePath /= prel) $ do + lift $ $(logError) + [i|Subdir doesn't match: expected "#{prel}", got "#{basePath}"|] + addError + Just (RegexDir regexString) -> do + lift $ $(logInfo) + [i|verifying subdir (regex): #{regexString}|] + let regex = makeRegexOpts + compIgnoreCase + execBlank + regexString + when (not (match regex basePath)) $ do + lift $ $(logError) + [i|Subdir doesn't match: expected regex "#{regexString}", got "#{basePath}"|] + addError + Nothing -> pure () VLeft e -> do lift $ $(logError) [i|Could not download (or verify hash) of #{dli}, Error was: #{e}|] diff --git a/ghcup.cabal b/ghcup.cabal index dcedc62..3caf05b 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -433,6 +433,8 @@ executable ghcup-gen , containers , haskus-utils-variant , hpath + , hpath-filepath + , libarchive , monad-logger , mtl , optics @@ -460,6 +462,11 @@ executable ghcup-gen hs-source-dirs: app/ghcup-gen default-language: Haskell2010 + if flag(tar) + import: + tar-bytestring + cpp-options: -DTAR + test-suite ghcup-test import: config diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 3a101b5..41a93d7 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-| @@ -577,6 +578,52 @@ unpackToDir dest av = do | otherwise -> throwE $ UnknownArchive fn +getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m) + => Path Abs -- ^ archive path + -> Excepts '[UnknownArchive +#if defined(TAR) + , Tar.FormatError +#else + , ArchiveResult +#endif + ] m [ByteString] +getArchiveFiles av = do + fn <- toFilePath <$> basename av + +#if defined(TAR) + let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [ByteString] + entries = + lE @Tar.FormatError + . Tar.foldEntries + (\e x -> fmap (Tar.entryPath e :) x) + (Right []) + (\e -> Left e) + . Tar.read + + rf :: MonadIO m => Path Abs -> Excepts '[Tar.FormatError] m BL.ByteString + rf = liftIO . readFile +#else + let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [ByteString] + entries = (fmap . fmap) (E.encodeUtf8 . T.pack . filepath) . lE . readArchiveBSL + + rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString + rf = liftIO . readFile +#endif + + -- extract, depending on file extension + if + | ".tar.gz" `B.isSuffixOf` fn -> liftE + (entries . GZip.decompress =<< rf av) + | ".tar.xz" `B.isSuffixOf` fn -> do + filecontents <- liftE $ rf av + let decompressed = Lzma.decompress filecontents + liftE $ entries decompressed + | ".tar.bz2" `B.isSuffixOf` fn -> + liftE (entries . BZip.decompress =<< rf av) + | ".tar" `B.isSuffixOf` fn -> liftE (entries =<< rf av) + | otherwise -> throwE $ UnknownArchive fn + + intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m) => Path Abs -- ^ unpacked tar dir -> TarDir -- ^ how to descend