Cooler patching

app/ghcup/GHCup/OptParse/Common.hs

@@ -208,8 +208,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
     ]
 
 
-bindistParser :: String -> Either String URI
+uriParser :: String -> Either String URI
-bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
+uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString
 
 
 absolutePathParser :: FilePath -> Either String FilePath

app/ghcup/GHCup/OptParse/Compile.hs

@@ -40,6 +40,7 @@ import           Prelude                 hiding ( appendFile )
 import           System.Exit
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
+import           URI.ByteString          hiding ( uriParser )
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
 import System.FilePath (isPathSeparator)
@@ -68,7 +69,7 @@ data GHCCompileOptions = GHCCompileOptions
   , bootstrapGhc :: Either Version FilePath
   , jobs         :: Maybe Int
   , buildConfig  :: Maybe FilePath
-  , patchDir     :: Maybe FilePath
+  , patches      :: Maybe (Either FilePath [URI])
   , crossTarget  :: Maybe Text
   , addConfArgs  :: [Text]
   , setCompile   :: Bool
@@ -84,9 +85,9 @@ data HLSCompileOptions = HLSCompileOptions
   , setCompile   :: Bool
   , ovewrwiteVer :: Maybe Version
   , isolateDir   :: Maybe FilePath
-  , cabalProject :: Maybe FilePath
+  , cabalProject :: Maybe (Either FilePath URI)
-  , cabalProjectLocal :: Maybe FilePath
+  , cabalProjectLocal :: Maybe URI
-  , patchDir     :: Maybe FilePath
+  , patches      :: Maybe (Either FilePath [URI])
   , targetGHCs   :: [ToolVersion]
   , cabalArgs    :: [Text]
   }
@@ -199,13 +200,23 @@ ghcCompileOpts =
               "Absolute path to build config file"
             )
           )
