From db4e411dfdcce87f2f793a8c6af860b5104de244 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 13 May 2022 11:58:01 +0200 Subject: [PATCH] Fix darwin binaries after copying --- lib/GHCup.hs | 8 ++++-- lib/GHCup/Utils.hs | 2 ++ lib/GHCup/Utils/File/Posix.hs | 45 ++++++++++++--------------------- lib/GHCup/Utils/File/Windows.hs | 1 + lib/GHCup/Utils/Prelude.hs | 18 ------------- 5 files changed, 25 insertions(+), 49 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index c8c6c4a..d6fae22 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -359,7 +359,8 @@ installUnpackedGHC path inst ver forceInstall lift $ logInfo $ "Merging file tree from \"" <> T.pack tmpInstallDest <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\"" fs <- mergeFileTreeAll (tmpInstallDest dropDrive (fromInstallDir inst)) (fromInstallDir inst) - (\f t -> liftIO $ install f t (not forceInstall)) + (\f t -> liftIO (install f t (not forceInstall))) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) case inst of IsolateDirResolved _ -> pure () _ -> recordInstalledFiles fs GHC (mkTVer ver) @@ -659,6 +660,7 @@ installHLSUnpacked :: ( MonadMask m , MonadCatch m , MonadIO m , MonadResource m + , HasPlatformReq env ) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) -> InstallDirResolved -- ^ Path to install to @@ -666,12 +668,14 @@ installHLSUnpacked :: ( MonadMask m -> Bool -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () installHLSUnpacked path inst ver forceInstall = do + PlatformRequest { .. } <- lift getPlatformReq lift $ logInfo "Installing HLS" tmpInstallDest <- lift withGHCupTmpDir lEM $ make ["DESTDIR=" <> tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) fs <- mergeFileTreeAll (tmpInstallDest dropDrive (fromInstallDir inst)) (fromInstallDir inst) - (\f t -> liftIO $ install f t (not forceInstall)) + (\f t -> liftIO (install f t (not forceInstall))) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst) case inst of IsolateDirResolved _ -> pure () _ -> recordInstalledFiles fs HLS (mkTVer ver) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 37f7444..4e31b09 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1033,6 +1033,8 @@ darwinNotarization Darwin path = exec darwinNotarization _ _ = pure $ Right () + + getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI getChangeLog dls tool (Left v') = preview (ix tool % ix v' % viChangeLog % _Just) dls diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 94c023b..24069a0 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {-| Module : GHCup.Utils.File.Posix @@ -418,41 +420,25 @@ copyFile :: FilePath -- ^ source file -> IO () copyFile from to fail' = do bracket - (do - fd <- openFd' from SPI.ReadOnly [FD.oNofollow] Nothing - handle' <- SPI.fdToHandle fd - pure (fd, handle') - ) - (\(_, handle') -> hClose handle') + (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing) + (hClose . snd) $ \(fromFd, fH) -> do - sourceFileMode <- fileMode - <$> getFdStatus fromFd - let dflags = - [ FD.oNofollow - , case fail' of - True -> FD.oExcl - False -> FD.oTrunc - ] - bracketeer - (do - fd <- openFd' to SPI.WriteOnly dflags $ Just sourceFileMode - handle' <- SPI.fdToHandle fd - pure (fd, handle') - ) - (\(_, handle') -> hClose handle') - (\(_, handle') -> do - hClose handle' - case fail' of - -- if we created the file and copying failed, it's - -- safe to clean up - True -> PF.removeLink to - False -> pure () - ) + sourceFileMode <- fileMode <$> getFdStatus fromFd + let dflags = [ FD.oNofollow + , if fail' then FD.oExcl else FD.oTrunc + ] + bracket + (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode) + (hClose . snd) $ \(_, tH) -> do hSetBinaryMode fH True hSetBinaryMode tH True streamlyCopy (fH, tH) where + openFdHandle fp omode flags fM = do + fd <- openFd' fp omode flags fM + handle' <- SPI.fdToHandle fd + pure (fd, handle') streamlyCopy (fH, tH) = S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH @@ -563,3 +549,4 @@ install from to fail' = do decide fs | PF.isRegularFile fs = copyFile from to fail' | PF.isSymbolicLink fs = recreateSymlink from to fail' | otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from) + diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index 4d70422..36f529f 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-| Module : GHCup.Utils.File.Windows diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 40ae60d..668fde2 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -759,21 +759,3 @@ breakOn :: Eq a => [a] -> [a] -> ([a], [a]) breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack) breakOn _ [] = ([], []) breakOn needle (x:xs) = first (x:) $ breakOn needle xs - - --- |Like `bracket`, but allows to have different clean-up --- actions depending on whether the in-between computation --- has raised an exception or not. -bracketeer :: IO a -- ^ computation to run first - -> (a -> IO b) -- ^ computation to run last, when - -- no exception was raised - -> (a -> IO b) -- ^ computation to run last, - -- when an exception was raised - -> (a -> IO c) -- ^ computation to run in-between - -> IO c -bracketeer before after afterEx thing = - mask $ \restore -> do - a <- before - r <- restore (thing a) `onException` afterEx a - _ <- after a - return r