1{- git-annex low-level content functions
2 -
3 - Copyright 2010-2018 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE CPP #-}
9
10module Annex.Content.LowLevel where
11
12import Annex.Common
13import Logs.Transfer
14import qualified Annex
15import Utility.DiskFree
16import Utility.FileMode
17import Utility.DataUnits
18import Utility.CopyFile
19import qualified Utility.RawFilePath as R
20
21import qualified System.FilePath.ByteString as P
22
23{- Runs the secure erase command if set, otherwise does nothing.
24 - File may or may not be deleted at the end; caller is responsible for
25 - making sure it's deleted. -}
26secureErase :: RawFilePath -> Annex ()
27secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
28  where
29	go basecmd = void $ liftIO $
30		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
31	gencmd = massReplace [ ("%file", shellEscape (fromRawFilePath file)) ]
32
33data LinkedOrCopied = Linked | Copied
34
35{- Hard links or copies src to dest, which must not already exist.
36 -
37 - Only uses a hard link when annex.thin is enabled and when src is
38 - not already hardlinked to elsewhere.
39 -
40 - Checks disk reserve before copying against the size of the key,
41 - and will fail if not enough space, or if the dest file already exists.
42 -
43 - The FileMode, if provided, influences the mode of the dest file.
44 - In particular, if it has an execute bit set, the dest file's
45 - execute bit will be set. The mode is not fully copied over because
46 - git doesn't support file modes beyond execute.
47 -}
48linkOrCopy :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
49linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig)
50
51linkOrCopy' :: Annex Bool -> Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
52linkOrCopy' canhardlink key src dest destmode = catchDefaultIO Nothing $
53	ifM canhardlink
54		( hardlink
55		, copy =<< getstat
56		)
57  where
58	hardlink = do
59		s <- getstat
60		if linkCount s > 1
61			then copy s
62			else liftIO (R.createLink src dest >> preserveGitMode dest destmode >> return (Just Linked))
63				`catchIO` const (copy s)
64	copy s = ifM (checkedCopyFile' key src dest destmode s)
65		( return (Just Copied)
66		, return Nothing
67		)
68	getstat = liftIO $ R.getFileStatus src
69
70{- Checks disk space before copying. -}
71checkedCopyFile :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex Bool
72checkedCopyFile key src dest destmode = catchBoolIO $
73	checkedCopyFile' key src dest destmode
74		=<< liftIO (R.getFileStatus src)
75
76checkedCopyFile' :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> FileStatus -> Annex Bool
77checkedCopyFile' key src dest destmode s = catchBoolIO $ do
78	sz <- liftIO $ getFileSize' src s
79	ifM (checkDiskSpace' sz (Just $ P.takeDirectory dest) key 0 True)
80		( liftIO $
81			copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest)
82				<&&> preserveGitMode dest destmode
83		, return False
84		)
85
86preserveGitMode :: RawFilePath -> Maybe FileMode -> IO Bool
87preserveGitMode f (Just mode)
88	| isExecutable mode = catchBoolIO $ do
89		modifyFileMode f $ addModes executeModes
90		return True
91	| otherwise = catchBoolIO $ do
92		modifyFileMode f $ removeModes executeModes
93		return True
94preserveGitMode _ _ = return True
95
96{- Checks that there is disk space available to store a given key,
97 - in a destination directory (or the annex) printing a warning if not.
98 -
99 - If the destination is on the same filesystem as the annex,
100 - checks for any other running downloads, removing the amount of data still
101 - to be downloaded from the free space. This way, we avoid overcommitting
102 - when doing concurrent downloads.
103 -}
104checkDiskSpace :: Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool
105checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (fromKey keySize key)) destdir key
106
107{- Allows specifying the size of the key, if it's known, which is useful
108 - as not all keys know their size. -}
109checkDiskSpace' :: Integer -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool
110checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force)
111	( return True
112	, do
113		-- We can't get inprogress and free at the same
114		-- time, and both can be changing, so there's a
115		-- small race here. Err on the side of caution
116		-- by getting inprogress first, so if it takes
117		-- a while, we'll see any decrease in the free
118		-- disk space.
119		inprogress <- if samefilesystem
120			then sizeOfDownloadsInProgress (/= key)
121			else pure 0
122		dir >>= liftIO . getDiskFree . fromRawFilePath >>= \case
123			Just have -> do
124				reserve <- annexDiskReserve <$> Annex.getGitConfig
125				let delta = need + reserve - have - alreadythere + inprogress
126				let ok = delta <= 0
127				unless ok $
128					warning $ needMoreDiskSpace delta
129				return ok
130			_ -> return True
131	)
132  where
133	dir = maybe (fromRepo gitAnnexDir) return destdir
134
135needMoreDiskSpace :: Integer -> String
136needMoreDiskSpace n = "not enough free space, need " ++
137	roughSize storageUnits True n ++ " more" ++ forcemsg
138  where
139	forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
140