-    <*> optional
+    <*> (optional
-          (option
+          (
-            str
+            (fmap Right $ many $ option
-            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+              (eitherReader uriParser)
-              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+              (long "patch" <> metavar "PATCH_URI" <> help
+                "URI to a patch (https/http/file)"
+              )
+            )
+            <|>
+            (fmap Left $ option
+              str
+              (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+                "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+              )
             )
           )
+        )
     <*> optional
           (option
             str
@@ -300,25 +311,35 @@ hlsCompileOpts =
            )
     <*> optional
           (option
-            str
+            ((fmap Right $ eitherReader uriParser) <|> (fmap Left str))
             (long "cabal-project" <> metavar "CABAL_PROJECT" <> help
-              "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."
+              "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
             )
           )
     <*> optional
           (option
-            (eitherReader absolutePathParser)
+            (eitherReader uriParser)
             (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help
-              "Absolute path to a cabal.project.local to be used for the build. Will be copied over."
+              "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
             )
           )
-    <*> optional
+    <*> (optional
-          (option
+          (
-            (eitherReader absolutePathParser)
+            (fmap Right $ many $ option
-            (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+              (eitherReader uriParser)
-              "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+              (long "patch" <> metavar "PATCH_URI" <> help
+                "URI to a patch (https/http/file)"
+              )
+            )
+            <|>
+            (fmap Left $ option
+              str
+              (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
+                "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"
+              )
             )
           )
+        )
     <*> some (toolVersionOption Nothing (Just GHC))
     <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)"))
 
@@ -435,7 +456,7 @@ compile compileCommand settings runAppState runLogger = do
                     isolateDir
                     cabalProject
                     cabalProjectLocal
-                    patchDir
+                    patches
                     cabalArgs
         GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
         let vi = getVersionInfo targetVer HLS dls
@@ -483,7 +504,7 @@ compile compileCommand settings runAppState runLogger = do
                     bootstrapGhc
                     jobs
                     buildConfig
-                    patchDir
+                    patches
                     addConfArgs
                     buildFlavour
                     hadrian

app/ghcup/GHCup/OptParse/Install.hs

@@ -37,7 +37,7 @@ import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
-import           URI.ByteString
+import           URI.ByteString          hiding ( uriParser )
 
 import qualified Data.Text                     as T
 
@@ -187,7 +187,7 @@ installOpts tool =
     <*> (   (   (,)
             <$> optional
                   (option
-                    (eitherReader bindistParser)
+                    (eitherReader uriParser)
                     (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
                       "Install the specified version from this bindist"
                     )

cabal.project

@@ -12,12 +12,6 @@ constraints: http-io-streams -brotli,
              any.Cabal ==3.6.2.0,
              any.aeson >= 2.0.1.0
 
-source-repository-package
-    type: git
-    location: https://github.com/hasufell/packages.git
-    tag: cc0b4688f8bb374fa92f17c856949de795b56291
-    subdir: haskus-utils-variant
-
 package libarchive
   flags: -system-libarchive
 

lib/GHCup.hs

@@ -62,7 +62,7 @@ import           Data.String                    ( fromString )
 import           Data.Text                      ( Text )
 import           Data.Time.Clock
 import           Data.Time.Format.ISO8601
-import           Data.Versions
+import           Data.Versions                hiding ( patch )
 import           Distribution.Types.Version   hiding ( Version )
 import           Distribution.Types.PackageId
 import           Distribution.Types.PackageDescription
@@ -84,6 +84,7 @@ import           System.IO.Error
 import           System.IO.Temp
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
+import           URI.ByteString
 
 import qualified Crypto.Hash.SHA256            as SHA256
 import qualified Data.List.NonEmpty            as NE
@@ -750,9 +751,9 @@ compileHLS :: ( MonadMask m
            -> Maybe Int
            -> Maybe Version
            -> Maybe FilePath
-           -> Maybe FilePath
+           -> Maybe (Either FilePath URI)
-           -> Maybe FilePath
+           -> Maybe URI
-           -> Maybe FilePath
+           -> Maybe (Either FilePath [URI])  -- ^ patches
            -> [Text]                   -- ^ additional args to cabal install
            -> Excepts '[ NoDownload
                        , GPGError
@@ -764,7 +765,7 @@ compileHLS :: ( MonadMask m
                        , BuildFailed
                        , NotInstalled
                        ] m Version
-compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patchdir cabalArgs = do
+compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patches cabalArgs = do
   PlatformRequest { .. } <- lift getPlatformReq
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   Dirs { .. } <- lift getDirs
@@ -836,23 +837,30 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
   liftE $ runBuildAction
     workdir
     Nothing
-    (reThrowAll @_ @'[PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
+    (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
       let installDir = workdir </> "out"
       liftIO $ createDirRecursive' installDir
 
       -- apply patches
-      forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
+      liftE $ applyAnyPatch patches workdir
 
       -- set up project files
       cp <- case cabalProject of
-        Just cp
+        Just (Left cp)
           | isAbsolute cp -> do
               copyFileE cp (workdir </> "cabal.project")
               pure "cabal.project"
           | otherwise -> pure (takeFileName cp)
+        Just (Right uri) -> do
+          tmpUnpack <- lift withGHCupTmpDir
+          cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
+          copyFileE cp (workdir </> "cabal.project")
+          pure "cabal.project"
         Nothing -> pure "cabal.project"
-      forM_ cabalProjectLocal $ \cpl -> copyFileE cpl (workdir </> cp <.> "local")
+      forM_ cabalProjectLocal $ \uri -> do
-
+        tmpUnpack <- lift withGHCupTmpDir
+        cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
+        copyFileE cpl (workdir </> cp <.> "local")
       artifacts <- forM (sort ghcs) $ \ghc -> do
         let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)
         liftIO $ createDirRecursive' installDir
@@ -2088,7 +2096,7 @@ compileGHC :: ( MonadMask m
            -> Either Version FilePath  -- ^ version to bootstrap with
            -> Maybe Int                -- ^ jobs
            -> Maybe FilePath           -- ^ build config
-           -> Maybe FilePath           -- ^ patch directory
+           -> Maybe (Either FilePath [URI])  -- ^ patches
            -> [Text]                   -- ^ additional args to ./configure
            -> Maybe String             -- ^ build flavour
            -> Bool
@@ -2117,7 +2125,7 @@ compileGHC :: ( MonadMask m
                  ]
                 m
                 GHCTargetVersion
-compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir
+compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir
   = do
     PlatformRequest { .. } <- lift getPlatformReq
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -2141,7 +2149,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
         workdir <- maybe (pure tmpUnpack)
                          (liftE . intoSubdir tmpUnpack)
                          (view dlSubdir dlInfo)
-        forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
+        liftE $ applyAnyPatch patches workdir
 
         pure (workdir, tmpUnpack, tver)
 
@@ -2149,7 +2157,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
       Right GitBranch{..} -> do
         tmpUnpack <- lift mkGhcupTmpDir
         let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
-        tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH] DownloadFailed $ do
+        tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
           let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
           lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
           lEM $ git [ "init" ]
@@ -2169,7 +2177,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
 
           lEM $ git [ "checkout", "FETCH_HEAD" ]
           lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
-          forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack)
+          liftE $ applyAnyPatch patches tmpUnpack
           lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap"
           lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap"
           CapturedProcess {..} <- lift $ makeOut
@@ -2844,3 +2852,25 @@ rmTmp = do
     let p = tmpdir </> f
     logDebug $ "rm -rf " <> T.pack p
     rmPathForcibly p
+
+
+applyAnyPatch :: ( MonadReader env m
+                 , HasDirs env
+                 , HasLog env
+                 , HasSettings env
+                 , MonadUnliftIO m
+                 , MonadCatch m
+                 , MonadResource m
+                 , MonadThrow m
+                 , MonadMask m
+                 , MonadIO m)
+              => Maybe (Either FilePath [URI])
+              -> FilePath
+              -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
+applyAnyPatch Nothing _                   = pure ()
+applyAnyPatch (Just (Left pdir)) workdir  = liftE $ applyPatches pdir workdir
+applyAnyPatch (Just (Right uris)) workdir = do
+  tmpUnpack <- lift withGHCupTmpDir
+  forM_ uris $ \uri -> do
+    patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
+    liftE $ applyPatch patch workdir

lib/GHCup/Utils.hs

@@ -67,7 +67,7 @@ import           Data.List
 import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.Maybe
 import           Data.Text                      ( Text )
-import           Data.Versions
+import           Data.Versions         hiding   ( patch )
 import           GHC.IO.Exception
 import           Haskus.Utils.Variant.Excepts
 import           Optics
@@ -892,15 +892,22 @@ applyPatches pdir ddir = do
                      execBlank
                      ([s|.+\.(patch|diff)$|] :: ByteString)
       )
-  forM_ (sort patches) $ \patch' -> do
+  forM_ (sort patches) $ \patch' -> applyPatch patch' ddir
-    lift $ logInfo $ "Applying patch " <> T.pack patch'
+
-    fmap (either (const Nothing) Just)
+
-         (exec
+applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
-           "patch"
+           => FilePath   -- ^ Patch
-           ["-p1", "-i", patch']
+           -> FilePath   -- ^ dir to apply patches in
-           (Just ddir)
+           -> Excepts '[PatchFailed] m ()
-           Nothing)
+applyPatch patch ddir = do
-      !? PatchFailed
+  lift $ logInfo $ "Applying patch " <> T.pack patch
+  fmap (either (const Nothing) Just)
+       (exec
+         "patch"
+         ["-p1", "-s", "-f", "-i", patch]
+         (Just ddir)
+         Nothing)
+    !? PatchFailed
 
 
 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353