1ceece3108By using System.Directory.OsPath, which takes and returns OsString, which is a ShortByteString. So, things like dirContents currently have the overhead of copying that to a ByteString, but that should be less than the overhead of using Strings which often in turn were converted to RawFilePaths. Added Utility.OsString and the OsString build flag. That flag is turned on in the stack.yaml, and will be turned on automatically by cabal when built with new enough libraries. The stack.yaml change is a bit ugly, and that could be reverted for now if it causes any problems. Note that Utility.OsString.toOsString on windows is avoiding only a check of encoding that is documented as being unlikely to fail. I don't think it can fail in git-annex; if it could, git-annex didn't contain such an encoding check before, so at worst that should be a wash.
76 lines
2.7 KiB
Haskell
76 lines
2.7 KiB
Haskell
{- git-annex tmp files
|
|
-
|
|
- Copyright 2019 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.Tmp where
|
|
|
|
import Annex.Common
|
|
import qualified Annex
|
|
import Annex.LockFile
|
|
import Annex.Perms
|
|
import Types.CleanupActions
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import Data.Time.Clock.POSIX
|
|
import System.PosixCompat.Files (modificationTime)
|
|
|
|
-- | For creation of tmp files, other than for key's contents.
|
|
--
|
|
-- The action should normally clean up whatever files it writes to the temp
|
|
-- directory that is passed to it. However, once the action is done,
|
|
-- any files left in that directory may be cleaned up by another process at
|
|
-- any time.
|
|
withOtherTmp :: (RawFilePath -> Annex a) -> Annex a
|
|
withOtherTmp a = do
|
|
Annex.addCleanupAction OtherTmpCleanup cleanupOtherTmp
|
|
tmpdir <- fromRepo gitAnnexTmpOtherDir
|
|
tmplck <- fromRepo gitAnnexTmpOtherLock
|
|
withSharedLock tmplck $ do
|
|
void $ createAnnexDirectory tmpdir
|
|
a tmpdir
|
|
|
|
-- | This uses an alternate temp directory. The action should normally
|
|
-- clean up whatever files it writes there, but if it leaves files
|
|
-- there (perhaps due to being interrupted), the files will be eventually
|
|
-- cleaned up by another git-annex process (after they're a week old).
|
|
--
|
|
-- Unlike withOtherTmp, this does not rely on locking working.
|
|
-- Its main use is in situations where the state of lockfile is not
|
|
-- determined yet, eg during initialization.
|
|
withEventuallyCleanedOtherTmp :: (RawFilePath -> Annex a) -> Annex a
|
|
withEventuallyCleanedOtherTmp = bracket setup cleanup
|
|
where
|
|
setup = do
|
|
tmpdir <- fromRepo gitAnnexTmpOtherDirOld
|
|
void $ createAnnexDirectory tmpdir
|
|
return tmpdir
|
|
cleanup = liftIO . void . tryIO . removeDirectory . fromRawFilePath
|
|
|
|
-- | Cleans up any tmp files that were left by a previous
|
|
-- git-annex process that got interrupted or failed to clean up after
|
|
-- itself for some other reason.
|
|
--
|
|
-- Does not do anything if withOtherTmp is running.
|
|
cleanupOtherTmp :: Annex ()
|
|
cleanupOtherTmp = do
|
|
tmplck <- fromRepo gitAnnexTmpOtherLock
|
|
void $ tryIO $ tryExclusiveLock tmplck $ do
|
|
tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
|
|
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
|
|
oldtmp <- fromRepo gitAnnexTmpOtherDirOld
|
|
liftIO $ mapM_ cleanold
|
|
=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
|
|
-- remove when empty
|
|
liftIO $ void $ tryIO $
|
|
removeDirectory (fromRawFilePath oldtmp)
|
|
where
|
|
cleanold f = do
|
|
now <- liftIO getPOSIXTime
|
|
let oldenough = now - (60 * 60 * 24 * 7)
|
|
catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus f) >>= \case
|
|
Just mtime | realToFrac mtime <= oldenough ->
|
|
void $ tryIO $ removeWhenExistsWith R.removeLink f
|
|
_ -> return ()
|