hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Preserve mtime when merging filetrees

Browse Source
This commit is contained in:
Julian Ospald 2022-05-20 00:15:35 +02:00
parent 430b655785
commit d5efc86d85
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 12 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
ghcup.cabal
View File

@ -109,6 +109,7 @@ library
, deepseq ^>=1.4.4.0 , deepseq ^>=1.4.4.0
, directory ^>=1.3.6.0 , directory ^>=1.3.6.0
, disk-free-space ^>=0.1.0.1 , disk-free-space ^>=0.1.0.1
, exceptions ^>=0.10
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, haskus-utils-types ^>=1.5 , haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1 , haskus-utils-variant ^>=3.2.1

15
lib/GHCup.hs
View File

@ -329,9 +329,9 @@ installUnpackedGHC path inst ver forceInstall
-- to run configure. -- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg. -- We also must make sure to preserve mtime to not confuse ghc-pkg.
liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do
mtime <- getModificationTime source mtime <- ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source)
moveFilePortable source dest moveFilePortable source dest
setModificationTime dest mtime forM_ mtime $ setModificationTime dest
| otherwise = do | otherwise = do
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
@ -356,7 +356,11 @@ installUnpackedGHC path inst ver forceInstall
inst inst
GHC GHC
(mkTVer ver) (mkTVer ver)
(\f t -> liftIO $ install f t (not forceInstall)) (\f t -> liftIO $ do
mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
install f t (not forceInstall)
forM_ mtime $ setModificationTime t)
pure () pure ()
@ -672,7 +676,10 @@ installHLSUnpacked path inst ver forceInstall = do
inst inst
HLS HLS
(mkTVer ver) (mkTVer ver)
(\f t -> liftIO $ install f t (not forceInstall)) (\f t -> liftIO $ do
mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
install f t (not forceInstall)
forM_ mtime $ setModificationTime t)
-- | Install an unpacked hls distribution (legacy). -- | Install an unpacked hls distribution (legacy).
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)