From adf44ba141b577baa494158f91942ca22294fa86 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Fri, 2 Apr 2021 16:54:27 +0200
Subject: [PATCH] Validate subdirs too, fixes #52

---
 app/ghcup-gen/Validate.hs | 55 +++++++++++++++++++++++++++++++++++----
 ghcup.cabal               |  7 +++++
 lib/GHCup/Utils.hs        | 47 +++++++++++++++++++++++++++++++++
 3 files changed, 104 insertions(+), 5 deletions(-)

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