File: Fix.hs

package info (click to toggle)
git-annex 10.20250416-2
  • links: PTS, VCS
  • area: main
  • in suites: trixie
  • size: 73,572 kB
  • sloc: haskell: 90,656; javascript: 9,103; sh: 1,469; makefile: 211; perl: 137; ansic: 44
file content (112 lines) | stat: -rw-r--r-- 3,392 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
{- git-annex command
 -
 - Copyright 2010-2015 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Command.Fix where

import Command
import Config
import qualified Annex
import Annex.ReplaceFile
import Annex.Content
import Annex.Perms
import Annex.Link
import qualified Database.Keys
import qualified Utility.RawFilePath as R

import System.PosixCompat.Files (fileMode, linkCount)
#if ! defined(mingw32_HOST_OS)
import qualified System.Posix.Files as Posix
import Utility.Touch
#endif

cmd :: Command
cmd = noCommit $ withAnnexOptions [annexedMatchingOptions, jsonOptions] $
	command "fix" SectionMaintenance
		"fix up links to annexed content"
		paramPaths (withParams seek)

seek :: CmdParams -> CommandSeek
seek ps = unlessM crippledFileSystem $
	withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
  where
	ww = WarnUnmatchLsFiles "fix"
	seeker = AnnexedFileSeeker
		{ startAction = const $ start FixAll
		, checkContentPresent = Nothing
		, usesLocationLog = False
		}

data FixWhat = FixSymlinks | FixAll

start :: FixWhat -> SeekInput -> OsPath -> Key -> CommandStart
start fixwhat si file key = do
	currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file'
	wantlink <- calcRepo $ gitAnnexLink file key
	case currlink of
		Just l
			| l /=  fromOsPath wantlink ->
				fixby $ fixSymlink file wantlink
			| otherwise -> stop
		Nothing -> case fixwhat of
			FixAll -> fixthin
			FixSymlinks -> stop
  where
	file' = fromOsPath file
	fixby = starting "fix" (mkActionItem (key, file)) si
	fixthin = do
		obj <- calcRepo (gitAnnexLocation key)
		stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do
			thin <- annexThin <$> Annex.getGitConfig
			fs <- liftIO $ catchMaybeIO $ R.getFileStatus file'
			os <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath obj)
			case (linkCount <$> fs, linkCount <$> os, thin) of
				(Just 1, Just 1, True) ->
					fixby $ makeHardLink file key
				(Just n, Just n', False) | n > 1 && n == n' ->
					fixby $ breakHardLink file key obj
				_ -> stop

breakHardLink :: OsPath -> Key -> OsPath -> CommandPerform
breakHardLink file key obj = do
	replaceWorkTreeFile file $ \tmp -> do
		mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file)
		unlessM (checkedCopyFile key obj tmp mode) $
			giveup "unable to break hard link"
		thawContent tmp
		Database.Keys.storeInodeCaches key [tmp]
		modifyContentDir obj $ freezeContent obj
	next $ return True

makeHardLink :: OsPath -> Key -> CommandPerform
makeHardLink file key = do
	replaceWorkTreeFile file $ \tmp -> do
		mode <- liftIO $ catchMaybeIO $ fileMode
			<$> R.getFileStatus (fromOsPath file)
		linkFromAnnex' key tmp mode >>= \case
			LinkAnnexFailed -> giveup "unable to make hard link"
			_ -> noop
	next $ return True

fixSymlink :: OsPath -> OsPath -> CommandPerform
fixSymlink file link = do
#if ! defined(mingw32_HOST_OS)
	-- preserve mtime of symlink
	mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes
		<$> R.getSymbolicLinkStatus (fromOsPath file)
#endif
	replaceWorkTreeFile file $ \tmpfile -> do
		let tmpfile' = fromOsPath tmpfile
		liftIO $ R.createSymbolicLink link' tmpfile'
#if ! defined(mingw32_HOST_OS)
		liftIO $ maybe noop (\t -> touch tmpfile' t False) mtime
#endif
	stageSymlink file =<< hashSymlink link'
	next $ return True
  where
	link' = fromOsPath link