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