diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports, BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-} module Annex ( Annex, diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -1,6 +1,6 @@ {- adjusted branch - - - Copyright 2016-2018 Joey Hess + - Copyright 2016-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -57,11 +57,13 @@ import Annex.GitOverlay import Utility.Tmp.Dir import Utility.CopyFile +import Utility.Directory.Create import qualified Database.Keys import Config import qualified Data.Map as M import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P -- How to perform various adjustments to a TreeItem. class AdjustTreeItem t where @@ -110,11 +112,10 @@ adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem) adjustToSymlink = adjustToSymlink' gitAnnexLink -adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem) +adjustToSymlink' :: (RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath) -> TreeItem -> Annex (Maybe TreeItem) adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case Just k -> do - absf <- inRepo $ \r -> absPath $ - fromRawFilePath $ fromTopFilePath f r + absf <- inRepo $ \r -> absPath $ fromTopFilePath f r linktarget <- calcRepo $ gitannexlink absf k Just . TreeItem f (fromTreeItemType TreeSymlink) <$> hashSymlink linktarget @@ -295,7 +296,7 @@ where setup = do lck <- fromRepo $ indexFileLock . indexFile - liftIO $ Git.LockFile.openLock lck + liftIO $ Git.LockFile.openLock (fromRawFilePath lck) cleanup = liftIO . Git.LockFile.closeLock {- Commits a given adjusted tree, with the provided parent ref. @@ -376,23 +377,27 @@ - index file is currently locked.) -} changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do - git_dir <- fromRawFilePath <$> fromRepo Git.localGitDir + git_dir <- fromRepo Git.localGitDir + let git_dir' = fromRawFilePath git_dir tmpwt <- fromRepo gitAnnexMergeDir - withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ + withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) -- Copy in refs and packed-refs, to work -- around bug in git 2.13.0, which -- causes it not to look in GIT_DIR for refs. refs <- liftIO $ dirContentsRecursive $ - git_dir "refs" - let refs' = (git_dir "packed-refs") : refs + git_dir' "refs" + let refs' = (git_dir' "packed-refs") : refs liftIO $ forM_ refs' $ \src -> whenM (doesFileExist src) $ do - dest <- relPathDirToFile git_dir src - let dest' = tmpgit dest - createDirectoryUnder git_dir (takeDirectory dest') - void $ createLinkOrCopy src dest' + dest <- relPathDirToFile git_dir + (toRawFilePath src) + let dest' = toRawFilePath tmpgit P. dest + createDirectoryUnder git_dir + (P.takeDirectory dest') + void $ createLinkOrCopy src + (fromRawFilePath dest') -- This reset makes git merge not care -- that the work tree is empty; otherwise -- it will think that all the files have @@ -418,7 +423,7 @@ setup = do whenM (doesDirectoryExist d) $ removeDirectoryRecursive d - createDirectoryUnder git_dir d + createDirectoryUnder git_dir (toRawFilePath d) cleanup _ = removeDirectoryRecursive d {- A merge commit has been made between the basisbranch and diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -176,7 +176,7 @@ -- files, so delete here. unless inoverlay $ unless (islocked LsFiles.valUs) $ - liftIO $ nukeFile file + liftIO $ removeWhenExistsWith removeLink file | otherwise -> do -- Only resolve using symlink when both -- were locked, otherwise use unlocked @@ -230,7 +230,7 @@ | otherwise = pure f makesymlink key dest = do - l <- calcRepo $ gitAnnexLink dest key + l <- calcRepo $ gitAnnexLink (toRawFilePath dest) key unless inoverlay $ replacewithsymlink dest l dest' <- toRawFilePath <$> stagefile dest stageSymlink dest' =<< hashSymlink l @@ -241,7 +241,7 @@ makepointer key dest destmode = do unless inoverlay $ unlessM (reuseOldFile unstagedmap key file dest) $ - linkFromAnnex key dest destmode >>= \case + linkFromAnnex key (toRawFilePath dest) destmode >>= \case LinkAnnexFailed -> liftIO $ writePointerFile (toRawFilePath dest) key destmode _ -> noop @@ -267,7 +267,7 @@ Nothing -> noop Just sha -> do link <- catSymLinkTarget sha - replacewithsymlink item (fromRawFilePath link) + replacewithsymlink item link -- And when grafting in anything else vs a symlink, -- the work tree already contains what we want. (_, Just TreeSymlink) -> noop @@ -309,7 +309,7 @@ <$> mapM Database.Keys.getInodeCaches resolvedks forM_ (M.toList unstagedmap) $ \(i, f) -> whenM (matchesresolved is i f) $ - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f where fs = S.fromList resolvedfs ks = S.fromList resolvedks @@ -363,7 +363,7 @@ let f' = fromRawFilePath f if isSymbolicLink s then pure $ Just (Left f', f') - else withTSDelta (\d -> liftIO $ toInodeCache d f' s) + else withTSDelta (\d -> liftIO $ toInodeCache d f s) >>= return . \case Just i -> Just (Right (inodeCacheToKey Strongly i), f') Nothing -> Nothing diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -41,6 +41,7 @@ import Data.Char import Data.ByteString.Builder import Control.Concurrent (threadDelay) +import qualified System.FilePath.ByteString as P import Annex.Common import Types.BranchState @@ -76,6 +77,7 @@ import qualified Annex import Annex.Hook import Utility.Directory.Stream +import qualified Utility.RawFilePath as R {- Name of the branch that is used to store git-annex's information. -} name :: Git.Ref @@ -446,7 +448,7 @@ prepareModifyIndex :: JournalLocked -> Annex () prepareModifyIndex _jl = do index <- fromRepo gitAnnexIndex - void $ liftIO $ tryIO $ removeFile $ index ++ ".lock" + void $ liftIO $ tryIO $ R.removeLink (index <> ".lock") {- Runs an action using the branch's index file. -} withIndex :: Annex a -> Annex a @@ -455,7 +457,7 @@ withIndex' bootstrapping a = withIndexFile AnnexIndexFile $ \f -> do checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do unless bootstrapping create - createAnnexDirectory $ takeDirectory f + createAnnexDirectory $ toRawFilePath $ takeDirectory f unless bootstrapping $ inRepo genIndex a @@ -477,7 +479,7 @@ {- Checks if the index needs to be updated. -} needUpdateIndex :: Git.Ref -> Annex Bool needUpdateIndex branchref = do - f <- fromRepo gitAnnexIndexStatus + f <- fromRawFilePath <$> fromRepo gitAnnexIndexStatus committedref <- Git.Ref . firstLine' <$> liftIO (catchDefaultIO mempty $ B.readFile f) return (committedref /= branchref) @@ -506,19 +508,19 @@ prepareModifyIndex jl g <- gitRepo let dir = gitAnnexJournalDir g - (jlogf, jlogh) <- openjlog tmpdir + (jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir) h <- hashObjectHandle withJournalHandle $ \jh -> Git.UpdateIndex.streamUpdateIndex g [genstream dir h jh jlogh] commitindex - liftIO $ cleanup dir jlogh jlogf + liftIO $ cleanup (fromRawFilePath dir) jlogh jlogf where genstream dir h jh jlogh streamer = readDirectory jh >>= \case Nothing -> return () Just file -> do unless (dirCruft file) $ do - let path = dir file + let path = dir P. toRawFilePath file sha <- Git.HashObject.hashFile h path hPutStrLn jlogh file streamer $ Git.UpdateIndex.updateIndexLine @@ -533,7 +535,7 @@ stagedfs <- lines <$> hGetContents jlogh mapM_ (removeFile . (dir )) stagedfs hClose jlogh - nukeFile jlogf + removeWhenExistsWith removeLink jlogf openjlog tmpdir = liftIO $ openTempFile tmpdir "jlog" {- This is run after the refs have been merged into the index, @@ -666,7 +668,7 @@ S.fromList . mapMaybe Git.Sha.extractSha . B8.lines <$> content where content = do - f <- fromRepo gitAnnexIgnoredRefs + f <- fromRawFilePath <$> fromRepo gitAnnexIgnoredRefs liftIO $ catchDefaultIO mempty $ B.readFile f addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex () @@ -684,7 +686,7 @@ getMergedRefs' :: Annex [(Git.Sha, Git.Branch)] getMergedRefs' = do - f <- fromRepo gitAnnexMergedRefs + f <- fromRawFilePath <$> fromRepo gitAnnexMergedRefs s <- liftIO $ catchDefaultIO mempty $ B.readFile f return $ map parse $ B8.lines s where diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.ChangedRefs ( ChangedRefs(..) , ChangedRefsHandle @@ -17,6 +19,7 @@ import Annex.Common import Utility.DirWatcher import Utility.DirWatcher.Types +import Utility.Directory.Create import qualified Git import Git.Sha import qualified Utility.SimpleProtocol as Proto @@ -25,6 +28,7 @@ import Control.Concurrent.STM import Control.Concurrent.STM.TBMChan import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P newtype ChangedRefs = ChangedRefs [Git.Ref] deriving (Show) @@ -77,8 +81,8 @@ chan <- liftIO $ newTBMChanIO 100 g <- gitRepo - let gittop = fromRawFilePath (Git.localGitDir g) - let refdir = gittop "refs" + let gittop = Git.localGitDir g + let refdir = gittop P. "refs" liftIO $ createDirectoryUnder gittop refdir let notifyhook = Just $ notifyHook chan @@ -89,7 +93,9 @@ if canWatch then do - h <- liftIO $ watchDir refdir (const False) True hooks id + h <- liftIO $ watchDir + (fromRawFilePath refdir) + (const False) True hooks id return $ Just $ ChangedRefsHandle h chan else return Nothing diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs --- a/Annex/CheckAttr.hs +++ b/Annex/CheckAttr.hs @@ -26,7 +26,7 @@ , "annex.largefiles" ] -checkAttr :: Git.Attr -> FilePath -> Annex String +checkAttr :: Git.Attr -> RawFilePath -> Annex String checkAttr attr file = withCheckAttrHandle $ \h -> liftIO $ Git.checkAttr h attr file diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs --- a/Annex/CheckIgnore.hs +++ b/Annex/CheckIgnore.hs @@ -22,7 +22,7 @@ newtype CheckGitIgnore = CheckGitIgnore Bool -checkIgnored :: CheckGitIgnore -> FilePath -> Annex Bool +checkIgnored :: CheckGitIgnore -> RawFilePath -> Annex Bool checkIgnored (CheckGitIgnore False) _ = pure False checkIgnored (CheckGitIgnore True) file = ifM (Annex.getState Annex.force) diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -1,6 +1,6 @@ {- git-annex file content managing - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -131,8 +131,7 @@ {- A safer check; the key's content must not only be present, but - is not in the process of being removed. -} inAnnexSafe :: Key -> Annex (Maybe Bool) -inAnnexSafe key = - inAnnex' (fromMaybe True) (Just False) (go . fromRawFilePath) key +inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key where is_locked = Nothing is_unlocked = Just True @@ -145,7 +144,7 @@ {- The content file must exist, but the lock file generally - won't exist unless a removal is in process. -} checklock (Just lockfile) contentfile = - ifM (liftIO $ doesFileExist contentfile) + ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) ( checkOr is_unlocked lockfile , return is_missing ) @@ -154,7 +153,7 @@ Just True -> is_locked Just False -> is_unlocked #else - checklock Nothing contentfile = liftIO $ ifM (doesFileExist contentfile) + checklock Nothing contentfile = liftIO $ ifM (doesFileExist (fromRawFilePath contentfile)) ( lockShared contentfile >>= \case Nothing -> return is_locked Just lockhandle -> do @@ -165,13 +164,13 @@ {- In Windows, see if we can take a shared lock. If so, - remove the lock file to clean up after ourselves. -} checklock (Just lockfile) contentfile = - ifM (liftIO $ doesFileExist contentfile) + ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) ( modifyContent lockfile $ liftIO $ lockShared lockfile >>= \case Nothing -> return is_locked Just lockhandle -> do dropLock lockhandle - void $ tryIO $ nukeFile lockfile + void $ tryIO $ removeWhenExistsWith removeLink lockfile return is_unlocked , return is_missing ) @@ -180,7 +179,7 @@ {- Windows has to use a separate lock file from the content, since - locking the actual content file would interfere with the user's - use of it. -} -contentLockFile :: Key -> Annex (Maybe FilePath) +contentLockFile :: Key -> Annex (Maybe RawFilePath) #ifndef mingw32_HOST_OS contentLockFile _ = pure Nothing #else @@ -236,7 +235,7 @@ {- Passed the object content file, and maybe a separate lock file to use, - when the content file itself should not be locked. -} -type ContentLocker = FilePath -> Maybe LockFile -> Annex (Maybe LockHandle) +type ContentLocker = RawFilePath -> Maybe LockFile -> Annex (Maybe LockHandle) #ifndef mingw32_HOST_OS posixLocker :: (Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle) @@ -262,7 +261,7 @@ - the file that is locked eg on Windows a different file is locked. -} lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a -> Annex a lockContentUsing locker key fallback a = do - contentfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + contentfile <- calcRepo (gitAnnexLocation key) lockfile <- contentLockFile key bracket (lock contentfile lockfile) @@ -295,22 +294,22 @@ cleanuplockfile lockfile = modifyContent lockfile $ void $ liftIO $ tryIO $ - nukeFile lockfile + removeWhenExistsWith R.removeLink lockfile {- Runs an action, passing it the temp file to get, - and if the action succeeds, verifies the file matches - the key and moves the file into the annex as a key's content. -} -getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool getViaTmp rsp v key action = checkDiskSpaceToGet key False $ getViaTmpFromDisk rsp v key action {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk - and not being copied into place. -} -getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool getViaTmpFromDisk rsp v key action = checkallowed $ do tmpfile <- prepTmp key - resuming <- liftIO $ doesFileExist tmpfile + resuming <- liftIO $ R.doesPathExist tmpfile (ok, verification) <- action tmpfile -- When the temp file already had content, we don't know if -- that content is good or not, so only trust if it the action @@ -338,7 +337,8 @@ -- including perhaps the content of another -- file than the one that was requested, -- and so it's best not to keep it on disk. - pruneTmpWorkDirBefore tmpfile (liftIO . nukeFile) + pruneTmpWorkDirBefore tmpfile + (liftIO . removeWhenExistsWith R.removeLink) return False ) -- On transfer failure, the tmp file is left behind, in case @@ -371,7 +371,7 @@ - If the RetrievalSecurityPolicy requires verification and the key's - backend doesn't support it, the verification will fail. -} -verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> FilePath -> Annex Bool +verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool verifyKeyContent rsp v verification k f = case (rsp, verification) of (_, Verified) -> return True (RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k) @@ -432,9 +432,8 @@ -} checkDiskSpaceToGet :: Key -> a -> Annex a -> Annex a checkDiskSpaceToGet key unabletoget getkey = do - tmp <- fromRepo $ gitAnnexTmpObjectLocation key - - e <- liftIO $ doesFileExist tmp + tmp <- fromRepo (gitAnnexTmpObjectLocation key) + e <- liftIO $ doesFileExist (fromRawFilePath tmp) alreadythere <- liftIO $ if e then getFileSize tmp else return 0 @@ -446,7 +445,7 @@ , return unabletoget ) -prepTmp :: Key -> Annex FilePath +prepTmp :: Key -> Annex RawFilePath prepTmp key = do tmp <- fromRepo $ gitAnnexTmpObjectLocation key createAnnexDirectory (parentDir tmp) @@ -456,11 +455,11 @@ - the temp file. If the action throws an exception, the temp file is - left behind, which allows for resuming. -} -withTmp :: Key -> (FilePath -> Annex a) -> Annex a +withTmp :: Key -> (RawFilePath -> Annex a) -> Annex a withTmp key action = do tmp <- prepTmp key res <- action tmp - pruneTmpWorkDirBefore tmp (liftIO . nukeFile) + pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) return res {- Moves a key's content into .git/annex/objects/ @@ -491,7 +490,7 @@ - accepted into the repository. Will display a warning message in this - case. May also throw exceptions in some cases. -} -moveAnnex :: Key -> FilePath -> Annex Bool +moveAnnex :: Key -> RawFilePath -> Annex Bool moveAnnex key src = ifM (checkSecureHashes' key) ( do withObjectLoc key storeobject @@ -501,9 +500,11 @@ where storeobject dest = ifM (liftIO $ R.doesPathExist dest) ( alreadyhave - , modifyContent dest' $ do + , modifyContent dest $ do freezeContent src - liftIO $ moveFile src dest' + liftIO $ moveFile + (fromRawFilePath src) + (fromRawFilePath dest) g <- Annex.gitRepo fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key @@ -511,9 +512,7 @@ ics <- mapM (populatePointerFile (Restage True) key dest) fs Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) ) - where - dest' = fromRawFilePath dest - alreadyhave = liftIO $ removeFile src + alreadyhave = liftIO $ R.removeLink src checkSecureHashes :: Key -> Annex (Maybe String) checkSecureHashes key = ifM (Backend.isCryptographicallySecure key) @@ -535,20 +534,20 @@ {- Populates the annex object file by hard linking or copying a source - file to it. -} -linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult +linkToAnnex :: Key -> RawFilePath -> Maybe InodeCache -> Annex LinkAnnexResult linkToAnnex key src srcic = ifM (checkSecureHashes' key) ( do - dest <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + dest <- calcRepo (gitAnnexLocation key) modifyContent dest $ linkAnnex To key src srcic dest Nothing , return LinkAnnexFailed ) {- Makes a destination file be a link or copy from the annex object. -} -linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult +linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult linkFromAnnex key dest destmode = do src <- calcRepo (gitAnnexLocation key) srcic <- withTSDelta (liftIO . genInodeCache src) - linkAnnex From key (fromRawFilePath src) srcic dest destmode + linkAnnex From key src srcic dest destmode data FromTo = From | To @@ -564,10 +563,10 @@ - - Nothing is done if the destination file already exists. -} -linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult +linkAnnex :: FromTo -> Key -> RawFilePath -> Maybe InodeCache -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed linkAnnex fromto key src (Just srcic) dest destmode = - withTSDelta (liftIO . genInodeCache dest') >>= \case + withTSDelta (liftIO . genInodeCache dest) >>= \case Just destic -> do cs <- Database.Keys.getInodeCaches key if null cs @@ -584,27 +583,26 @@ Linked -> noop checksrcunchanged where - dest' = toRawFilePath dest failed = do Database.Keys.addInodeCaches key [srcic] return LinkAnnexFailed - checksrcunchanged = withTSDelta (liftIO . genInodeCache (toRawFilePath src)) >>= \case + checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case Just srcic' | compareStrong srcic srcic' -> do - destic <- withTSDelta (liftIO . genInodeCache dest') + destic <- withTSDelta (liftIO . genInodeCache dest) Database.Keys.addInodeCaches key $ catMaybes [destic, Just srcic] return LinkAnnexOk _ -> do - liftIO $ nukeFile dest + liftIO $ removeWhenExistsWith R.removeLink dest failed {- Removes the annex object file for a key. Lowlevel. -} unlinkAnnex :: Key -> Annex () unlinkAnnex key = do - obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + obj <- calcRepo (gitAnnexLocation key) modifyContent obj $ do secureErase obj - liftIO $ nukeFile obj + liftIO $ removeWhenExistsWith R.removeLink obj {- Runs an action to transfer an object's content. - @@ -656,7 +654,7 @@ cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do - file <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + file <- calcRepo (gitAnnexLocation key) void $ tryIO $ thawContentDir file cleaner liftIO $ removeparents file (3 :: Int) @@ -665,16 +663,15 @@ removeparents file n = do let dir = parentDir file maybe noop (const $ removeparents dir (n-1)) - <=< catchMaybeIO $ removeDirectory dir + <=< catchMaybeIO $ removeDirectory (fromRawFilePath dir) {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: ContentRemovalLock -> Annex () removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> cleanObjectLoc key $ do - let file' = fromRawFilePath file - secureErase file' - liftIO $ nukeFile file' + secureErase file + liftIO $ removeWhenExistsWith R.removeLink file g <- Annex.gitRepo mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) =<< Database.Keys.getAssociatedFiles key @@ -688,7 +685,7 @@ -- If it was a hard link to the annex object, -- that object might have been frozen as part of the -- removal process, so thaw it. - , void $ tryIO $ thawContent $ fromRawFilePath file + , void $ tryIO $ thawContent file ) {- Check if a file contains the unmodified content of the key. @@ -701,7 +698,7 @@ where go Nothing = return False go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc - expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key (fromRawFilePath f)) + expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f) ( do -- The file could have been modified while it was -- being verified. Detect that. @@ -736,14 +733,15 @@ - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath moveBad key = do - src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + src <- calcRepo (gitAnnexLocation key) bad <- fromRepo gitAnnexBadDir - let dest = bad takeFileName src + let dest = bad P. P.takeFileName src + let dest' = fromRawFilePath dest createAnnexDirectory (parentDir dest) cleanObjectLoc key $ - liftIO $ moveFile src dest + liftIO $ moveFile (fromRawFilePath src) dest' logStatus key InfoMissing - return dest + return dest' data KeyLocation = InAnnex | InAnywhere @@ -760,7 +758,7 @@ -} s <- Annex.getState id depth <- gitAnnexLocationDepth <$> Annex.getGitConfig - liftIO $ walk s depth dir + liftIO $ walk s depth (fromRawFilePath dir) where walk s depth dir = do contents <- catchDefaultIO [] (dirContents dir) @@ -825,7 +823,7 @@ go False = return False go True = do ok <- copy - when ok $ thawContent file + when ok $ thawContent (toRawFilePath file) return ok copy = ifM (liftIO $ doesFileExist file) ( return True @@ -839,9 +837,9 @@ {- Finds files directly inside a directory like gitAnnexBadDir - (not in subdirectories) and returns the corresponding keys. -} -dirKeys :: (Git.Repo -> FilePath) -> Annex [Key] +dirKeys :: (Git.Repo -> RawFilePath) -> Annex [Key] dirKeys dirspec = do - dir <- fromRepo dirspec + dir <- fromRawFilePath <$> fromRepo dirspec ifM (liftIO $ doesDirectoryExist dir) ( do contents <- liftIO $ getDirectoryContents dir @@ -857,7 +855,7 @@ - Also, stale keys that can be proven to have no value - (ie, their content is already present) are deleted. -} -staleKeysPrune :: (Git.Repo -> FilePath) -> Bool -> Annex [Key] +staleKeysPrune :: (Git.Repo -> RawFilePath) -> Bool -> Annex [Key] staleKeysPrune dirspec nottransferred = do contents <- dirKeys dirspec @@ -866,8 +864,8 @@ dir <- fromRepo dirspec forM_ dups $ \k -> - pruneTmpWorkDirBefore (dir fromRawFilePath (keyFile k)) - (liftIO . removeFile) + pruneTmpWorkDirBefore (dir P. keyFile k) + (liftIO . R.removeLink) if nottransferred then do @@ -882,9 +880,9 @@ - This preserves the invariant that the workdir never exists without - the content file. -} -pruneTmpWorkDirBefore :: FilePath -> (FilePath -> Annex a) -> Annex a +pruneTmpWorkDirBefore :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a pruneTmpWorkDirBefore f action = do - let workdir = gitAnnexTmpWorkDir f + let workdir = fromRawFilePath $ gitAnnexTmpWorkDir f liftIO $ whenM (doesDirectoryExist workdir) $ removeDirectoryRecursive workdir action f @@ -899,21 +897,22 @@ - the temporary work directory is retained (unless - empty), so anything in it can be used on resume. -} -withTmpWorkDir :: Key -> (FilePath -> Annex (Maybe a)) -> Annex (Maybe a) +withTmpWorkDir :: Key -> (RawFilePath -> Annex (Maybe a)) -> Annex (Maybe a) withTmpWorkDir key action = do -- Create the object file if it does not exist. This way, -- staleKeysPrune only has to look for object files, and can -- clean up gitAnnexTmpWorkDir for those it finds. obj <- prepTmp key - unlessM (liftIO $ doesFileExist obj) $ do - liftIO $ writeFile obj "" + let obj' = fromRawFilePath obj + unlessM (liftIO $ doesFileExist obj') $ do + liftIO $ writeFile obj' "" setAnnexFilePerm obj let tmpdir = gitAnnexTmpWorkDir obj createAnnexDirectory tmpdir res <- action tmpdir case res of - Just _ -> liftIO $ removeDirectoryRecursive tmpdir - Nothing -> liftIO $ void $ tryIO $ removeDirectory tmpdir + Just _ -> liftIO $ removeDirectoryRecursive (fromRawFilePath tmpdir) + Nothing -> liftIO $ void $ tryIO $ removeDirectory (fromRawFilePath tmpdir) return res {- Finds items in the first, smaller list, that are not diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -9,8 +9,6 @@ module Annex.Content.LowLevel where -import System.PosixCompat.Files - import Annex.Common import Logs.Transfer import qualified Annex @@ -18,16 +16,20 @@ import Utility.FileMode import Utility.DataUnits import Utility.CopyFile +import qualified Utility.RawFilePath as R +import System.PosixCompat.Files +import qualified System.FilePath.ByteString as P + {- Runs the secure erase command if set, otherwise does nothing. - File may or may not be deleted at the end; caller is responsible for - making sure it's deleted. -} -secureErase :: FilePath -> Annex () +secureErase :: RawFilePath -> Annex () secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig where go basecmd = void $ liftIO $ boolSystem "sh" [Param "-c", Param $ gencmd basecmd] - gencmd = massReplace [ ("%file", shellEscape file) ] + gencmd = massReplace [ ("%file", shellEscape (fromRawFilePath file)) ] data LinkedOrCopied = Linked | Copied @@ -44,10 +46,10 @@ - execute bit will be set. The mode is not fully copied over because - git doesn't support file modes beyond execute. -} -linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) +linkOrCopy :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig) -linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) +linkOrCopy' :: Annex Bool -> Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) linkOrCopy' canhardlink key src dest destmode = catchDefaultIO Nothing $ ifM canhardlink ( hardlink @@ -58,30 +60,30 @@ s <- getstat if linkCount s > 1 then copy s - else liftIO (createLink src dest >> preserveGitMode dest destmode >> return (Just Linked)) + else liftIO (R.createLink src dest >> preserveGitMode dest destmode >> return (Just Linked)) `catchIO` const (copy s) copy s = ifM (checkedCopyFile' key src dest destmode s) ( return (Just Copied) , return Nothing ) - getstat = liftIO $ getFileStatus src + getstat = liftIO $ R.getFileStatus src {- Checks disk space before copying. -} -checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool +checkedCopyFile :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex Bool checkedCopyFile key src dest destmode = catchBoolIO $ checkedCopyFile' key src dest destmode - =<< liftIO (getFileStatus src) + =<< liftIO (R.getFileStatus src) -checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool +checkedCopyFile' :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> FileStatus -> Annex Bool checkedCopyFile' key src dest destmode s = catchBoolIO $ - ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True) + ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ P.takeDirectory dest) key 0 True) ( liftIO $ - copyFileExternal CopyAllMetaData src dest + copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest) <&&> preserveGitMode dest destmode , return False ) -preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool +preserveGitMode :: RawFilePath -> Maybe FileMode -> IO Bool preserveGitMode f (Just mode) | isExecutable mode = catchBoolIO $ do modifyFileMode f $ addModes executeModes @@ -99,12 +101,12 @@ - to be downloaded from the free space. This way, we avoid overcommitting - when doing concurrent downloads. -} -checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace :: Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (fromKey keySize key)) destdir key {- Allows specifying the size of the key, if it's known, which is useful - as not all keys know their size. -} -checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace' :: Integer -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force) ( return True , do @@ -117,7 +119,7 @@ inprogress <- if samefilesystem then sizeOfDownloadsInProgress (/= key) else pure 0 - dir >>= liftIO . getDiskFree >>= \case + dir >>= liftIO . getDiskFree . fromRawFilePath >>= \case Just have -> do reserve <- annexDiskReserve <$> Annex.getGitConfig let delta = need + reserve - have - alreadythere + inprogress @@ -128,7 +130,7 @@ _ -> return True ) where - dir = maybe (fromRawFilePath <$> fromRepo gitAnnexDir) return destdir + dir = maybe (fromRepo gitAnnexDir) return destdir needMoreDiskSpace :: Integer -> String needMoreDiskSpace n = "not enough free space, need " ++ diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -25,6 +25,7 @@ #if ! defined(mingw32_HOST_OS) import Utility.Touch #endif +import qualified Utility.RawFilePath as R {- Populates a pointer file with the content of a key. - @@ -37,12 +38,12 @@ where go (Just k') | k == k' = do let f' = fromRawFilePath f - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' - liftIO $ nukeFile f' + destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f + liftIO $ removeWhenExistsWith R.removeLink f (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do let tmp' = toRawFilePath tmp - ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case - Just _ -> thawContent tmp >> return True + ok <- linkOrCopy k obj tmp' destmode >>= \case + Just _ -> thawContent tmp' >> return True Nothing -> liftIO (writePointerFile tmp' k destmode) >> return False ic <- withTSDelta (liftIO . genInodeCache tmp') return (ic, ok) @@ -60,15 +61,16 @@ let file' = fromRawFilePath file st <- liftIO $ catchMaybeIO $ getFileStatus file' let mode = fmap fileMode st - secureErase file' - liftIO $ nukeFile file' + secureErase file + liftIO $ removeWhenExistsWith R.removeLink file ic <- replaceWorkTreeFile file' $ \tmp -> do - liftIO $ writePointerFile (toRawFilePath tmp) key mode + let tmp' = toRawFilePath tmp + liftIO $ writePointerFile tmp' key mode #if ! defined(mingw32_HOST_OS) -- Don't advance mtime; this avoids unncessary re-smudging -- by git in some cases. liftIO $ maybe noop - (\t -> touch tmp t False) + (\t -> touch tmp' t False) (fmap modificationTimeHiRes st) #endif withTSDelta (liftIO . genInodeCache (toRawFilePath tmp)) diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -64,7 +64,7 @@ (untrusted, have) <- trustPartition UnTrusted locs numcopies <- if null fs then getNumCopies - else maximum <$> mapM (getFileNumCopies . fromRawFilePath) fs + else maximum <$> mapM getFileNumCopies fs return (NumCopies (length have), numcopies, S.fromList untrusted) {- Check that we have enough copies still to drop the content. diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -52,18 +52,19 @@ import Data.Either import qualified Data.Set as S -type GetFileMatcher = FilePath -> Annex (FileMatcher Annex) +type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex) -checkFileMatcher :: GetFileMatcher -> FilePath -> Annex Bool -checkFileMatcher getmatcher file = checkFileMatcher' getmatcher file (return True) +checkFileMatcher :: GetFileMatcher -> RawFilePath -> Annex Bool +checkFileMatcher getmatcher file = + checkFileMatcher' getmatcher file (return True) -- | Allows running an action when no matcher is configured for the file. -checkFileMatcher' :: GetFileMatcher -> FilePath -> Annex Bool -> Annex Bool +checkFileMatcher' :: GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool checkFileMatcher' getmatcher file notconfigured = do matcher <- getmatcher file checkMatcher matcher Nothing afile S.empty notconfigured d where - afile = AssociatedFile (Just (toRawFilePath file)) + afile = AssociatedFile (Just file) -- checkMatcher will never use this, because afile is provided. d = return True @@ -71,7 +72,7 @@ checkMatcher matcher mkey afile notpresent notconfigured d | isEmpty matcher = notconfigured | otherwise = case (mkey, afile) of - (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file + (Nothing, AssociatedFile (Just file)) -> go =<< fileMatchInfo file (Just key, _) -> go (MatchingKey key afile) _ -> d where diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -13,23 +13,23 @@ import Git.Config import Types.GitConfig import Utility.Path +import Utility.Path.AbsRel import Utility.SafeCommand import Utility.Directory import Utility.Exception import Utility.Monad import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R import Utility.PartialPrelude import System.IO -import System.FilePath -import System.PosixCompat.Files import Data.List import Data.Maybe import Control.Monad import Control.Monad.IfElse import qualified Data.Map as M -import qualified System.FilePath.ByteString as P import qualified Data.ByteString as S +import System.FilePath.ByteString import Control.Applicative import Prelude @@ -53,7 +53,7 @@ fixupDirect :: Repo -> Repo fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do r - { location = l { worktree = Just (toRawFilePath (parentDir (fromRawFilePath d))) } + { location = l { worktree = Just (parentDir d) } , gitGlobalOpts = gitGlobalOpts r ++ [ Param "-c" , Param $ fromConfigKey coreBare ++ "=" ++ boolConfig False @@ -108,13 +108,12 @@ , return r ) where - dotgit = w P. ".git" - dotgit' = fromRawFilePath dotgit + dotgit = w ".git" - replacedotgit = whenM (doesFileExist dotgit') $ do - linktarget <- relPathDirToFile (fromRawFilePath w) (fromRawFilePath d) - nukeFile dotgit' - createSymbolicLink linktarget dotgit' + replacedotgit = whenM (doesFileExist (fromRawFilePath dotgit)) $ do + linktarget <- relPathDirToFile w d + removeWhenExistsWith R.removeLink dotgit + R.createSymbolicLink linktarget dotgit unsetcoreworktree = maybe (error "unset core.worktree failed") (\_ -> return ()) @@ -124,13 +123,14 @@ -- git-worktree sets up a "commondir" file that contains -- the path to the main git directory. -- Using --separate-git-dir does not. - catchDefaultIO Nothing (headMaybe . lines <$> readFile (fromRawFilePath (d P. "commondir"))) >>= \case + catchDefaultIO Nothing (headMaybe . lines <$> readFile (fromRawFilePath (d "commondir"))) >>= \case Just gd -> do -- Make the worktree's git directory -- contain an annex symlink to the main -- repository's annex directory. - let linktarget = gd "annex" - createSymbolicLink linktarget (dotgit' "annex") + let linktarget = toRawFilePath gd "annex" + R.createSymbolicLink linktarget + (dotgit "annex") Nothing -> return () -- Repo adjusted, so that symlinks to objects that get checked @@ -143,7 +143,7 @@ needsSubmoduleFixup :: Repo -> Bool needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) = - (".git" P. "modules") `S.isInfixOf` d + (".git" "modules") `S.isInfixOf` d needsSubmoduleFixup _ = False needsGitLinkFixup :: Repo -> IO Bool @@ -151,6 +151,6 @@ -- Optimization: Avoid statting .git in the common case; only -- when the gitdir is not in the usual place inside the worktree -- might .git be a file. - | wt P. ".git" == d = return False - | otherwise = doesFileExist (fromRawFilePath (wt P. ".git")) + | wt ".git" == d = return False + | otherwise = doesFileExist (fromRawFilePath (wt ".git")) needsGitLinkFixup _ = return False diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -90,8 +90,8 @@ withWorkTreeRelated d a = withAltRepo modrepo unmodrepo (const a) where modrepo g = liftIO $ do - g' <- addGitEnv g "GIT_COMMON_DIR" - =<< absPath (fromRawFilePath (localGitDir g)) + g' <- addGitEnv g "GIT_COMMON_DIR" . fromRawFilePath + =<< absPath (localGitDir g) g'' <- addGitEnv g' "GIT_DIR" d return (g'' { gitEnvOverridesGitDir = True }, ()) unmodrepo g g' = g' diff --git a/Annex/HashObject.hs b/Annex/HashObject.hs --- a/Annex/HashObject.hs +++ b/Annex/HashObject.hs @@ -33,7 +33,7 @@ Annex.changeState $ \s -> s { Annex.hashobjecthandle = Nothing } return () -hashFile :: FilePath -> Annex Sha +hashFile :: RawFilePath -> Annex Sha hashFile f = do h <- hashObjectHandle liftIO $ Git.HashObject.hashFile h f diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -271,7 +271,7 @@ mktreeitem (loc, v) = case v of Right k -> do relf <- fromRepo $ fromTopFilePath topf - symlink <- calcRepo $ gitAnnexLink (fromRawFilePath relf) k + symlink <- calcRepo $ gitAnnexLink relf k linksha <- hashSymlink symlink return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha Left sha -> @@ -393,7 +393,7 @@ importordownload cidmap db (loc, (cid, sz)) largematcher= do f <- locworktreefile loc - matcher <- largematcher (fromRawFilePath f) + matcher <- largematcher f -- When importing a key is supported, always use it rather -- than downloading and retrieving a key, to avoid -- generating trees with different keys for the same content. @@ -457,7 +457,7 @@ let af = AssociatedFile (Just f) let downloader p' tmpfile = do k' <- Remote.retrieveExportWithContentIdentifier - ia loc cid tmpfile + ia loc cid (fromRawFilePath tmpfile) (pure k) (combineMeterUpdate p' p) ok <- moveAnnex k' tmpfile @@ -475,7 +475,7 @@ doimportsmall cidmap db loc cid sz p = do let downloader tmpfile = do k <- Remote.retrieveExportWithContentIdentifier - ia loc cid tmpfile + ia loc cid (fromRawFilePath tmpfile) (mkkey tmpfile) p case keyGitSha k of @@ -498,7 +498,7 @@ let af = AssociatedFile (Just f) let downloader tmpfile p = do k <- Remote.retrieveExportWithContentIdentifier - ia loc cid tmpfile + ia loc cid (fromRawFilePath tmpfile) (mkkey tmpfile) p case keyGitSha k of @@ -530,15 +530,15 @@ mkkey tmpfile = do let mi = MatchingFile FileInfo { matchFile = f - , contentFile = Just (toRawFilePath tmpfile) + , contentFile = Just tmpfile } islargefile <- checkMatcher' matcher mi mempty if islargefile then do - backend <- chooseBackend (fromRawFilePath f) + backend <- chooseBackend f let ks = KeySource { keyFilename = f - , contentLocation = toRawFilePath tmpfile + , contentLocation = tmpfile , inodeCache = Nothing } fst <$> genKey ks nullMeterUpdate backend @@ -671,7 +671,7 @@ notIgnoredImportLocation :: ImportTreeConfig -> CheckGitIgnore -> ImportLocation -> Annex Bool notIgnoredImportLocation importtreeconfig ci loc = not <$> checkIgnored ci f where - f = fromRawFilePath $ case importtreeconfig of + f = case importtreeconfig of ImportSubTree dir _ -> getTopFilePath dir P. fromImportLocation loc ImportTree -> diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -21,6 +21,7 @@ CheckGitIgnore(..), gitAddParams, addAnnexedFile, + addingExistingLink, ) where import Annex.Common @@ -61,7 +62,7 @@ data LockDownConfig = LockDownConfig { lockingFile :: Bool -- ^ write bit removed during lock down - , hardlinkFileTmpDir :: Maybe FilePath + , hardlinkFileTmpDir :: Maybe RawFilePath -- ^ hard link to temp directory } deriving (Show) @@ -98,7 +99,7 @@ nohardlink = withTSDelta $ liftIO . nohardlink' nohardlink' delta = do - cache <- genInodeCache (toRawFilePath file) delta + cache <- genInodeCache file' delta return $ LockedDown cfg $ KeySource { keyFilename = file' , contentLocation = file' @@ -107,12 +108,12 @@ withhardlink tmpdir = do when (lockingFile cfg) $ - freezeContent file + freezeContent file' withTSDelta $ \delta -> liftIO $ do - (tmpfile, h) <- openTempFile tmpdir $ + (tmpfile, h) <- openTempFile (fromRawFilePath tmpdir) $ relatedTemplate $ "ingest-" ++ takeFileName file hClose h - nukeFile tmpfile + removeWhenExistsWith removeLink tmpfile withhardlink' delta tmpfile `catchIO` const (nohardlink' delta) @@ -139,7 +140,7 @@ Just k -> do let f = keyFilename source if lockingFile cfg - then addLink ci (fromRawFilePath f) k mic + then addLink ci f k mic else do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (contentLocation source) @@ -157,14 +158,14 @@ k <- case mk of Nothing -> do backend <- maybe - (chooseBackend $ fromRawFilePath $ keyFilename source) + (chooseBackend $ keyFilename source) (return . Just) preferredbackend fst <$> genKey source meterupdate backend Just k -> return k let src = contentLocation source ms <- liftIO $ catchMaybeIO $ R.getFileStatus src - mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta (fromRawFilePath src)) ms + mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms case (mcache, inodeCache source) of (_, Nothing) -> go k mcache ms (Just newc, Just c) | compareStrong c newc -> go k mcache ms @@ -176,12 +177,12 @@ go _ _ Nothing = failure "failed to generate a key" golocked key mcache s = - tryNonAsync (moveAnnex key $ fromRawFilePath $ contentLocation source) >>= \case + tryNonAsync (moveAnnex key $ contentLocation source) >>= \case Right True -> do populateAssociatedFiles key source restage success key mcache s Right False -> giveup "failed to add content to annex" - Left e -> restoreFile (fromRawFilePath $ keyFilename source) key e + Left e -> restoreFile (keyFilename source) key e gounlocked key (Just cache) s = do -- Remove temp directory hard link first because @@ -189,7 +190,7 @@ -- already has a hard link. cleanCruft source cleanOldKeys (keyFilename source) key - linkToAnnex key (fromRawFilePath $ keyFilename source) (Just cache) >>= \case + linkToAnnex key (keyFilename source) (Just cache) >>= \case LinkAnnexFailed -> failure "failed to link to annex" _ -> do finishIngestUnlocked' key source restage @@ -229,7 +230,7 @@ cleanCruft :: KeySource -> Annex () cleanCruft source = when (contentLocation source /= keyFilename source) $ - liftIO $ nukeFile $ fromRawFilePath $ contentLocation source + liftIO $ removeWhenExistsWith R.removeLink $ contentLocation source -- If a worktree file was was hard linked to an annex object before, -- modifying the file would have caused the object to have the wrong @@ -254,28 +255,28 @@ -- so no need for any recovery. (f:_) -> do ic <- withTSDelta (liftIO . genInodeCache f) - void $ linkToAnnex key (fromRawFilePath f) ic + void $ linkToAnnex key f ic _ -> logStatus key InfoMissing {- On error, put the file back so it doesn't seem to have vanished. - This can be called before or after the symlink is in place. -} -restoreFile :: FilePath -> Key -> SomeException -> Annex a +restoreFile :: RawFilePath -> Key -> SomeException -> Annex a restoreFile file key e = do whenM (inAnnex key) $ do - liftIO $ nukeFile file + liftIO $ removeWhenExistsWith R.removeLink file -- The key could be used by other files too, so leave the -- content in the annex, and make a copy back to the file. obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) - unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $ - warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj + unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $ + warning $ "Unable to restore content of " ++ fromRawFilePath file ++ "; it should be located in " ++ obj thawContent file throwM e {- Creates the symlink to the annexed content, returns the link target. -} -makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex String +makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do l <- calcRepo $ gitAnnexLink file key - replaceWorkTreeFile file $ makeAnnexLink l . toRawFilePath + replaceWorkTreeFile file' $ makeAnnexLink l . toRawFilePath -- touch symlink to have same time as the original file, -- as provided in the InodeCache @@ -284,6 +285,8 @@ Nothing -> noop return l + where + file' = fromRawFilePath file {- Creates the symlink to the annexed content, and stages it in git. - @@ -294,15 +297,15 @@ - Also, using git add allows it to skip gitignored files, unless forced - to include them. -} -addLink :: CheckGitIgnore -> FilePath -> Key -> Maybe InodeCache -> Annex () +addLink :: CheckGitIgnore -> RawFilePath -> Key -> Maybe InodeCache -> Annex () addLink ci file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig) ( do _ <- makeLink file key mcache ps <- gitAddParams ci - Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] + Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file] , do l <- makeLink file key mcache - addAnnexLink l (toRawFilePath file) + addAnnexLink l file ) {- Parameters to pass to git add, forcing addition of ignored files. @@ -339,15 +342,15 @@ - - When the content of the key is not accepted into the annex, returns False. -} -addAnnexedFile :: CheckGitIgnore -> AddUnlockedMatcher -> FilePath -> Key -> Maybe FilePath -> Annex Bool +addAnnexedFile :: CheckGitIgnore -> AddUnlockedMatcher -> RawFilePath -> Key -> Maybe RawFilePath -> Annex Bool addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi) ( do mode <- maybe (pure Nothing) - (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp) + (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp) mtmp - stagePointerFile file' mode =<< hashPointerFile key - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file') + stagePointerFile file mode =<< hashPointerFile key + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) case mtmp of Just tmp -> ifM (moveAnnex key tmp) ( linkunlocked mode >> return True @@ -366,13 +369,13 @@ where mi = case mtmp of Just tmp -> MatchingFile $ FileInfo - { contentFile = Just (toRawFilePath tmp) - , matchFile = file' + { contentFile = Just tmp + , matchFile = file } -- Provide as much info as we can without access to the -- file's content. Nothing -> MatchingInfo $ ProvidedInfo - { providedFilePath = file' + { providedFilePath = file , providedKey = Just key , providedFileSize = fromMaybe 0 $ keySize `fromKey` key @@ -381,9 +384,23 @@ } linkunlocked mode = linkFromAnnex key file mode >>= \case - LinkAnnexFailed -> liftIO $ - writePointerFile file' key mode + LinkAnnexFailed -> liftIO $ writepointer mode _ -> return () - writepointer mode = liftIO $ writePointerFile file' key mode + + writepointer mode = liftIO $ writePointerFile file key mode - file' = toRawFilePath file +{- Use with actions that add an already existing annex symlink or pointer + - file. The warning avoids a confusing situation where the file got copied + - from another git-annex repo, probably by accident. -} +addingExistingLink :: RawFilePath -> Key -> Annex a -> Annex a +addingExistingLink f k a = do + unlessM (isKnownKey k <||> inAnnex k) $ do + islink <- isJust <$> isAnnexLink f + warning $ unwords + [ fromRawFilePath f + , "is a git-annex" + , if islink then "symlink." else "pointer file." + , "Its content is not available in this repository." + , "(Maybe " ++ fromRawFilePath f ++ " was copied from another repository?)" + ] + a diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -50,6 +50,7 @@ import Annex.Tmp import Utility.UserInfo import Utility.ThreadScheduler +import qualified Utility.RawFilePath as R #ifndef mingw32_HOST_OS import Annex.Perms import Utility.FileMode @@ -59,6 +60,7 @@ #endif import qualified Data.Map as M +import qualified System.FilePath.ByteString as P import Control.Concurrent.Async checkCanInitialize :: Annex a -> Annex a @@ -79,8 +81,8 @@ genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d genDescription Nothing = do - reldir <- liftIO . relHome - =<< liftIO . absPath . fromRawFilePath + reldir <- liftIO . relHome . fromRawFilePath + =<< liftIO . absPath =<< fromRepo Git.repoPath hostname <- fromMaybe "" <$> liftIO getHostname let at = if null hostname then "" else "@" @@ -194,24 +196,24 @@ mapM_ warning warnings return r -probeCrippledFileSystem' :: FilePath -> IO (Bool, [String]) +probeCrippledFileSystem' :: RawFilePath -> IO (Bool, [String]) #ifdef mingw32_HOST_OS probeCrippledFileSystem' _ = return (True, []) #else probeCrippledFileSystem' tmp = do - let f = tmp "gaprobe" + let f = fromRawFilePath (tmp P. "gaprobe") writeFile f "" r <- probe f - void $ tryIO $ allowWrite f + void $ tryIO $ allowWrite (toRawFilePath f) removeFile f return r where probe f = catchDefaultIO (True, []) $ do let f2 = f ++ "2" - nukeFile f2 + removeWhenExistsWith removeLink f2 createSymbolicLink f f2 - nukeFile f2 - preventWrite f + removeWhenExistsWith removeLink f2 + preventWrite (toRawFilePath f) -- Should be unable to write to the file, unless -- running as root, but some crippled -- filesystems ignore write bit removals. @@ -246,18 +248,18 @@ probeLockSupport = return True #else probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do - let f = tmp "lockprobe" + let f = tmp P. "lockprobe" mode <- annexFileMode liftIO $ withAsync warnstall (const (go f mode)) where go f mode = do - nukeFile f + removeWhenExistsWith R.removeLink f let locktest = bracket (Posix.lockExclusive (Just mode) f) Posix.dropLock (const noop) ok <- isRight <$> tryNonAsync locktest - nukeFile f + removeWhenExistsWith R.removeLink f return ok warnstall = do @@ -272,17 +274,17 @@ return False #else withEventuallyCleanedOtherTmp $ \tmp -> do - let f = tmp "gaprobe" - let f2 = tmp "gaprobe2" + let f = tmp P. "gaprobe" + let f2 = tmp P. "gaprobe2" liftIO $ do - nukeFile f - nukeFile f2 + removeWhenExistsWith R.removeLink f + removeWhenExistsWith R.removeLink f2 ms <- tryIO $ do - createNamedPipe f ownerReadMode - createLink f f2 - getFileStatus f - nukeFile f - nukeFile f2 + createNamedPipe (fromRawFilePath f) ownerReadMode + R.createLink f f2 + R.getFileStatus f + removeWhenExistsWith R.removeLink f + removeWhenExistsWith R.removeLink f2 return $ either (const False) isNamedPipe ms #endif diff --git a/Annex/InodeSentinal.hs b/Annex/InodeSentinal.hs --- a/Annex/InodeSentinal.hs +++ b/Annex/InodeSentinal.hs @@ -78,13 +78,14 @@ createInodeSentinalFile evenwithobjects = unlessM (alreadyexists <||> hasobjects) $ do s <- annexSentinalFile - createAnnexDirectory (parentDir (fromRawFilePath (sentinalFile s))) + createAnnexDirectory (parentDir (sentinalFile s)) liftIO $ writeSentinalFile s where alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile hasobjects | evenwithobjects = pure False - | otherwise = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir + | otherwise = liftIO . doesDirectoryExist . fromRawFilePath + =<< fromRepo gitAnnexObjectDir annexSentinalFile :: Annex SentinalFile annexSentinalFile = do diff --git a/Annex/Journal.hs b/Annex/Journal.hs --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -50,11 +50,11 @@ setJournalFile _jl file content = withOtherTmp $ \tmp -> do createAnnexDirectory =<< fromRepo gitAnnexJournalDir -- journal file is written atomically - jfile <- fromRawFilePath <$> fromRepo (journalFile file) - let tmpfile = tmp takeFileName jfile + jfile <- fromRepo (journalFile file) + let tmpfile = fromRawFilePath (tmp P. P.takeFileName jfile) liftIO $ do withFile tmpfile WriteMode $ \h -> writeJournalHandle h content - moveFile tmpfile jfile + moveFile tmpfile (fromRawFilePath jfile) {- Gets any journalled content for a file in the branch. -} getJournalFile :: JournalLocked -> RawFilePath -> Annex (Maybe L.ByteString) @@ -82,19 +82,19 @@ getJournalledFilesStale = do g <- gitRepo fs <- liftIO $ catchDefaultIO [] $ - getDirectoryContents $ gitAnnexJournalDir g + getDirectoryContents $ fromRawFilePath $ gitAnnexJournalDir g return $ filter (`notElem` [".", ".."]) $ map (fromRawFilePath . fileJournal . toRawFilePath) fs withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a withJournalHandle a = do - d <- fromRepo gitAnnexJournalDir + d <- fromRawFilePath <$> fromRepo gitAnnexJournalDir bracketIO (openDirectory d) closeDirectory (liftIO . a) {- Checks if there are changes in the journal. -} journalDirty :: Annex Bool journalDirty = do - d <- fromRepo gitAnnexJournalDir + d <- fromRawFilePath <$> fromRepo gitAnnexJournalDir liftIO $ (not <$> isDirectoryEmpty d) `catchIO` (const $ doesDirectoryExist d) diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -42,7 +42,7 @@ import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P -type LinkTarget = String +type LinkTarget = S.ByteString {- Checks if a file is a link to a key. -} isAnnexLink :: RawFilePath -> Annex (Maybe Key) @@ -56,7 +56,7 @@ - Returns Nothing if the file is not a symlink, or not a link to annex - content. -} -getAnnexLinkTarget :: RawFilePath -> Annex (Maybe S.ByteString) +getAnnexLinkTarget :: RawFilePath -> Annex (Maybe LinkTarget) getAnnexLinkTarget f = getAnnexLinkTarget' f =<< (coreSymlinks <$> Annex.getGitConfig) @@ -107,9 +107,9 @@ makeGitLink :: LinkTarget -> RawFilePath -> Annex () makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) ( liftIO $ do - void $ tryIO $ removeFile (fromRawFilePath file) - createSymbolicLink linktarget (fromRawFilePath file) - , liftIO $ writeFile (fromRawFilePath file) linktarget + void $ tryIO $ R.removeLink file + R.createSymbolicLink linktarget file + , liftIO $ S.writeFile (fromRawFilePath file) linktarget ) {- Creates a link on disk, and additionally stages it in git. -} @@ -120,13 +120,13 @@ {- Injects a symlink target into git, returning its Sha. -} hashSymlink :: LinkTarget -> Annex Sha -hashSymlink = hashBlob . toInternalGitPath . toRawFilePath +hashSymlink = hashBlob . toInternalGitPath {- Stages a symlink to an annexed object, using a Sha of its target. -} stageSymlink :: RawFilePath -> Sha -> Annex () stageSymlink file sha = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageSymlink (fromRawFilePath file) sha) + inRepo (Git.UpdateIndex.stageSymlink file sha) {- Injects a pointer file content into git, returning its Sha. -} hashPointerFile :: Key -> Annex Sha @@ -187,7 +187,7 @@ -- update-index is documented as picky about "./file" and it -- fails on "../../repo/path/file" when cwd is not in the repo -- being acted on. Avoid these problems with an absolute path. - absf <- liftIO $ absPath $ fromRawFilePath f + absf <- liftIO $ absPath f Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)] where isunmodified tsd = genInodeCache f tsd >>= return . \case @@ -203,7 +203,7 @@ runner :: Git.Queue.InternalActionRunner Annex runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do realindex <- liftIO $ Git.Index.currentIndexFile r - let lock = Git.Index.indexFileLock realindex + let lock = fromRawFilePath (Git.Index.indexFileLock realindex) lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock unlockindex = liftIO . maybe noop Git.LockFile.closeLock showwarning = warning $ unableToRestage Nothing @@ -211,8 +211,8 @@ go (Just _) = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" $ \tmpdir -> do let tmpindex = tmpdir "index" let updatetmpindex = do - r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv - =<< Git.Index.indexEnvVal tmpindex + r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv + =<< Git.Index.indexEnvVal (toRawFilePath tmpindex) -- Avoid git warning about CRLF munging. let r'' = r' { gitGlobalOpts = gitGlobalOpts r' ++ [ Param "-c" @@ -224,9 +224,9 @@ whenM checkunmodified $ feed f' let replaceindex = catchBoolIO $ do - moveFile tmpindex realindex + moveFile tmpindex (fromRawFilePath realindex) return True - ok <- liftIO (createLinkOrCopy realindex tmpindex) + ok <- liftIO (createLinkOrCopy (fromRawFilePath realindex) tmpindex) <&&> updatetmpindex <&&> liftIO replaceindex unless ok showwarning diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -1,6 +1,6 @@ {- git-annex file locations - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,8 +20,6 @@ gitAnnexLink, gitAnnexLinkCanonical, gitAnnexContentLock, - gitAnnexMapping, - gitAnnexInodeCache, gitAnnexInodeSentinal, gitAnnexInodeSentinalCache, annexLocations, @@ -68,7 +66,6 @@ gitAnnexJournalDir', gitAnnexJournalLock, gitAnnexGitQueueLock, - gitAnnexMergeLock, gitAnnexIndex, gitAnnexIndexStatus, gitAnnexViewIndex, @@ -161,9 +158,6 @@ - - When the file is not present, returns the location where the file should - be stored. - - - - This does not take direct mode into account, so in direct mode it is not - - the actual location of the file's content. -} gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO RawFilePath gitAnnexLocation key r config = gitAnnexLocation' key r config @@ -199,32 +193,27 @@ check [] = error "internal" {- Calculates a symlink target to link a file to an annexed object. -} -gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath +gitAnnexLink :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath gitAnnexLink file key r config = do - currdir <- getCurrentDirectory + currdir <- R.getCurrentDirectory let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir - fromRawFilePath . toInternalGitPath . toRawFilePath - <$> relPathDirToFile (parentDir absfile) (fromRawFilePath loc) + toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc where getgitdir currdir {- This special case is for git submodules on filesystems not - supporting symlinks; generate link target that will - work portably. -} | not (coreSymlinks config) && needsSubmoduleFixup r = - toRawFilePath $ - absNormPathUnix currdir $ fromRawFilePath $ - Git.repoPath r P. ".git" + absNormPathUnix currdir (Git.repoPath r P. ".git") | otherwise = Git.localGitDir r - absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $ - absPathFrom - (fromRawFilePath $ toInternalGitPath $ toRawFilePath d) - (fromRawFilePath $ toInternalGitPath $ toRawFilePath p) + absNormPathUnix d p = toInternalGitPath $ + absPathFrom (toInternalGitPath d) (toInternalGitPath p) {- Calculates a symlink target as would be used in a typical git - repository, with .git in the top of the work tree. -} -gitAnnexLinkCanonical :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath +gitAnnexLinkCanonical :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config' where r' = case r of @@ -237,25 +226,10 @@ } {- File used to lock a key's content. -} -gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath +gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO RawFilePath gitAnnexContentLock key r config = do loc <- gitAnnexLocation key r config - return $ fromRawFilePath loc ++ ".lck" - -{- File that maps from a key to the file(s) in the git repository. - - Used in direct mode. -} -gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath -gitAnnexMapping key r config = do - loc <- gitAnnexLocation key r config - return $ fromRawFilePath loc ++ ".map" - -{- File that caches information about a key's content, used to determine - - if a file has changed. - - Used in direct mode. -} -gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath -gitAnnexInodeCache key r config = do - loc <- gitAnnexLocation key r config - return $ fromRawFilePath loc ++ ".cache" + return $ loc <> ".lck" gitAnnexInodeSentinal :: Git.Repo -> RawFilePath gitAnnexInodeSentinal r = gitAnnexDir r P. "sentinal" @@ -268,41 +242,38 @@ gitAnnexDir r = P.addTrailingPathSeparator $ Git.localGitDir r P. annexDir {- The part of the annex directory where file contents are stored. -} -gitAnnexObjectDir :: Git.Repo -> FilePath -gitAnnexObjectDir r = fromRawFilePath $ - P.addTrailingPathSeparator $ Git.localGitDir r P. objectDir' +gitAnnexObjectDir :: Git.Repo -> RawFilePath +gitAnnexObjectDir r = P.addTrailingPathSeparator $ + Git.localGitDir r P. objectDir' {- .git/annex/tmp/ is used for temp files for key's contents -} -gitAnnexTmpObjectDir :: Git.Repo -> FilePath -gitAnnexTmpObjectDir = fromRawFilePath . gitAnnexTmpObjectDir' - -gitAnnexTmpObjectDir' :: Git.Repo -> RawFilePath -gitAnnexTmpObjectDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P. "tmp" +gitAnnexTmpObjectDir :: Git.Repo -> RawFilePath +gitAnnexTmpObjectDir r = P.addTrailingPathSeparator $ + gitAnnexDir r P. "tmp" {- .git/annex/othertmp/ is used for other temp files -} -gitAnnexTmpOtherDir :: Git.Repo -> FilePath -gitAnnexTmpOtherDir r = fromRawFilePath $ - P.addTrailingPathSeparator $ gitAnnexDir r P. "othertmp" +gitAnnexTmpOtherDir :: Git.Repo -> RawFilePath +gitAnnexTmpOtherDir r = P.addTrailingPathSeparator $ + gitAnnexDir r P. "othertmp" {- Lock file for gitAnnexTmpOtherDir. -} -gitAnnexTmpOtherLock :: Git.Repo -> FilePath -gitAnnexTmpOtherLock r = fromRawFilePath $ gitAnnexDir r P. "othertmp.lck" +gitAnnexTmpOtherLock :: Git.Repo -> RawFilePath +gitAnnexTmpOtherLock r = gitAnnexDir r P. "othertmp.lck" {- .git/annex/misctmp/ was used by old versions of git-annex and is still - used during initialization -} -gitAnnexTmpOtherDirOld :: Git.Repo -> FilePath -gitAnnexTmpOtherDirOld r = fromRawFilePath $ - P.addTrailingPathSeparator $ gitAnnexDir r P. "misctmp" +gitAnnexTmpOtherDirOld :: Git.Repo -> RawFilePath +gitAnnexTmpOtherDirOld r = P.addTrailingPathSeparator $ + gitAnnexDir r P. "misctmp" {- .git/annex/watchtmp/ is used by the watcher and assistant -} -gitAnnexTmpWatcherDir :: Git.Repo -> FilePath -gitAnnexTmpWatcherDir r = fromRawFilePath $ - P.addTrailingPathSeparator $ gitAnnexDir r P. "watchtmp" +gitAnnexTmpWatcherDir :: Git.Repo -> RawFilePath +gitAnnexTmpWatcherDir r = P.addTrailingPathSeparator $ + gitAnnexDir r P. "watchtmp" {- The temp file to use for a given key's content. -} -gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath -gitAnnexTmpObjectLocation key r = fromRawFilePath $ - gitAnnexTmpObjectDir' r P. keyFile key +gitAnnexTmpObjectLocation :: Key -> Git.Repo -> RawFilePath +gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r P. keyFile key {- Given a temp file such as gitAnnexTmpObjectLocation, makes a name for a - subdirectory in the same location, that can be used as a work area @@ -311,127 +282,122 @@ - There are ordering requirements for creating these directories; - use Annex.Content.withTmpWorkDir to set them up. -} -gitAnnexTmpWorkDir :: FilePath -> FilePath +gitAnnexTmpWorkDir :: RawFilePath -> RawFilePath gitAnnexTmpWorkDir p = - let (dir, f) = splitFileName p + let (dir, f) = P.splitFileName p -- Using a prefix avoids name conflict with any other keys. - in dir "work." ++ f + in dir P. "work." <> f {- .git/annex/bad/ is used for bad files found during fsck -} -gitAnnexBadDir :: Git.Repo -> FilePath -gitAnnexBadDir r = fromRawFilePath $ - P.addTrailingPathSeparator $ gitAnnexDir r P. "bad" +gitAnnexBadDir :: Git.Repo -> RawFilePath +gitAnnexBadDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "bad" {- The bad file to use for a given key. -} -gitAnnexBadLocation :: Key -> Git.Repo -> FilePath -gitAnnexBadLocation key r = gitAnnexBadDir r fromRawFilePath (keyFile key) +gitAnnexBadLocation :: Key -> Git.Repo -> RawFilePath +gitAnnexBadLocation key r = gitAnnexBadDir r P. keyFile key {- .git/annex/foounused is used to number possibly unused keys -} -gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath -gitAnnexUnusedLog prefix r = - fromRawFilePath (gitAnnexDir r) (prefix ++ "unused") +gitAnnexUnusedLog :: RawFilePath -> Git.Repo -> RawFilePath +gitAnnexUnusedLog prefix r = gitAnnexDir r P. (prefix <> "unused") {- .git/annex/keysdb/ contains a database of information about keys. -} -gitAnnexKeysDb :: Git.Repo -> FilePath -gitAnnexKeysDb r = fromRawFilePath $ gitAnnexDir r P. "keysdb" +gitAnnexKeysDb :: Git.Repo -> RawFilePath +gitAnnexKeysDb r = gitAnnexDir r P. "keysdb" {- Lock file for the keys database. -} -gitAnnexKeysDbLock :: Git.Repo -> FilePath -gitAnnexKeysDbLock r = gitAnnexKeysDb r ++ ".lck" +gitAnnexKeysDbLock :: Git.Repo -> RawFilePath +gitAnnexKeysDbLock r = gitAnnexKeysDb r <> ".lck" {- Contains the stat of the last index file that was - reconciled with the keys database. -} -gitAnnexKeysDbIndexCache :: Git.Repo -> FilePath -gitAnnexKeysDbIndexCache r = gitAnnexKeysDb r ++ ".cache" +gitAnnexKeysDbIndexCache :: Git.Repo -> RawFilePath +gitAnnexKeysDbIndexCache r = gitAnnexKeysDb r <> ".cache" {- .git/annex/fsck/uuid/ is used to store information about incremental - fscks. -} -gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath -gitAnnexFsckDir u r = fromRawFilePath $ - gitAnnexDir r P. "fsck" P. fromUUID u +gitAnnexFsckDir :: UUID -> Git.Repo -> RawFilePath +gitAnnexFsckDir u r = gitAnnexDir r P. "fsck" P. fromUUID u {- used to store information about incremental fscks. -} -gitAnnexFsckState :: UUID -> Git.Repo -> FilePath -gitAnnexFsckState u r = gitAnnexFsckDir u r "state" +gitAnnexFsckState :: UUID -> Git.Repo -> RawFilePath +gitAnnexFsckState u r = gitAnnexFsckDir u r P. "state" {- Directory containing database used to record fsck info. -} -gitAnnexFsckDbDir :: UUID -> Git.Repo -> FilePath -gitAnnexFsckDbDir u r = gitAnnexFsckDir u r "fsckdb" +gitAnnexFsckDbDir :: UUID -> Git.Repo -> RawFilePath +gitAnnexFsckDbDir u r = gitAnnexFsckDir u r P. "fsckdb" {- Directory containing old database used to record fsck info. -} -gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> FilePath -gitAnnexFsckDbDirOld u r = gitAnnexFsckDir u r "db" +gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> RawFilePath +gitAnnexFsckDbDirOld u r = gitAnnexFsckDir u r P. "db" {- Lock file for the fsck database. -} -gitAnnexFsckDbLock :: UUID -> Git.Repo -> FilePath -gitAnnexFsckDbLock u r = gitAnnexFsckDir u r "fsck.lck" +gitAnnexFsckDbLock :: UUID -> Git.Repo -> RawFilePath +gitAnnexFsckDbLock u r = gitAnnexFsckDir u r P. "fsck.lck" {- .git/annex/fsckresults/uuid is used to store results of git fscks -} -gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath -gitAnnexFsckResultsLog u r = fromRawFilePath $ +gitAnnexFsckResultsLog :: UUID -> Git.Repo -> RawFilePath +gitAnnexFsckResultsLog u r = gitAnnexDir r P. "fsckresults" P. fromUUID u {- .git/annex/smudge.log is used to log smudges worktree files that need to - be updated. -} -gitAnnexSmudgeLog :: Git.Repo -> FilePath -gitAnnexSmudgeLog r = fromRawFilePath $ gitAnnexDir r P. "smudge.log" +gitAnnexSmudgeLog :: Git.Repo -> RawFilePath +gitAnnexSmudgeLog r = gitAnnexDir r P. "smudge.log" -gitAnnexSmudgeLock :: Git.Repo -> FilePath -gitAnnexSmudgeLock r = fromRawFilePath $ gitAnnexDir r P. "smudge.lck" +gitAnnexSmudgeLock :: Git.Repo -> RawFilePath +gitAnnexSmudgeLock r = gitAnnexDir r P. "smudge.lck" {- .git/annex/move.log is used to log moves that are in progress, - to better support resuming an interrupted move. -} -gitAnnexMoveLog :: Git.Repo -> FilePath -gitAnnexMoveLog r = fromRawFilePath $ gitAnnexDir r P. "move.log" +gitAnnexMoveLog :: Git.Repo -> RawFilePath +gitAnnexMoveLog r = gitAnnexDir r P. "move.log" -gitAnnexMoveLock :: Git.Repo -> FilePath -gitAnnexMoveLock r = fromRawFilePath $ gitAnnexDir r P. "move.lck" +gitAnnexMoveLock :: Git.Repo -> RawFilePath +gitAnnexMoveLock r = gitAnnexDir r P. "move.lck" {- .git/annex/export/ is used to store information about - exports to special remotes. -} -gitAnnexExportDir :: Git.Repo -> FilePath -gitAnnexExportDir r = fromRawFilePath $ gitAnnexDir r P. "export" +gitAnnexExportDir :: Git.Repo -> RawFilePath +gitAnnexExportDir r = gitAnnexDir r P. "export" {- Directory containing database used to record export info. -} -gitAnnexExportDbDir :: UUID -> Git.Repo -> FilePath -gitAnnexExportDbDir u r = gitAnnexExportDir r fromUUID u "exportdb" +gitAnnexExportDbDir :: UUID -> Git.Repo -> RawFilePath +gitAnnexExportDbDir u r = gitAnnexExportDir r P. fromUUID u P. "exportdb" {- Lock file for export state for a special remote. -} -gitAnnexExportLock :: UUID -> Git.Repo -> FilePath -gitAnnexExportLock u r = gitAnnexExportDbDir u r ++ ".lck" +gitAnnexExportLock :: UUID -> Git.Repo -> RawFilePath +gitAnnexExportLock u r = gitAnnexExportDbDir u r <> ".lck" {- Lock file for updating the export state for a special remote. -} -gitAnnexExportUpdateLock :: UUID -> Git.Repo -> FilePath -gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r ++ ".upl" +gitAnnexExportUpdateLock :: UUID -> Git.Repo -> RawFilePath +gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r <> ".upl" {- Log file used to keep track of files that were in the tree exported to a - remote, but were excluded by its preferred content settings. -} -gitAnnexExportExcludeLog :: UUID -> Git.Repo -> FilePath -gitAnnexExportExcludeLog u r = fromRawFilePath $ - gitAnnexDir r P. "export.ex" P. fromUUID u +gitAnnexExportExcludeLog :: UUID -> Git.Repo -> RawFilePath +gitAnnexExportExcludeLog u r = gitAnnexDir r P. "export.ex" P. fromUUID u {- Directory containing database used to record remote content ids. - - (This used to be "cid", but a problem with the database caused it to - need to be rebuilt with a new name.) -} -gitAnnexContentIdentifierDbDir :: Git.Repo -> FilePath -gitAnnexContentIdentifierDbDir r = fromRawFilePath $ gitAnnexDir r P. "cidsdb" +gitAnnexContentIdentifierDbDir :: Git.Repo -> RawFilePath +gitAnnexContentIdentifierDbDir r = gitAnnexDir r P. "cidsdb" {- Lock file for writing to the content id database. -} -gitAnnexContentIdentifierLock :: Git.Repo -> FilePath -gitAnnexContentIdentifierLock r = gitAnnexContentIdentifierDbDir r ++ ".lck" +gitAnnexContentIdentifierLock :: Git.Repo -> RawFilePath +gitAnnexContentIdentifierLock r = gitAnnexContentIdentifierDbDir r <> ".lck" {- .git/annex/schedulestate is used to store information about when - scheduled jobs were last run. -} -gitAnnexScheduleState :: Git.Repo -> FilePath -gitAnnexScheduleState r = fromRawFilePath $ gitAnnexDir r P. "schedulestate" +gitAnnexScheduleState :: Git.Repo -> RawFilePath +gitAnnexScheduleState r = gitAnnexDir r P. "schedulestate" {- .git/annex/creds/ is used to store credentials to access some special - remotes. -} -gitAnnexCredsDir :: Git.Repo -> FilePath -gitAnnexCredsDir r = fromRawFilePath $ - P.addTrailingPathSeparator $ gitAnnexDir r P. "creds" +gitAnnexCredsDir :: Git.Repo -> RawFilePath +gitAnnexCredsDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "creds" {- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp - when HTTPS is enabled -} @@ -441,81 +407,78 @@ gitAnnexWebPrivKey r = fromRawFilePath $ gitAnnexDir r P. "privkey.pem" {- .git/annex/feeds/ is used to record per-key (url) state by importfeeds -} -gitAnnexFeedStateDir :: Git.Repo -> FilePath -gitAnnexFeedStateDir r = fromRawFilePath $ - P.addTrailingPathSeparator $ gitAnnexDir r P. "feedstate" +gitAnnexFeedStateDir :: Git.Repo -> RawFilePath +gitAnnexFeedStateDir r = P.addTrailingPathSeparator $ + gitAnnexDir r P. "feedstate" -gitAnnexFeedState :: Key -> Git.Repo -> FilePath -gitAnnexFeedState k r = gitAnnexFeedStateDir r fromRawFilePath (keyFile k) +gitAnnexFeedState :: Key -> Git.Repo -> RawFilePath +gitAnnexFeedState k r = gitAnnexFeedStateDir r P. keyFile k -{- .git/annex/merge/ is used as a empty work tree for direct mode merges and - - merges in adjusted branches. -} +{- .git/annex/merge/ is used as a empty work tree for merges in + - adjusted branches. -} gitAnnexMergeDir :: Git.Repo -> FilePath gitAnnexMergeDir r = fromRawFilePath $ P.addTrailingPathSeparator $ gitAnnexDir r P. "merge" {- .git/annex/transfer/ is used to record keys currently - being transferred, and other transfer bookkeeping info. -} -gitAnnexTransferDir :: Git.Repo -> FilePath -gitAnnexTransferDir r = fromRawFilePath $ +gitAnnexTransferDir :: Git.Repo -> RawFilePath +gitAnnexTransferDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "transfer" {- .git/annex/journal/ is used to journal changes made to the git-annex - branch -} -gitAnnexJournalDir :: Git.Repo -> FilePath -gitAnnexJournalDir r = fromRawFilePath $ +gitAnnexJournalDir :: Git.Repo -> RawFilePath +gitAnnexJournalDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" gitAnnexJournalDir' :: Git.Repo -> RawFilePath -gitAnnexJournalDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" +gitAnnexJournalDir' r = + P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" {- Lock file for the journal. -} -gitAnnexJournalLock :: Git.Repo -> FilePath -gitAnnexJournalLock r = fromRawFilePath $ gitAnnexDir r P. "journal.lck" +gitAnnexJournalLock :: Git.Repo -> RawFilePath +gitAnnexJournalLock r = gitAnnexDir r P. "journal.lck" {- Lock file for flushing a git queue that writes to the git index or - other git state that should only have one writer at a time. -} -gitAnnexGitQueueLock :: Git.Repo -> FilePath -gitAnnexGitQueueLock r = fromRawFilePath $ gitAnnexDir r P. "gitqueue.lck" - -{- Lock file for direct mode merge. -} -gitAnnexMergeLock :: Git.Repo -> FilePath -gitAnnexMergeLock r = fromRawFilePath $ gitAnnexDir r P. "merge.lck" +gitAnnexGitQueueLock :: Git.Repo -> RawFilePath +gitAnnexGitQueueLock r = gitAnnexDir r P. "gitqueue.lck" {- .git/annex/index is used to stage changes to the git-annex branch -} -gitAnnexIndex :: Git.Repo -> FilePath -gitAnnexIndex r = fromRawFilePath $ gitAnnexDir r P. "index" +gitAnnexIndex :: Git.Repo -> RawFilePath +gitAnnexIndex r = gitAnnexDir r P. "index" {- Holds the ref of the git-annex branch that the index was last updated to. - - The .lck in the name is a historical accident; this is not used as a - lock. -} -gitAnnexIndexStatus :: Git.Repo -> FilePath -gitAnnexIndexStatus r = fromRawFilePath $ gitAnnexDir r P. "index.lck" +gitAnnexIndexStatus :: Git.Repo -> RawFilePath +gitAnnexIndexStatus r = gitAnnexDir r P. "index.lck" {- The index file used to generate a filtered branch view._-} -gitAnnexViewIndex :: Git.Repo -> FilePath -gitAnnexViewIndex r = fromRawFilePath $ gitAnnexDir r P. "viewindex" +gitAnnexViewIndex :: Git.Repo -> RawFilePath +gitAnnexViewIndex r = gitAnnexDir r P. "viewindex" {- File containing a log of recently accessed views. -} -gitAnnexViewLog :: Git.Repo -> FilePath -gitAnnexViewLog r = fromRawFilePath $ gitAnnexDir r P. "viewlog" +gitAnnexViewLog :: Git.Repo -> RawFilePath +gitAnnexViewLog r = gitAnnexDir r P. "viewlog" {- List of refs that have already been merged into the git-annex branch. -} -gitAnnexMergedRefs :: Git.Repo -> FilePath -gitAnnexMergedRefs r = fromRawFilePath $ gitAnnexDir r P. "mergedrefs" +gitAnnexMergedRefs :: Git.Repo -> RawFilePath +gitAnnexMergedRefs r = gitAnnexDir r P. "mergedrefs" {- List of refs that should not be merged into the git-annex branch. -} -gitAnnexIgnoredRefs :: Git.Repo -> FilePath -gitAnnexIgnoredRefs r = fromRawFilePath $ gitAnnexDir r P. "ignoredrefs" +gitAnnexIgnoredRefs :: Git.Repo -> RawFilePath +gitAnnexIgnoredRefs r = gitAnnexDir r P. "ignoredrefs" {- Pid file for daemon mode. -} -gitAnnexPidFile :: Git.Repo -> FilePath -gitAnnexPidFile r = fromRawFilePath $ gitAnnexDir r P. "daemon.pid" +gitAnnexPidFile :: Git.Repo -> RawFilePath +gitAnnexPidFile r = gitAnnexDir r P. "daemon.pid" {- Pid lock file for pidlock mode -} -gitAnnexPidLockFile :: Git.Repo -> FilePath -gitAnnexPidLockFile r = fromRawFilePath $ gitAnnexDir r P. "pidlock" +gitAnnexPidLockFile :: Git.Repo -> RawFilePath +gitAnnexPidLockFile r = gitAnnexDir r P. "pidlock" {- Status file for daemon mode. -} gitAnnexDaemonStatusFile :: Git.Repo -> FilePath @@ -523,8 +486,8 @@ gitAnnexDir r P. "daemon.status" {- Log file for daemon mode. -} -gitAnnexDaemonLogFile :: Git.Repo -> FilePath -gitAnnexDaemonLogFile r = fromRawFilePath $ gitAnnexDir r P. "daemon.log" +gitAnnexDaemonLogFile :: Git.Repo -> RawFilePath +gitAnnexDaemonLogFile r = gitAnnexDir r P. "daemon.log" {- Log file for fuzz test. -} gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath @@ -532,25 +495,24 @@ gitAnnexDir r P. "fuzztest.log" {- Html shim file used to launch the webapp. -} -gitAnnexHtmlShim :: Git.Repo -> FilePath -gitAnnexHtmlShim r = fromRawFilePath $ gitAnnexDir r P. "webapp.html" +gitAnnexHtmlShim :: Git.Repo -> RawFilePath +gitAnnexHtmlShim r = gitAnnexDir r P. "webapp.html" {- File containing the url to the webapp. -} -gitAnnexUrlFile :: Git.Repo -> FilePath -gitAnnexUrlFile r = fromRawFilePath $ gitAnnexDir r P. "url" +gitAnnexUrlFile :: Git.Repo -> RawFilePath +gitAnnexUrlFile r = gitAnnexDir r P. "url" {- Temporary file used to edit configuriation from the git-annex branch. -} -gitAnnexTmpCfgFile :: Git.Repo -> FilePath -gitAnnexTmpCfgFile r = fromRawFilePath $ gitAnnexDir r P. "config.tmp" +gitAnnexTmpCfgFile :: Git.Repo -> RawFilePath +gitAnnexTmpCfgFile r = gitAnnexDir r P. "config.tmp" {- .git/annex/ssh/ is used for ssh connection caching -} -gitAnnexSshDir :: Git.Repo -> FilePath -gitAnnexSshDir r = fromRawFilePath $ - P.addTrailingPathSeparator $ gitAnnexDir r P. "ssh" +gitAnnexSshDir :: Git.Repo -> RawFilePath +gitAnnexSshDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "ssh" {- .git/annex/remotes/ is used for remote-specific state. -} -gitAnnexRemotesDir :: Git.Repo -> FilePath -gitAnnexRemotesDir r = fromRawFilePath $ +gitAnnexRemotesDir :: Git.Repo -> RawFilePath +gitAnnexRemotesDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "remotes" {- This is the base directory name used by the assistant when making diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -26,10 +26,11 @@ import Annex.LockPool import qualified Data.Map as M +import qualified System.FilePath.ByteString as P {- Create a specified lock file, and takes a shared lock, which is retained - in the cache. -} -lockFileCached :: FilePath -> Annex () +lockFileCached :: RawFilePath -> Annex () lockFileCached file = go =<< fromLockCache file where go (Just _) = noop -- already locked @@ -42,7 +43,7 @@ #endif changeLockCache $ M.insert file lockhandle -unlockFile :: FilePath -> Annex () +unlockFile :: RawFilePath -> Annex () unlockFile file = maybe noop go =<< fromLockCache file where go lockhandle = do @@ -52,7 +53,7 @@ getLockCache :: Annex LockCache getLockCache = getState lockcache -fromLockCache :: FilePath -> Annex (Maybe LockHandle) +fromLockCache :: RawFilePath -> Annex (Maybe LockHandle) fromLockCache file = M.lookup file <$> getLockCache changeLockCache :: (LockCache -> LockCache) -> Annex () @@ -62,10 +63,10 @@ {- Runs an action with a shared lock held. If an exclusive lock is held, - blocks until it becomes free. -} -withSharedLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a +withSharedLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a withSharedLock getlockfile a = debugLocks $ do lockfile <- fromRepo getlockfile - createAnnexDirectory $ takeDirectory lockfile + createAnnexDirectory $ P.takeDirectory lockfile mode <- annexFileMode bracket (lock mode lockfile) (liftIO . dropLock) (const a) where @@ -77,17 +78,17 @@ {- Runs an action with an exclusive lock held. If the lock is already - held, blocks until it becomes free. -} -withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a +withExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a withExclusiveLock getlockfile a = bracket (takeExclusiveLock getlockfile) (liftIO . dropLock) (const a) {- Takes an exclusive lock, blocking until it's free. -} -takeExclusiveLock :: (Git.Repo -> FilePath) -> Annex LockHandle +takeExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex LockHandle takeExclusiveLock getlockfile = debugLocks $ do lockfile <- fromRepo getlockfile - createAnnexDirectory $ takeDirectory lockfile + createAnnexDirectory $ P.takeDirectory lockfile mode <- annexFileMode lock mode lockfile where @@ -99,10 +100,10 @@ {- Tries to take an exclusive lock and run an action. If the lock is - already held, returns Nothing. -} -tryExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex (Maybe a) +tryExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex (Maybe a) tryExclusiveLock getlockfile a = debugLocks $ do lockfile <- fromRepo getlockfile - createAnnexDirectory $ takeDirectory lockfile + createAnnexDirectory $ P.takeDirectory lockfile mode <- annexFileMode bracket (lock mode lockfile) (liftIO . unlock) go where diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -63,7 +63,7 @@ {- Numcopies value for a file, from any configuration source, including the - deprecated git config. -} -getFileNumCopies :: FilePath -> Annex NumCopies +getFileNumCopies :: RawFilePath -> Annex NumCopies getFileNumCopies f = fromSources [ getForcedNumCopies , getFileNumCopies' f @@ -72,17 +72,17 @@ getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies getAssociatedFileNumCopies (AssociatedFile afile) = - maybe getNumCopies getFileNumCopies (fromRawFilePath <$> afile) + maybe getNumCopies getFileNumCopies afile {- This is the globally visible numcopies value for a file. So it does - not include local configuration in the git config or command line - options. -} -getGlobalFileNumCopies :: FilePath -> Annex NumCopies +getGlobalFileNumCopies :: RawFilePath -> Annex NumCopies getGlobalFileNumCopies f = fromSources [ getFileNumCopies' f ] -getFileNumCopies' :: FilePath -> Annex (Maybe NumCopies) +getFileNumCopies' :: RawFilePath -> Annex (Maybe NumCopies) getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr where getattr = (NumCopies <$$> readish) @@ -95,12 +95,12 @@ - This is good enough for everything except dropping the file, which - requires active verification of the copies. -} -numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v +numCopiesCheck :: RawFilePath -> Key -> (Int -> Int -> v) -> Annex v numCopiesCheck file key vs = do have <- trustExclude UnTrusted =<< Remote.keyLocations key numCopiesCheck' file vs have -numCopiesCheck' :: FilePath -> (Int -> Int -> v) -> [UUID] -> Annex v +numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' file vs have = do NumCopies needed <- getFileNumCopies file return $ length have `vs` needed diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -31,24 +31,26 @@ import Git.ConfigTypes import qualified Annex import Config +import Utility.Directory.Create +import qualified Utility.RawFilePath as R withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig -setAnnexFilePerm :: FilePath -> Annex () +setAnnexFilePerm :: RawFilePath -> Annex () setAnnexFilePerm = setAnnexPerm False -setAnnexDirPerm :: FilePath -> Annex () +setAnnexDirPerm :: RawFilePath -> Annex () setAnnexDirPerm = setAnnexPerm True {- Sets appropriate file mode for a file or directory in the annex, - other than the content files and content directory. Normally, - don't change the mode, but with core.sharedRepository set, - allow the group to write, etc. -} -setAnnexPerm :: Bool -> FilePath -> Annex () +setAnnexPerm :: Bool -> RawFilePath -> Annex () setAnnexPerm = setAnnexPerm' Nothing -setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> FilePath -> Annex () +setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> RawFilePath -> Annex () setAnnexPerm' modef isdir file = unlessM crippledFileSystem $ withShared $ liftIO . go where @@ -65,7 +67,7 @@ modifyFileMode file $ f [] modef' = fromMaybe addModes modef -resetAnnexFilePerm :: FilePath -> Annex () +resetAnnexFilePerm :: RawFilePath -> Annex () resetAnnexFilePerm = resetAnnexPerm False {- Like setAnnexPerm, but ignores the current mode of the file entirely, @@ -76,7 +78,7 @@ - which is going to be moved to a non-temporary location and needs - usual modes. -} -resetAnnexPerm :: Bool -> FilePath -> Annex () +resetAnnexPerm :: Bool -> RawFilePath -> Annex () resetAnnexPerm isdir file = unlessM crippledFileSystem $ do defmode <- liftIO defaultFileMode let modef moremodes _oldmode = addModes moremodes defmode @@ -97,13 +99,13 @@ {- Creates a directory inside the gitAnnexDir, creating any parent - directories up to and including the gitAnnexDir. - Makes directories with appropriate permissions. -} -createAnnexDirectory :: FilePath -> Annex () +createAnnexDirectory :: RawFilePath -> Annex () createAnnexDirectory dir = do - top <- parentDir . fromRawFilePath <$> fromRepo gitAnnexDir + top <- parentDir <$> fromRepo gitAnnexDir createDirectoryUnder' top dir createdir where createdir p = do - liftIO $ createDirectory p + liftIO $ R.createDirectory p setAnnexDirPerm p {- Create a directory in the git work tree, creating any parent @@ -111,10 +113,10 @@ - - Uses default permissions. -} -createWorkTreeDirectory :: FilePath -> Annex () +createWorkTreeDirectory :: RawFilePath -> Annex () createWorkTreeDirectory dir = do fromRepo repoWorkTree >>= liftIO . \case - Just wt -> createDirectoryUnder (fromRawFilePath wt) dir + Just wt -> createDirectoryUnder wt dir -- Should never happen, but let whatever tries to write -- to the directory be what throws an exception, as that -- will be clearer than an exception from here. @@ -129,7 +131,7 @@ - shared repository, the current user may not be able to change a file - owned by another user, so failure to set this mode is ignored. -} -freezeContent :: FilePath -> Annex () +freezeContent :: RawFilePath -> Annex () freezeContent file = unlessM crippledFileSystem $ withShared go where @@ -141,7 +143,7 @@ removeModes writeModes . addModes [ownerReadMode] -isContentWritePermOk :: FilePath -> Annex Bool +isContentWritePermOk :: RawFilePath -> Annex Bool isContentWritePermOk file = ifM crippledFileSystem ( return True , withShared go @@ -151,12 +153,12 @@ go AllShared = want writeModes go _ = return True want wantmode = - liftIO (catchMaybeIO $ fileMode <$> getFileStatus file) >>= return . \case + liftIO (catchMaybeIO $ fileMode <$> R.getFileStatus file) >>= return . \case Nothing -> True Just havemode -> havemode == combineModes (havemode:wantmode) {- Adjusts read mode of annexed file per core.sharedRepository setting. -} -chmodContent :: FilePath -> Annex () +chmodContent :: RawFilePath -> Annex () chmodContent file = unlessM crippledFileSystem $ withShared go where @@ -169,7 +171,7 @@ {- Allows writing to an annexed file that freezeContent was called on - before. -} -thawContent :: FilePath -> Annex () +thawContent :: RawFilePath -> Annex () thawContent file = thawPerms $ withShared go where go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file @@ -190,7 +192,7 @@ - is set, this is not done, since the group must be allowed to delete the - file. -} -freezeContentDir :: FilePath -> Annex () +freezeContentDir :: RawFilePath -> Annex () freezeContentDir file = unlessM crippledFileSystem $ withShared go where @@ -199,14 +201,15 @@ go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir go _ = liftIO $ preventWrite dir -thawContentDir :: FilePath -> Annex () -thawContentDir file = thawPerms $ liftIO $ allowWrite $ parentDir file +thawContentDir :: RawFilePath -> Annex () +thawContentDir file = + thawPerms $ liftIO $ allowWrite $ parentDir file {- Makes the directory tree to store an annexed file's content, - with appropriate permissions on each level. -} -createContentDir :: FilePath -> Annex () +createContentDir :: RawFilePath -> Annex () createContentDir dest = do - unlessM (liftIO $ doesDirectoryExist dir) $ + unlessM (liftIO $ R.doesPathExist dir) $ createAnnexDirectory dir -- might have already existed with restricted perms unlessM crippledFileSystem $ @@ -217,7 +220,7 @@ {- Creates the content directory for a file if it doesn't already exist, - or thaws it if it does, then runs an action to modify the file, and - finally, freezes the content directory. -} -modifyContent :: FilePath -> Annex a -> Annex a +modifyContent :: RawFilePath -> Annex a -> Annex a modifyContent f a = do createContentDir f -- also thaws it v <- tryNonAsync a diff --git a/Annex/Queue.hs b/Annex/Queue.hs --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -31,7 +31,7 @@ store =<< flushWhenFull =<< (Git.Queue.addCommand command params files q =<< gitRepo) -addInternalAction :: Git.Queue.InternalActionRunner Annex -> [(FilePath, IO Bool)] -> Annex () +addInternalAction :: Git.Queue.InternalActionRunner Annex -> [(RawFilePath, IO Bool)] -> Annex () addInternalAction runner files = do q <- get store =<< flushWhenFull =<< diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -19,6 +19,7 @@ import Annex.Perms import Git import Utility.Tmp.Dir +import Utility.Directory.Create #ifndef mingw32_HOST_OS import Utility.Path.Max #endif @@ -30,7 +31,7 @@ {- replaceFile on a file located inside the .git directory. -} replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a replaceGitDirFile = replaceFile $ \dir -> do - top <- fromRawFilePath <$> fromRepo localGitDir + top <- fromRepo localGitDir liftIO $ createDirectoryUnder top dir {- replaceFile on a worktree file. -} @@ -52,29 +53,30 @@ - The createdirectory action is only run when moving the file into place - fails, and can create any parent directory structure needed. -} -replaceFile :: (FilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a +replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a replaceFile createdirectory file action = withOtherTmp $ \othertmpdir -> do + let othertmpdir' = fromRawFilePath othertmpdir #ifndef mingw32_HOST_OS -- Use part of the filename as the template for the temp -- directory. This does not need to be unique, but it -- makes it more clear what this temp directory is for. - filemax <- liftIO $ fileNameLengthLimit othertmpdir + filemax <- liftIO $ fileNameLengthLimit othertmpdir' let basetmp = take (filemax `div` 2) (takeFileName file) #else -- Windows has limits on the whole path length, so keep -- it short. let basetmp = "t" #endif - withTmpDirIn othertmpdir basetmp $ \tmpdir -> do + withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do let tmpfile = tmpdir basetmp r <- action tmpfile replaceFileFrom tmpfile file createdirectory return r -replaceFileFrom :: FilePath -> FilePath -> (FilePath -> Annex ()) -> Annex () +replaceFileFrom :: FilePath -> FilePath -> (RawFilePath -> Annex ()) -> Annex () replaceFileFrom src dest createdirectory = go `catchIO` fallback where go = liftIO $ moveFile src dest fallback _ = do - createdirectory (parentDir dest) + createdirectory (parentDir (toRawFilePath dest)) go diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -38,6 +38,7 @@ import Types.Concurrency import Git.Env import Git.Ssh +import qualified Utility.RawFilePath as R import Annex.Perms #ifndef mingw32_HOST_OS import Annex.LockPool @@ -45,6 +46,7 @@ import Control.Concurrent.STM import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P {- Some ssh commands are fed stdin on a pipe and so should be allowed to - consume it. But ssh commands that are not piped stdin should generally @@ -102,9 +104,11 @@ sshCachingInfo (host, port) = go =<< sshCacheDir' where go (Right dir) = - liftIO (bestSocketPath $ dir hostport2socket host port) >>= return . \case + liftIO (bestSocketPath $ dir P. hostport2socket host port) >>= return . \case Nothing -> (Nothing, []) - Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile) + Just socketfile -> + let socketfile' = fromRawFilePath socketfile + in (Just socketfile', sshConnectionCachingParams socketfile') -- No connection caching with concurrency is not a good -- combination, so warn the user. go (Left whynocaching) = do @@ -130,20 +134,20 @@ - file. - - If no path can be constructed that is a valid socket, returns Nothing. -} -bestSocketPath :: FilePath -> IO (Maybe FilePath) +bestSocketPath :: RawFilePath -> IO (Maybe RawFilePath) bestSocketPath abssocketfile = do relsocketfile <- liftIO $ relPathCwdToFile abssocketfile - let socketfile = if length abssocketfile <= length relsocketfile + let socketfile = if S.length abssocketfile <= S.length relsocketfile then abssocketfile else relsocketfile - return $ if valid_unix_socket_path (socketfile ++ sshgarbage) + return $ if valid_unix_socket_path socketfile sshgarbagelen then Just socketfile else Nothing where -- ssh appends a 16 char extension to the socket when setting it -- up, which needs to be taken into account when checking -- that a valid socket was constructed. - sshgarbage = replicate (1+16) 'X' + sshgarbagelen = 1+16 sshConnectionCachingParams :: FilePath -> [CommandParam] sshConnectionCachingParams socketfile = @@ -160,10 +164,10 @@ - - The directory will be created if it does not exist. -} -sshCacheDir :: Annex (Maybe FilePath) +sshCacheDir :: Annex (Maybe RawFilePath) sshCacheDir = eitherToMaybe <$> sshCacheDir' -sshCacheDir' :: Annex (Either String FilePath) +sshCacheDir' :: Annex (Either String RawFilePath) sshCacheDir' = ifM (fromMaybe BuildInfo.sshconnectioncaching . annexSshCaching <$> Annex.getGitConfig) ( ifM crippledFileSystem @@ -186,7 +190,7 @@ usetmpdir tmpdir = do let socktmp = tmpdir "ssh" createDirectoryIfMissing True socktmp - return socktmp + return (toRawFilePath socktmp) crippledfswarning = unwords [ "This repository is on a crippled filesystem, so unix named" @@ -285,9 +289,9 @@ enumSocketFiles = liftIO . go =<< sshCacheDir where go Nothing = return [] - go (Just dir) = filterM (doesFileExist . socket2lock) + go (Just dir) = filterM (R.doesPathExist . socket2lock) =<< filter (not . isLock) - <$> catchDefaultIO [] (dirContents dir) + <$> catchDefaultIO [] (dirContents (fromRawFilePath dir)) {- Stop any unused ssh connection caching processes. -} sshCleanup :: Annex () @@ -333,25 +337,25 @@ } void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid -> forceSuccessProcess p pid - liftIO $ nukeFile socketfile + liftIO $ removeWhenExistsWith removeLink socketfile {- This needs to be as short as possible, due to limitations on the length - of the path to a socket file. At the same time, it needs to be unique - for each host. -} -hostport2socket :: SshHost -> Maybe Integer -> FilePath +hostport2socket :: SshHost -> Maybe Integer -> RawFilePath hostport2socket host Nothing = hostport2socket' $ fromSshHost host hostport2socket host (Just port) = hostport2socket' $ fromSshHost host ++ "!" ++ show port -hostport2socket' :: String -> FilePath +hostport2socket' :: String -> RawFilePath hostport2socket' s - | length s > lengthofmd5s = show $ md5 $ encodeBL s - | otherwise = s + | length s > lengthofmd5s = toRawFilePath $ show $ md5 $ encodeBL s + | otherwise = toRawFilePath s where lengthofmd5s = 32 -socket2lock :: FilePath -> FilePath -socket2lock socket = socket ++ lockExt +socket2lock :: FilePath -> RawFilePath +socket2lock socket = toRawFilePath (socket ++ lockExt) isLock :: FilePath -> Bool isLock f = lockExt `isSuffixOf` f @@ -369,8 +373,8 @@ {- Note that this looks at the true length of the path in bytes, as it will - appear on disk. -} -valid_unix_socket_path :: FilePath -> Bool -valid_unix_socket_path f = S.length (encodeBS f) < sizeof_sockaddr_un_sun_path +valid_unix_socket_path :: RawFilePath -> Int -> Bool +valid_unix_socket_path f n = S.length f + n < sizeof_sockaddr_un_sun_path {- Parses the SSH port, and returns the other OpenSSH options. If - several ports are found, the last one takes precedence. -} diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -21,7 +21,7 @@ -- 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 :: (FilePath -> Annex a) -> Annex a +withOtherTmp :: (RawFilePath -> Annex a) -> Annex a withOtherTmp a = do Annex.addCleanup OtherTmpCleanup cleanupOtherTmp tmpdir <- fromRepo gitAnnexTmpOtherDir @@ -38,14 +38,14 @@ -- 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 :: (FilePath -> Annex a) -> Annex a +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 + 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 @@ -56,9 +56,9 @@ cleanupOtherTmp = do tmplck <- fromRepo gitAnnexTmpOtherLock void $ tryIO $ tryExclusiveLock (const tmplck) $ do - tmpdir <- fromRepo gitAnnexTmpOtherDir + tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir - oldtmp <- fromRepo gitAnnexTmpOtherDirOld + oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld liftIO $ mapM_ cleanold =<< dirContentsRecursive oldtmp liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty where @@ -67,5 +67,5 @@ let oldenough = now - (60 * 60 * 24 * 7) catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case Just mtime | realToFrac mtime <= oldenough -> - void $ tryIO $ nukeFile f + void $ tryIO $ removeWhenExistsWith removeLink f _ -> return () diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -35,9 +35,11 @@ import Types.WorkerPool import Annex.WorkerPool import Backend (isCryptographicallySecure) +import qualified Utility.RawFilePath as R import Control.Concurrent import qualified Data.Map.Strict as M +import qualified System.FilePath.ByteString as P import Data.Ord upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v @@ -96,11 +98,11 @@ else recordFailedTransfer t info return v where - prep :: FilePath -> Annex () -> FileMode -> Annex (Maybe LockHandle, Bool) + prep :: RawFilePath -> Annex () -> FileMode -> Annex (Maybe LockHandle, Bool) #ifndef mingw32_HOST_OS prep tfile createtfile mode = catchPermissionDenied (const prepfailed) $ do let lck = transferLockFile tfile - createAnnexDirectory $ takeDirectory lck + createAnnexDirectory $ P.takeDirectory lck tryLockExclusive (Just mode) lck >>= \case Nothing -> return (Nothing, True) Just lockhandle -> ifM (checkSaneLock lck lockhandle) @@ -114,7 +116,7 @@ #else prep tfile createtfile _mode = catchPermissionDenied (const prepfailed) $ do let lck = transferLockFile tfile - createAnnexDirectory $ takeDirectory lck + createAnnexDirectory $ P.takeDirectory lck catchMaybeIO (liftIO $ lockExclusive lck) >>= \case Nothing -> return (Nothing, False) Just Nothing -> return (Nothing, True) @@ -127,9 +129,9 @@ cleanup _ Nothing = noop cleanup tfile (Just lockhandle) = do let lck = transferLockFile tfile - void $ tryIO $ removeFile tfile + void $ tryIO $ R.removeLink tfile #ifndef mingw32_HOST_OS - void $ tryIO $ removeFile lck + void $ tryIO $ R.removeLink lck dropLock lockhandle #else {- Windows cannot delete the lockfile until the lock @@ -138,7 +140,7 @@ - so ignore failure to remove. -} dropLock lockhandle - void $ tryIO $ removeFile lck + void $ tryIO $ R.removeLink lck #endif retry numretries oldinfo metervar run = diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -33,11 +33,13 @@ import Utility.Glob import Types.Command import CmdLine.Action +import qualified Utility.RawFilePath as R import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.Set as S import qualified Data.Map as M +import qualified System.FilePath.ByteString as P import "mtl" Control.Monad.Writer {- Each visible ViewFilter in a view results in another level of @@ -292,12 +294,12 @@ - it to a file yields a set of ViewedFile which all contain the same - MetaFields that were present in the input metadata - (excluding fields that are not visible). -} -prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool -prop_view_roundtrips f metadata visible = or - [ null f - , null (takeFileName f) && null (takeDirectory f) +prop_view_roundtrips :: AssociatedFile -> MetaData -> Bool -> Bool +prop_view_roundtrips (AssociatedFile Nothing) _ _ = True +prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or + [ B.null (P.takeFileName f) && B.null (P.takeDirectory f) , viewTooLarge view - , all hasfields (viewedFiles view viewedFileFromReference f metadata) + , all hasfields (viewedFiles view viewedFileFromReference (fromRawFilePath f) metadata) ] where view = View (Git.Ref "foo") $ @@ -353,7 +355,7 @@ applyView' mkviewedfile getfilemetadata view = do top <- fromRepo Git.repoPath (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] - liftIO . nukeFile =<< fromRepo gitAnnexViewIndex + liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex viewg <- withViewIndex gitRepo withUpdateIndex viewg $ \uh -> do forM_ l $ \(f, sha, mode) -> do @@ -369,8 +371,7 @@ let f = fromRawFilePath $ getTopFilePath topf let metadata' = getfilemetadata f `unionMetaData` metadata forM_ (genviewedfiles f metadata') $ \fv -> do - f' <- fromRawFilePath <$> - fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) + f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k) go uh topf sha (Just treeitemtype) Nothing | "." `B.isPrefixOf` getTopFilePath topf = diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs --- a/Annex/View/ViewedFile.hs +++ b/Annex/View/ViewedFile.hs @@ -17,7 +17,10 @@ ) where import Annex.Common +import Utility.QuickCheck +import qualified Data.ByteString as S + type FileName = String type ViewedFile = FileName @@ -34,14 +37,14 @@ -} viewedFileFromReference :: MkViewedFile viewedFileFromReference f = concat - [ escape base + [ escape (fromRawFilePath base) , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%" - , escape $ concat extensions + , escape $ fromRawFilePath $ S.concat extensions ] where (path, basefile) = splitFileName f dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path) - (base, extensions) = splitShortExtensions basefile + (base, extensions) = splitShortExtensions (toRawFilePath basefile) {- To avoid collisions with filenames or directories that contain - '%', and to allow the original directories to be extracted @@ -76,11 +79,12 @@ [] -> sep l curr cs | otherwise = sep l (c:curr) cs -prop_viewedFile_roundtrips :: FilePath -> Bool -prop_viewedFile_roundtrips f +prop_viewedFile_roundtrips :: TestableFilePath -> Bool +prop_viewedFile_roundtrips tf -- Relative filenames wanted, not directories. | any (isPathSeparator) (end f ++ beginning f) = True | isAbsolute f = True | otherwise = dir == dirFromViewedFile (viewedFileFromReference f) where + f = fromTestableFilePath tf dir = joinPath $ beginning $ splitDirectories f diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -106,7 +106,7 @@ fileMode <$> R.getFileStatus f ic <- replaceWorkTreeFile (fromRawFilePath f) $ \tmp -> do let tmp' = toRawFilePath tmp - linkFromAnnex k tmp destmode >>= \case + linkFromAnnex k tmp' destmode >>= \case LinkAnnexOk -> withTSDelta (liftIO . genInodeCache tmp') LinkAnnexNoop -> return Nothing diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -123,7 +123,7 @@ Just have -> do inprogress <- sizeOfDownloadsInProgress (const True) partial <- liftIO $ sum - <$> (mapM getFileSize =<< dirContents workdir) + <$> (mapM (getFileSize . toRawFilePath) =<< dirContents workdir) reserve <- annexDiskReserve <$> Annex.getGitConfig let maxsize = have - reserve - inprogress + partial if maxsize > 0 @@ -141,7 +141,7 @@ youtubeDlTo :: Key -> URLString -> FilePath -> MeterUpdate -> Annex Bool youtubeDlTo key url dest p = do res <- withTmpWorkDir key $ \workdir -> - youtubeDl url workdir p >>= \case + youtubeDl url (fromRawFilePath workdir) p >>= \case Right (Just mediafile) -> do liftIO $ renameFile mediafile dest return (Just True) diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -62,7 +62,8 @@ import Network.Socket (HostName) stopDaemon :: Annex () -stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile +stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath + =<< fromRepo gitAnnexPidFile {- Starts the daemon. If the daemon is run in the foreground, once it's - running, can start the browser. @@ -75,24 +76,24 @@ enableInteractiveBranchAccess pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ debugM desc $ "logging to " ++ logfile + liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile createAnnexDirectory (parentDir pidfile) #ifndef mingw32_HOST_OS createAnnexDirectory (parentDir logfile) - logfd <- liftIO $ handleToFd =<< openLog logfile + logfd <- liftIO $ handleToFd =<< openLog (fromRawFilePath logfile) if foreground then do origout <- liftIO $ catchMaybeIO $ fdToHandle =<< dup stdOutput origerr <- liftIO $ catchMaybeIO $ fdToHandle =<< dup stdError - let undaemonize = Utility.Daemon.foreground logfd (Just pidfile) + let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile)) start undaemonize $ case startbrowser of Nothing -> Nothing Just a -> Just $ a origout origerr else - start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing + start (Utility.Daemon.daemonize logfd (Just (fromRawFilePath pidfile)) False) Nothing #else -- Windows doesn't daemonize, but does redirect output to the -- log file. The only way to do so is to restart the program. @@ -128,7 +129,7 @@ checkCanWatch dstatus <- startDaemonStatus logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ debugM desc $ "logging to " ++ logfile + liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile liftIO $ daemonize $ flip runAssistant (go webappwaiter) =<< newAssistantData st dstatus diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -51,7 +51,8 @@ go (Just base) = do let program = base "git-annex" programfile <- programFile - createDirectoryIfMissing True (parentDir programfile) + createDirectoryIfMissing True $ + fromRawFilePath (parentDir (toRawFilePath programfile)) writeFile programfile program #ifdef darwin_HOST_OS @@ -100,9 +101,10 @@ installWrapper file content = do curr <- catchDefaultIO "" $ readFileStrict file when (curr /= content) $ do - createDirectoryIfMissing True (parentDir file) + createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file))) viaTmp writeFile file content - modifyFileMode file $ addModes [ownerExecuteMode] + modifyFileMode (toRawFilePath file) $ + addModes [ownerExecuteMode] installFileManagerHooks :: FilePath -> IO () #ifdef linux_HOST_OS @@ -131,7 +133,7 @@ scriptname action = "git-annex " ++ action installscript f c = whenM (safetoinstallscript f) $ do writeFile f c - modifyFileMode f $ addModes [ownerExecuteMode] + modifyFileMode (toRawFilePath f) $ addModes [ownerExecuteMode] safetoinstallscript f = catchDefaultIO True $ elem autoaddedcomment . lines <$> readFileStrict f autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)" diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -15,12 +15,13 @@ import Utility.OSX import Utility.Path import Utility.Directory +import Utility.FileSystemEncoding #endif installAutoStart :: FilePath -> FilePath -> IO () installAutoStart command file = do #ifdef darwin_HOST_OS - createDirectoryIfMissing True (parentDir file) + createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file))) writeFile file $ genOSXAutoStartFile osxAutoStartLabel command ["assistant", "--autostart"] #else diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs --- a/Assistant/Install/Menu.hs +++ b/Assistant/Install/Menu.hs @@ -10,10 +10,16 @@ module Assistant.Install.Menu where -import Common - import Utility.FreeDesktop +import Utility.FileSystemEncoding +import Utility.Path +import System.IO +import Utility.SystemDirectory +#ifndef darwin_HOST_OS +import System.FilePath +#endif + installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO () #ifdef darwin_HOST_OS installMenu _command _menufile _iconsrcdir _icondir = return () @@ -39,7 +45,7 @@ installIcon :: FilePath -> FilePath -> IO () installIcon src dest = do - createDirectoryIfMissing True (parentDir dest) + createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath dest))) withBinaryFile src ReadMode $ \hin -> withBinaryFile dest WriteMode $ \hout -> hGetContents hin >>= hPutStr hout diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -46,7 +46,9 @@ {- Runs an action in the git repository in the specified directory. -} inDir :: FilePath -> Annex a -> IO a inDir dir a = do - state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir + state <- Annex.new + =<< Git.Config.read + =<< Git.Construct.fromPath (toRawFilePath dir) Annex.eval state $ a `finally` stopCoProcesses {- Creates a new repository, and returns its UUID. -} diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -26,7 +26,7 @@ setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of Left err -> error err Right pubkey -> do - absdir <- absPath repodir + absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir) unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $ error "failed setting up ssh authorized keys" diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -91,10 +91,10 @@ remoterepair fsckresults = case Remote.repairRepo =<< mrmt of Nothing -> return False Just mkrepair -> do - thisrepopath <- liftIO . absPath . fromRawFilePath + thisrepopath <- liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath) a <- liftAnnex $ mkrepair $ - repair fsckresults (Just thisrepopath) + repair fsckresults (Just (fromRawFilePath thisrepopath)) liftIO $ catchBoolIO a repair fsckresults referencerepo = do @@ -140,7 +140,8 @@ repairStaleLocks :: [FilePath] -> Assistant () repairStaleLocks lockfiles = go =<< getsizes where - getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize lf + getsize lf = catchMaybeIO $ (\s -> (lf, s)) + <$> getFileSize (toRawFilePath lf) getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles go [] = return () go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l)) @@ -148,7 +149,7 @@ waitforit "to check stale git lock file" l' <- getsizes if l' == l - then liftIO $ mapM_ nukeFile (map fst l) + then liftIO $ mapM_ (removeWhenExistsWith removeLink . fst) l else go l' , do waitforit "for git lock file writer" diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -17,6 +17,7 @@ import Utility.NotificationBroadcaster import Utility.Url import Utility.PID +import qualified Utility.RawFilePath as R import qualified Git.Construct import qualified Git.Config import qualified Annex @@ -39,8 +40,8 @@ prepRestart :: Assistant () prepRestart = do liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread - liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) - liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) + liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile) + liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile) {- To finish a restart, send a global redirect to the new url - to any web browsers that are displaying the webapp. @@ -75,8 +76,8 @@ geturl where geturl = do - r <- Git.Config.read =<< Git.Construct.fromPath repo - waiturl $ gitAnnexUrlFile r + r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo) + waiturl $ fromRawFilePath $ gitAnnexUrlFile r waiturl urlfile = do v <- tryIO $ readFile urlfile case v of diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -244,10 +244,11 @@ installSshKeyPair :: SshKeyPair -> SshData -> IO SshData installSshKeyPair sshkeypair sshdata = do sshdir <- sshDir - createDirectoryIfMissing True $ parentDir $ sshdir sshPrivKeyFile sshdata + createDirectoryIfMissing True $ fromRawFilePath $ + parentDir $ toRawFilePath $ sshdir sshPrivKeyFile sshdata unlessM (doesFileExist $ sshdir sshPrivKeyFile sshdata) $ - writeFileProtected (sshdir sshPrivKeyFile sshdata) (sshPrivKey sshkeypair) + writeFileProtected (toRawFilePath (sshdir sshPrivKeyFile sshdata)) (sshPrivKey sshkeypair) unlessM (doesFileExist $ sshdir sshPubKeyFile sshdata) $ writeFile (sshdir sshPubKeyFile sshdata) (sshPubKey sshkeypair) @@ -330,7 +331,7 @@ , "Host " ++ mangledhost ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) (settings ++ config) - setSshConfigMode configfile + setSshConfigMode (toRawFilePath configfile) return $ sshdata { sshHostName = T.pack mangledhost diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -57,10 +57,11 @@ liftAnnex $ do -- Clean up anything left behind by a previous process -- on unclean shutdown. - void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir + void $ liftIO $ tryIO $ removeDirectoryRecursive + (fromRawFilePath lockdowndir) void $ createAnnexDirectory lockdowndir waitChangeTime $ \(changes, time) -> do - readychanges <- handleAdds lockdowndir havelsof delayadd $ + readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof delayadd $ simplifyChanges changes if shouldCommit False time (length readychanges) readychanges then do @@ -261,7 +262,7 @@ let (pending, inprocess) = partition isPendingAddChange incomplete let lockdownconfig = LockDownConfig { lockingFile = False - , hardlinkFileTmpDir = Just lockdowndir + , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) } (postponed, toadd) <- partitionEithers <$> safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess @@ -304,7 +305,7 @@ delta <- liftAnnex getTSDelta let cfg = LockDownConfig { lockingFile = False - , hardlinkFileTmpDir = Just lockdowndir + , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) } if M.null m then forM toadd (add cfg) diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.Threads.Merger where import Assistant.Common @@ -13,6 +15,7 @@ import Assistant.Sync import Utility.DirWatcher import Utility.DirWatcher.Types +import Utility.Directory.Create import Annex.CurrentBranch import qualified Annex import qualified Annex.Branch @@ -21,13 +24,15 @@ import qualified Git.Ref import qualified Command.Sync +import qualified System.FilePath.ByteString as P + {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} mergeThread :: NamedThread mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo - let gitd = fromRawFilePath (Git.localGitDir g) - let dir = gitd "refs" + let gitd = Git.localGitDir g + let dir = gitd P. "refs" liftIO $ createDirectoryUnder gitd dir let hook a = Just <$> asIO2 (runHandler a) changehook <- hook onChange @@ -37,8 +42,8 @@ , modifyHook = changehook , errHook = errhook } - void $ liftIO $ watchDir dir (const False) True hooks id - debug ["watching", dir] + void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id + debug ["watching", fromRawFilePath dir] type Handler = FilePath -> Assistant () diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -159,7 +159,7 @@ -} remotesUnder :: FilePath -> Assistant [Remote] remotesUnder dir = do - repotop <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath + repotop <- liftAnnex $ fromRepo Git.repoPath rs <- liftAnnex remoteList pairs <- liftAnnex $ mapM (checkremote repotop) rs let (waschanged, rs') = unzip pairs @@ -169,7 +169,7 @@ return $ mapMaybe snd $ filter fst pairs where checkremote repotop r = case Remote.localpath r of - Just p | dirContains dir (absPathFrom repotop p) -> + Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) -> (,) <$> pure True <*> updateRemote r _ -> return (False, Just r) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -42,6 +42,7 @@ import Annex.Path import Annex.Tmp import qualified Annex +import qualified Utility.RawFilePath as R #ifdef WITH_WEBAPP import Assistant.WebApp.Types #endif @@ -66,7 +67,7 @@ ifM (not <$> liftAnnex (inRepo checkIndexFast)) ( do notice ["corrupt index file found at startup; removing and restaging"] - liftAnnex $ inRepo $ nukeFile . indexFile + liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile {- Normally the startup scan avoids re-staging files, - but with the index deleted, everything needs to be - restaged. -} @@ -80,7 +81,7 @@ - will be automatically regenerated. -} unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do notice ["corrupt annex/index file found at startup; removing"] - liftAnnex $ liftIO . nukeFile =<< fromRepo gitAnnexIndex + liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex {- Fix up ssh remotes set up by past versions of the assistant. -} liftIO $ fixUpSshRemotes @@ -221,9 +222,9 @@ -} checkLogSize :: Int -> Assistant () checkLogSize n = do - f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile + f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile logs <- liftIO $ listLogs f - totalsize <- liftIO $ sum <$> mapM getFileSize logs + totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs when (totalsize > 2 * oneMegabyte) $ do notice ["Rotated logs due to size:", show totalsize] liftIO $ openLog f >>= handleToFd >>= redirLog diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -47,7 +47,7 @@ | otherwise = do let f = transferFile t g mi <- liftIO $ catchDefaultIO Nothing $ - readTransferInfoFile Nothing f + readTransferInfoFile Nothing (fromRawFilePath f) maybe noop (newsize t info . bytesComplete) mi newsize t info sz diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -37,7 +37,7 @@ , modifyHook = modifyhook , errHook = errhook } - void $ liftIO $ watchDir dir (const False) True hooks id + void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id debug ["watching for transfers"] type Handler = FilePath -> Assistant () diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -46,7 +46,7 @@ , modifyHook = changed , delDirHook = changed } - let dir = parentDir flagfile + let dir = fromRawFilePath (parentDir (toRawFilePath flagfile)) let depth = length (splitPath dir) + 1 let nosubdirs f = length (splitPath f) == depth void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -24,6 +24,7 @@ import Utility.DirWatcher import Utility.DirWatcher.Types import Utility.InodeCache +import qualified Utility.RawFilePath as R import qualified Annex import qualified Annex.Queue import qualified Git @@ -169,7 +170,7 @@ ig _ = False unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change) -unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file) +unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file)) ( noChange , a ) @@ -194,7 +195,7 @@ {- Small files are added to git as-is, while large ones go into the annex. -} add :: GetFileMatcher -> FilePath -> Assistant (Maybe Change) -add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher file) +add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher (toRawFilePath file)) ( pendingAddChange file , do liftAnnex $ Annex.Queue.addCommand "add" @@ -217,7 +218,8 @@ =<< inRepo (toTopFilePath (toRawFilePath file)) samefilestatus key file status = do cache <- Database.Keys.getInodeCaches key - curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta file status + curr <- withTSDelta $ \delta -> + liftIO $ toInodeCache delta (toRawFilePath file) status case (cache, curr) of (_, Just c) -> elemInodeCaches c cache ([], Nothing) -> return True @@ -280,7 +282,7 @@ Nothing -> noop Just key -> liftAnnex $ addassociatedfile key file - onAddSymlink' (Just $ fromRawFilePath lt) mk file fs + onAddSymlink' (Just lt) mk file fs {- A symlink might be an arbitrary symlink, which is just added. - Or, if it is a git-annex symlink, ensure it points to the content @@ -288,15 +290,17 @@ -} onAddSymlink :: Handler onAddSymlink file filestatus = unlessIgnored file $ do - linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) - kv <- liftAnnex (lookupKey (toRawFilePath file)) + linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file') + kv <- liftAnnex (lookupKey file') onAddSymlink' linktarget kv file filestatus + where + file' = toRawFilePath file -onAddSymlink' :: Maybe String -> Maybe Key -> Handler +onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler onAddSymlink' linktarget mk file filestatus = go mk where go (Just key) = do - link <- liftAnnex $ calcRepo $ gitAnnexLink file key + link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key if linktarget == Just link then ensurestaged (Just link) =<< getDaemonStatus else do @@ -326,16 +330,17 @@ ensurestaged Nothing _ = noChange {- For speed, tries to reuse the existing blob for symlink target. -} -addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change) +addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change) addLink file link mk = do debug ["add symlink", file] liftAnnex $ do v <- catObjectDetails $ Ref $ encodeBS' $ ':':file case v of Just (currlink, sha, _type) - | s2w8 link == L.unpack currlink -> + | L.fromStrict link == currlink -> stageSymlink (toRawFilePath file) sha - _ -> stageSymlink (toRawFilePath file) =<< hashSymlink link + _ -> stageSymlink (toRawFilePath file) + =<< hashSymlink link madeChange file $ LinkChange mk onDel :: Handler diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -91,7 +91,9 @@ else do htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile - go tlssettings addr webapp htmlshim (Just urlfile) + go tlssettings addr webapp + (fromRawFilePath htmlshim) + (Just urlfile) where -- The webapp thread does not wait for the startupSanityCheckThread -- to finish, so that the user interface remains responsive while @@ -100,8 +102,7 @@ getreldir | noannex = return Nothing | otherwise = Just <$> - (relHome =<< absPath . fromRawFilePath - =<< getAnnex' (fromRepo repoPath)) + (relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath)) go tlssettings addr webapp htmlshim urlfile = do let url = myUrl tlssettings webapp addr maybe noop (`writeFileProtected` url) urlfile diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -113,16 +113,16 @@ | transferDirection t == Download = do debug ["finished downloading git-annex distribution"] maybe (failedupgrade "bad download") go - =<< liftAnnex (withObjectLoc k (fsckit . fromRawFilePath)) + =<< liftAnnex (withObjectLoc k fsckit) | otherwise = cleanup where k = mkKey $ const $ distributionKey d fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case - Nothing -> return $ Just f + Nothing -> return $ Just (fromRawFilePath f) Just b -> case Types.Backend.verifyKeyContent b of - Nothing -> return $ Just f + Nothing -> return $ Just (fromRawFilePath f) Just verifier -> ifM (verifier k f) - ( return $ Just f + ( return $ Just (fromRawFilePath f) , return Nothing ) go f = do @@ -163,7 +163,7 @@ {- OS X uses a dmg, so mount it, and copy the contents into place. -} unpack = liftIO $ do olddir <- oldVersionLocation - withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do + withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) "git-annex.upgrade" $ \tmpdir -> do void $ boolSystem "hdiutil" [ Param "attach", File distributionfile , Param "-mountpoint", File tmpdir @@ -188,7 +188,7 @@ - into place. -} unpack = liftIO $ do olddir <- oldVersionLocation - withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do + withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) "git-annex.upgrade" $ \tmpdir -> do let tarball = tmpdir "tar" -- Cannot rely on filename extension, and this also -- avoids problems if tar doesn't support transparent @@ -219,8 +219,8 @@ unlessM (doesDirectoryExist dir) $ error $ "did not find " ++ dir ++ " in " ++ distributionfile makeorigsymlink olddir = do - let origdir = parentDir olddir installBase - nukeFile origdir + let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) installBase + removeWhenExistsWith removeLink origdir createSymbolicLink newdir origdir {- Finds where the old version was installed. -} @@ -228,7 +228,7 @@ oldVersionLocation = readProgramFile >>= \case Nothing -> error "Cannot find old distribution bundle; not upgrading." Just pf -> do - let pdir = parentDir pf + let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf #ifdef darwin_HOST_OS let dirs = splitDirectories pdir {- It will probably be deep inside a git-annex.app directory. -} @@ -257,7 +257,7 @@ return Nothing where s = installBase ++ "." ++ distributionVersion d - topdir = parentDir olddir + topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir newloc = topdir s trymkdir dir fallback = (createDirectory dir >> return (Just dir)) @@ -278,8 +278,8 @@ deleteFromManifest :: FilePath -> IO () deleteFromManifest dir = do fs <- map (dir ) . lines <$> catchDefaultIO "" (readFile manifest) - mapM_ nukeFile fs - nukeFile manifest + mapM_ (removeWhenExistsWith removeLink) fs + removeWhenExistsWith removeLink manifest removeEmptyRecursive dir where manifest = dir "git-annex.MANIFEST" diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -16,7 +16,7 @@ import Assistant.Sync import qualified Remote import qualified Git -import Config.Files +import Config.Files.AutoStart import Logs.Trust import Logs.Remote import Logs.PreferredContent @@ -90,7 +90,8 @@ mapM_ (\r -> changeSyncable (Just r) False) rs liftAnnex $ prepareRemoveAnnexDir dir - liftIO $ removeDirectoryRecursive =<< absPath dir + liftIO $ removeDirectoryRecursive . fromRawFilePath + =<< absPath (toRawFilePath dir) redirect ShutdownConfirmedR _ -> $(widgetFile "configurators/delete/currentrepository") diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -247,7 +247,7 @@ RepoGroupStandard gr -> case associatedDirectory repoconfig gr of Just d -> do top <- fromRawFilePath <$> fromRepo Git.repoPath - createWorkTreeDirectory (top d) + createWorkTreeDirectory (toRawFilePath (top d)) Nothing -> noop _ -> noop diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -20,7 +20,7 @@ import qualified Git import qualified Git.Config import qualified Git.Command -import Config.Files +import Config.Files.AutoStart import Utility.FreeDesktop import Utility.DiskFree #ifndef mingw32_HOST_OS @@ -78,8 +78,8 @@ checkRepositoryPath p = do home <- myHomeDir let basepath = expandTilde home $ T.unpack p - path <- absPath basepath - let parent = parentDir path + path <- fromRawFilePath <$> absPath (toRawFilePath basepath) + let parent = fromRawFilePath $ parentDir (toRawFilePath path) problems <- catMaybes <$> mapM runcheck [ (return $ path == "/", "Enter the full path to use for the repository.") , (return $ all isSpace basepath, "A blank path? Seems unlikely.") @@ -354,7 +354,9 @@ combineRepos dir name = liftAnnex $ do hostname <- fromMaybe "host" <$> liftIO getHostname mylocation <- fromRepo Git.repoLocation - mypath <- liftIO $ relPathDirToFile dir mylocation + mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile + (toRawFilePath dir) + (toRawFilePath mylocation) liftIO $ inDir dir $ void $ makeGitRemote hostname mypath addRemote $ makeGitRemote name dir @@ -415,7 +417,9 @@ canWrite :: FilePath -> IO Bool canWrite dir = do tocheck <- ifM (doesDirectoryExist dir) - (return dir, return $ parentDir dir) + ( return dir + , return $ fromRawFilePath $ parentDir $ toRawFilePath dir + ) catchBoolIO $ fileAccess tocheck False True False {- Gets the UUID of the git repo at a location, which may not exist, or diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -16,7 +16,7 @@ import qualified Annex import qualified Git import Config -import Config.Files +import Config.Files.AutoStart import Annex.NumCopies import Utility.DataUnits import Git.Config @@ -24,6 +24,7 @@ import qualified BuildInfo import qualified Data.Text as T +import qualified System.FilePath.ByteString as P data PrefsForm = PrefsForm { diskReserve :: Text @@ -118,5 +119,6 @@ inAutoStartFile :: Annex Bool inAutoStartFile = do - here <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath - any (`equalFilePath` here) <$> liftIO readAutoStartFile + here <- liftIO . absPath =<< fromRepo Git.repoPath + any (`P.equalFilePath` here) . map toRawFilePath + <$> liftIO readAutoStartFile diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -391,7 +391,7 @@ Nothing -> go [passwordprompts 0] Nothing Just pass -> withTmpFile "ssh" $ \passfile h -> do hClose h - writeFileProtected passfile pass + writeFileProtected (toRawFilePath passfile) pass environ <- getEnvironment let environ' = addEntries [ ("SSH_ASKPASS", program) diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -73,6 +73,6 @@ getLogR :: Handler Html getLogR = page "Logs" Nothing $ do logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile - logs <- liftIO $ listLogs logfile + logs <- liftIO $ listLogs (fromRawFilePath logfile) logcontent <- liftIO $ concat <$> mapM readFile logs $(widgetFile "control/log") diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -118,8 +118,8 @@ - blocking the response to the browser on it. -} openFileBrowser :: Handler Bool openFileBrowser = do - path <- liftIO . absPath . fromRawFilePath - =<< liftAnnex (fromRepo Git.repoPath) + path <- fromRawFilePath + <$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath)) #ifdef darwin_HOST_OS let cmd = "open" let p = proc cmd [path] diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs --- a/Assistant/WebApp/OtherRepos.hs +++ b/Assistant/WebApp/OtherRepos.hs @@ -12,9 +12,10 @@ import Assistant.Common import Assistant.WebApp.Types import Assistant.WebApp.Page -import Config.Files +import Config.Files.AutoStart import Utility.Yesod import Assistant.Restart +import qualified Utility.RawFilePath as R getRepositorySwitcherR :: Handler Html getRepositorySwitcherR = page "Switch repository" Nothing $ do @@ -24,9 +25,9 @@ listOtherRepos :: IO [(String, String)] listOtherRepos = do dirs <- readAutoStartFile - pwd <- getCurrentDirectory + pwd <- R.getCurrentDirectory gooddirs <- filterM isrepo $ - filter (\d -> not $ d `dirContains` pwd) dirs + filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs names <- mapM relHome gooddirs return $ sort $ zip names gooddirs where diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -88,7 +88,7 @@ {- Looks up the backend that should be used for a file. - That can be configured on a per-file basis in the gitattributes file, - or forced with --backend. -} -chooseBackend :: FilePath -> Annex (Maybe Backend) +chooseBackend :: RawFilePath -> Annex (Maybe Backend) chooseBackend f = Annex.getState Annex.forcebackend >>= go where go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS diff --git a/Backend/External.hs b/Backend/External.hs --- a/Backend/External.hs +++ b/Backend/External.hs @@ -102,12 +102,12 @@ return $ GetNextMessage go go _ = Nothing -verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> FilePath -> Annex Bool +verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> RawFilePath -> Annex Bool verifyKeyContentExternal ebname hasext meterupdate k f = withExternalState ebname hasext $ \st -> handleRequest st req notavail go where - req = VERIFYKEYCONTENT (toProtoKey k) f + req = VERIFYKEYCONTENT (toProtoKey k) (fromRawFilePath f) -- This should not be able to happen, because CANVERIFY is checked -- before this function is enable, and so the external program diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -15,12 +15,13 @@ import Annex.Common import qualified Annex +import Backend.Utilities import Types.Key import Types.Backend import Types.KeySource import Utility.Hash import Utility.Metered -import Backend.Utilities +import qualified Utility.RawFilePath as R import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -100,7 +101,7 @@ {- A key is a hash of its contents. -} keyValue :: Hash -> KeySource -> MeterUpdate -> Annex Key keyValue hash source meterupdate = do - let file = fromRawFilePath (contentLocation source) + let file = contentLocation source filesize <- liftIO $ getFileSize file s <- hashFile hash file meterupdate return $ mkKey $ \k -> k @@ -117,10 +118,10 @@ {- A key's checksum is checked during fsck when it's content is present - except for in fast mode. -} -checkKeyChecksum :: Hash -> Key -> FilePath -> Annex Bool +checkKeyChecksum :: Hash -> Key -> RawFilePath -> Annex Bool checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do fast <- Annex.getState Annex.fast - exists <- liftIO $ doesFileExist file + exists <- liftIO $ R.doesPathExist file case (exists, fast) of (True, False) -> do showAction "checksum" @@ -191,9 +192,9 @@ oldvariety = fromKey keyVariety oldkey newvariety = backendVariety newbackend -hashFile :: Hash -> FilePath -> MeterUpdate -> Annex String +hashFile :: Hash -> RawFilePath -> MeterUpdate -> Annex String hashFile hash file meterupdate = - liftIO $ withMeteredFile file meterupdate $ \b -> do + liftIO $ withMeteredFile (fromRawFilePath file) meterupdate $ \b -> do let h = hasher b -- Force full evaluation of hash so whole file is read -- before returning. diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -39,7 +39,7 @@ keyValue source _ = do let f = contentLocation source stat <- liftIO $ R.getFileStatus f - sz <- liftIO $ getFileSize' (fromRawFilePath f) stat + sz <- liftIO $ getFileSize' f stat relf <- fromRawFilePath . getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) return $ mkKey $ \k -> k diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -16,6 +16,7 @@ import Utility.Path import Utility.Monad import Utility.Directory +import Utility.FileSystemEncoding import Config.Files import Utility.OSX import Assistant.Install.AutoStart @@ -77,7 +78,7 @@ ( return () , do programfile <- inDestDir =<< programFile - createDirectoryIfMissing True (parentDir programfile) + createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath programfile))) writeFile programfile command ) diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,18 @@ +git-annex (8.20201116) upstream; urgency=medium + + * move: Fix a regression in the last release that made move --to not + honor numcopies settings. + * sync --content: Fix a bug where a file that was not preferred content + could be transferred to a remote. This happened when the file got deleted + after the sync started running. + * Warn when adding a annex symlink or pointer file that uses a key that + is not known to the repository, to prevent confusion if the user has + copied it from some other repository. + * examinekey: Added two new format variables: objectpath and objectpointer + * examinekey: Added --migrate-to-backend + + -- Joey Hess Mon, 16 Nov 2020 09:36:35 -0400 + git-annex (8.20201103) upstream; urgency=medium * move: Improve resuming a move that was interrupted after the object diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -137,7 +137,7 @@ ) where go a' = batchInput fmt - (Right <$$> liftIO . relPathCwdToFile) + (Right . fromRawFilePath <$$> liftIO . relPathCwdToFile . toRawFilePath) (batchCommandAction . uncurry a') batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex () diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -124,7 +124,8 @@ "Restricted login shell for git-annex only SSH access" where mkrepo = do - r <- Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath + r <- Git.Construct.repoAbsPath (toRawFilePath dir) + >>= Git.Construct.fromAbsPath Git.Config.read r `catchIO` \_ -> do hn <- fromMaybe "unknown" <$> getHostname diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -71,7 +71,9 @@ canondir home d | "~/" `isPrefixOf` d = return d | "/~/" `isPrefixOf` d = return $ drop 1 d - | otherwise = relHome $ absPathFrom home d + | otherwise = relHome $ fromRawFilePath $ absPathFrom + (toRawFilePath home) + (toRawFilePath d) {- Modifies a Command to check that it is run in either a git-annex - repository, or a repository with a gcrypt-id set. -} diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -25,6 +25,7 @@ import Git.FilePath import qualified Limit import CmdLine.GitAnnex.Options +import CmdLine.Action import Logs import Logs.Unused import Types.Transfer @@ -44,11 +45,11 @@ import qualified Database.Keys import qualified Utility.RawFilePath as R import Utility.Tuple -import CmdLine.Action import Control.Concurrent.Async import System.Posix.Types import Data.IORef +import qualified System.FilePath.ByteString as P data AnnexedFileSeeker = AnnexedFileSeeker { startAction :: SeekInput -> RawFilePath -> Key -> CommandStart @@ -92,7 +93,7 @@ seekFiltered (const (pure True)) a $ seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l -withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek +withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do matcher <- Limit.getMatcher forM_ params $ \p -> do @@ -102,13 +103,18 @@ a f where get p = ifM (isDirectory <$> getFileStatus p) - ( map (\f -> (f, makeRelative (parentDir p) f)) + ( map (\f -> + let f' = toRawFilePath f + in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f')) <$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p - , return [(p, takeFileName p)] + , return [(p', P.takeFileName p')] ) + where + p' = toRawFilePath p + checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo - { contentFile = Just (toRawFilePath f) - , matchFile = toRawFilePath relf + { contentFile = Just f + , matchFile = relf } withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek @@ -490,7 +496,7 @@ currbranch <- getCurrentBranch stopattop <- prepviasymlink ps' <- flip filterM ps $ \p -> do - relf <- liftIO $ relPathCwdToFile p + relf <- liftIO $ relPathCwdToFile $ toRawFilePath p ifM (not <$> (exists p <||> hidden currbranch relf)) ( prob (p ++ " not found") , ifM (viasymlink stopattop (upFrom relf)) @@ -517,7 +523,7 @@ viasymlink _ Nothing = return False viasymlink stopattop (Just p) = do - st <- liftIO $ getSymbolicLinkStatus p + st <- liftIO $ R.getSymbolicLinkStatus p if stopattop st then return False else if isSymbolicLink st @@ -526,7 +532,7 @@ hidden currbranch f | allowhidden = isJust - <$> catObjectMetaDataHidden (toRawFilePath f) currbranch + <$> catObjectMetaDataHidden f currbranch | otherwise = return False prob msg = do diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -129,7 +129,8 @@ noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $ giveup "You cannot run this command while git-annex watch or git-annex assistant is running." where - daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile + daemonpid = liftIO . checkDaemon . fromRawFilePath + =<< fromRepo gitAnnexPidFile dontCheck :: CommandCheck -> Command -> Command dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -81,8 +81,9 @@ annexdotfiles <- getGitConfigVal annexDotFiles let gofile (si, file) = case largeFilesOverride o of Nothing -> - let file' = fromRawFilePath file - in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force)) + ifM (pure (annexdotfiles || not (dotfile file)) + <&&> (checkFileMatcher largematcher file + <||> Annex.getState Annex.force)) ( start o si file addunlockedmatcher , ifM (annexAddSmallFiles <$> Annex.getGitConfig) ( startSmall o si file @@ -128,20 +129,19 @@ addSmallOverridden :: AddOptions -> RawFilePath -> Annex Bool addSmallOverridden o file = do showNote "adding content to git repository" - let file' = fromRawFilePath file - s <- liftIO $ getSymbolicLinkStatus file' + s <- liftIO $ R.getSymbolicLinkStatus file if not (isRegularFile s) then addFile (checkGitIgnoreOption o) file else do -- Can't use addFile because the clean filter will -- honor annex.largefiles and it has been overridden. -- Instead, hash the file and add to the index. - sha <- hashFile file' + sha <- hashFile file let ty = if isExecutable (fileMode s) then TreeExecutable else TreeFile Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageFile sha ty file') + inRepo (Git.UpdateIndex.stageFile sha ty (fromRawFilePath file)) return True addFile :: CheckGitIgnore -> RawFilePath -> Annex Bool @@ -169,16 +169,17 @@ liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case Just s | isSymbolicLink s -> fixuplink key _ -> add - fixuplink key = starting "add" (ActionItemWorkTreeFile file) si $ do - -- the annexed symlink is present but not yet added to git - liftIO $ removeFile (fromRawFilePath file) - addLink (checkGitIgnoreOption o) (fromRawFilePath file) key Nothing - next $ - cleanup key =<< inAnnex key - fixuppointer key = starting "add" (ActionItemWorkTreeFile file) si $ do - -- the pointer file is present, but not yet added to git - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) - next $ addFile (checkGitIgnoreOption o) file + fixuplink key = + starting "add" (ActionItemWorkTreeFile file) si $ + addingExistingLink file key $ do + liftIO $ removeFile (fromRawFilePath file) + addLink (checkGitIgnoreOption o) file key Nothing + next $ cleanup key =<< inAnnex key + fixuppointer key = + starting "add" (ActionItemWorkTreeFile file) si $ + addingExistingLink file key $ do + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) + next $ addFile (checkGitIgnoreOption o) file perform :: AddOptions -> RawFilePath -> AddUnlockedMatcher -> CommandPerform perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.AddUnused where import Logs.Location @@ -33,7 +35,7 @@ addLink (CheckGitIgnore False) file key Nothing return True where - file = "unused." ++ fromRawFilePath (keyFile key) + file = "unused." <> keyFile key {- The content is not in the annex, but in another directory, and - it seems better to error out, rather than moving bad/tmp content into diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -7,8 +7,6 @@ module Command.AddUrl where -import Network.URI - import Command import Backend import qualified Annex @@ -32,8 +30,12 @@ import Utility.Metered import Utility.HtmlDetect import Utility.Path.Max +import qualified Utility.RawFilePath as R import qualified Annex.Transfer as Transfer +import Network.URI +import qualified System.FilePath.ByteString as P + cmd :: Command cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $ command "addurl" SectionCommon "add urls to annex" @@ -163,14 +165,15 @@ startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart startRemote addunlockedmatcher r o si file uri sz = do pathmax <- liftIO $ fileNameLengthLimit "." - let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file + let file' = joinPath $ map (truncateFilePath pathmax) $ + splitDirectories file startingAddUrl si uri o $ do showNote $ "from " ++ Remote.name r showDestinationFile file' - performRemote addunlockedmatcher r o uri file' sz + performRemote addunlockedmatcher r o uri (toRawFilePath file') sz -performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform -performRemote addunlockedmatcher r o uri file sz = ifAnnexed (toRawFilePath file) adduri geturi +performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform +performRemote addunlockedmatcher r o uri file sz = ifAnnexed file adduri geturi where loguri = setDownloader uri OtherDownloader adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize @@ -179,7 +182,7 @@ Just n -> (True, n == fromMaybe n (fromKey keySize key), loguri) geturi = next $ isJust <$> downloadRemoteFile addunlockedmatcher r (downloadOptions o) uri file sz -downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) +downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> RawFilePath -> Maybe Integer -> Annex (Maybe Key) downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do let urlkey = Backend.URL.fromUrl uri sz createWorkTreeDirectory (parentDir file) @@ -200,7 +203,7 @@ ) where loguri = setDownloader uri OtherDownloader - af = AssociatedFile (Just (toRawFilePath file)) + af = AssociatedFile (Just file) startWeb :: AddUnlockedMatcher -> AddUrlOptions -> SeekInput -> URLString -> CommandStart startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURI urlstring @@ -229,7 +232,7 @@ , pure f ) _ -> pure $ url2file url (pathdepthOption o) pathmax - performWeb addunlockedmatcher o urlstring file urlinfo + performWeb addunlockedmatcher o urlstring (toRawFilePath file) urlinfo sanitizeOrPreserveFilePath :: AddUrlOptions -> FilePath -> Annex FilePath sanitizeOrPreserveFilePath o f @@ -255,8 +258,8 @@ , "has a security problem (" ++ d ++ "), not adding." ] -performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform -performWeb addunlockedmatcher o url file urlinfo = ifAnnexed (toRawFilePath file) addurl geturl +performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> RawFilePath -> Url.UrlInfo -> CommandPerform +performWeb addunlockedmatcher o url file urlinfo = ifAnnexed file addurl geturl where geturl = next $ isJust <$> addUrlFile addunlockedmatcher (downloadOptions o) url urlinfo file addurl = addUrlChecked o url file webUUID $ \k -> @@ -267,11 +270,11 @@ {- Check that the url exists, and has the same size as the key, - and add it as an url to the key. -} -addUrlChecked :: AddUrlOptions -> URLString -> FilePath -> UUID -> (Key -> Annex (Bool, Bool, URLString)) -> Key -> CommandPerform +addUrlChecked :: AddUrlOptions -> URLString -> RawFilePath -> UUID -> (Key -> Annex (Bool, Bool, URLString)) -> Key -> CommandPerform addUrlChecked o url file u checkexistssize key = ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key)) ( do - showDestinationFile file + showDestinationFile (fromRawFilePath file) next $ return True , do (exists, samesize, url') <- checkexistssize key @@ -293,49 +296,49 @@ - different file, based on the title of the media. Unless the user - specified fileOption, which then forces using the FilePath. -} -addUrlFile :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +addUrlFile :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key) addUrlFile addunlockedmatcher o url urlinfo file = ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) ( nodownloadWeb addunlockedmatcher o url urlinfo file , downloadWeb addunlockedmatcher o url urlinfo file ) -downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key) downloadWeb addunlockedmatcher o url urlinfo file = - go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just (toRawFilePath file))) + go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file)) where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing downloader f p = Url.withUrlOptions $ downloadUrl urlkey p [url] f go Nothing = return Nothing - go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtml <$> readFile tmp)) + go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtml <$> readFile (fromRawFilePath tmp))) ( tryyoutubedl tmp , normalfinish tmp ) normalfinish tmp = checkCanAdd o file $ \canadd -> do - showDestinationFile file + showDestinationFile (fromRawFilePath file) createWorkTreeDirectory (parentDir file) Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file -- Ask youtube-dl what filename it will download first, -- so it's only used when the file contains embedded media. tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case Right mediafile -> - let f = youtubeDlDestFile o file mediafile - in ifAnnexed (toRawFilePath f) - (alreadyannexed f) + let f = youtubeDlDestFile o file (toRawFilePath mediafile) + in ifAnnexed f + (alreadyannexed (fromRawFilePath f)) (dl f) Left _ -> normalfinish tmp where dl dest = withTmpWorkDir mediakey $ \workdir -> do - let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . nukeFile) + let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) showNote "using youtube-dl" Transfer.notifyTransfer Transfer.Download url $ Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> - youtubeDl url workdir p >>= \case + youtubeDl url (fromRawFilePath workdir) p >>= \case Right (Just mediafile) -> do cleanuptmp checkCanAdd o dest $ \canadd -> do - showDestinationFile dest - addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile) + showDestinationFile (fromRawFilePath dest) + addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile)) return $ Just mediakey Right Nothing -> normalfinish tmp Left msg -> do @@ -378,34 +381,34 @@ - Downloads the url, sets up the worktree file, and returns the - real key. -} -downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key) +downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe Key) downloadWith canadd addunlockedmatcher downloader dummykey u url file = go =<< downloadWith' downloader dummykey u url afile where - afile = AssociatedFile (Just (toRawFilePath file)) + afile = AssociatedFile (Just file) go Nothing = return Nothing go (Just tmp) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp u url file {- Like downloadWith, but leaves the dummy key content in - the returned location. -} -downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> AssociatedFile -> Annex (Maybe FilePath) +downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> AssociatedFile -> Annex (Maybe RawFilePath) downloadWith' downloader dummykey u url afile = checkDiskSpaceToGet dummykey Nothing $ do tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey ok <- Transfer.notifyTransfer Transfer.Download url $ Transfer.download u dummykey afile Transfer.stdRetry $ \p -> do createAnnexDirectory (parentDir tmp) - downloader tmp p + downloader (fromRawFilePath tmp) p if ok then return (Just tmp) else return Nothing -finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key +finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> UUID -> URLString -> RawFilePath -> Annex Key finishDownloadWith canadd addunlockedmatcher tmp u url file = do backend <- chooseBackend file let source = KeySource - { keyFilename = toRawFilePath file - , contentLocation = toRawFilePath tmp + { keyFilename = file + , contentLocation = tmp , inodeCache = Nothing } key <- fst <$> genKey source nullMeterUpdate backend @@ -419,14 +422,16 @@ } {- Adds worktree file to the repository. -} -addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () +addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> RawFilePath -> Key -> Maybe RawFilePath -> Annex () addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of Nothing -> go Just tmp -> do -- Move to final location for large file check. pruneTmpWorkDirBefore tmp $ \_ -> do - createWorkTreeDirectory (takeDirectory file) - liftIO $ renameFile tmp file + createWorkTreeDirectory (P.takeDirectory file) + liftIO $ renameFile + (fromRawFilePath tmp) + (fromRawFilePath file) largematcher <- largeFilesMatcher large <- checkFileMatcher largematcher file if large @@ -434,9 +439,11 @@ -- Move back to tmp because addAnnexedFile -- needs the file in a different location -- than the work tree file. - liftIO $ renameFile file tmp + liftIO $ renameFile + (fromRawFilePath file) + (fromRawFilePath tmp) go - else void $ Command.Add.addSmall noci (toRawFilePath file) + else void $ Command.Add.addSmall noci file where go = do maybeShowJSON $ JSONChunk [("key", serializeKey key)] @@ -446,18 +453,18 @@ ( do when (isJust mtmp) $ logStatus key InfoPresent - , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp + , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)) mtmp ) -- git does not need to check ignores, because that has already -- been done, as witnessed by the CannAddFile. noci = CheckGitIgnore False -nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key) nodownloadWeb addunlockedmatcher o url urlinfo file | Url.urlExists urlinfo = if rawOption o then nomedia - else either (const nomedia) usemedia + else either (const nomedia) (usemedia . toRawFilePath) =<< youtubeDlFileName url | otherwise = do warning $ "unable to access url: " ++ url @@ -472,14 +479,14 @@ let mediakey = Backend.URL.fromUrl mediaurl Nothing nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest -youtubeDlDestFile :: DownloadOptions -> FilePath -> FilePath -> FilePath +youtubeDlDestFile :: DownloadOptions -> RawFilePath -> RawFilePath -> RawFilePath youtubeDlDestFile o destfile mediafile | isJust (fileOption o) = destfile - | otherwise = takeFileName mediafile + | otherwise = P.takeFileName mediafile -nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key) +nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key) nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do - showDestinationFile file + showDestinationFile (fromRawFilePath file) createWorkTreeDirectory (parentDir file) addWorkTree canadd addunlockedmatcher webUUID url file key Nothing return (Just key) @@ -515,14 +522,14 @@ data CanAddFile = CanAddFile -checkCanAdd :: DownloadOptions -> FilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) -checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file)) +checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) +checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file)) ( do - warning $ file ++ " already exists; not overwriting" + warning $ fromRawFilePath file ++ " already exists; not overwriting" return Nothing , ifM (checkIgnored (checkGitIgnoreOption o) file) ( do - warning $ "not adding " ++ file ++ " which is .gitignored (use --no-check-gitignore to override)" + warning $ "not adding " ++ fromRawFilePath file ++ " which is .gitignored (use --no-check-gitignore to override)" return Nothing , a CanAddFile ) diff --git a/Command/Assistant.hs b/Command/Assistant.hs --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -12,6 +12,7 @@ import Annex.Init import Annex.Path import Config.Files +import Config.Files.AutoStart import qualified BuildInfo import Utility.HumanTime import Assistant.Install diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -72,7 +72,7 @@ Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key where shouldCopy - | autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<) + | autoMode o = want <||> numCopiesCheck file key (<) | otherwise = return True want = case fromToOptions o of Right (ToRemote dest) -> diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -15,6 +15,7 @@ import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Annex.NumCopies import Annex.Content +import qualified Utility.RawFilePath as R cmd :: Command cmd = command "dropunused" SectionMaintenance @@ -63,8 +64,8 @@ where droplocal = Command.Drop.performLocal key (AssociatedFile Nothing) numcopies [] -performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform +performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform performOther filespec key = do f <- fromRepo $ filespec key - pruneTmpWorkDirBefore f (liftIO . nukeFile) + pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith R.removeLink) next $ return True diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,17 +10,70 @@ import Command import qualified Utility.Format import Command.Find (parseFormatOption, showFormatted, keyVars) +import Annex.Link +import Backend +import Types.Backend +import Types.Key +import Data.Char +import qualified Data.ByteString as B + cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $ withGlobalOptions [jsonOptions] $ command "examinekey" SectionPlumbing "prints information from a key" (paramRepeating paramKey) - (batchable run (optional parseFormatOption)) + (batchable run optParser) -run :: Maybe Utility.Format.Format -> SeekInput -> String -> Annex Bool -run format _ p = do - let k = fromMaybe (giveup "bad key") $ deserializeKey p - showFormatted format (serializeKey' k) (keyVars k) +data ExamineOptions = ExamineOptions + { format :: Maybe Utility.Format.Format + , migrateToBackend :: Maybe (DeferredParse Backend) + , associatedFile :: AssociatedFile + } + +optParser :: Parser ExamineOptions +optParser = ExamineOptions + <$> optional parseFormatOption + <*> (fmap (DeferredParse . tobackend) <$> migrateopt) + <*> (AssociatedFile <$> fileopt) + where + fileopt = optional $ strOption + ( long "filename" <> metavar paramFile + <> help "file associated with the key" + ) + migrateopt = optional $ strOption + ( long "migrate-to-backend" <> metavar paramName + <> help "migrate key to other backend when possible" + ) + tobackend = lookupBackendVariety . parseKeyVariety . encodeBS + +run :: ExamineOptions -> SeekInput -> String -> Annex Bool +run o _ input = do + k <- getkey + + objectpath <- calcRepo $ gitAnnexLocation k + let objectpointer = formatPointer k + showFormatted (format o) (serializeKey' k) $ + [ ("objectpath", fromRawFilePath objectpath) + , ("objectpointer", fromRawFilePath objectpointer) + ] ++ keyVars k return True + where + -- Parse the input, which is either a key, or in batch mode + -- can be "key filename" + (ikb, ifb) = B.break (== (fromIntegral (ord ' '))) (toRawFilePath input) + ifb' = B.drop 1 ifb + ik = fromMaybe (giveup "bad key") (deserializeKey' ikb) + af = if B.null ifb' + then associatedFile o + else AssociatedFile (Just ifb') + + getkey = case migrateToBackend o of + Nothing -> pure ik + Just v -> getParsed v >>= \b -> + maybeLookupBackendVariety (fromKey keyVariety ik) >>= \case + Just ib -> case fastMigrate ib of + Just fm -> fromMaybe ik <$> fm ik b af + Nothing -> pure ik + Nothing -> pure ik diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -46,11 +46,10 @@ start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart start fixwhat si file key = do currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file - wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key + wantlink <- calcRepo $ gitAnnexLink file key case currlink of Just l - | l /= toRawFilePath wantlink -> fixby $ - fixSymlink (fromRawFilePath file) wantlink + | l /= wantlink -> fixby $ fixSymlink file wantlink | otherwise -> stop Nothing -> case fixwhat of FixAll -> fixthin @@ -73,12 +72,12 @@ breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform breakHardLink file key obj = do replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do + let tmp' = toRawFilePath tmp mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file - let obj' = fromRawFilePath obj - unlessM (checkedCopyFile key obj' tmp mode) $ + unlessM (checkedCopyFile key obj tmp' mode) $ error "unable to break hard link" - thawContent tmp - modifyContent obj' $ freezeContent obj' + thawContent tmp' + modifyContent obj $ freezeContent obj Database.Keys.storeInodeCaches key [file] next $ return True @@ -86,25 +85,25 @@ makeHardLink file key = do replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file - linkFromAnnex key tmp mode >>= \case + linkFromAnnex key (toRawFilePath tmp) mode >>= \case LinkAnnexFailed -> error "unable to make hard link" _ -> noop next $ return True -fixSymlink :: FilePath -> FilePath -> CommandPerform +fixSymlink :: RawFilePath -> RawFilePath -> CommandPerform fixSymlink file link = do #if ! defined(mingw32_HOST_OS) -- preserve mtime of symlink mtime <- liftIO $ catchMaybeIO $ modificationTimeHiRes - <$> getSymbolicLinkStatus file + <$> R.getSymbolicLinkStatus file #endif createWorkTreeDirectory (parentDir file) - liftIO $ removeFile file - liftIO $ createSymbolicLink link file + liftIO $ R.removeLink file + liftIO $ R.createSymbolicLink link file #if ! defined(mingw32_HOST_OS) liftIO $ maybe noop (\t -> touch file t False) mtime #endif - next $ cleanupSymlink file + next $ cleanupSymlink (fromRawFilePath file) cleanupSymlink :: FilePath -> CommandCleanup cleanupSymlink file = do diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -16,6 +16,7 @@ import Annex.Perms import qualified Annex import qualified Backend.URL +import qualified Utility.RawFilePath as R import Network.URI @@ -51,12 +52,12 @@ let (keyname, file) = separate (== ' ') s if not (null keyname) && not (null file) then do - file' <- liftIO $ relPathCwdToFile file + file' <- liftIO $ relPathCwdToFile (toRawFilePath file) return $ Right (file', keyOpt keyname) else return $ Left "Expected pairs of key and filename" go (si, (file, key)) = - let ai = mkActionItem (key, toRawFilePath file) + let ai = mkActionItem (key, file) in starting "fromkey" ai si $ perform key file @@ -67,9 +68,11 @@ inbackend <- inAnnex key unless inbackend $ giveup $ "key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" - let ai = mkActionItem (key, toRawFilePath file) + let ai = mkActionItem (key, file') starting "fromkey" ai si $ - perform key file + perform key file' + where + file' = toRawFilePath file -- From user input to a Key. -- User can input either a serialized key, or an url. @@ -86,15 +89,15 @@ Just k -> k Nothing -> giveup $ "bad key/url " ++ s -perform :: Key -> FilePath -> CommandPerform -perform key file = lookupKeyNotHidden (toRawFilePath file) >>= \case - Nothing -> ifM (liftIO $ doesFileExist file) +perform :: Key -> RawFilePath -> CommandPerform +perform key file = lookupKeyNotHidden file >>= \case + Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file)) ( hasothercontent , do link <- calcRepo $ gitAnnexLink file key createWorkTreeDirectory (parentDir file) - liftIO $ createSymbolicLink link file - Annex.Queue.addCommand "add" [Param "--"] [file] + liftIO $ R.createSymbolicLink link file + Annex.Queue.addCommand "add" [Param "--"] [fromRawFilePath file] next $ return True ) Just k @@ -102,5 +105,5 @@ | otherwise -> hasothercontent where hasothercontent = do - warning $ file ++ " already exists with different content" + warning $ fromRawFilePath file ++ " already exists with different content" next $ return False diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Command.Fsck where @@ -42,6 +43,7 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.Either +import qualified System.FilePath.ByteString as P cmd :: Command cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ @@ -115,7 +117,7 @@ start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case Nothing -> stop Just backend -> do - numcopies <- getFileNumCopies (fromRawFilePath file) + numcopies <- getFileNumCopies file case from of Nothing -> go $ perform key file backend numcopies Just r -> go $ performRemote key afile backend numcopies r @@ -177,11 +179,11 @@ pid <- liftIO getPID t <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory t - let tmp = t "fsck" ++ show pid ++ "." ++ fromRawFilePath (keyFile key) - let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) + let tmp = t P. "fsck" <> toRawFilePath (show pid) <> "." <> keyFile key + let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop) cleanup cleanup `after` a tmp - getfile tmp = ifM (checkDiskSpace (Just (takeDirectory tmp)) key 0 True) + getfile tmp = ifM (checkDiskSpace (Just (P.takeDirectory tmp)) key 0 True) ( ifM (getcheap tmp) ( return (Just True) , ifM (Annex.getState Annex.fast) @@ -191,10 +193,10 @@ ) , return (Just False) ) - getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp dummymeter + getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter dummymeter _ = noop getcheap tmp = case Remote.retrieveKeyFileCheap remote of - Just a -> isRight <$> tryNonAsync (a key afile tmp) + Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp)) Nothing -> return False startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart @@ -222,16 +224,16 @@ {- Checks that symlinks points correctly to the annexed content. -} fixLink :: Key -> RawFilePath -> Annex Bool fixLink key file = do - want <- calcRepo $ gitAnnexLink (fromRawFilePath file) key + want <- calcRepo $ gitAnnexLink file key have <- getAnnexLinkTarget file maybe noop (go want) have return True where go want have - | want /= fromRawFilePath (fromInternalGitPath have) = do + | want /= fromInternalGitPath have = do showNote "fixing link" - createWorkTreeDirectory (parentDir (fromRawFilePath file)) - liftIO $ removeFile (fromRawFilePath file) + createWorkTreeDirectory (parentDir file) + liftIO $ R.removeLink file addAnnexLink want file | otherwise = noop @@ -239,9 +241,9 @@ - in this repository only. -} verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool verifyLocationLog key keystatus ai = do - obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + obj <- calcRepo (gitAnnexLocation key) present <- if isKeyUnlockedThin keystatus - then liftIO (doesFileExist obj) + then liftIO (doesFileExist (fromRawFilePath obj)) else inAnnex key u <- getUUID @@ -253,8 +255,8 @@ KeyLockedThin -> thawContent obj _ -> freezeContent obj unlessM (isContentWritePermOk obj) $ - warning $ "** Unable to set correct write mode for " ++ obj ++ " ; perhaps you don't own that file" - whenM (liftIO $ doesDirectoryExist $ parentDir obj) $ + warning $ "** Unable to set correct write mode for " ++ fromRawFilePath obj ++ " ; perhaps you don't own that file" + whenM (liftIO $ R.doesPathExist $ parentDir obj) $ freezeContentDir obj {- Warn when annex.securehashesonly is set and content using an @@ -263,7 +265,7 @@ - config was set. -} whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $ whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ - warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key" + warning $ "** Despite annex.securehashesonly being set, " ++ fromRawFilePath obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key" verifyLocationLog' key ai present u (logChange key u) @@ -344,13 +346,14 @@ Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do + let tmp' = toRawFilePath tmp mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file ifM (annexThin <$> Annex.getGitConfig) - ( void $ linkFromAnnex key tmp mode + ( void $ linkFromAnnex key tmp' mode , do - obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) - void $ checkedCopyFile key obj tmp mode - thawContent tmp + obj <- calcRepo (gitAnnexLocation key) + void $ checkedCopyFile key obj tmp' mode + thawContent tmp' ) Database.Keys.storeInodeCaches key [file] _ -> return () @@ -366,19 +369,19 @@ checkKeySize key _ ai = do file <- calcRepo $ gitAnnexLocation key ifM (liftIO $ R.doesPathExist file) - ( checkKeySizeOr badContent key (fromRawFilePath file) ai + ( checkKeySizeOr badContent key file ai , return True ) -withLocalCopy :: Maybe FilePath -> (FilePath -> Annex Bool) -> Annex Bool +withLocalCopy :: Maybe RawFilePath -> (RawFilePath -> Annex Bool) -> Annex Bool withLocalCopy Nothing _ = return True withLocalCopy (Just localcopy) f = f localcopy -checkKeySizeRemote :: Key -> Remote -> ActionItem -> FilePath -> Annex Bool +checkKeySizeRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool checkKeySizeRemote key remote ai localcopy = checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai -checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> ActionItem -> Annex Bool +checkKeySizeOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool checkKeySizeOr bad key file ai = case fromKey keySize key of Nothing -> return True Just size -> do @@ -436,25 +439,25 @@ content <- calcRepo (gitAnnexLocation key) ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( nocheck - , checkBackendOr badContent backend key (fromRawFilePath content) ai + , checkBackendOr badContent backend key content ai ) where nocheck = return True ai = mkActionItem (key, afile) -checkBackendRemote :: Backend -> Key -> Remote -> ActionItem -> FilePath -> Annex Bool +checkBackendRemote :: Backend -> Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool checkBackendRemote backend key remote ai localcopy = checkBackendOr (badContentRemote remote localcopy) backend key localcopy ai -checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> ActionItem -> Annex Bool +checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> RawFilePath -> ActionItem -> Annex Bool checkBackendOr bad backend key file ai = checkBackendOr' bad backend key file ai (return True) -- The postcheck action is run after the content is verified, -- in order to detect situations where the file is changed while being -- verified. -checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> ActionItem -> Annex Bool -> Annex Bool +checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> RawFilePath -> ActionItem -> Annex Bool -> Annex Bool checkBackendOr' bad backend key file ai postcheck = case Types.Backend.verifyKeyContent backend of Nothing -> return True @@ -529,19 +532,20 @@ - symlink to a file in the remote). To avoid any further data loss, - that temp file is moved to the bad content directory unless - the local annex has a copy of the content. -} -badContentRemote :: Remote -> FilePath -> Key -> Annex String +badContentRemote :: Remote -> RawFilePath -> Key -> Annex String badContentRemote remote localcopy key = do bad <- fromRepo gitAnnexBadDir - let destbad = bad fromRawFilePath (keyFile key) - movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) + let destbad = bad P. keyFile key + let destbad' = fromRawFilePath destbad + movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad')) ( return False , do createAnnexDirectory (parentDir destbad) liftIO $ catchDefaultIO False $ - ifM (isSymbolicLink <$> getSymbolicLinkStatus localcopy) - ( copyFileExternal CopyTimeStamps localcopy destbad + ifM (isSymbolicLink <$> R.getSymbolicLinkStatus localcopy) + ( copyFileExternal CopyTimeStamps (fromRawFilePath localcopy) destbad' , do - moveFile localcopy destbad + moveFile (fromRawFilePath localcopy) destbad' return True ) ) @@ -551,7 +555,7 @@ Remote.logStatus remote key InfoMissing return $ case (movedbad, dropped) of (True, Right ()) -> "moved from " ++ Remote.name remote ++ - " to " ++ destbad + " to " ++ fromRawFilePath destbad (False, Right ()) -> "dropped from " ++ Remote.name remote (_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e @@ -584,10 +588,10 @@ recordStartTime u = do f <- fromRepo (gitAnnexFsckState u) createAnnexDirectory $ parentDir f - liftIO $ nukeFile f - liftIO $ withFile f WriteMode $ \h -> do + liftIO $ removeWhenExistsWith R.removeLink f + liftIO $ withFile (fromRawFilePath f) WriteMode $ \h -> do #ifndef mingw32_HOST_OS - t <- modificationTime <$> getFileStatus f + t <- modificationTime <$> R.getFileStatus f #else t <- getPOSIXTime #endif @@ -598,16 +602,17 @@ showTime = show resetStartTime :: UUID -> Annex () -resetStartTime u = liftIO . nukeFile =<< fromRepo (gitAnnexFsckState u) +resetStartTime u = liftIO . removeWhenExistsWith R.removeLink + =<< fromRepo (gitAnnexFsckState u) {- Gets the incremental fsck start time. -} getStartTime :: UUID -> Annex (Maybe EpochTime) getStartTime u = do f <- fromRepo (gitAnnexFsckState u) liftIO $ catchDefaultIO Nothing $ do - timestamp <- modificationTime <$> getFileStatus f + timestamp <- modificationTime <$> R.getFileStatus f let fromstatus = Just (realToFrac timestamp) - fromfile <- parsePOSIXTime <$> readFile f + fromfile <- parsePOSIXTime <$> readFile (fromRawFilePath f) return $ if matchingtimestamp fromfile fromstatus then Just timestamp else Nothing diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -174,10 +174,11 @@ runFuzzAction :: FuzzAction -> Annex () runFuzzAction (FuzzAdd (FuzzFile f)) = do - createWorkTreeDirectory (parentDir f) + createWorkTreeDirectory (parentDir (toRawFilePath f)) n <- liftIO (getStdRandom random :: IO Int) liftIO $ writeFile f $ show n ++ "\n" -runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f +runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ + removeWhenExistsWith removeLink f runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ rename src dest runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ @@ -208,7 +209,7 @@ case md of Nothing -> genFuzzAction Just d -> do - newd <- liftIO $ newDir (parentDir $ toFilePath d) + newd <- liftIO $ newDir (parentDir $ toRawFilePath $ toFilePath d) maybe genFuzzAction (return . FuzzMoveDir d) newd FuzzDeleteDir _ -> do d <- liftIO existingDir @@ -260,13 +261,13 @@ , go (n - 1) ) -newDir :: FilePath -> IO (Maybe FuzzDir) +newDir :: RawFilePath -> IO (Maybe FuzzDir) newDir parent = go (100 :: Int) where go 0 = return Nothing go n = do (FuzzDir d) <- genFuzzDir - ifM (doesnotexist (parent d)) + ifM (doesnotexist (fromRawFilePath parent d)) ( return $ Just $ FuzzDir d , go (n - 1) ) diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -60,7 +60,7 @@ afile = AssociatedFile (Just file) ai = mkActionItem (key, afile) expensivecheck - | autoMode o = numCopiesCheck (fromRawFilePath file) key (<) + | autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) afile | otherwise = return True @@ -118,5 +118,6 @@ download (Remote.uuid r) key afile stdRetry (\p -> do showAction $ "from " ++ Remote.name r - Remote.verifiedAction (Remote.retrieveKeyFile r key afile dest p) + Remote.verifiedAction $ + Remote.retrieveKeyFile r key afile (fromRawFilePath dest) p ) witness diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -34,6 +34,7 @@ import Git.Types import Types.Import import Utility.Metered +import qualified Utility.RawFilePath as R import Control.Concurrent.STM @@ -118,10 +119,11 @@ seek :: ImportOptions -> CommandSeek seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do - repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath - inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o) + repopath <- liftIO . absPath =<< fromRepo Git.repoPath + inrepops <- liftIO $ filter (dirContains repopath) + <$> mapM (absPath . toRawFilePath) (importFiles o) unless (null inrepops) $ do - giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops + giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords (map fromRawFilePath inrepops) largematcher <- largeFilesMatcher addunlockedmatcher <- addUnlockedMatcher (commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o)) @@ -136,23 +138,21 @@ (importToSubDir o) seekRemote r (importToBranch o) subdir (importContent o) (checkGitIgnoreOption o) -startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart +startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (RawFilePath, RawFilePath) -> CommandStart startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = - ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) + ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus srcfile) ( starting "import" ai si pickaction , stop ) where - ai = ActionItemWorkTreeFile destfile' + ai = ActionItemWorkTreeFile destfile si = SeekInput [] - destfile' = toRawFilePath destfile - deletedup k = do showNote $ "duplicate of " ++ serializeKey k verifyExisting k destfile ( do - liftIO $ removeFile srcfile + liftIO $ R.removeLink srcfile next $ return True , do warning "Could not verify that the content is still present in the annex; not removing from the import location." @@ -165,35 +165,35 @@ ignored <- checkIgnored (checkGitIgnoreOption o) destfile if ignored then do - warning $ "not importing " ++ destfile ++ " which is .gitignored (use --no-check-gitignore to override)" + warning $ "not importing " ++ fromRawFilePath destfile ++ " which is .gitignored (use --no-check-gitignore to override)" stop else do - existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile) + existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile) case existing of Nothing -> importfilechecked ld k Just s | isDirectory s -> notoverwriting "(is a directory)" | isSymbolicLink s -> ifM (Annex.getState Annex.force) ( do - liftIO $ nukeFile destfile + liftIO $ removeWhenExistsWith R.removeLink destfile importfilechecked ld k , notoverwriting "(is a symlink)" ) | otherwise -> ifM (Annex.getState Annex.force) ( do - liftIO $ nukeFile destfile + liftIO $ removeWhenExistsWith R.removeLink destfile importfilechecked ld k , notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)" ) checkdestdir cont = do let destdir = parentDir destfile - existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destdir) + existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destdir) case existing of Nothing -> cont Just s | isDirectory s -> cont | otherwise -> do - warning $ "not importing " ++ destfile ++ " because " ++ destdir ++ " is not a directory" + warning $ "not importing " ++ fromRawFilePath destfile ++ " because " ++ fromRawFilePath destdir ++ " is not a directory" stop importfilechecked ld k = do @@ -201,13 +201,17 @@ -- The dest file is what will be ingested. createWorkTreeDirectory (parentDir destfile) liftIO $ if mode == Duplicate || mode == SkipDuplicates - then void $ copyFileExternal CopyAllMetaData srcfile destfile - else moveFile srcfile destfile + then void $ copyFileExternal CopyAllMetaData + (fromRawFilePath srcfile) + (fromRawFilePath destfile) + else moveFile + (fromRawFilePath srcfile) + (fromRawFilePath destfile) -- Get the inode cache of the dest file. It should be -- weakly the same as the originally locked down file's -- inode cache. (Since the file may have been copied, -- its inodes may not be the same.) - newcache <- withTSDelta $ liftIO . genInodeCache destfile' + newcache <- withTSDelta $ liftIO . genInodeCache destfile let unchanged = case (newcache, inodeCache (keySource ld)) of (_, Nothing) -> True (Just newc, Just c) | compareWeak c newc -> True @@ -218,8 +222,8 @@ -- is what will be ingested. let ld' = ld { keySource = KeySource - { keyFilename = destfile' - , contentLocation = destfile' + { keyFilename = destfile + , contentLocation = destfile , inodeCache = newcache } } @@ -228,15 +232,15 @@ >>= maybe stop (\addedk -> next $ Command.Add.cleanup addedk True) - , next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile' + , next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile ) notoverwriting why = do - warning $ "not overwriting existing " ++ destfile ++ " " ++ why + warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why stop lockdown a = do let mi = MatchingFile $ FileInfo - { contentFile = Just (toRawFilePath srcfile) - , matchFile = toRawFilePath destfile + { contentFile = Just srcfile + , matchFile = destfile } lockingfile <- not <$> addUnlocked addunlockedmatcher mi -- Minimal lock down with no hard linking so nothing @@ -245,7 +249,7 @@ { lockingFile = lockingfile , hardlinkFileTmpDir = Nothing } - v <- lockDown cfg srcfile + v <- lockDown cfg (fromRawFilePath srcfile) case v of Just ld -> do backend <- chooseBackend destfile @@ -270,7 +274,7 @@ _ -> importfile ld k skipbecause s = showNote (s ++ "; skipping") >> next (return True) -verifyExisting :: Key -> FilePath -> (CommandPerform, CommandPerform) -> CommandPerform +verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform verifyExisting key destfile (yes, no) = do -- Look up the numcopies setting for the file that it would be -- imported to, if it were imported. diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -22,6 +22,7 @@ import qualified Data.Text as T import System.Log.Logger import Control.Concurrent.Async +import qualified System.FilePath.ByteString as P import Command import qualified Annex @@ -188,13 +189,14 @@ performDownload addunlockedmatcher opts cache todownload = case location todownload of Enclosure url -> checkknown url $ rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do + let f' = fromRawFilePath f r <- Remote.claimingUrl url if Remote.uuid r == webUUID || rawOption (downloadOptions opts) then do let dlopts = (downloadOptions opts) -- force using the filename -- chosen here - { fileOption = Just f + { fileOption = Just f' -- don't use youtube-dl , rawOption = True } @@ -218,7 +220,8 @@ downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz Right (UrlMulti l) -> do kl <- forM l $ \(url', sz, subf) -> - downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' (f sanitizeFilePath subf) sz + let dest = f P. toRawFilePath (sanitizeFilePath subf) + in downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' dest sz return $ Just $ if all isJust kl then catMaybes kl else [] @@ -257,7 +260,7 @@ Nothing -> return True Just f -> do showStartOther "addurl" (Just url) (SeekInput []) - getter f >>= \case + getter (toRawFilePath f) >>= \case Just ks -- Download problem. | null ks -> do @@ -307,7 +310,7 @@ | rawOption (downloadOptions opts) = downloadlink | otherwise = do r <- withTmpWorkDir mediakey $ \workdir -> do - dl <- youtubeDl linkurl workdir nullMeterUpdate + dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate case dl of Right (Just mediafile) -> do let ext = case takeExtension mediafile of @@ -315,7 +318,7 @@ s -> s ok <- rundownload linkurl ext $ \f -> checkCanAdd (downloadOptions opts) f $ \canadd -> do - addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile) + addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile)) return (Just [mediakey]) return (Just ok) -- youtude-dl didn't support it, so @@ -454,9 +457,10 @@ - least 23 hours. -} checkFeedBroken :: URLString -> Annex Bool checkFeedBroken url = checkFeedBroken' url =<< feedState url -checkFeedBroken' :: URLString -> FilePath -> Annex Bool +checkFeedBroken' :: URLString -> RawFilePath -> Annex Bool checkFeedBroken' url f = do - prev <- maybe Nothing readish <$> liftIO (catchMaybeIO $ readFile f) + prev <- maybe Nothing readish + <$> liftIO (catchMaybeIO $ readFile (fromRawFilePath f)) now <- liftIO getCurrentTime case prev of Nothing -> do @@ -471,7 +475,9 @@ return broken clearFeedProblem :: URLString -> Annex () -clearFeedProblem url = void $ liftIO . tryIO . removeFile =<< feedState url +clearFeedProblem url = + void $ liftIO . tryIO . removeFile . fromRawFilePath + =<< feedState url -feedState :: URLString -> Annex FilePath +feedState :: URLString -> Annex RawFilePath feedState url = fromRepo $ gitAnnexFeedState $ fromUrl url Nothing diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -12,6 +12,7 @@ import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M import qualified Data.Vector as V +import qualified System.FilePath.ByteString as P import Data.Ord import qualified Data.Semigroup as Sem import Prelude @@ -152,9 +153,9 @@ case v' of Right u -> uuidInfo o u si Left _ -> do - relp <- liftIO $ relPathCwdToFile p - ifAnnexed (toRawFilePath relp) - (fileInfo o relp si) + relp <- liftIO $ relPathCwdToFile (toRawFilePath p) + ifAnnexed relp + (fileInfo o (fromRawFilePath relp) si) (treeishInfo o p si) ) where @@ -435,7 +436,7 @@ where desc = "transfers in progress" line uuidmap t i = unwords - [ formatDirection (transferDirection t) ++ "ing" + [ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing" , fromRawFilePath $ actionItemDesc $ mkActionItem (transferKey t, associatedFile i) , if transferDirection t == Upload then "to" else "from" @@ -579,7 +580,7 @@ then return (numcopiesstats, repodata) else do locs <- Remote.keyLocations key - nc <- updateNumCopiesStats (fromRawFilePath file) numcopiesstats locs + nc <- updateNumCopiesStats file numcopiesstats locs return (nc, updateRepoData key locs repodata) return $! (presentdata', referenceddata', numcopiesstats', repodata') , return vs @@ -643,7 +644,7 @@ M.fromList $ zip locs (map update locs) update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m) -updateNumCopiesStats :: FilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats +updateNumCopiesStats :: RawFilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats updateNumCopiesStats file (NumCopiesStats m) locs = do have <- trustExclude UnTrusted locs !variance <- Variance <$> numCopiesCheck' file (-) have @@ -663,7 +664,7 @@ "+ " ++ show (unknownSizeKeys d) ++ " unknown size" -staleSize :: String -> (Git.Repo -> FilePath) -> Stat +staleSize :: String -> (Git.Repo -> RawFilePath) -> Stat staleSize label dirspec = go =<< lift (dirKeys dirspec) where go [] = nostat @@ -675,8 +676,8 @@ return $ sizer storageUnits False size keysizes keys = do dir <- lift $ fromRepo dirspec - liftIO $ forM keys $ \k -> catchDefaultIO 0 $ - getFileSize (dir fromRawFilePath (keyFile k)) + liftIO $ forM keys $ \k -> + catchDefaultIO 0 $ getFileSize (dir P. keyFile k) aside :: String -> String aside s = " (" ++ s ++ ")" diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -55,7 +55,7 @@ start' :: Key -> CommandStart start' k = startingCustomOutput k $ do - tmpf <- fromRepo $ gitAnnexTmpObjectLocation k + tmpf <- fromRawFilePath <$> fromRepo (gitAnnexTmpObjectLocation k) whenM (liftIO $ doesFileExist tmpf) $ liftIO $ putStrLn tmpf next $ return True diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -60,26 +60,25 @@ perform :: RawFilePath -> Key -> CommandPerform perform file key = do lockdown =<< calcRepo (gitAnnexLocation key) - addLink (CheckGitIgnore False) (fromRawFilePath file) key + addLink (CheckGitIgnore False) file key =<< withTSDelta (liftIO . genInodeCache file) next $ cleanup file key where lockdown obj = do ifM (isUnmodified key obj) ( breakhardlink obj - , repopulate (fromRawFilePath obj) + , repopulate obj ) whenM (liftIO $ R.doesPathExist obj) $ - freezeContent $ fromRawFilePath obj + freezeContent obj -- It's ok if the file is hard linked to obj, but if some other -- associated file is, we need to break that link to lock down obj. breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do - let obj' = fromRawFilePath obj - modifyContent obj' $ replaceGitAnnexDirFile obj' $ \tmp -> do - unlessM (checkedCopyFile key obj' tmp Nothing) $ + modifyContent obj $ replaceGitAnnexDirFile (fromRawFilePath obj) $ \tmp -> do + unlessM (checkedCopyFile key obj (toRawFilePath tmp) Nothing) $ giveup "unable to lock file" Database.Keys.storeInodeCaches key [obj] @@ -89,10 +88,10 @@ fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key mfile <- firstM (isUnmodified key) fs - liftIO $ nukeFile obj + liftIO $ removeWhenExistsWith R.removeLink obj case mfile of Just unmodified -> - unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing) + unlessM (checkedCopyFile key unmodified obj Nothing) lostcontent Nothing -> lostcontent diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -12,6 +12,7 @@ import Data.Char import Data.Time.Clock.POSIX import Data.Time +import qualified System.FilePath.ByteString as P import Command import Logs @@ -207,10 +208,10 @@ getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool) getKeyLog key os = do top <- fromRepo Git.repoPath - p <- liftIO $ relPathCwdToFile $ fromRawFilePath top + p <- liftIO $ relPathCwdToFile top config <- Annex.getGitConfig - let logfile = p fromRawFilePath (locationLogFile config key) - getGitLog [logfile] (Param "--remove-empty" : os) + let logfile = p P. locationLogFile config key + getGitLog [fromRawFilePath logfile] (Param "--remove-empty" : os) {- Streams the git log for all git-annex branch changes. -} getAllLog :: [CommandParam] -> Annex ([RefChange], IO Bool) diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -178,8 +178,7 @@ | Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r | Git.repoIsUrl r = return r | otherwise = liftIO $ do - r' <- Git.Construct.fromAbsPath - =<< absPath (fromRawFilePath (Git.repoPath r)) + r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r) r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r' return (fromMaybe r' r'') diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -165,8 +165,8 @@ (Just k, _) -> return $ Right (Right k, m) (Nothing, Just f) -> do - f' <- liftIO $ relPathCwdToFile f - return $ Right (Left (toRawFilePath f'), m) + f' <- liftIO $ relPathCwdToFile (toRawFilePath f) + return $ Right (Left f', m) (Nothing, Nothing) -> return $ Left "JSON input is missing either file or key" diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -44,7 +44,7 @@ Just oldbackend -> do exists <- inAnnex key newbackend <- maybe defaultBackend return - =<< chooseBackend (fromRawFilePath file) + =<< chooseBackend file if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists then starting "migrate" (mkActionItem (key, file)) si $ perform file key oldbackend newbackend diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -88,4 +88,4 @@ where getnumcopies = case afile of AssociatedFile Nothing -> getNumCopies - AssociatedFile (Just af) -> getFileNumCopies (fromRawFilePath af) + AssociatedFile (Just af) -> getFileNumCopies af diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -151,7 +151,7 @@ when fastcheck $ warning "This could have failed because --fast is enabled." stop - Right True -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> + Right True -> logMove srcuuid destuuid True key $ \deststartedwithcopy -> finish deststartedwithcopy $ unlessM (expectedPresent dest key) $ Remote.logStatus dest key InfoPresent @@ -226,7 +226,7 @@ get = notifyTransfer Download afile $ download (Remote.uuid src) key afile stdRetry $ \p -> getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key $ \t -> - Remote.verifiedAction $ Remote.retrieveKeyFile src key afile t p + Remote.verifiedAction $ Remote.retrieveKeyFile src key afile (fromRawFilePath t) p dispatch _ _ False = stop -- failed dispatch RemoveNever _ True = next $ return True -- copy complete @@ -363,7 +363,7 @@ go logf -- Only need to check log when there is a copy. | deststartedwithcopy = do - wasnocopy <- checkLogFile logf gitAnnexMoveLock + wasnocopy <- checkLogFile (fromRawFilePath logf) gitAnnexMoveLock (== logline) if wasnocopy then go' False diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -83,8 +83,8 @@ (s, ok) <- case k of KeyContainer s -> liftIO $ genkey (Param s) KeyFile f -> do - createAnnexDirectory (takeDirectory f) - liftIO $ nukeFile f + createAnnexDirectory (toRawFilePath (takeDirectory f)) + liftIO $ removeWhenExistsWith removeLink f liftIO $ protectedOutput $ genkey (File f) case (ok, parseFingerprint s) of (False, _) -> giveup $ "uftp_keymgt failed: " ++ s @@ -176,8 +176,8 @@ (callback, environ, statush) <- liftIO multicastCallbackEnv tmpobjdir <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory tmpobjdir - withTmpDirIn tmpobjdir "multicast" $ \tmpdir -> withAuthList $ \authlist -> do - abstmpdir <- liftIO $ absPath tmpdir + withTmpDirIn (fromRawFilePath tmpobjdir) "multicast" $ \tmpdir -> withAuthList $ \authlist -> do + abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir) abscallback <- liftIO $ searchPath callback let ps = -- Avoid it running as a daemon. @@ -190,7 +190,7 @@ , Param "-S", Param authlist -- Receive files into tmpdir -- (it needs an absolute path) - , Param "-D", File abstmpdir + , Param "-D", File (fromRawFilePath abstmpdir) -- Run callback after each file received -- (it needs an absolute path) , Param "-s", Param (fromMaybe callback abscallback) @@ -210,11 +210,11 @@ case deserializeKey (takeFileName f) of Nothing -> do warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f Just k -> void $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \dest -> unVerified $ liftIO $ catchBoolIO $ do - rename f dest + rename f (fromRawFilePath dest) return True -- Under Windows, uftp uses key containers, which are not files on the diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -220,11 +220,11 @@ -- to read them. So, set up a temp directory that only -- we can read. withTmpDir "pair" $ \tmp -> do - liftIO $ void $ tryIO $ modifyFileMode tmp $ + liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $ removeModes otherGroupModes let sendf = tmp "send" let recvf = tmp "recv" - liftIO $ writeFileProtected sendf $ + liftIO $ writeFileProtected (toRawFilePath sendf) $ serializePairData ourpairdata observer <- liftIO Wormhole.mkCodeObserver @@ -256,7 +256,7 @@ Wormhole.sendFile sendf observer wormholeparams `concurrently` Wormhole.receiveFile recvf producer wormholeparams - liftIO $ nukeFile sendf + liftIO $ removeWhenExistsWith removeLink sendf if sendres /= True then return SendFailed else if recvres /= True diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -47,8 +47,8 @@ Nothing -> return $ Left "bad key" Just k -> do let f = reverse rf - f' <- liftIO $ relPathCwdToFile f - return $ Right (toRawFilePath f', k) + f' <- liftIO $ relPathCwdToFile (toRawFilePath f) + return $ Right (f', k) seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of @@ -91,27 +91,28 @@ - unlocked file, which would leave the new key unlocked - and vulnerable to corruption. -} ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do - oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey) + oldobj <- calcRepo (gitAnnexLocation oldkey) isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing , do {- The file being rekeyed is itself an unlocked file; if - it's hard linked to the old key, that link must be broken. -} - oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey) + oldobj <- calcRepo (gitAnnexLocation oldkey) v <- tryNonAsync $ do st <- liftIO $ R.getFileStatus file when (linkCount st > 1) $ do freezeContent oldobj replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do - unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ + let tmp' = toRawFilePath tmp + unlessM (checkedCopyFile oldkey oldobj tmp' Nothing) $ error "can't lock old key" - thawContent tmp + thawContent tmp' ic <- withTSDelta (liftIO . genInodeCache file) case v of Left e -> do warning (show e) return False Right () -> do - r <- linkToAnnex newkey (fromRawFilePath file) ic + r <- linkToAnnex newkey file ic return $ case r of LinkAnnexFailed -> False LinkAnnexOk -> True @@ -124,7 +125,7 @@ ( do -- Update symlink to use the new key. liftIO $ removeFile (fromRawFilePath file) - addLink (CheckGitIgnore False) (fromRawFilePath file) newkey Nothing + addLink (CheckGitIgnore False) file newkey Nothing , do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file liftIO $ whenM (isJust <$> isPointerFile file) $ diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -45,4 +45,4 @@ go tmp = unVerified $ do opts <- filterRsyncSafeOptions . maybe [] words <$> getField "RsyncOptions" - liftIO $ rsyncServerReceive (map Param opts) tmp + liftIO $ rsyncServerReceive (map Param opts) (fromRawFilePath tmp) diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -43,11 +43,13 @@ startSrcDest :: [FilePath] -> CommandStart startSrcDest ps@(src:dest:[]) | src == dest = stop - | otherwise = notAnnexed src $ ifAnnexed (toRawFilePath dest) go stop + | otherwise = notAnnexed src' $ + ifAnnexed (toRawFilePath dest) go stop where + src' = toRawFilePath src go key = starting "reinject" ai si $ - ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src) - ( perform src key + ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src') + ( perform src' key , giveup $ src ++ " does not have expected content of " ++ dest ) ai = ActionItemOther (Just src) @@ -55,31 +57,31 @@ startSrcDest _ = giveup "specify a src file and a dest file" startKnown :: FilePath -> CommandStart -startKnown src = notAnnexed src $ +startKnown src = notAnnexed src' $ starting "reinject" ai si $ do (key, _) <- genKey ks nullMeterUpdate Nothing ifM (isKnownKey key) - ( perform src key + ( perform src' key , do warning "Not known content; skipping" next $ return True ) where - ks = KeySource src' src' Nothing src' = toRawFilePath src + ks = KeySource src' src' Nothing ai = ActionItemOther (Just src) si = SeekInput [src] -notAnnexed :: FilePath -> CommandStart -> CommandStart +notAnnexed :: RawFilePath -> CommandStart -> CommandStart notAnnexed src a = ifM (fromRepo Git.repoIsLocalBare) ( a - , ifAnnexed (toRawFilePath src) - (giveup $ "cannot used annexed file as src: " ++ src) + , ifAnnexed src + (giveup $ "cannot used annexed file as src: " ++ fromRawFilePath src) a ) -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform src key = ifM move ( next $ cleanup key , error "failed" diff --git a/Command/Repair.hs b/Command/Repair.hs --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -14,6 +14,7 @@ import qualified Git.Ref import Git.Types import Annex.Version +import qualified Utility.RawFilePath as R cmd :: Command cmd = noCommit $ dontCheck repoExists $ @@ -75,7 +76,7 @@ Annex.Branch.forceCommit "committing index after git repository repair" liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index" nukeindex = do - inRepo $ nukeFile . gitAnnexIndex + inRepo $ removeWhenExistsWith R.removeLink . gitAnnexIndex liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt." missingbranch = liftIO $ putStrLn "Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast" diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -41,7 +41,8 @@ | null ru || null rf -> return $ Left "Expected: \"file url\"" | otherwise -> do let f = reverse rf - f' <- liftIO $ relPathCwdToFile f + f' <- liftIO $ fromRawFilePath + <$> relPathCwdToFile (toRawFilePath f) return $ Right (f', reverse ru) start :: (SeekInput, (FilePath, URLString)) -> CommandStart diff --git a/Command/SetKey.hs b/Command/SetKey.hs --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -21,7 +21,7 @@ start :: [String] -> CommandStart start ps@(keyname:file:[]) = starting "setkey" ai si $ - perform file (keyOpt keyname) + perform (toRawFilePath file) (keyOpt keyname) where ai = ActionItemOther (Just file) si = SeekInput ps @@ -30,7 +30,7 @@ keyOpt :: String -> Key keyOpt = fromMaybe (giveup "bad key") . deserializeKey -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform file key = do -- the file might be on a different filesystem, so moveFile is used -- rather than simply calling moveAnnex; disk space is also @@ -38,7 +38,7 @@ ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key $ \dest -> unVerified $ if dest /= file then liftIO $ catchBoolIO $ do - moveFile file dest + moveFile (fromRawFilePath file) (fromRawFilePath dest) return True else return True if ok diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -54,7 +54,7 @@ seek :: SmudgeOptions -> CommandSeek seek (SmudgeOptions f False) = commandAction (smudge f) -seek (SmudgeOptions f True) = commandAction (clean f) +seek (SmudgeOptions f True) = commandAction (clean (toRawFilePath f)) seek UpdateOption = commandAction update -- Smudge filter is fed git file content, and if it's a pointer to an @@ -83,7 +83,7 @@ -- Clean filter is fed file content on stdin, decides if a file -- should be stored in the annex, and outputs a pointer to its -- injested content if so. Otherwise, the original content. -clean :: FilePath -> CommandStart +clean :: RawFilePath -> CommandStart clean file = do b <- liftIO $ L.hGetContents stdin ifM fileoutsiderepo @@ -98,10 +98,11 @@ where go b = case parseLinkTargetOrPointerLazy b of Just k -> do - getMoveRaceRecovery k (toRawFilePath file) - liftIO $ L.hPut stdout b + addingExistingLink file k $ do + getMoveRaceRecovery k file + liftIO $ L.hPut stdout b Nothing -> do - let fileref = Git.Ref.fileRef (toRawFilePath file) + let fileref = Git.Ref.fileRef file indexmeta <- catObjectMetaData fileref go' b indexmeta =<< catKey' fileref indexmeta go' b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) @@ -120,7 +121,7 @@ -- annexed and is unmodified. case oldkey of Nothing -> doingest oldkey - Just ko -> ifM (isUnmodifiedCheap ko (toRawFilePath file)) + Just ko -> ifM (isUnmodifiedCheap ko file) ( liftIO $ emitPointer ko , doingest oldkey ) @@ -141,7 +142,7 @@ liftIO . emitPointer =<< postingest =<< (\ld -> ingest' oldbackend nullMeterUpdate ld Nothing norestage) - =<< lockDown cfg file + =<< lockDown cfg (fromRawFilePath file) postingest (Just k, _) = do logStatus k InfoPresent @@ -156,8 +157,7 @@ -- git diff can run the clean filter on files outside the -- repository; can't annex those fileoutsiderepo = do - repopath <- liftIO . absPath . fromRawFilePath - =<< fromRepo Git.repoPath + repopath <- liftIO . absPath =<< fromRepo Git.repoPath filepath <- liftIO $ absPath file return $ not $ dirContains repopath filepath @@ -175,7 +175,7 @@ -- annexed content before, annex it. This handles cases such as renaming an -- unlocked annexed file followed by git add, which the user naturally -- expects to behave the same as git mv. -shouldAnnex :: FilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool +shouldAnnex :: RawFilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool shouldAnnex file indexmeta moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig) ( checkunchangedgitfile $ checkmatcher checkheuristics , checkunchangedgitfile checkheuristics @@ -196,7 +196,7 @@ Just _ -> return True Nothing -> checkknowninode - checkknowninode = withTSDelta (liftIO . genInodeCache (toRawFilePath file)) >>= \case + checkknowninode = withTSDelta (liftIO . genInodeCache file) >>= \case Nothing -> pure False Just ic -> Database.Keys.isInodeKnown ic =<< sentinalStatus diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -61,6 +61,6 @@ displayStatus s = do let c = statusChar s absf <- fromRepo $ fromTopFilePath (statusFile s) - f <- liftIO $ relPathCwdToFile $ fromRawFilePath absf + f <- liftIO $ fromRawFilePath <$> relPathCwdToFile absf unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ liftIO $ putStrLn $ [c] ++ " " ++ f diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -191,7 +191,7 @@ <*> pure (pushOption v) <*> pure (contentOption v) <*> pure (noContentOption v) - <*> liftIO (mapM absPath (contentOfOption v)) + <*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v)) <*> pure (cleanupOption v) <*> pure (keyOptions v) <*> pure (resolveMergeOverride v) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -251,7 +251,7 @@ , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 33%" $ \r k -> do loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) - tmp <- prepTmp k + tmp <- fromRawFilePath <$> prepTmp k partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do sz <- hFileSize h L.hGet h $ fromInteger $ sz `div` 3 @@ -260,14 +260,14 @@ get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ \r k -> do - tmp <- prepTmp k + tmp <- fromRawFilePath <$> prepTmp k liftIO $ writeFile tmp "" lockContentForRemoval k noop removeAnnex get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from end" $ \r k -> do loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) - tmp <- prepTmp k + tmp <- fromRawFilePath <$> prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k noop removeAnnex get r k @@ -293,9 +293,9 @@ Nothing -> return True Just b -> case Types.Backend.verifyKeyContent b of Nothing -> return True - Just verifier -> verifier k (serializeKey k) + Just verifier -> verifier k (serializeKey' k) get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate @@ -352,7 +352,7 @@ liftIO $ hClose h tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case Left _ -> return False - Right () -> verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified k tmp + Right () -> verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified k (toRawFilePath tmp) checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation removeexport ea k = Remote.removeExport ea k testexportlocation removeexportdirectory ea = case Remote.removeExportDirectory ea of @@ -369,14 +369,14 @@ Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of Nothing -> return False Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> unVerified $ isRight - <$> tryNonAsync (a k (AssociatedFile Nothing) dest) + <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) ] where check checkval desc a = testCase desc $ @@ -436,7 +436,7 @@ k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of Just a -> a ks nullMeterUpdate Nothing -> giveup "failed to generate random key (backend problem)" - _ <- moveAnnex k f + _ <- moveAnnex k (toRawFilePath f) return k getReadonlyKey :: Remote -> FilePath -> Annex Key diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -11,9 +11,10 @@ import Annex.Content import Types.Transfer import Logs.Transfer -import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered import Utility.SimpleProtocol +import qualified CmdLine.GitAnnexShell.Fields as Fields +import qualified Utility.RawFilePath as R cmd :: Command cmd = noCommit $ @@ -58,7 +59,7 @@ bytes <- readUpdate maybe (error "transferinfo protocol error") (update . toBytesProcessed) bytes - , tryIO $ removeFile tfile + , tryIO $ R.removeLink tfile , exitSuccess ] stop diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -64,7 +64,7 @@ fromPerform key file remote = go Upload file $ download (uuid remote) key file stdRetry $ \p -> getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> - tryNonAsync (Remote.retrieveKeyFile remote key file t p) >>= \case + tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Right v -> return (True, v) Left e -> do warning (show e) diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -48,7 +48,7 @@ | otherwise = notifyTransfer direction file $ download (Remote.uuid remote) key file stdRetry $ \p -> getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key file t p) >>= \case + r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Left e -> do warning (show e) return (False, UnVerified) diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -14,6 +14,7 @@ import Utility.CopyFile import qualified Database.Keys import Git.FilePath +import qualified Utility.RawFilePath as R cmd :: Command cmd = withGlobalOptions [annexedMatchingOptions] $ @@ -54,7 +55,7 @@ cleanup :: RawFilePath -> Key -> CommandCleanup cleanup file key = do Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) - src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + src <- calcRepo (gitAnnexLocation key) ifM (Annex.getState Annex.fast) ( do -- Only make a hard link if the annexed file does not @@ -62,19 +63,21 @@ -- This avoids unannexing (and uninit) ending up -- hard linking files together, which would be -- surprising. - s <- liftIO $ getFileStatus src + s <- liftIO $ R.getFileStatus src if linkCount s > 1 then copyfrom src else hardlinkfrom src , copyfrom src ) where - file' = fromRawFilePath file copyfrom src = - thawContent file' `after` liftIO (copyFileExternal CopyAllMetaData src file') + thawContent file `after` liftIO + (copyFileExternal CopyAllMetaData + (fromRawFilePath src) + (fromRawFilePath file)) hardlinkfrom src = -- creating a hard link could fall; fall back to copying - ifM (liftIO $ catchBoolIO $ createLink src file' >> return True) + ifM (liftIO $ catchBoolIO $ R.createLink src file >> return True) ( return True , copyfrom src ) diff --git a/Command/Undo.hs b/Command/Undo.hs --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -16,6 +16,7 @@ import qualified Git.Command as Git import qualified Git.Branch import qualified Command.Sync +import qualified Utility.RawFilePath as R cmd :: Command cmd = notBareRepo $ @@ -62,15 +63,15 @@ -- and then any adds. This order is necessary to handle eg, removing -- a directory and replacing it with a file. let (removals, adds) = partition (\di -> dstsha di `elem` nullShas) diff' - let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $ + let mkrel di = liftIO $ relPathCwdToFile $ fromTopFilePath (file di) g forM_ removals $ \di -> do f <- mkrel di - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith R.removeLink f forM_ adds $ \di -> do - f <- mkrel di + f <- fromRawFilePath <$> mkrel di inRepo $ Git.run [Param "checkout", Param "--", File f] next $ liftIO cleanup diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -31,8 +31,8 @@ b <- current_branch when (b == Annex.Branch.name) $ giveup $ "cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out" - top <- fromRawFilePath <$> fromRepo Git.repoPath - currdir <- liftIO getCurrentDirectory + top <- fromRepo Git.repoPath + currdir <- liftIO R.getCurrentDirectory whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" where @@ -73,7 +73,7 @@ then liftIO $ removeDirectoryRecursive annexdir else giveup $ unlines [ "Not fully uninitialized" - , "Some annexed data is still left in " ++ annexobjectdir + , "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir , "This may include deleted files, or old versions of modified files." , "" , "If you don't care about preserving the data, just delete the" @@ -108,7 +108,7 @@ prepareRemoveAnnexDir' :: FilePath -> IO () prepareRemoveAnnexDir' annexdir = dirTreeRecursiveSkipping (const False) annexdir - >>= mapM_ (void . tryIO . allowWrite) + >>= mapM_ (void . tryIO . allowWrite . toRawFilePath) {- Keys that were moved out of the annex have a hard link still in the - annex, with > 1 link count, and those can be removed. diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -50,7 +50,7 @@ replaceWorkTreeFile (fromRawFilePath dest) $ \tmp -> ifM (inAnnex key) ( do - r <- linkFromAnnex key tmp destmode + r <- linkFromAnnex key (toRawFilePath tmp) destmode case r of LinkAnnexOk -> return () LinkAnnexNoop -> return () diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -108,7 +108,7 @@ l <- a let unusedlist = number c l unless (null l) $ showLongNote $ msg unusedlist - updateUnusedLog file $ M.fromList unusedlist + updateUnusedLog (toRawFilePath file) (M.fromList unusedlist) return $ c + length l number :: Int -> [a] -> [(Int, a)] diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -43,11 +43,12 @@ start :: CommandStart start = do f <- fromRepo gitAnnexTmpCfgFile + let f' = fromRawFilePath f createAnnexDirectory $ parentDir f cfg <- getCfg descs <- uuidDescriptions - liftIO $ writeFile f $ genCfg cfg descs - vicfg cfg f + liftIO $ writeFile f' $ genCfg cfg descs + vicfg cfg f' stop vicfg :: Cfg -> FilePath -> Annex () @@ -57,7 +58,7 @@ unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ giveup $ vi ++ " exited nonzero; aborting" r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f) - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f case r of Left s -> do liftIO $ writeFile f s diff --git a/Command/View.hs b/Command/View.hs --- a/Command/View.hs +++ b/Command/View.hs @@ -19,6 +19,8 @@ import Annex.View import Logs.View +import qualified System.FilePath.ByteString as P + cmd :: Command cmd = notBareRepo $ command "view" SectionMetaData "enter a view branch" @@ -101,19 +103,19 @@ - and this pollutes the view, so remove them. - (However, emptry directories used by submodules are not - removed.) -} - top <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath + top <- liftIO . absPath =<< fromRepo Git.repoPath (l, cleanup) <- inRepo $ - LsFiles.notInRepoIncludingEmptyDirectories [] False - [toRawFilePath top] + LsFiles.notInRepoIncludingEmptyDirectories [] False [top] forM_ l (removeemptydir top) liftIO $ void cleanup unlessM (liftIO $ doesDirectoryExist here) $ do - showLongNote (cwdmissing top) + showLongNote (cwdmissing (fromRawFilePath top)) return ok where removeemptydir top d = do p <- inRepo $ toTopFilePath d - liftIO $ tryIO $ removeDirectory (top fromRawFilePath (getTopFilePath p)) + liftIO $ tryIO $ removeDirectory $ + fromRawFilePath $ (top P. getTopFilePath p) cwdmissing top = unlines [ "This view does not include the subdirectory you are currently in." , "Perhaps you should: cd " ++ top diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -27,7 +27,7 @@ import qualified Git.Config import qualified Git.CurrentRepo import qualified Annex -import Config.Files +import Config.Files.AutoStart import Upgrade import Annex.Version import Utility.Android @@ -75,15 +75,15 @@ listenAddress' <- if isJust (listenAddress o) then pure (listenAddress o) else annexListen <$> Annex.getGitConfig - ifM (checkpid <&&> checkshim f) + ifM (checkpid <&&> checkshim (fromRawFilePath f)) ( if isJust (listenAddress o) then giveup "The assistant is already running, so --listen cannot be used." else do - url <- liftIO . readFile + url <- liftIO . readFile . fromRawFilePath =<< fromRepo gitAnnexUrlFile liftIO $ if isJust listenAddress' then putStrLn url - else liftIO $ openBrowser browser f url Nothing Nothing + else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing , do startDaemon True True Nothing cannotrun listenAddress' $ Just $ \origout origerr url htmlshim -> @@ -93,7 +93,7 @@ ) checkpid = do pidfile <- fromRepo gitAnnexPidFile - liftIO $ isJust <$> checkDaemon pidfile + liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile) checkshim f = liftIO $ doesFileExist f notinitialized = do g <- Annex.gitRepo @@ -105,8 +105,8 @@ notHome :: Annex Bool notHome = do g <- Annex.gitRepo - d <- liftIO $ absPath (Git.repoLocation g) - h <- liftIO $ absPath =<< myHomeDir + d <- liftIO $ absPath (Git.repoPath g) + h <- liftIO $ absPath . toRawFilePath =<< myHomeDir return (d /= h) {- When run without a repo, start the first available listed repository in @@ -191,7 +191,7 @@ openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () openBrowser mcmd htmlshim realurl outh errh = do - htmlshim' <- absPath htmlshim + htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim) openBrowser' mcmd htmlshim' realurl outh errh openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PackageImports #-} - module Common (module X) where import Control.Monad as X @@ -21,9 +19,12 @@ import Utility.Exception as X import Utility.DebugLocks as X import Utility.SafeCommand as X +import Utility.ShellEscape as X import Utility.Process as X import Utility.Path as X +import Utility.Path.AbsRel as X import Utility.Directory as X +import Utility.MoveFile as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -85,7 +85,7 @@ setCrippledFileSystem b = setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) -pidLockFile :: Annex (Maybe FilePath) +pidLockFile :: Annex (Maybe RawFilePath) #ifndef mingw32_HOST_OS pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) ( Just <$> Annex.fromRepo gitAnnexPidLockFile diff --git a/Config/Files.hs b/Config/Files.hs --- a/Config/Files.hs +++ b/Config/Files.hs @@ -9,10 +9,11 @@ module Config.Files where -import Common -import Utility.Tmp import Utility.FreeDesktop +import Utility.Exception +import System.FilePath + {- ~/.config/git-annex/file -} userConfigFile :: FilePath -> IO FilePath userConfigFile file = do @@ -21,40 +22,6 @@ autoStartFile :: IO FilePath autoStartFile = userConfigFile "autostart" - -{- Returns anything listed in the autostart file (which may not exist). -} -readAutoStartFile :: IO [FilePath] -readAutoStartFile = do - f <- autoStartFile - filter valid . nub . map dropTrailingPathSeparator . lines - <$> catchDefaultIO "" (readFile f) - where - -- Ignore any relative paths; some old buggy versions added eg "." - valid = isAbsolute - -modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO () -modifyAutoStartFile func = do - dirs <- readAutoStartFile - let dirs' = nubBy equalFilePath $ func dirs - when (dirs' /= dirs) $ do - f <- autoStartFile - createDirectoryIfMissing True (parentDir f) - viaTmp writeFile f $ unlines dirs' - -{- Adds a directory to the autostart file. If the directory is already - - present, it's moved to the top, so it will be used as the default - - when opening the webapp. -} -addAutoStartFile :: FilePath -> IO () -addAutoStartFile path = do - path' <- absPath path - modifyAutoStartFile $ (:) path' - -{- Removes a directory from the autostart file. -} -removeAutoStartFile :: FilePath -> IO () -removeAutoStartFile path = do - path' <- absPath path - modifyAutoStartFile $ - filter (not . equalFilePath path') {- The path to git-annex is written here; which is useful when something - has installed it to some awful non-PATH location. -} diff --git a/Config/Files/AutoStart.hs b/Config/Files/AutoStart.hs new file mode 100644 --- /dev/null +++ b/Config/Files/AutoStart.hs @@ -0,0 +1,49 @@ +{- git-annex autostart file + - + - Copyright 2012-2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Config.Files.AutoStart where + +import Common +import Config.Files +import Utility.Tmp + +{- Returns anything listed in the autostart file (which may not exist). -} +readAutoStartFile :: IO [FilePath] +readAutoStartFile = do + f <- autoStartFile + filter valid . nub . map dropTrailingPathSeparator . lines + <$> catchDefaultIO "" (readFile f) + where + -- Ignore any relative paths; some old buggy versions added eg "." + valid = isAbsolute + +modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO () +modifyAutoStartFile func = do + dirs <- readAutoStartFile + let dirs' = nubBy equalFilePath $ func dirs + when (dirs' /= dirs) $ do + f <- autoStartFile + createDirectoryIfMissing True $ + fromRawFilePath (parentDir (toRawFilePath f)) + viaTmp writeFile f $ unlines dirs' + +{- Adds a directory to the autostart file. If the directory is already + - present, it's moved to the top, so it will be used as the default + - when opening the webapp. -} +addAutoStartFile :: FilePath -> IO () +addAutoStartFile path = do + path' <- fromRawFilePath <$> absPath (toRawFilePath path) + modifyAutoStartFile $ (:) path' + +{- Removes a directory from the autostart file. -} +removeAutoStartFile :: FilePath -> IO () +removeAutoStartFile path = do + path' <- fromRawFilePath <$> absPath (toRawFilePath path) + modifyAutoStartFile $ + filter (not . equalFilePath path') diff --git a/Config/Smudge.hs b/Config/Smudge.hs --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -15,7 +15,10 @@ import qualified Git.Command import Git.Types import Config +import Utility.Directory.Create +import qualified System.FilePath.ByteString as P + configureSmudgeFilter :: Annex () configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do -- If this is run in a newly cloned repository, git may not have @@ -33,12 +36,12 @@ gf <- Annex.fromRepo Git.attributes lfs <- readattr lf gfs <- readattr gf - gittop <- fromRawFilePath . Git.localGitDir <$> gitRepo + gittop <- Git.localGitDir <$> gitRepo liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do - createDirectoryUnder gittop (takeDirectory lf) - writeFile lf (lfs ++ "\n" ++ unlines stdattr) + createDirectoryUnder gittop (P.takeDirectory lf) + writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr) where - readattr = liftIO . catchDefaultIO "" . readFileStrict + readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath stdattr :: [String] stdattr = @@ -51,7 +54,7 @@ -- git-annex does not commit that. deconfigureSmudgeFilter :: Annex () deconfigureSmudgeFilter = do - lf <- Annex.fromRepo Git.attributesLocal + lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal ls <- liftIO $ catchDefaultIO [] $ lines <$> readFileStrict lf liftIO $ writeFile lf $ unlines $ filter (\l -> l `notElem` stdattr && not (null l)) ls diff --git a/Creds.hs b/Creds.hs --- a/Creds.hs +++ b/Creds.hs @@ -36,6 +36,7 @@ import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import qualified Data.Map as M +import qualified System.FilePath.ByteString as P import Utility.Base64 {- A CredPair can be stored in a file, or in the environment, or @@ -190,14 +191,14 @@ writeCreds creds file = do d <- fromRepo gitAnnexCredsDir createAnnexDirectory d - liftIO $ writeFileProtected (d file) creds + liftIO $ writeFileProtected (d P. toRawFilePath file) creds readCreds :: FilePath -> Annex (Maybe Creds) readCreds f = liftIO . catchMaybeIO . readFileStrict =<< credsFile f credsFile :: FilePath -> Annex FilePath credsFile basefile = do - d <- fromRepo gitAnnexCredsDir + d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir return $ d basefile encodeCredPair :: CredPair -> Creds @@ -210,9 +211,9 @@ removeCreds :: FilePath -> Annex () removeCreds file = do - d <- fromRepo gitAnnexCredsDir + d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir let f = d file - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -25,12 +25,13 @@ import qualified Data.ByteString.Char8 as B8 import System.Random import Control.Concurrent +import qualified System.FilePath.ByteString as P #endif benchmarkDbs :: CriterionMode -> Integer -> Annex () #ifdef WITH_BENCHMARK benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do - db <- benchDb tmpdir n + db <- benchDb (toRawFilePath tmpdir) n liftIO $ runMode mode [ bgroup "keys database" [ getAssociatedFilesHitBench db @@ -101,7 +102,7 @@ data BenchDb = BenchDb H.DbQueue Integer (MVar Integer) -benchDb :: FilePath -> Integer -> Annex BenchDb +benchDb :: RawFilePath -> Integer -> Annex BenchDb benchDb tmpdir num = do liftIO $ putStrLn $ "setting up database with " ++ show num ++ " items" initDb db SQL.createTables @@ -113,6 +114,6 @@ mv <- liftIO $ newMVar 1 return (BenchDb h num mv) where - db = tmpdir show num "db" + db = tmpdir P. toRawFilePath (show num "db") #endif /* WITH_BENCHMARK */ diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -10,6 +10,7 @@ {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} #if MIN_VERSION_persistent_template(2,8,0) {-# LANGUAGE DerivingStrategies #-} @@ -47,9 +48,11 @@ import qualified Git.DiffTree as DiffTree import Logs import qualified Logs.ContentIdentifier as Log +import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH +import qualified System.FilePath.ByteString as P data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue @@ -75,8 +78,8 @@ openDb :: Annex ContentIdentifierHandle openDb = do dbdir <- fromRepo gitAnnexContentIdentifierDbDir - let db = dbdir "db" - unlessM (liftIO $ doesFileExist db) $ do + let db = dbdir P. "db" + unlessM (liftIO $ R.doesPathExist db) $ do initDb db $ void $ runMigrationSilent migrateContentIdentifier h <- liftIO $ H.openDbQueue H.SingleWriter db "content_identifiers" diff --git a/Database/Export.hs b/Database/Export.hs --- a/Database/Export.hs +++ b/Database/Export.hs @@ -10,6 +10,7 @@ {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} #if MIN_VERSION_persistent_template(2,8,0) {-# LANGUAGE DerivingStrategies #-} @@ -59,9 +60,11 @@ import Git.Sha import Git.FilePath import qualified Git.DiffTree +import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH +import qualified System.FilePath.ByteString as P data ExportHandle = ExportHandle H.DbQueue UUID @@ -97,8 +100,8 @@ openDb :: UUID -> Annex ExportHandle openDb u = do dbdir <- fromRepo (gitAnnexExportDbDir u) - let db = dbdir "db" - unlessM (liftIO $ doesFileExist db) $ do + let db = dbdir P. "db" + unlessM (liftIO $ R.doesPathExist db) $ do initDb db $ void $ runMigrationSilent migrateExport h <- liftIO $ H.openDbQueue H.SingleWriter db "exported" diff --git a/Database/Fsck.hs b/Database/Fsck.hs --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -9,6 +9,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} #if MIN_VERSION_persistent_template(2,8,0) @@ -33,10 +34,12 @@ import Utility.Exception import Annex.Common import Annex.LockFile +import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH import Data.Time.Clock +import qualified System.FilePath.ByteString as P data FsckHandle = FsckHandle H.DbQueue UUID @@ -62,14 +65,14 @@ go = do removedb =<< fromRepo (gitAnnexFsckDbDir u) removedb =<< fromRepo (gitAnnexFsckDbDirOld u) - removedb = liftIO . void . tryIO . removeDirectoryRecursive + removedb = liftIO . void . tryIO . removeDirectoryRecursive . fromRawFilePath {- Opens the database, creating it if it doesn't exist yet. -} openDb :: UUID -> Annex FsckHandle openDb u = do dbdir <- fromRepo (gitAnnexFsckDbDir u) - let db = dbdir "db" - unlessM (liftIO $ doesFileExist db) $ do + let db = dbdir P. "db" + unlessM (liftIO $ R.doesPathExist db) $ do initDb db $ void $ runMigrationSilent migrateFsck lockFileCached =<< fromRepo (gitAnnexFsckDbLock u) diff --git a/Database/Handle.hs b/Database/Handle.hs --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -63,10 +63,10 @@ {- Opens the database, but does not perform any migrations. Only use - once the database is known to exist and have the right tables. -} -openDb :: DbConcurrency -> FilePath -> TableName -> IO DbHandle +openDb :: DbConcurrency -> RawFilePath -> TableName -> IO DbHandle openDb dbconcurrency db tablename = do jobs <- newEmptyMVar - worker <- async (workerThread (T.pack db) tablename jobs) + worker <- async (workerThread (T.pack (fromRawFilePath db)) tablename jobs) -- work around https://github.com/yesodweb/persistent/issues/474 liftIO $ fileEncoding stderr diff --git a/Database/Init.hs b/Database/Init.hs --- a/Database/Init.hs +++ b/Database/Init.hs @@ -5,15 +5,20 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Database.Init where import Annex.Common import Annex.Perms import Utility.FileMode +import Utility.Directory.Create +import qualified Utility.RawFilePath as R import Database.Persist.Sqlite -import qualified Data.Text as T import Lens.Micro +import qualified Data.Text as T +import qualified System.FilePath.ByteString as P {- Ensures that the database is freshly initialized. Deletes any - existing database. Pass the migration action for the database. @@ -23,24 +28,24 @@ - file causes Sqlite to always use the same permissions for additional - files it writes later on -} -initDb :: FilePath -> SqlPersistM () -> Annex () +initDb :: P.RawFilePath -> SqlPersistM () -> Annex () initDb db migration = do - let dbdir = takeDirectory db - let tmpdbdir = dbdir ++ ".tmp" - let tmpdb = tmpdbdir "db" - let tdb = T.pack tmpdb - top <- parentDir . fromRawFilePath <$> fromRepo gitAnnexDir + let dbdir = P.takeDirectory db + let tmpdbdir = dbdir <> ".tmp" + let tmpdb = tmpdbdir P. "db" + let tdb = T.pack (fromRawFilePath tmpdb) + top <- parentDir <$> fromRepo gitAnnexDir liftIO $ do createDirectoryUnder top tmpdbdir runSqliteInfo (enableWAL tdb) migration setAnnexDirPerm tmpdbdir -- Work around sqlite bug that prevents it from honoring -- less restrictive umasks. - liftIO $ setFileMode tmpdb =<< defaultFileMode + liftIO $ R.setFileMode tmpdb =<< defaultFileMode setAnnexFilePerm tmpdb liftIO $ do - void $ tryIO $ removeDirectoryRecursive dbdir - rename tmpdbdir dbdir + void $ tryIO $ removeDirectoryRecursive (fromRawFilePath dbdir) + rename (fromRawFilePath tmpdbdir) (fromRawFilePath dbdir) {- Make sure that the database uses WAL mode, to prevent readers - from blocking writers, and prevent a writer from blocking readers. diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -43,6 +43,7 @@ import Git.Command import Git.Types import Git.Index +import qualified Utility.RawFilePath as R import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -114,8 +115,8 @@ openDb False DbUnavailable = return DbUnavailable openDb createdb _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do dbdir <- fromRepo gitAnnexKeysDb - let db = dbdir "db" - dbexists <- liftIO $ doesFileExist db + let db = dbdir P. "db" + dbexists <- liftIO $ R.doesPathExist db case (dbexists, createdb) of (True, _) -> open db (False, True) -> do @@ -214,8 +215,8 @@ reconcileStaged :: H.DbQueue -> Annex () reconcileStaged qh = do gitindex <- inRepo currentIndexFile - indexcache <- fromRepo gitAnnexKeysDbIndexCache - withTSDelta (liftIO . genInodeCache (toRawFilePath gitindex)) >>= \case + indexcache <- fromRawFilePath <$> fromRepo gitAnnexKeysDbIndexCache + withTSDelta (liftIO . genInodeCache gitindex) >>= \case Just cur -> liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case Nothing -> go cur indexcache diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -10,6 +10,7 @@ {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} #if MIN_VERSION_persistent_template(2,8,0) {-# LANGUAGE DerivingStrategies #-} diff --git a/Database/Queue.hs b/Database/Queue.hs --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -19,6 +19,7 @@ ) where import Utility.Monad +import Utility.RawFilePath import Database.Handle import Database.Persist.Sqlite @@ -36,7 +37,7 @@ {- Opens the database queue, but does not perform any migrations. Only use - if the database is known to exist and have the right tables; ie after - running initDb. -} -openDbQueue :: DbConcurrency -> FilePath -> TableName -> IO DbQueue +openDbQueue :: DbConcurrency -> RawFilePath -> TableName -> IO DbQueue openDbQueue dbconcurrency db tablename = DQ <$> openDb dbconcurrency db tablename <*> (newMVar =<< emptyQueue) diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -3,11 +3,12 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git ( @@ -37,10 +38,12 @@ relPath, ) where +import qualified Data.ByteString as B import Network.URI (uriPath, uriScheme, unEscapeString) #ifndef mingw32_HOST_OS import System.Posix.Files #endif +import qualified System.FilePath.ByteString as P import Common import Git.Types @@ -130,14 +133,13 @@ | otherwise = action {- Path to a repository's gitattributes file. -} -attributes :: Repo -> FilePath +attributes :: Repo -> RawFilePath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = fromRawFilePath (repoPath repo) ".gitattributes" + | otherwise = repoPath repo P. ".gitattributes" -attributesLocal :: Repo -> FilePath -attributesLocal repo = fromRawFilePath (localGitDir repo) - "info" "attributes" +attributesLocal :: Repo -> RawFilePath +attributesLocal repo = localGitDir repo P. "info" P. "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} @@ -159,13 +161,13 @@ where torel p = do p' <- relPathCwdToFile p - return $ if null p' then "." else p' + return $ if B.null p' then "." else p' {- Adusts the path to a local Repo using the provided function. -} -adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo +adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do - d' <- f' d - w' <- maybe (pure Nothing) (Just <$$> f') w + d' <- f d + w' <- maybe (pure Nothing) (Just <$$> f) w return $ r { location = l { gitdir = d' @@ -173,8 +175,7 @@ } } where - f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do - d' <- toRawFilePath <$> f (fromRawFilePath d) + d' <- f d return $ r { location = LocalUnknown d' } adjustPath _ r = pure r diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -1,6 +1,6 @@ {- git check-attr interface - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,10 +11,12 @@ import Git import Git.Command import qualified Utility.CoProcess as CoProcess +import qualified Utility.RawFilePath as R import System.IO.Error +import qualified Data.ByteString as B -type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], String) +type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath) type Attr = String @@ -22,7 +24,7 @@ - values and returns a handle. -} checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle checkAttrStart attrs repo = do - currdir <- getCurrentDirectory + currdir <- R.getCurrentDirectory h <- gitCoProcessStart True params repo return (h, attrs, currdir) where @@ -38,16 +40,16 @@ {- Gets an attribute of a file. When the attribute is not specified, - returns "" -} -checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String +checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String checkAttr (h, attrs, currdir) want file = do pairs <- CoProcess.query h send (receive "") let vals = map snd $ filter (\(attr, _) -> attr == want) pairs case vals of ["unspecified"] -> return "" [v] -> return v - _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file + _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ fromRawFilePath file where - send to = hPutStr to $ file' ++ "\0" + send to = B.hPutStr to $ file' `B.snoc` 0 receive c from = do s <- hGetSomeString from 1024 if null s diff --git a/Git/CheckIgnore.hs b/Git/CheckIgnore.hs --- a/Git/CheckIgnore.hs +++ b/Git/CheckIgnore.hs @@ -18,6 +18,7 @@ import qualified Utility.CoProcess as CoProcess import System.IO.Error +import qualified Data.ByteString as B type CheckIgnoreHandle = CoProcess.CoProcessHandle @@ -51,11 +52,11 @@ checkIgnoreStop = void . tryIO . CoProcess.stop {- Returns True if a file is ignored. -} -checkIgnored :: CheckIgnoreHandle -> FilePath -> IO Bool +checkIgnored :: CheckIgnoreHandle -> RawFilePath -> IO Bool checkIgnored h file = CoProcess.query h send (receive "") where send to = do - hPutStr to $ file ++ "\0" + B.hPutStr to $ file `B.snoc` 0 hFlush to receive c from = do s <- hGetSomeString from 1024 diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -141,9 +141,9 @@ Nothing -> return l Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} - top <- absPath $ fromRawFilePath (gitdir l) - let p = absPathFrom top (fromRawFilePath d) - return $ l { worktree = Just (toRawFilePath p) } + top <- absPath (gitdir l) + let p = absPathFrom top d + return $ l { worktree = Just p } Just NoConfigValue -> return l return $ r { location = l' } diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git.Construct ( @@ -38,6 +39,9 @@ import qualified Git.Url as Url import Utility.UserInfo +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P + {- Finds the git repository used for the cwd, which may be in a parent - directory. -} fromCwd :: IO (Maybe Repo) @@ -46,40 +50,40 @@ seekUp dir = do r <- checkForRepo dir case r of - Nothing -> case upFrom dir of + Nothing -> case upFrom (toRawFilePath dir) of Nothing -> return Nothing - Just d -> seekUp d + Just d -> seekUp (fromRawFilePath d) Just loc -> pure $ Just $ newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -} -fromPath :: FilePath -> IO Repo +fromPath :: RawFilePath -> IO Repo fromPath dir = fromAbsPath =<< absPath dir {- Local Repo constructor, requires an absolute path to the repo be - specified. -} -fromAbsPath :: FilePath -> IO Repo +fromAbsPath :: RawFilePath -> IO Repo fromAbsPath dir - | absoluteGitPath (encodeBS dir) = hunt + | absoluteGitPath dir = hunt | otherwise = - error $ "internal error, " ++ dir ++ " is not absolute" + error $ "internal error, " ++ show dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown . toRawFilePath - canondir = dropTrailingPathSeparator dir + ret = pure . newFrom . LocalUnknown + canondir = P.dropTrailingPathSeparator dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} hunt - | (pathSeparator:".git") `isSuffixOf` canondir = - ifM (doesDirectoryExist $ dir ".git") + | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = + ifM (doesDirectoryExist $ fromRawFilePath dir ".git") ( ret dir - , ret (takeDirectory canondir) + , ret (P.takeDirectory canondir) ) - | otherwise = ifM (doesDirectoryExist dir) + | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir)) ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom) -- git falls back to dir.git when dir doesn't -- exist, as long as dir didn't end with a -- path separator , if dir == canondir - then ret (dir ++ ".git") + then ret (dir <> ".git") else ret dir ) @@ -95,7 +99,8 @@ fromUrlStrict :: String -> IO Repo fromUrlStrict url - | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u + | "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $ + unEscapeString $ uriPath u | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url @@ -129,7 +134,8 @@ filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteKey - construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) + construct (k,v) = remoteNamedFromKey k $ + fromRemoteLocation (fromConfigValue v) repo {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -155,18 +161,18 @@ fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ fromRawFilePath (repoPath repo) dir' + fromPath $ repoPath repo P. toRawFilePath dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. - This converts such a directory to an absolute path. - Note that it has to run on the system where the remote is. -} -repoAbsPath :: FilePath -> IO FilePath +repoAbsPath :: RawFilePath -> IO RawFilePath repoAbsPath d = do - d' <- expandTilde d + d' <- expandTilde (fromRawFilePath d) h <- myHomeDir - return $ h d' + return $ toRawFilePath $ h d' expandTilde :: FilePath -> IO FilePath #ifdef mingw32_HOST_OS @@ -199,7 +205,7 @@ checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ - check (checkGitDirFile dir) $ + check (checkGitDirFile (toRawFilePath dir)) $ check isBareRepo $ return Nothing where @@ -221,10 +227,10 @@ gitSignature file = doesFileExist $ dir file -- Check for a .git file. -checkGitDirFile :: FilePath -> IO (Maybe RepoLocation) +checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation) checkGitDirFile dir = adjustGitDirFile' $ Local - { gitdir = toRawFilePath (dir ".git") - , worktree = Just (toRawFilePath dir) + { gitdir = dir P. ".git" + , worktree = Just dir } -- git-submodule, git-worktree, and --separate-git-dir @@ -236,14 +242,16 @@ adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) adjustGitDirFile' loc = do - let gd = fromRawFilePath (gitdir loc) - c <- firstLine <$> catchDefaultIO "" (readFile gd) + let gd = gitdir loc + c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd)) if gitdirprefix `isPrefixOf` c then do - top <- takeDirectory <$> absPath gd + top <- fromRawFilePath . P.takeDirectory <$> absPath gd return $ Just $ loc - { gitdir = toRawFilePath $ absPathFrom top $ - drop (length gitdirprefix) c + { gitdir = absPathFrom + (toRawFilePath top) + (toRawFilePath + (drop (length gitdirprefix) c)) } else return Nothing where diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -1,10 +1,12 @@ {- The current git repository. - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.CurrentRepo where import Common @@ -13,7 +15,11 @@ import qualified Git.Config import Utility.Env import Utility.Env.Set +import qualified Utility.RawFilePath as R +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P + {- Gets the current git repository. - - Honors GIT_DIR and GIT_WORK_TREE. @@ -37,14 +43,14 @@ gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd prefix <- getpathenv "GIT_PREFIX" - wt <- maybe (fromRawFilePath <$> worktree (location r)) Just + wt <- maybe (worktree (location r)) Just <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r Just d -> do - curr <- getCurrentDirectory + curr <- R.getCurrentDirectory unless (d `dirContains` curr) $ - setCurrentDirectory d + setCurrentDirectory (fromRawFilePath d) return $ addworktree wt r where getpathenv s = do @@ -52,24 +58,25 @@ case v of Just d -> do unsetEnv s - return (Just d) + return (Just (toRawFilePath d)) Nothing -> return Nothing - getpathenvprefix s (Just prefix) | not (null prefix) = + getpathenvprefix s (Just prefix) | not (B.null prefix) = getpathenv s >>= \case Nothing -> return Nothing Just d | d == "." -> return (Just d) - | otherwise -> Just <$> absPath (prefix d) + | otherwise -> Just + <$> absPath (prefix P. d) getpathenvprefix s _ = getpathenv s configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d - curr <- getCurrentDirectory + curr <- R.getCurrentDirectory loc <- adjustGitDirFile $ Local - { gitdir = toRawFilePath absd - , worktree = Just (toRawFilePath curr) + { gitdir = absd + , worktree = Just curr } r <- Git.Config.read $ newFrom loc return $ if Git.Config.isBare r @@ -79,6 +86,7 @@ addworktree w r = changelocation r $ Local { gitdir = gitdir (location r) - , worktree = fmap toRawFilePath w + , worktree = w } + changelocation r l = r { location = l } diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -17,6 +17,7 @@ commitDiff, ) where +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 @@ -34,9 +35,11 @@ {- Checks if the DiffTreeItem modifies a file with a given name - or under a directory by that name. -} isDiffOf :: DiffTreeItem -> TopFilePath -> Bool -isDiffOf diff f = case fromRawFilePath (getTopFilePath f) of - "" -> True -- top of repo contains all - d -> d `dirContains` fromRawFilePath (getTopFilePath (file diff)) +isDiffOf diff f = + let f' = getTopFilePath f + in if B.null f' + then True -- top of repo contains all + else f' `dirContains` getTopFilePath (file diff) {- Diffs two tree Refs. -} diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool) diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -58,8 +58,7 @@ {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath -toTopFilePath file repo = TopFilePath . toRawFilePath - <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) +toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file {- The input RawFilePath must already be relative to the top of the git - repository -} diff --git a/Git/Filename.hs b/Git/Filename.hs --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -10,6 +10,7 @@ import Common import Utility.Format (decode_c, encode_c) +import Utility.QuickCheck import Data.Char import Data.Word @@ -35,21 +36,14 @@ encode :: RawFilePath -> S.ByteString encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -prop_encode_decode_roundtrip :: FilePath -> Bool -prop_encode_decode_roundtrip s = s' == - fromRawFilePath (decode (encode (toRawFilePath s'))) +-- Encoding and then decoding roundtrips only when the string does not +-- contain high unicode, because eg, both "\12345" and "\227\128\185" +-- are encoded to "\343\200\271". +-- +-- That is not a real-world problem, and using TestableFilePath +-- limits what's tested to ascii, so avoids running into it. +prop_encode_decode_roundtrip :: TestableFilePath -> Bool +prop_encode_decode_roundtrip ts = + s == fromRawFilePath (decode (encode (toRawFilePath s))) where - s' = nonul (nohigh s) - -- Encoding and then decoding roundtrips only when - -- the string does not contain high unicode, because eg, - -- both "\12345" and "\227\128\185" are encoded to - -- "\343\200\271". - -- - -- This property papers over the problem, by only - -- testing ascii - nohigh = filter isAscii - -- A String can contain a NUL, but toRawFilePath - -- truncates on the NUL, which is generally fine - -- because unix filenames cannot contain NUL. - -- So the encoding only roundtrips when there is no nul. - nonul = filter (/= '\NUL') + s = fromTestableFilePath ts diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -36,10 +36,10 @@ hashObjectStop = CoProcess.stop {- Injects a file into git, returning the Sha of the object. -} -hashFile :: HashObjectHandle -> FilePath -> IO Sha +hashFile :: HashObjectHandle -> RawFilePath -> IO Sha hashFile h file = CoProcess.query h send receive where - send to = hPutStrLn to =<< absPath file + send to = S8.hPutStrLn to =<< absPath file receive from = getSha "hash-object" $ S8.hGetLine from class HashableBlob t where @@ -60,7 +60,7 @@ hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do hashableBlobToHandle tmph b hClose tmph - hashFile h tmp + hashFile h (toRawFilePath tmp) {- Injects some content into git, returning its Sha. - diff --git a/Git/Index.hs b/Git/Index.hs --- a/Git/Index.hs +++ b/Git/Index.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Index where import Common @@ -12,6 +14,8 @@ import Utility.Env import Utility.Env.Set +import qualified System.FilePath.ByteString as P + indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -26,8 +30,8 @@ - - So, an absolute path is the only safe option for this to return. -} -indexEnvVal :: FilePath -> IO String -indexEnvVal = absPath +indexEnvVal :: RawFilePath -> IO String +indexEnvVal p = fromRawFilePath <$> absPath p {- Forces git to use the specified index file. - @@ -36,7 +40,7 @@ - - Warning: Not thread safe. -} -override :: FilePath -> Repo -> IO (IO ()) +override :: RawFilePath -> Repo -> IO (IO ()) override index _r = do res <- getEnv var val <- indexEnvVal index @@ -48,13 +52,13 @@ reset _ = unsetEnv var {- The normal index file. Does not check GIT_INDEX_FILE. -} -indexFile :: Repo -> FilePath -indexFile r = fromRawFilePath (localGitDir r) "index" +indexFile :: Repo -> RawFilePath +indexFile r = localGitDir r P. "index" {- The index file git will currently use, checking GIT_INDEX_FILE. -} -currentIndexFile :: Repo -> IO FilePath -currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv +currentIndexFile :: Repo -> IO RawFilePath +currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv {- Git locks the index by creating this file. -} -indexFileLock :: FilePath -> FilePath -indexFileLock f = f ++ ".lock" +indexFileLock :: RawFilePath -> RawFilePath +indexFileLock f = f <> ".lock" diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -37,12 +37,14 @@ import Utility.InodeCache import Utility.TimeStamp import Utility.Attoparsec +import qualified Utility.RawFilePath as R import System.Posix.Types import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified System.FilePath.ByteString as P {- It's only safe to use git ls-files on the current repo, not on a remote. - @@ -208,12 +210,12 @@ typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = guardSafeForLsFiles repo $ do - (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo + (fs, cleanup) <- pipeNullSplit' (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. - top <- absPath (fromRawFilePath (repoPath repo)) - currdir <- getCurrentDirectory - return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top decodeBL' f)) fs, cleanup) + top <- absPath (repoPath repo) + currdir <- R.getCurrentDirectory + return (map (\f -> relPathDirToFileAbs currdir $ top P. f) fs, cleanup) where prefix = [ Param "diff" diff --git a/Git/Objects.hs b/Git/Objects.hs --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -5,39 +5,45 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Objects where import Common import Git import Git.Sha -objectsDir :: Repo -> FilePath -objectsDir r = fromRawFilePath (localGitDir r) "objects" +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P -packDir :: Repo -> FilePath -packDir r = objectsDir r "pack" +objectsDir :: Repo -> RawFilePath +objectsDir r = localGitDir r P. "objects" -packIdxFile :: FilePath -> FilePath -packIdxFile = flip replaceExtension "idx" +packDir :: Repo -> RawFilePath +packDir r = objectsDir r P. "pack" +packIdxFile :: RawFilePath -> RawFilePath +packIdxFile = flip P.replaceExtension "idx" + listPackFiles :: Repo -> IO [FilePath] listPackFiles r = filter (".pack" `isSuffixOf`) - <$> catchDefaultIO [] (dirContents $ packDir r) + <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r) listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $ mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) - <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) + <$> dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r)) -looseObjectFile :: Repo -> Sha -> FilePath -looseObjectFile r sha = objectsDir r prefix rest +looseObjectFile :: Repo -> Sha -> RawFilePath +looseObjectFile r sha = objectsDir r P. prefix P. rest where - (prefix, rest) = splitAt 2 (fromRef sha) + (prefix, rest) = B.splitAt 2 (fromRef' sha) listAlternates :: Repo -> IO [FilePath] -listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile) +listAlternates r = catchDefaultIO [] $ + lines <$> readFile (fromRawFilePath alternatesfile) where - alternatesfile = objectsDir r "info" "alternates" + alternatesfile = objectsDir r P. "info" P. "alternates" {- A repository recently cloned with --shared will have one or more - alternates listed, and contain no loose objects or packs. -} diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -45,11 +45,11 @@ - to as the queue grows. -} | InternalAction { getRunner :: InternalActionRunner m - , getInternalFiles :: [(FilePath, IO Bool)] + , getInternalFiles :: [(RawFilePath, IO Bool)] } {- The String must be unique for each internal action. -} -data InternalActionRunner m = InternalActionRunner String (Repo -> [(FilePath, IO Bool)] -> m ()) +data InternalActionRunner m = InternalActionRunner String (Repo -> [(RawFilePath, IO Bool)] -> m ()) instance Eq (InternalActionRunner m) where InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2 @@ -108,7 +108,7 @@ different _ = True {- Adds an internal action to the queue. -} -addInternalAction :: MonadIO m => InternalActionRunner m -> [(FilePath, IO Bool)] -> Queue m -> Repo -> m (Queue m) +addInternalAction :: MonadIO m => InternalActionRunner m -> [(RawFilePath, IO Bool)] -> Queue m -> Repo -> m (Queue m) addInternalAction runner files q repo = updateQueue action different (length files) q repo where diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -35,12 +35,15 @@ import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch +import Utility.Directory.Create import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode +import qualified Utility.RawFilePath as R import qualified Data.Set as S import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} @@ -50,9 +53,9 @@ mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeBad =<< listLooseObjectShas r where - removeLoose s = nukeFile (looseObjectFile r s) + removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s) removeBad s = do - void $ tryIO $ allowRead $ looseObjectFile r s + void $ tryIO $ allowRead $ looseObjectFile r s whenM (isMissing s r) $ removeLoose s @@ -76,10 +79,11 @@ putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do moveFile packfile (tmpdir takeFileName packfile) - nukeFile $ packIdxFile packfile + removeWhenExistsWith R.removeLink + (packIdxFile (toRawFilePath packfile)) forM_ packs $ \packfile -> do let tmp = tmpdir takeFileName packfile - allowRead tmp + allowRead (toRawFilePath tmp) -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> @@ -99,7 +103,7 @@ | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do unlessM (boolSystem "git" [Param "init", File tmpdir]) $ error $ "failed to create temp repository in " ++ tmpdir - tmpr <- Config.read =<< Construct.fromAbsPath tmpdir + tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir) rs <- Construct.fromRemotes r stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) @@ -160,8 +164,8 @@ copyObjects :: Repo -> Repo -> IO Bool copyObjects srcr destr = rsync [ Param "-qr" - , File $ addTrailingPathSeparator $ objectsDir srcr - , File $ addTrailingPathSeparator $ objectsDir destr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr ] {- To deal with missing objects that cannot be recovered, resets any @@ -243,14 +247,15 @@ rs <- mapMaybe parsePacked . lines <$> catchDefaultIO "" (safeReadFile f) forM_ rs makeref - nukeFile f + removeWhenExistsWith removeLink f where makeref (sha, ref) = do - let gitd = fromRawFilePath (localGitDir r) - let dest = gitd fromRef ref + let gitd = localGitDir r + let dest = gitd P. fromRef' ref + let dest' = fromRawFilePath dest createDirectoryUnder gitd (parentDir dest) - unlessM (doesFileExist dest) $ - writeFile dest (fromRef sha) + unlessM (doesFileExist dest') $ + writeFile dest' (fromRef sha) packedRefsFile :: Repo -> FilePath packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" @@ -265,7 +270,7 @@ {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) fromRef b +nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P. fromRef' b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -391,7 +396,7 @@ | otherwise = do (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do - nukeFile (indexFile r) + removeWhenExistsWith R.removeLink (indexFile r) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup @@ -439,12 +444,11 @@ preRepair :: Repo -> IO () preRepair g = do unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do - nukeFile headfile + removeWhenExistsWith removeLink headfile writeFile headfile "ref: refs/heads/master" explodePackedRefsFile g - unless (repoIsLocalBare g) $ do - let f = indexFile g - void $ tryIO $ allowWrite f + unless (repoIsLocalBare g) $ + void $ tryIO $ allowWrite $ indexFile g where headfile = fromRawFilePath (localGitDir g) "HEAD" validhead s = "ref: refs/" `isPrefixOf` s @@ -568,7 +572,7 @@ else successfulfinish modifiedbranches corruptedindex = do - nukeFile (indexFile g) + removeWhenExistsWith R.removeLink (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. fsckresult' <- findBroken False g @@ -614,5 +618,5 @@ safeReadFile :: FilePath -> IO String safeReadFile f = do - allowRead f + allowRead (toRawFilePath f) readFileStrict f diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} module Git.Types where @@ -79,9 +79,15 @@ instance Show ConfigKey where show = fromConfigKey -fromConfigValue :: ConfigValue -> String -fromConfigValue (ConfigValue s) = decodeBS' s -fromConfigValue NoConfigValue = mempty +class FromConfigValue a where + fromConfigValue :: ConfigValue -> a + +instance FromConfigValue S.ByteString where + fromConfigValue (ConfigValue s) = s + fromConfigValue NoConfigValue = mempty + +instance FromConfigValue String where + fromConfigValue = decodeBS' . fromConfigValue instance Show ConfigValue where show = fromConfigValue diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -31,6 +31,7 @@ import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Control.Monad.IO.Class @@ -117,12 +118,12 @@ <> indexPath p {- A streamer that adds a symlink to the index. -} -stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer +stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha <*> pure TreeSymlink - <*> toTopFilePath (toRawFilePath file) repo + <*> toTopFilePath file repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} @@ -135,7 +136,7 @@ indexPath = toInternalGitPath . getTopFilePath {- Refreshes the index, by checking file stat information. -} -refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool +refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool refreshIndex repo feeder = withCreateProcess p go where params = @@ -150,9 +151,8 @@ { std_in = CreatePipe } go (Just h) _ _ pid = do - feeder $ \f -> do - hPutStr h f - hPutStr h "\0" + feeder $ \f -> + S.hPut h (S.snoc f 0) hFlush h hClose h checkSuccessProcess pid diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -14,7 +14,7 @@ GitVersion, ) where -import Common +import Utility.Process import Utility.DottedVersion type GitVersion = DottedVersion diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -31,7 +31,6 @@ prop_isomorphic_key_encode ) where -import Data.Char import qualified Data.Text as T import qualified Data.ByteString as S import qualified Data.Attoparsec.ByteString as A @@ -100,16 +99,10 @@ <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative --- AssociatedFile cannot be empty, and cannot contain a NUL --- (but can be Nothing). instance Arbitrary AssociatedFile where - arbitrary = (AssociatedFile . fmap conv <$> arbitrary) - `suchThat` (/= AssociatedFile (Just S.empty)) - `suchThat` (\(AssociatedFile f) -> maybe True (S.notElem 0) f) - where - -- Generating arbitrary unicode leads to encoding errors - -- when LANG=C, so limit to ascii. - conv = toRawFilePath . filter isAscii + arbitrary = AssociatedFile + . fmap (toRawFilePath . fromTestableFilePath) + <$> arbitrary instance Arbitrary Key where arbitrary = mkKey . const <$> arbitrary diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -333,7 +333,7 @@ then approxNumCopies else case mi of MatchingFile fi -> getGlobalFileNumCopies $ - fromRawFilePath $ matchFile fi + matchFile fi MatchingKey _ _ -> approxNumCopies MatchingInfo {} -> approxNumCopies MatchingUserInfo {} -> approxNumCopies @@ -464,8 +464,7 @@ LimitAnnexFiles -> goannexed sz fi LimitDiskFiles -> case contentFile fi of Just f -> do - filesize <- liftIO $ catchMaybeIO $ - getFileSize (fromRawFilePath f) + filesize <- liftIO $ catchMaybeIO $ getFileSize f return $ filesize `vs` Just sz Nothing -> goannexed sz fi go sz _ (MatchingKey key _) = checkkey sz key diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -180,7 +180,8 @@ getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem] getExportExcluded u = do logf <- fromRepo $ gitAnnexExportExcludeLog u - liftIO $ catchDefaultIO [] $ parser <$> L.readFile logf + liftIO $ catchDefaultIO [] $ parser + <$> L.readFile (fromRawFilePath logf) where parser = map Git.Tree.lsTreeItemToTreeItem . rights diff --git a/Logs/File.hs b/Logs/File.hs --- a/Logs/File.hs +++ b/Logs/File.hs @@ -29,32 +29,37 @@ -- | Writes content to a file, replacing the file atomically, and -- making the new file have whatever permissions the git repository is -- configured to use. Creates the parent directory when necessary. -writeLogFile :: FilePath -> String -> Annex () -writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c +writeLogFile :: RawFilePath -> String -> Annex () +writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (fromRawFilePath f) c where - writelog f' c' = do - liftIO $ writeFile f' c' - setAnnexFilePerm f' + writelog tmp c' = do + liftIO $ writeFile tmp c' + setAnnexFilePerm (toRawFilePath tmp) -- | Runs the action with a handle connected to a temp file. -- The temp file replaces the log file once the action succeeds. -withLogHandle :: FilePath -> (Handle -> Annex a) -> Annex a +withLogHandle :: RawFilePath -> (Handle -> Annex a) -> Annex a withLogHandle f a = do createAnnexDirectory (parentDir f) - replaceGitAnnexDirFile f $ \tmp -> + replaceGitAnnexDirFile (fromRawFilePath f) $ \tmp -> bracket (setup tmp) cleanup a where setup tmp = do - setAnnexFilePerm tmp + setAnnexFilePerm (toRawFilePath tmp) liftIO $ openFile tmp WriteMode cleanup h = liftIO $ hClose h -- | Appends a line to a log file, first locking it to prevent -- concurrent writers. -appendLogFile :: FilePath -> (Git.Repo -> FilePath) -> L.ByteString -> Annex () -appendLogFile f lck c = createDirWhenNeeded f $ withExclusiveLock lck $ do - liftIO $ withFile f AppendMode $ \h -> L8.hPutStrLn h c - setAnnexFilePerm f +appendLogFile :: RawFilePath -> (Git.Repo -> RawFilePath) -> L.ByteString -> Annex () +appendLogFile f lck c = + createDirWhenNeeded f $ + withExclusiveLock lck $ do + liftIO $ withFile f' AppendMode $ + \h -> L8.hPutStrLn h c + setAnnexFilePerm (toRawFilePath f') + where + f' = fromRawFilePath f -- | Modifies a log file. -- @@ -64,18 +69,19 @@ -- -- The file is locked to prevent concurrent writers, and it is written -- atomically. -modifyLogFile :: FilePath -> (Git.Repo -> FilePath) -> ([L.ByteString] -> [L.ByteString]) -> Annex () +modifyLogFile :: RawFilePath -> (Git.Repo -> RawFilePath) -> ([L.ByteString] -> [L.ByteString]) -> Annex () modifyLogFile f lck modf = withExclusiveLock lck $ do ls <- liftIO $ fromMaybe [] - <$> tryWhenExists (L8.lines <$> L.readFile f) + <$> tryWhenExists (L8.lines <$> L.readFile f') let ls' = modf ls when (ls' /= ls) $ createDirWhenNeeded f $ - viaTmp writelog f (L8.unlines ls') + viaTmp writelog f' (L8.unlines ls') where - writelog f' b = do - liftIO $ L.writeFile f' b - setAnnexFilePerm f' + f' = fromRawFilePath f + writelog lf b = do + liftIO $ L.writeFile lf b + setAnnexFilePerm (toRawFilePath lf) -- | Checks the content of a log file to see if any line matches. -- @@ -83,7 +89,7 @@ -- action is concurrently modifying the file. It does not lock the file, -- for speed, but instead relies on the fact that a log file usually -- ends in a newline. -checkLogFile :: FilePath -> (Git.Repo -> FilePath) -> (L.ByteString -> Bool) -> Annex Bool +checkLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> (L.ByteString -> Bool) -> Annex Bool checkLogFile f lck matchf = withExclusiveLock lck $ bracket setup cleanup go where setup = liftIO $ tryWhenExists $ openFile f ReadMode @@ -117,7 +123,7 @@ -- -- Locking is used to prevent writes to to the log file while this -- is running. -streamLogFile :: FilePath -> (Git.Repo -> FilePath) -> (String -> Annex ()) -> Annex () +streamLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> (String -> Annex ()) -> Annex () streamLogFile f lck a = withExclusiveLock lck $ bracketOnError setup cleanup go where setup = liftIO $ tryWhenExists $ openFile f ReadMode @@ -128,9 +134,9 @@ mapM_ a =<< liftIO (lines <$> hGetContents h) liftIO $ hClose h liftIO $ writeFile f "" - setAnnexFilePerm f + setAnnexFilePerm (toRawFilePath f) -createDirWhenNeeded :: FilePath -> Annex () -> Annex () +createDirWhenNeeded :: RawFilePath -> Annex () -> Annex () createDirWhenNeeded f a = a `catchNonAsync` \_e -> do -- Most of the time, the directory will exist, so this is only -- done if writing the file fails. diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -15,6 +15,7 @@ import Git.Fsck import Git.Types import Logs.File +import qualified Utility.RawFilePath as R import qualified Data.Set as S @@ -24,7 +25,8 @@ case fsckresults of FsckFailed -> store S.empty False logfile FsckFoundMissing s t - | S.null s -> liftIO $ nukeFile logfile + | S.null s -> liftIO $ + removeWhenExistsWith R.removeLink logfile | otherwise -> store s t logfile where store s t logfile = writeLogFile logfile $ serialize s t @@ -38,7 +40,7 @@ readFsckResults u = do logfile <- fromRepo $ gitAnnexFsckResultsLog u liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $ - deserialize . lines <$> readFile logfile + deserialize . lines <$> readFile (fromRawFilePath logfile) where deserialize ("truncated":ls) = deserialize' ls True deserialize ls = deserialize' ls False @@ -47,5 +49,6 @@ in if S.null s then FsckFailed else FsckFoundMissing s t clearFsckResults :: UUID -> Annex () -clearFsckResults = liftIO . nukeFile <=< fromRepo . gitAnnexFsckResultsLog +clearFsckResults = liftIO . removeWhenExistsWith R.removeLink + <=< fromRepo . gitAnnexFsckResultsLog diff --git a/Logs/Remote/Pure.hs b/Logs/Remote/Pure.hs --- a/Logs/Remote/Pure.hs +++ b/Logs/Remote/Pure.hs @@ -22,6 +22,7 @@ import Types.ProposedAccepted import Logs.UUIDBased import Annex.SpecialRemote.Config +import Utility.QuickCheck import qualified Data.ByteString.Lazy as L import qualified Data.Map as M @@ -85,8 +86,10 @@ rest = drop 1 r {- for quickcheck -} -prop_isomorphic_configEscape :: String -> Bool -prop_isomorphic_configEscape s = s == (configUnEscape . configEscape) s +prop_isomorphic_configEscape :: TestableString -> Bool +prop_isomorphic_configEscape ts = s == (configUnEscape . configEscape) s + where + s = fromTestableString ts prop_parse_show_Config :: RemoteConfig -> Bool prop_parse_show_Config c diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -63,7 +63,7 @@ getLastRunTimes :: Annex (M.Map ScheduledActivity LocalTime) getLastRunTimes = do - f <- fromRepo gitAnnexScheduleState + f <- fromRawFilePath <$> fromRepo gitAnnexScheduleState liftIO $ fromMaybe M.empty <$> catchDefaultIO Nothing (readish <$> readFile f) diff --git a/Logs/Smudge.hs b/Logs/Smudge.hs --- a/Logs/Smudge.hs +++ b/Logs/Smudge.hs @@ -32,7 +32,7 @@ streamSmudged :: (Key -> TopFilePath -> Annex ()) -> Annex () streamSmudged a = do logf <- fromRepo gitAnnexSmudgeLog - streamLogFile logf gitAnnexSmudgeLock $ \l -> + streamLogFile (fromRawFilePath logf) gitAnnexSmudgeLock $ \l -> case parse l of Nothing -> noop Just (k, f) -> a k f diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Logs.Transfer where @@ -19,6 +20,7 @@ import Annex.LockPool import Utility.TimeStamp import Logs.File +import qualified Utility.RawFilePath as R #ifndef mingw32_HOST_OS import Annex.Perms #endif @@ -26,6 +28,8 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Control.Concurrent +import qualified Data.ByteString.Char8 as B8 +import qualified System.FilePath.ByteString as P describeTransfer :: Transfer -> TransferInfo -> String describeTransfer t info = unwords @@ -56,12 +60,12 @@ - which should be run after locking the transfer lock file, but - before using the callback, and a MVar that can be used to read - the number of bytesComplete. -} -mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath, Annex (), MVar Integer) +mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, RawFilePath, Annex (), MVar Integer) mkProgressUpdater t info = do tfile <- fromRepo $ transferFile t let createtfile = void $ tryNonAsync $ writeTransferInfoFile info tfile mvar <- liftIO $ newMVar 0 - return (liftIO . updater tfile mvar, tfile, createtfile, mvar) + return (liftIO . updater (fromRawFilePath tfile) mvar, tfile, createtfile, mvar) where updater tfile mvar b = modifyMVar_ mvar $ \oldbytes -> do let newbytes = fromBytesProcessed b @@ -103,13 +107,13 @@ tfile <- fromRepo $ transferFile t let lck = transferLockFile tfile let cleanstale = do - void $ tryIO $ removeFile tfile - void $ tryIO $ removeFile lck + void $ tryIO $ R.removeLink tfile + void $ tryIO $ R.removeLink lck #ifndef mingw32_HOST_OS v <- getLockStatus lck case v of StatusLockedBy pid -> liftIO $ catchDefaultIO Nothing $ - readTransferInfoFile (Just pid) tfile + readTransferInfoFile (Just pid) (fromRawFilePath tfile) _ -> do -- Take a non-blocking lock while deleting -- the stale lock file. Ignore failure @@ -145,7 +149,7 @@ infos <- mapM checkTransfer transfers return $ mapMaybe running $ zip transfers infos where - findfiles = liftIO . mapM dirContentsRecursive + findfiles = liftIO . mapM (dirContentsRecursive . fromRawFilePath) =<< mapM (fromRepo . transferDir) dirs running (t, Just i) = Just (t, i) running (_, Nothing) = Nothing @@ -172,7 +176,7 @@ return $ case (mt, mi) of (Just t, Just i) -> Just (t, i) _ -> Nothing - findfiles = liftIO . mapM dirContentsRecursive + findfiles = liftIO . mapM (dirContentsRecursive . fromRawFilePath) =<< mapM (fromRepo . failedTransferDir u) [Download, Upload] clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)] @@ -184,7 +188,7 @@ removeFailedTransfer :: Transfer -> Annex () removeFailedTransfer t = do f <- fromRepo $ failedTransferFile t - liftIO $ void $ tryIO $ removeFile f + liftIO $ void $ tryIO $ R.removeLink f recordFailedTransfer :: Transfer -> TransferInfo -> Annex () recordFailedTransfer t info = do @@ -192,20 +196,23 @@ writeTransferInfoFile info failedtfile {- The transfer information file to use for a given Transfer. -} -transferFile :: Transfer -> Git.Repo -> FilePath -transferFile (Transfer direction u kd) r = transferDir direction r - filter (/= '/') (fromUUID u) - fromRawFilePath (keyFile (mkKey (const kd))) +transferFile :: Transfer -> Git.Repo -> RawFilePath +transferFile (Transfer direction u kd) r = + transferDir direction r + P. B8.filter (/= '/') (fromUUID u) + P. keyFile (mkKey (const kd)) {- The transfer information file to use to record a failed Transfer -} -failedTransferFile :: Transfer -> Git.Repo -> FilePath -failedTransferFile (Transfer direction u kd) r = failedTransferDir u direction r - fromRawFilePath (keyFile (mkKey (const kd))) +failedTransferFile :: Transfer -> Git.Repo -> RawFilePath +failedTransferFile (Transfer direction u kd) r = + failedTransferDir u direction r + P. keyFile (mkKey (const kd)) {- The transfer lock file corresponding to a given transfer info file. -} -transferLockFile :: FilePath -> FilePath -transferLockFile infofile = let (d,f) = splitFileName infofile in - combine d ("lck." ++ f) +transferLockFile :: RawFilePath -> RawFilePath +transferLockFile infofile = + let (d, f) = P.splitFileName infofile + in P.combine d ("lck." <> f) {- Parses a transfer information filename to a Transfer. -} parseTransferFile :: FilePath -> Maybe Transfer @@ -220,7 +227,7 @@ where bits = splitDirectories file -writeTransferInfoFile :: TransferInfo -> FilePath -> Annex () +writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex () writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info -- The file keeps whatever permissions it has, so should be used only @@ -286,16 +293,16 @@ else pure Nothing -- not failure {- The directory holding transfer information files for a given Direction. -} -transferDir :: Direction -> Git.Repo -> FilePath -transferDir direction r = gitAnnexTransferDir r formatDirection direction +transferDir :: Direction -> Git.Repo -> RawFilePath +transferDir direction r = gitAnnexTransferDir r P. formatDirection direction {- The directory holding failed transfer information files for a given - Direction and UUID -} -failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath +failedTransferDir :: UUID -> Direction -> Git.Repo -> RawFilePath failedTransferDir u direction r = gitAnnexTransferDir r - "failed" - formatDirection direction - filter (/= '/') (fromUUID u) + P. "failed" + P. formatDirection direction + P. B8.filter (/= '/') (fromUUID u) prop_read_write_transferinfo :: TransferInfo -> Bool prop_read_write_transferinfo info diff --git a/Logs/Unused.hs b/Logs/Unused.hs --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -15,6 +15,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Unused ( UnusedMap, updateUnusedLog, @@ -55,13 +57,13 @@ where oldts _old@(_, ts) _new@(int, _) = (int, ts) -updateUnusedLog :: FilePath -> UnusedMap -> Annex () +updateUnusedLog :: RawFilePath -> UnusedMap -> Annex () updateUnusedLog prefix m = do oldl <- readUnusedLog prefix newl <- preserveTimestamps oldl . flip map2log m <$> liftIO getPOSIXTime writeUnusedLog prefix newl -writeUnusedLog :: FilePath -> UnusedLog -> Annex () +writeUnusedLog :: RawFilePath -> UnusedLog -> Annex () writeUnusedLog prefix l = do logfile <- fromRepo $ gitAnnexUnusedLog prefix writeLogFile logfile $ unlines $ map format $ M.toList l @@ -69,9 +71,9 @@ format (k, (i, Just t)) = show i ++ " " ++ serializeKey k ++ " " ++ show t format (k, (i, Nothing)) = show i ++ " " ++ serializeKey k -readUnusedLog :: FilePath -> Annex UnusedLog +readUnusedLog :: RawFilePath -> Annex UnusedLog readUnusedLog prefix = do - f <- fromRepo $ gitAnnexUnusedLog prefix + f <- fromRawFilePath <$> fromRepo (gitAnnexUnusedLog prefix) ifM (liftIO $ doesFileExist f) ( M.fromList . mapMaybe parse . lines <$> liftIO (readFileStrict f) @@ -87,13 +89,13 @@ skey = reverse rskey ts = reverse rts -readUnusedMap :: FilePath -> Annex UnusedMap +readUnusedMap :: RawFilePath -> Annex UnusedMap readUnusedMap = log2map <$$> readUnusedLog -dateUnusedLog :: FilePath -> Annex (Maybe UTCTime) +dateUnusedLog :: RawFilePath -> Annex (Maybe UTCTime) dateUnusedLog prefix = do f <- fromRepo $ gitAnnexUnusedLog prefix - liftIO $ catchMaybeIO $ getModificationTime f + liftIO $ catchMaybeIO $ getModificationTime $ fromRawFilePath f {- Set of unused keys. This is cached for speed. -} unusedKeys :: Annex (S.Set Key) diff --git a/Logs/View.hs b/Logs/View.hs --- a/Logs/View.hs +++ b/Logs/View.hs @@ -50,7 +50,7 @@ recentViews :: Annex [View] recentViews = do - f <- fromRepo gitAnnexViewLog + f <- fromRawFilePath <$> fromRepo gitAnnexViewLog liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f) {- Gets the currently checked out view, if there is one. -} diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -49,7 +49,7 @@ - This allows uploads of keys without size to still have progress - displayed. -} -data KeySizer = KeySizer Key (Annex (Maybe FilePath)) +data KeySizer = KeySizer Key (Annex (Maybe RawFilePath)) instance MeterSize KeySizer where getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -43,10 +43,10 @@ size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp runner (next (Len size)) FileSize f next -> do - size <- liftIO $ catchDefaultIO 0 $ getFileSize f + size <- liftIO $ catchDefaultIO 0 $ getFileSize (toRawFilePath f) runner (next (Len size)) ContentSize k next -> do - let getsize = liftIO . catchMaybeIO . getFileSize . fromRawFilePath + let getsize = liftIO . catchMaybeIO . getFileSize size <- inAnnex' isJust Nothing getsize k runner (next (Len <$> size)) ReadContent k af o sender next -> do @@ -77,7 +77,7 @@ let runtransfer ti = Right <$> transfer download k af (\p -> getViaTmp rsp DefaultVerify k $ \tmp -> - storefile tmp o l getb validitycheck p ti) + storefile (fromRawFilePath tmp) o l getb validitycheck p ti) let fallback = return $ Left $ ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" checktransfer runtransfer fallback @@ -166,7 +166,7 @@ indicatetransferred ti rightsize <- do - sz <- liftIO $ getFileSize dest + sz <- liftIO $ getFileSize (toRawFilePath dest) return (toInteger sz == l + o) runner validitycheck >>= \case diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -124,7 +124,7 @@ -- the callback. serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO () serveUnixSocket unixsocket serveconn = do - nukeFile unixsocket + removeWhenExistsWith removeLink unixsocket soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol S.bind soc (S.SockAddrUnix unixsocket) -- Allow everyone to read and write to the socket, @@ -135,7 +135,7 @@ -- Connections have to authenticate to do anything, -- so it's fine that other local users can connect to the -- socket. - modifyFileMode unixsocket $ addModes + modifyFileMode (toRawFilePath unixsocket) $ addModes [groupReadMode, groupWriteMode, otherReadMode, otherWriteMode] S.listen soc 2 forever $ do diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Remote.BitTorrent (remote) where @@ -29,8 +30,10 @@ import qualified Annex.Url as Url import Remote.Helper.ExportImport import Annex.SpecialRemote.Config +import qualified Utility.RawFilePath as R import Network.URI +import qualified System.FilePath.ByteString as P #ifdef WITH_TORRENTPARSER import Data.Torrent @@ -167,7 +170,7 @@ torrentUrlKey u = return $ fromUrl (fst $ torrentUrlNum u) Nothing {- Temporary filename to use to store the torrent file. -} -tmpTorrentFile :: URLString -> Annex FilePath +tmpTorrentFile :: URLString -> Annex RawFilePath tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u {- A cleanup action is registered to delete the torrent file @@ -179,34 +182,37 @@ -} registerTorrentCleanup :: URLString -> Annex () registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ - liftIO . nukeFile =<< tmpTorrentFile u + liftIO . removeWhenExistsWith R.removeLink =<< tmpTorrentFile u {- Downloads the torrent file. (Not its contents.) -} downloadTorrentFile :: URLString -> Annex Bool downloadTorrentFile u = do torrent <- tmpTorrentFile u - ifM (liftIO $ doesFileExist torrent) + ifM (liftIO $ doesFileExist (fromRawFilePath torrent)) ( return True , do showAction "downloading torrent file" createAnnexDirectory (parentDir torrent) if isTorrentMagnetUrl u then withOtherTmp $ \othertmp -> do - kf <- fromRawFilePath . keyFile <$> torrentUrlKey u - let metadir = othertmp "torrentmeta" kf + kf <- keyFile <$> torrentUrlKey u + let metadir = othertmp P. "torrentmeta" P. kf createAnnexDirectory metadir showOutput - ok <- downloadMagnetLink u metadir torrent - liftIO $ removeDirectoryRecursive metadir + ok <- downloadMagnetLink u + (fromRawFilePath metadir) + (fromRawFilePath torrent) + liftIO $ removeDirectoryRecursive + (fromRawFilePath metadir) return ok else withOtherTmp $ \othertmp -> do - withTmpFileIn othertmp "torrent" $ \f h -> do + withTmpFileIn (fromRawFilePath othertmp) "torrent" $ \f h -> do liftIO $ hClose h - resetAnnexFilePerm f + resetAnnexFilePerm (toRawFilePath f) ok <- Url.withUrlOptions $ Url.download nullMeterUpdate u f when ok $ - liftIO $ renameFile f torrent + liftIO $ renameFile f (fromRawFilePath torrent) return ok ) @@ -237,14 +243,15 @@ downloadTorrentContent k u dest filenum p = do torrent <- tmpTorrentFile u withOtherTmp $ \othertmp -> do - kf <- fromRawFilePath . keyFile <$> torrentUrlKey u - let downloaddir = othertmp "torrent" kf + kf <- keyFile <$> torrentUrlKey u + let downloaddir = othertmp P. "torrent" P. kf createAnnexDirectory downloaddir f <- wantedfile torrent + let dlf = fromRawFilePath downloaddir f showOutput - ifM (download torrent downloaddir <&&> liftIO (doesFileExist (downloaddir f))) + ifM (download torrent downloaddir <&&> liftIO (doesFileExist dlf)) ( do - liftIO $ renameFile (downloaddir f) dest + liftIO $ renameFile dlf dest -- The downloaddir is not removed here, -- so if aria downloaded parts of other -- files, and this is called again, it will @@ -258,9 +265,9 @@ where download torrent tmpdir = ariaProgress (fromKey keySize k) p [ Param $ "--select-file=" ++ show filenum - , File torrent + , File (fromRawFilePath torrent) , Param "-d" - , File tmpdir + , File (fromRawFilePath tmpdir) , Param "--seed-time=0" , Param "--summary-interval=0" , Param "--file-allocation=none" @@ -347,11 +354,11 @@ {- Examines the torrent file and gets the list of files in it, - and their sizes. -} -torrentFileSizes :: FilePath -> IO [(FilePath, Integer)] +torrentFileSizes :: RawFilePath -> IO [(FilePath, Integer)] torrentFileSizes torrent = do #ifdef WITH_TORRENTPARSER let mkfile = joinPath . map (scrub . decodeBL) - b <- B.readFile torrent + b <- B.readFile (fromRawFilePath torrent) return $ case readTorrent b of Left e -> giveup $ "failed to parse torrent: " ++ e Right t -> case tInfo t of diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -285,11 +285,11 @@ bup2GitRemote "" = do -- bup -r "" operates on ~/.bup h <- myHomeDir - Git.Construct.fromAbsPath $ h ".bup" + Git.Construct.fromAbsPath $ toRawFilePath $ h ".bup" bup2GitRemote r | bupLocal r = if "/" `isPrefixOf` r - then Git.Construct.fromAbsPath r + then Git.Construct.fromAbsPath (toRawFilePath r) else giveup "please specify an absolute path" | otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir where diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Remote.Directory ( @@ -15,6 +16,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as M +import qualified System.FilePath.ByteString as P import Data.Default import Annex.Common @@ -25,7 +27,6 @@ import Config.Cost import Config import Annex.SpecialRemote.Config -import Utility.FileMode import Remote.Helper.Special import Remote.Helper.ExportImport import Types.Import @@ -35,10 +36,13 @@ import Annex.UUID import Backend import Types.KeySource +import Types.ProposedAccepted import Utility.Metered import Utility.Tmp import Utility.InodeCache -import Types.ProposedAccepted +import Utility.FileMode +import Utility.Directory.Create +import qualified Utility.RawFilePath as R remote :: RemoteType remote = specialRemoteType $ RemoteType @@ -106,20 +110,21 @@ , config = c , getRepo = return r , gitconfig = gc - , localpath = Just dir + , localpath = Just dir' , readonly = False , appendonly = False , availability = LocallyAvailable , remotetype = remote , mkUnavailable = gen r u rc (gc { remoteAnnexDirectory = Just "/dev/null" }) rs - , getInfo = return [("directory", dir)] + , getInfo = return [("directory", dir')] , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs } where - dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc + dir = toRawFilePath dir' + dir' = fromMaybe (giveup "missing directory") (remoteAnnexDirectory gc) directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) directorySetup _ mu _ c gc = do @@ -127,7 +132,7 @@ -- verify configuration is sane let dir = maybe (giveup "Specify directory=") fromProposedAccepted $ M.lookup directoryField c - absdir <- liftIO $ absPath dir + absdir <- liftIO $ fromRawFilePath <$> absPath (toRawFilePath dir) liftIO $ unlessM (doesDirectoryExist absdir) $ giveup $ "Directory does not exist: " ++ absdir (c', _encsetup) <- encryptionSetup c gc @@ -140,81 +145,90 @@ {- Locations to try to access a given Key in the directory. - We try more than one since we used to write to different hash - directories. -} -locations :: FilePath -> Key -> [FilePath] -locations d k = map (\f -> d fromRawFilePath f) (keyPaths k) +locations :: RawFilePath -> Key -> [RawFilePath] +locations d k = map (d P.) (keyPaths k) {- Returns the location off a Key in the directory. If the key is - present, returns the location that is actually used, otherwise - returns the first, default location. -} -getLocation :: FilePath -> Key -> IO FilePath +getLocation :: RawFilePath -> Key -> IO RawFilePath getLocation d k = do let locs = locations d k - fromMaybe (Prelude.head locs) <$> firstM doesFileExist locs + fromMaybe (Prelude.head locs) + <$> firstM (doesFileExist . fromRawFilePath) locs {- Directory where the file(s) for a key are stored. -} -storeDir :: FilePath -> Key -> FilePath -storeDir d k = addTrailingPathSeparator $ - d fromRawFilePath (hashDirLower def k) fromRawFilePath (keyFile k) +storeDir :: RawFilePath -> Key -> RawFilePath +storeDir d k = P.addTrailingPathSeparator $ + d P. hashDirLower def k P. keyFile k {- Check if there is enough free disk space in the remote's directory to - store the key. Note that the unencrypted key size is checked. -} -storeKeyM :: FilePath -> ChunkConfig -> Storer +storeKeyM :: RawFilePath -> ChunkConfig -> Storer storeKeyM d chunkconfig k c m = ifM (checkDiskSpaceDirectory d k) ( byteStorer (store d chunkconfig) k c m , giveup "Not enough free disk space." ) -checkDiskSpaceDirectory :: FilePath -> Key -> Annex Bool +checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool checkDiskSpaceDirectory d k = do annexdir <- fromRepo gitAnnexObjectDir samefilesystem <- liftIO $ catchDefaultIO False $ (\a b -> deviceID a == deviceID b) - <$> getFileStatus d - <*> getFileStatus annexdir + <$> R.getFileStatus d + <*> R.getFileStatus annexdir checkDiskSpace (Just d) k 0 samefilesystem -store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex () +store :: RawFilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex () store d chunkconfig k b p = liftIO $ do void $ tryIO $ createDirectoryUnder d tmpdir case chunkconfig of LegacyChunks chunksize -> - Legacy.store d chunksize (finalizeStoreGeneric d) k b p tmpdir destdir + Legacy.store + (fromRawFilePath d) + chunksize + (finalizeStoreGeneric d) + k b p + (fromRawFilePath tmpdir) + (fromRawFilePath destdir) _ -> do - let tmpf = tmpdir kf - meteredWriteFile p tmpf b + let tmpf = tmpdir P. kf + meteredWriteFile p (fromRawFilePath tmpf) b finalizeStoreGeneric d tmpdir destdir where - tmpdir = addTrailingPathSeparator $ d "tmp" kf - kf = fromRawFilePath (keyFile k) + tmpdir = P.addTrailingPathSeparator $ d P. "tmp" P. kf + kf = keyFile k destdir = storeDir d k {- Passed a temp directory that contains the files that should be placed - in the dest directory, moves it into place. Anything already existing - in the dest directory will be deleted. File permissions will be locked - down. -} -finalizeStoreGeneric :: FilePath -> FilePath -> FilePath -> IO () +finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO () finalizeStoreGeneric d tmp dest = do - removeDirGeneric d dest + removeDirGeneric (fromRawFilePath d) dest' createDirectoryUnder d (parentDir dest) - renameDirectory tmp dest + renameDirectory (fromRawFilePath tmp) dest' -- may fail on some filesystems void $ tryIO $ do - mapM_ preventWrite =<< dirContents dest + mapM_ (preventWrite . toRawFilePath) =<< dirContents dest' preventWrite dest + where + dest' = fromRawFilePath dest -retrieveKeyFileM :: FilePath -> ChunkConfig -> Retriever +retrieveKeyFileM :: RawFilePath -> ChunkConfig -> Retriever retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d retrieveKeyFileM d _ = byteRetriever $ \k sink -> - sink =<< liftIO (L.readFile =<< getLocation d k) + sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k) -retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) +retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) -- no cheap retrieval possible for chunks retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing #ifndef mingw32_HOST_OS retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do - file <- absPath =<< getLocation d k + file <- fromRawFilePath <$> (absPath =<< getLocation d k) ifM (doesFileExist file) ( createSymbolicLink file f , giveup "content file not present in remote" @@ -223,8 +237,10 @@ retrieveKeyFileCheapM _ _ = Nothing #endif -removeKeyM :: FilePath -> Remover -removeKeyM d k = liftIO $ removeDirGeneric d (storeDir d k) +removeKeyM :: RawFilePath -> Remover +removeKeyM d k = liftIO $ removeDirGeneric + (fromRawFilePath d) + (fromRawFilePath (storeDir d k)) {- Removes the directory, which must be located under the topdir. - @@ -238,7 +254,7 @@ -} removeDirGeneric :: FilePath -> FilePath -> IO () removeDirGeneric topdir dir = do - void $ tryIO $ allowWrite dir + void $ tryIO $ allowWrite (toRawFilePath dir) #ifdef mingw32_HOST_OS {- Windows needs the files inside the directory to be writable - before it can delete them. -} @@ -250,85 +266,88 @@ unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $ throwM e -checkPresentM :: FilePath -> ChunkConfig -> CheckPresent +checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k checkPresentM d _ k = checkPresentGeneric d (locations d k) -checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool +checkPresentGeneric :: RawFilePath -> [RawFilePath] -> Annex Bool checkPresentGeneric d ps = checkPresentGeneric' d $ - liftIO $ anyM doesFileExist ps + liftIO $ anyM (doesFileExist . fromRawFilePath) ps -checkPresentGeneric' :: FilePath -> Annex Bool -> Annex Bool +checkPresentGeneric' :: RawFilePath -> Annex Bool -> Annex Bool checkPresentGeneric' d check = ifM check ( return True - , ifM (liftIO $ doesDirectoryExist d) + , ifM (liftIO $ doesDirectoryExist (fromRawFilePath d)) ( return False - , giveup $ "directory " ++ d ++ " is not accessible" + , giveup $ "directory " ++ fromRawFilePath d ++ " is not accessible" ) ) -storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM :: RawFilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM d src _k loc p = liftIO $ do - createDirectoryUnder d (takeDirectory dest) + createDirectoryUnder d (P.takeDirectory dest) -- Write via temp file so that checkPresentGeneric will not -- see it until it's fully stored. - viaTmp (\tmp () -> withMeteredFile src p (L.writeFile tmp)) dest () + viaTmp go (fromRawFilePath dest) () where dest = exportPath d loc + go tmp () = withMeteredFile src p (L.writeFile tmp) -retrieveExportM :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () +retrieveExportM :: RawFilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () retrieveExportM d _k loc dest p = liftIO $ withMeteredFile src p (L.writeFile dest) where - src = exportPath d loc + src = fromRawFilePath $ exportPath d loc -removeExportM :: FilePath -> Key -> ExportLocation -> Annex () +removeExportM :: RawFilePath -> Key -> ExportLocation -> Annex () removeExportM d _k loc = liftIO $ do - nukeFile src + removeWhenExistsWith removeLink src removeExportLocation d loc where - src = exportPath d loc + src = fromRawFilePath $ exportPath d loc -checkPresentExportM :: FilePath -> Key -> ExportLocation -> Annex Bool +checkPresentExportM :: RawFilePath -> Key -> ExportLocation -> Annex Bool checkPresentExportM d _k loc = checkPresentGeneric d [exportPath d loc] -renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) +renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM d _k oldloc newloc = liftIO $ do - createDirectoryUnder d (takeDirectory dest) - renameFile src dest + createDirectoryUnder d (P.takeDirectory dest) + renameFile (fromRawFilePath src) (fromRawFilePath dest) removeExportLocation d oldloc return (Just ()) where src = exportPath d oldloc dest = exportPath d newloc -exportPath :: FilePath -> ExportLocation -> FilePath -exportPath d loc = d fromRawFilePath (fromExportLocation loc) +exportPath :: RawFilePath -> ExportLocation -> RawFilePath +exportPath d loc = d P. fromExportLocation loc {- Removes the ExportLocation's parent directory and its parents, so long as - they're empty, up to but not including the topdir. -} -removeExportLocation :: FilePath -> ExportLocation -> IO () +removeExportLocation :: RawFilePath -> ExportLocation -> IO () removeExportLocation topdir loc = - go (Just $ takeDirectory $ fromRawFilePath $ fromExportLocation loc) (Right ()) + go (Just $ P.takeDirectory $ fromExportLocation loc) (Right ()) where go _ (Left _e) = return () go Nothing _ = return () - go (Just loc') _ = go (upFrom loc') - =<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation (toRawFilePath loc'))) + go (Just loc') _ = + let p = fromRawFilePath $ exportPath topdir $ + mkExportLocation loc' + in go (upFrom loc') =<< tryIO (removeDirectory p) -listImportableContentsM :: FilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) listImportableContentsM dir = catchMaybeIO $ liftIO $ do - l <- dirContentsRecursive dir - l' <- mapM go l + l <- dirContentsRecursive (fromRawFilePath dir) + l' <- mapM (go . toRawFilePath) l return $ ImportableContents (catMaybes l') [] where go f = do - st <- getFileStatus f + st <- R.getFileStatus f mkContentIdentifier f st >>= \case Nothing -> return Nothing Just cid -> do - relf <- toRawFilePath <$> relPathDirToFile dir f + relf <- relPathDirToFile dir f sz <- getFileSize' f st return $ Just (mkImportLocation relf, (cid, sz)) @@ -340,7 +359,7 @@ -- result in extra work to re-import them. -- -- If the file is not a regular file, this will return Nothing. -mkContentIdentifier :: FilePath -> FileStatus -> IO (Maybe ContentIdentifier) +mkContentIdentifier :: RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier) mkContentIdentifier f st = fmap (ContentIdentifier . encodeBS . showInodeCache) <$> toInodeCache noTSDelta f st @@ -350,33 +369,35 @@ | new == Just old = cont | otherwise = giveup "file content has changed" -importKeyM :: FilePath -> ExportLocation -> ContentIdentifier -> MeterUpdate -> Annex Key +importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> MeterUpdate -> Annex Key importKeyM dir loc cid p = do - backend <- chooseBackend (fromRawFilePath f) + backend <- chooseBackend f k <- fst <$> genKey ks p backend - currcid <- liftIO $ mkContentIdentifier absf =<< getFileStatus absf + currcid <- liftIO $ mkContentIdentifier absf + =<< R.getFileStatus absf guardSameContentIdentifiers (return k) cid currcid where f = fromExportLocation loc - absf = dir fromRawFilePath f + absf = dir P. f ks = KeySource { keyFilename = f - , contentLocation = toRawFilePath absf + , contentLocation = absf , inodeCache = Nothing } -retrieveExportWithContentIdentifierM :: FilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key +retrieveExportWithContentIdentifierM :: RawFilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key retrieveExportWithContentIdentifierM dir loc cid dest mkkey p = precheck $ docopy postcheck where f = exportPath dir loc + f' = fromRawFilePath f docopy cont = do #ifndef mingw32_HOST_OS let open = do -- Need a duplicate fd for the post check, since -- hGetContentsMetered closes its handle. - fd <- openFd f ReadOnly Nothing defaultFileFlags + fd <- openFd f' ReadOnly Nothing defaultFileFlags dupfd <- dup fd h <- fdToHandle fd return (h, dupfd) @@ -385,7 +406,7 @@ closeFd dupfd bracketIO open close $ \(h, dupfd) -> do #else - let open = openBinaryFile f ReadMode + let open = openBinaryFile f' ReadMode let close = hClose bracketIO open close $ \h -> do #endif @@ -401,7 +422,7 @@ -- content. precheck cont = guardSameContentIdentifiers cont cid =<< liftIO . mkContentIdentifier f - =<< liftIO (getFileStatus f) + =<< liftIO (R.getFileStatus f) -- Check after copy, in case the file was changed while it was -- being copied. @@ -429,15 +450,16 @@ #endif guardSameContentIdentifiers cont cid currcid -storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +storeExportWithContentIdentifierM :: RawFilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do - liftIO $ createDirectoryUnder dir destdir + liftIO $ createDirectoryUnder dir (toRawFilePath destdir) withTmpFileIn destdir template $ \tmpf tmph -> do + let tmpf' = toRawFilePath tmpf liftIO $ withMeteredFile src p (L.hPut tmph) liftIO $ hFlush tmph liftIO $ hClose tmph - resetAnnexFilePerm tmpf - liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf >>= \case + resetAnnexFilePerm tmpf' + liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf' >>= \case Nothing -> giveup "unable to generate content identifier" Just newcid -> do checkExportContent dir loc @@ -446,17 +468,17 @@ (const $ liftIO $ rename tmpf dest) return newcid where - dest = exportPath dir loc + dest = fromRawFilePath $ exportPath dir loc (destdir, base) = splitFileName dest template = relatedTemplate (base ++ ".tmp") -removeExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () +removeExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () removeExportWithContentIdentifierM dir k loc removeablecids = checkExportContent dir loc removeablecids (giveup "unsafe to remove modified file") $ \case DoesNotExist -> return () KnownContentIdentifier -> removeExportM dir k loc -checkPresentExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +checkPresentExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierM dir _k loc knowncids = checkPresentGeneric' dir $ checkExportContent dir loc knowncids (return False) $ \case @@ -480,9 +502,9 @@ -- -- So, it suffices to check if the destination file's current -- content is known, and immediately run the callback. -checkExportContent :: FilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a +checkExportContent :: RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a checkExportContent dir loc knowncids unsafe callback = - tryWhenExists (liftIO $ getFileStatus dest) >>= \case + tryWhenExists (liftIO $ R.getFileStatus dest) >>= \case Just destst | not (isRegularFile destst) -> unsafe | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier dest destst) >>= \case diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -7,10 +7,13 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.Directory.LegacyChunked where import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P import Annex.Common import Utility.FileMode @@ -18,6 +21,7 @@ import qualified Remote.Helper.Chunked.Legacy as Legacy import Annex.Tmp import Utility.Metered +import Utility.Directory.Create withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool withCheckedFiles _ [] _locations _ _ = return False @@ -70,17 +74,20 @@ feed bytes' (sz - s) ls h else return (l:ls) -storeHelper :: FilePath -> (FilePath -> FilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO () +storeHelper :: FilePath -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO () storeHelper repotop finalizer key storer tmpdir destdir = do - void $ liftIO $ tryIO $ createDirectoryUnder repotop tmpdir - Legacy.storeChunks key tmpdir destdir storer recorder finalizer + void $ liftIO $ tryIO $ createDirectoryUnder + (toRawFilePath repotop) + (toRawFilePath tmpdir) + Legacy.storeChunks key tmpdir destdir storer recorder (legacyFinalizer finalizer) where recorder f s = do - void $ tryIO $ allowWrite f + let f' = toRawFilePath f + void $ tryIO $ allowWrite f' writeFile f s - void $ tryIO $ preventWrite f + void $ tryIO $ preventWrite f' -store :: FilePath -> ChunkSize -> (FilePath -> FilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO () +store :: FilePath -> ChunkSize -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO () store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \dests -> storeLegacyChunked p chunksize dests b @@ -88,21 +95,30 @@ - Done very innefficiently, by writing to a temp file. - :/ This is legacy code.. -} -retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Retriever +retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." - let tmp = tmpdir fromRawFilePath (keyFile basek) ++ ".directorylegacy.tmp" + let tmp = fromRawFilePath $ + tmpdir P. keyFile basek <> ".directorylegacy.tmp" let go = \k sink -> do - liftIO $ void $ withStoredFiles d locations k $ \fs -> do + liftIO $ void $ withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ \fs -> do forM_ fs $ S.appendFile tmp <=< S.readFile return True b <- liftIO $ L.readFile tmp - liftIO $ nukeFile tmp + liftIO $ removeWhenExistsWith removeLink tmp sink b byteRetriever go basek p c -checkKey :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex Bool -checkKey d locations k = liftIO $ withStoredFiles d locations k $ - -- withStoredFiles checked that it exists - const $ return True +checkKey :: RawFilePath -> (RawFilePath -> Key -> [RawFilePath]) -> Key -> Annex Bool +checkKey d locations k = liftIO $ + withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ + -- withStoredFiles checked that it exists + const $ return True + +legacyFinalizer :: (RawFilePath -> RawFilePath -> IO ()) -> (FilePath -> FilePath -> IO ()) +legacyFinalizer f = \a b -> f (toRawFilePath a) (toRawFilePath b) + +legacyLocations :: (RawFilePath -> Key -> [RawFilePath]) -> (FilePath -> Key -> [FilePath]) +legacyLocations locations = \f k -> + map fromRawFilePath $ locations (toRawFilePath f) k diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -1,6 +1,6 @@ {- git remotes encrypted using git-remote-gcrypt - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,6 +20,7 @@ import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P import Control.Exception import Data.Default @@ -58,6 +59,7 @@ import Utility.Gpg import Utility.SshHost import Utility.Tuple +import Utility.Directory.Create import Messages.Progress import Types.ProposedAccepted @@ -284,7 +286,7 @@ - which is needed for direct rsync of objects to work. -} rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do - createAnnexDirectory (tmp objectDir) + createAnnexDirectory (toRawFilePath (tmp objectDir)) dummycfg <- liftIO dummyRemoteGitConfig (rsynctransport, rsyncurl, _) <- rsyncTransport r dummycfg let tmpconfig = tmp "config" @@ -368,12 +370,12 @@ store' repo r rsyncopts | not $ Git.repoIsUrl repo = byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do - let tmpdir = Git.repoLocation repo "tmp" fromRawFilePath (keyFile k) - void $ tryIO $ createDirectoryUnder (Git.repoLocation repo) tmpdir - let tmpf = tmpdir fromRawFilePath (keyFile k) - meteredWriteFile p tmpf b - let destdir = parentDir $ gCryptLocation repo k - Remote.Directory.finalizeStoreGeneric (Git.repoLocation repo) tmpdir destdir + let tmpdir = Git.repoPath repo P. "tmp" P. keyFile k + void $ tryIO $ createDirectoryUnder (Git.repoPath repo) tmpdir + let tmpf = tmpdir P. keyFile k + meteredWriteFile p (fromRawFilePath tmpf) b + let destdir = parentDir $ toRawFilePath $ gCryptLocation repo k + Remote.Directory.finalizeStoreGeneric (Git.repoPath repo) tmpdir destdir | Git.repoIsSsh repo = if accessShell r then fileStorer $ \k f p -> do oh <- mkOutputHandler @@ -414,7 +416,9 @@ remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Remover remove' repo r rsyncopts k | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ - liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation repo) (parentDir (gCryptLocation repo k)) + liftIO $ Remote.Directory.removeDirGeneric + (fromRawFilePath (Git.repoPath repo)) + (fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k)))) | Git.repoIsSsh repo = shellOrRsync r removeshell removersync | otherwise = unsupportedUrl where diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -640,8 +640,8 @@ loc <- liftIO $ gitAnnexLocation key repo gc liftIO $ ifM (R.doesPathExist loc) ( do - absloc <- absPath (fromRawFilePath loc) - createSymbolicLink absloc file + absloc <- absPath loc + R.createSymbolicLink absloc (toRawFilePath file) , giveup "remote does not contain key" ) | Git.repoIsSsh repo = Just $ \key af file -> @@ -692,7 +692,7 @@ let rsp = RetrievalAllKeysSecure res <- Annex.Content.getViaTmp rsp verify key $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> - copier object dest p' (liftIO checksuccessio) + copier object (fromRawFilePath dest) p' (liftIO checksuccessio) Annex.Content.saveState True return res ) @@ -820,7 +820,7 @@ State _ _ (CopyCoWTried v) _ _ -> v dorsync = do -- dest may already exist, so make sure rsync can write to it - void $ liftIO $ tryIO $ allowWrite dest + void $ liftIO $ tryIO $ allowWrite (toRawFilePath dest) oh <- mkOutputHandlerQuiet Ssh.rsyncHelper oh (Just p) $ rsyncparams ++ [File src, File dest] diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -389,7 +389,7 @@ ret sha256 size _ -> do sha256 <- calcsha256 - size <- liftIO $ getFileSize content + size <- liftIO $ getFileSize (toRawFilePath content) rememberboth sha256 size ret sha256 size where diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -251,7 +251,7 @@ where go pe cks = do let ls = map chunkKeyList cks - currsize <- liftIO $ catchMaybeIO $ getFileSize dest + currsize <- liftIO $ catchMaybeIO $ getFileSize (toRawFilePath dest) let ls' = maybe ls (setupResume ls) currsize if any null ls' then noop -- dest is already complete diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -5,11 +5,13 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Remote.Helper.Hooks (addHooks) where import qualified Data.Map as M +import qualified System.FilePath.ByteString as P import Annex.Common import Types.Remote @@ -46,13 +48,13 @@ runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a runHooks r starthook stophook a = do dir <- fromRepo gitAnnexRemotesDir - let lck = dir remoteid ++ ".lck" + let lck = dir P. remoteid <> ".lck" whenM (notElem lck . M.keys <$> getLockCache) $ do createAnnexDirectory dir firstrun lck a where - remoteid = show (uuid r) + remoteid = fromUUID (uuid r) run Nothing = noop run (Just command) = void $ liftIO $ boolSystem "sh" [Param "-c", Param command] diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -32,7 +32,7 @@ -- the meter as it's sent. httpBodyStorer :: FilePath -> MeterUpdate -> IO RequestBody httpBodyStorer src m = do - size <- getFileSize src + size <- getFileSize (toRawFilePath src) let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink return $ RequestBodyStream (fromInteger size) streamer diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -32,7 +32,7 @@ store :: (MeterUpdate -> ProtoRunner Bool) -> Key -> AssociatedFile -> MeterUpdate -> Annex () store runner k af p = do - let sizer = KeySizer k (fmap fst <$> prepSendAnnex k) + let sizer = KeySizer k (fmap (toRawFilePath . fst) <$> prepSendAnnex k) metered (Just p) sizer $ \_ p' -> runner p' (P2P.put k af p') >>= \case Just True -> return () diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -93,8 +93,9 @@ fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex ()) -> Storer fileStorer a k (FileContent f) m = a k f m fileStorer a k (ByteContent b) m = withTmp k $ \f -> do - liftIO $ L.writeFile f b - a k f m + let f' = fromRawFilePath f + liftIO $ L.writeFile f' b + a k f' m -- A Storer that expects to be provided with a L.ByteString of -- the content to store. @@ -106,8 +107,8 @@ fileRetriever :: (FilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever fileRetriever a k m callback = do f <- prepTmp k - a f k m - pruneTmpWorkDirBefore f (callback . FileContent) + a (fromRawFilePath f) k m + pruneTmpWorkDirBefore f (callback . FileContent . fromRawFilePath) -- A Retriever that generates a lazy ByteString containing the Key's -- content, and passes it to a callback action which will fully consume it @@ -248,7 +249,7 @@ displayprogress p k srcfile a | displayProgress cfg = - metered (Just p) (KeySizer k (return srcfile)) (const a) + metered (Just p) (KeySizer k (pure (fmap toRawFilePath srcfile))) (const a) | otherwise = a p {- Sink callback for retrieveChunks. Stores the file content into the @@ -283,10 +284,10 @@ withBytes content $ \b -> decrypt cmd c cipher (feedBytes b) $ readBytes write - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f (Nothing, _, FileContent f) -> do withBytes content write - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f (Nothing, _, ByteContent b) -> write b where write b = case mh of diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -224,7 +224,7 @@ storeGeneric' :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex Bool storeGeneric' o meterupdate basedest populatedest = withRsyncScratchDir $ \tmp -> do let dest = tmp basedest - createAnnexDirectory (parentDir dest) + createAnnexDirectory (parentDir (toRawFilePath dest)) ok <- populatedest dest ps <- sendParams if ok @@ -250,7 +250,7 @@ where includes = concatMap use dirHashes use h = let dir = fromRawFilePath (h def k) in - [ parentDir dir + [ fromRawFilePath (parentDir (toRawFilePath dir)) , dir -- match content directory and anything in it , dir fromRawFilePath (keyFile k) "***" @@ -314,7 +314,8 @@ removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex () removeExportM o _k loc = - removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc + removeGeneric o $ map fromRawFilePath $ + includes $ fromExportLocation loc where includes f = f : case upFrom f of Nothing -> [] @@ -325,9 +326,9 @@ where d = fromRawFilePath $ fromExportDirectory ed allbelow f = f "***" - includes f = f : case upFrom f of + includes f = f : case upFrom (toRawFilePath f) of Nothing -> [] - Just f' -> includes f' + Just f' -> includes (fromRawFilePath f') renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM _ _ _ _ = return Nothing @@ -351,7 +352,7 @@ - up trees for rsync. -} withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a withRsyncScratchDir a = do - t <- fromRepo gitAnnexTmpObjectDir + t <- fromRawFilePath <$> fromRepo gitAnnexTmpObjectDir withTmpDirIn t "rsynctmp" a rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> FilePath -> Maybe MeterUpdate -> Annex () diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -13,6 +13,7 @@ import Annex.Locations import Utility.Rsync import Utility.SafeCommand +import Utility.ShellEscape import Utility.FileSystemEncoding import Annex.DirHashes #ifdef mingw32_HOST_OS diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -333,7 +333,7 @@ storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) storeHelper info h magic f object p = liftIO $ case partSize info of Just partsz | partsz > 0 -> do - fsz <- getFileSize f + fsz <- getFileSize (toRawFilePath f) if fsz > partsz then multipartupload fsz partsz else singlepartupload diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -190,7 +190,8 @@ createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool createClient configdir furl = do - createDirectoryIfMissing True (parentDir configdir) + createDirectoryIfMissing True $ + fromRawFilePath $ parentDir $ toRawFilePath configdir boolTahoe configdir "create-client" [ Param "--nickname", Param "git-annex" , Param "--introducer", Param furl diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -30,7 +30,8 @@ import Common import CmdLine.GitAnnex.Options -import qualified Utility.SafeCommand +import qualified Utility.ShellEscape +import qualified Utility.RawFilePath as R import qualified Annex import qualified Git.Filename import qualified Git.Types @@ -68,7 +69,7 @@ import qualified Annex.View.ViewedFile import qualified Logs.View import qualified Command.TestRemote -import qualified Utility.Path +import qualified Utility.Path.Tests import qualified Utility.FileMode import qualified BuildInfo import qualified Utility.Format @@ -141,7 +142,7 @@ exitWith exitcode runsubprocesstests (Just _) = isolateGitConfig $ do ensuretmpdir - crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' tmpdir + crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' (toRawFilePath tmpdir) adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of Nothing -> error "No tests found!?" @@ -183,13 +184,13 @@ [ testProperty "prop_encode_decode_roundtrip" Git.Filename.prop_encode_decode_roundtrip , testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip , testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode - , testProperty "prop_isomorphic_shellEscape" Utility.SafeCommand.prop_isomorphic_shellEscape - , testProperty "prop_isomorphic_shellEscape_multiword" Utility.SafeCommand.prop_isomorphic_shellEscape_multiword + , testProperty "prop_isomorphic_shellEscape" Utility.ShellEscape.prop_isomorphic_shellEscape + , testProperty "prop_isomorphic_shellEscape_multiword" Utility.ShellEscape.prop_isomorphic_shellEscape_multiword , testProperty "prop_isomorphic_configEscape" Logs.Remote.prop_isomorphic_configEscape , testProperty "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config - , testProperty "prop_upFrom_basics" Utility.Path.prop_upFrom_basics - , testProperty "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics - , testProperty "prop_relPathDirToFile_regressionTest" Utility.Path.prop_relPathDirToFile_regressionTest + , testProperty "prop_upFrom_basics" Utility.Path.Tests.prop_upFrom_basics + , testProperty "prop_relPathDirToFileAbs_basics" Utility.Path.Tests.prop_relPathDirToFileAbs_basics + , testProperty "prop_relPathDirToFileAbs_regressionTest" Utility.Path.Tests.prop_relPathDirToFileAbs_regressionTest , testProperty "prop_cost_sane" Config.Cost.prop_cost_sane , testProperty "prop_matcher_sane" Utility.Matcher.prop_matcher_sane , testProperty "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane @@ -311,6 +312,7 @@ , testCase "get (ssh remote)" test_get_ssh_remote , testCase "move" test_move , testCase "move (ssh remote)" test_move_ssh_remote + , testCase "move (numcopies)" test_move_numcopies , testCase "copy" test_copy , testCase "lock" test_lock , testCase "lock --force" test_lock_force @@ -410,7 +412,7 @@ test_ignore_deleted_files = intmpclonerepo $ do git_annex "get" [annexedfile] @? "get failed" git_annex_expectoutput "find" [] [annexedfile] - nukeFile annexedfile + removeWhenExistsWith removeLink annexedfile -- A file that has been deleted, but the deletion not staged, -- is a special case; make sure git-annex skips these. git_annex_expectoutput "find" [] [] @@ -656,6 +658,20 @@ unannexed ingitfile inmainrepo $ unannexed ingitfile +test_move_numcopies :: Assertion +test_move_numcopies = intmpclonerepo $ do + inmainrepo $ annexed_present annexedfile + git_annex "numcopies" ["2"] @? "setting numcopies failed" + git_annex "move" ["--from", "origin", annexedfile] @? "move of file --from remote with numcopies unsatisfied but not made worse failed unexpectedly" + annexed_present annexedfile + inmainrepo $ annexed_notpresent annexedfile + git_annex "move" ["--to", "origin", annexedfile] @? "move of file --to remote with numcopies unsatisfied but not made worse failed unexpectedly" + annexed_notpresent annexedfile + inmainrepo $ annexed_present annexedfile + git_annex "get" [annexedfile] @? "get of file failed" + git_annex_shouldfail "move" ["--from", "origin", annexedfile] @? "move of file --from remote violated numcopies setting" + git_annex_shouldfail "move" ["--to", "origin", annexedfile] @? "move of file --to remote violated numcopies setting" + test_copy :: Assertion test_copy = intmpclonerepo $ do annexed_notpresent annexedfile @@ -768,7 +784,8 @@ Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) Database.Keys.removeInodeCaches k Database.Keys.closeDb - liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache + liftIO . removeWhenExistsWith R.removeLink + =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache writecontent annexedfile "test_lock_force content" git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail" git_annex "lock" ["--force", annexedfile] @? "lock --force of modified file failed" @@ -866,7 +883,7 @@ where corrupt f = do git_annex "get" [f] @? "get of file failed" - Utility.FileMode.allowWrite f + Utility.FileMode.allowWrite (toRawFilePath f) writecontent f (changedcontent f) ifM (hasUnlockedFiles <$> getTestMode) ( git_annex "fsck" [] @? "fsck failed on unlocked file with changed file content" @@ -1030,7 +1047,7 @@ where checkunused expectedkeys desc = do git_annex "unused" [] @? "unused failed" - unusedmap <- annexeval $ Logs.Unused.readUnusedMap "" + unusedmap <- annexeval $ Logs.Unused.readUnusedMap mempty let unusedkeys = M.elems unusedmap assertEqual ("unused keys differ " ++ desc) (sort expectedkeys) (sort unusedkeys) @@ -1315,7 +1332,7 @@ @? "unlock conflictor failed" writecontent conflictor "newconflictor" indir r1 $ - nukeFile conflictor + removeWhenExistsWith removeLink conflictor let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] forM_ l $ \r -> indir r $ git_annex "sync" [] @? "sync failed" @@ -1441,7 +1458,7 @@ withtmpclonerepo $ \r2 -> do indir r1 $ do disconnectOrigin - createDirectoryIfMissing True (parentDir remoteconflictor) + createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor))) writecontent remoteconflictor annexedcontent add_annex conflictor @? "add remoteconflicter failed" git_annex "sync" [] @? "sync failed in r1" @@ -1689,7 +1706,8 @@ test_bup_remote :: Assertion test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do - dir <- absPath "dir" -- bup special remote needs an absolute path + -- bup special remote needs an absolute path + dir <- fromRawFilePath <$> absPath (toRawFilePath "dir") createDirectory dir git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" git_annex "get" [annexedfile] @? "get of file failed" @@ -1713,10 +1731,11 @@ where gpgcmd = Utility.Gpg.mkGpgCmd Nothing testscheme scheme = do - abstmp <- absPath tmpdir + abstmp <- fromRawFilePath <$> absPath (toRawFilePath tmpdir) testscheme' scheme abstmp testscheme' scheme abstmp = intmpclonerepo $ do - gpgtmp <- ( "gpgtmp") <$> relPathCwdToFile abstmp + gpgtmp <- ( "gpgtmp") . fromRawFilePath + <$> relPathCwdToFile (toRawFilePath abstmp) createDirectoryIfMissing False gpgtmp Utility.Gpg.testTestHarness gpgtmp gpgcmd @? "test harness self-test failed" @@ -1813,7 +1832,7 @@ test_addurl = intmpclonerepo $ do -- file:// only; this test suite should not hit the network let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps) - f <- absPath "myurl" + f <- fromRawFilePath <$> absPath (toRawFilePath "myurl") let url = replace "\\" "/" ("file:///" ++ dropDrive f) writecontent f "foo" git_annex_shouldfail "addurl" [url] @? "addurl failed to fail on file url" @@ -1842,7 +1861,7 @@ git_annex "merge" ["foo/" ++ origbranch] @? "git annex merge failed" annexed_present_imported "import" - nukeFile "import" + removeWhenExistsWith removeLink "import" writecontent "import" (content "newimport1") git_annex "add" ["import"] @? "add of import failed" commitchanges @@ -1851,7 +1870,7 @@ -- verify that export refuses to overwrite modified file writedir "import" (content "newimport2") - nukeFile "import" + removeWhenExistsWith removeLink "import" writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed" commitchanges @@ -1861,7 +1880,7 @@ -- resolving import conflict git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" not <$> boolSystem "git" [Param "merge", Param "foo/master", Param "-mmerge"] @? "git merge of conflict failed to exit nonzero" - nukeFile "import" + removeWhenExistsWith removeLink "import" writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed" commitchanges diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -93,8 +93,9 @@ with_ssh_origin cloner a = cloner $ do let k = Git.Types.ConfigKey (encodeBS' config) let v = Git.Types.ConfigValue (toRawFilePath "/dev/null") - origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) - let originurl = "localhost:" ++ origindir + origindir <- absPath . Git.Types.fromConfigValue + =<< annexeval (Config.getConfig k v) + let originurl = "localhost:" ++ fromRawFilePath origindir boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" a where @@ -105,7 +106,7 @@ checkRepo :: Types.Annex a -> FilePath -> IO a checkRepo getval d = do - s <- Annex.new =<< Git.Construct.fromPath d + s <- Annex.new =<< Git.Construct.fromPath (toRawFilePath d) Annex.eval s $ getval `finally` Annex.Action.stopCoProcesses @@ -223,7 +224,7 @@ {- Prevent global git configs from affecting the test suite. -} isolateGitConfig :: IO a -> IO a isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do - tmphomeabs <- absPath tmphome + tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome) Utility.Env.Set.setEnv "HOME" tmphomeabs True Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True diff --git a/Types/Backend.hs b/Types/Backend.hs --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -20,7 +20,7 @@ , genKey :: Maybe (KeySource -> MeterUpdate -> a Key) -- Verifies the content of a key using a hash. This does not need -- to be cryptographically secure. - , verifyKeyContent :: Maybe (Key -> FilePath -> a Bool) + , verifyKeyContent :: Maybe (Key -> RawFilePath -> a Bool) -- Checks if a key can be upgraded to a better form. , canUpgradeKey :: Maybe (Key -> Bool) -- Checks if there is a fast way to migrate a key to a different diff --git a/Types/LockCache.hs b/Types/LockCache.hs --- a/Types/LockCache.hs +++ b/Types/LockCache.hs @@ -10,7 +10,9 @@ LockHandle ) where -import qualified Data.Map as M import Utility.LockPool (LockHandle) -type LockCache = M.Map FilePath LockHandle +import qualified Data.Map as M +import System.FilePath.ByteString (RawFilePath) + +type LockCache = M.Map RawFilePath LockHandle diff --git a/Types/Transfer.hs b/Types/Transfer.hs --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Types.Transfer where @@ -17,6 +18,7 @@ import Utility.Url import Utility.FileSystemEncoding +import qualified Data.ByteString as B import Data.Time.Clock.POSIX import Control.Concurrent import Control.Applicative @@ -56,7 +58,7 @@ data Direction = Upload | Download deriving (Eq, Ord, Show, Read) -formatDirection :: Direction -> String +formatDirection :: Direction -> B.ByteString formatDirection Upload = "upload" formatDirection Download = "download" diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -51,9 +51,9 @@ where err msg = do g <- Annex.gitRepo - p <- liftIO $ absPath $ fromRawFilePath $ Git.repoPath g + p <- liftIO $ absPath $ Git.repoPath g return $ Just $ unwords - [ "Repository", p + [ "Repository", fromRawFilePath p , "is at unsupported version" , show (fromRepoVersion v) ++ "." , msg diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -18,7 +18,8 @@ -- do the reorganisation of the key files olddir <- fromRawFilePath <$> fromRepo gitAnnexDir keys <- getKeysPresent0 olddir - forM_ keys $ \k -> moveAnnex k $ olddir keyFile0 k + forM_ keys $ \k -> + moveAnnex k $ toRawFilePath $ olddir keyFile0 k -- update the symlinks to the key files -- No longer needed here; V1.upgrade does the same thing diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -13,6 +13,7 @@ import Data.ByteString.Builder import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P import Annex.Common import Annex.Content @@ -74,12 +75,13 @@ forM_ files move where move f = do - let k = fileKey1 (takeFileName f) - let d = parentDir f + let f' = toRawFilePath f + let k = fileKey1 (fromRawFilePath (P.takeFileName f')) + let d = parentDir f' liftIO $ allowWrite d - liftIO $ allowWrite f - _ <- moveAnnex k f - liftIO $ removeDirectory d + liftIO $ allowWrite f' + _ <- moveAnnex k f' + liftIO $ removeDirectory (fromRawFilePath d) updateSymlinks :: Annex () updateSymlinks = do @@ -94,7 +96,8 @@ case r of Nothing -> noop Just (k, _) -> do - link <- calcRepo $ gitAnnexLink f k + link <- fromRawFilePath + <$> calcRepo (gitAnnexLink (toRawFilePath f) k) liftIO $ removeFile f liftIO $ createSymbolicLink link f Annex.Queue.addCommand "add" [Param "--"] [f] @@ -113,10 +116,10 @@ , return [] ) move (l, k) = do - dest <- fromRepo $ logFile2 k + dest <- fromRepo (logFile2 k) dir <- fromRepo Upgrade.V2.gitStateDir let f = dir l - createWorkTreeDirectory (parentDir dest) + createWorkTreeDirectory (parentDir (toRawFilePath dest)) -- could just git mv, but this way deals with -- log files that are not checked into git, -- as well as merging with already upgraded @@ -214,7 +217,8 @@ " (unknown backend " ++ bname ++ ")" getKeyFilesPresent1 :: Annex [FilePath] -getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir +getKeyFilesPresent1 = getKeyFilesPresent1' . fromRawFilePath + =<< fromRepo gitAnnexObjectDir getKeyFilesPresent1' :: FilePath -> Annex [FilePath] getKeyFilesPresent1' dir = ifM (liftIO $ doesDirectoryExist dir) diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -132,7 +132,7 @@ gitAttributesUnWrite :: Git.Repo -> IO () gitAttributesUnWrite repo = do - let attributes = Git.attributes repo + let attributes = fromRawFilePath (Git.attributes repo) whenM (doesFileExist attributes) $ do c <- readFileStrict attributes liftIO $ viaTmp writeFile attributes $ unlines $ diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -132,13 +132,14 @@ fromdirect f k = ifM (Direct.goodContent k f) ( do + let f' = toRawFilePath f -- If linkToAnnex fails for some reason, the work tree -- file still has the content; the annex object file -- is just not populated with it. Since the work tree -- file is recorded as an associated file, things will -- still work that way, it's just not ideal. - ic <- withTSDelta (liftIO . genInodeCache (toRawFilePath f)) - void $ Content.linkToAnnex k f ic + ic <- withTSDelta (liftIO . genInodeCache f') + void $ Content.linkToAnnex k f' ic , unlessM (Content.inAnnex k) $ do -- Worktree file was deleted or modified; -- if there are no other copies of the content @@ -150,7 +151,7 @@ ) writepointer f k = liftIO $ do - nukeFile f + removeWhenExistsWith removeLink f S.writeFile f (formatPointer k) {- Remove all direct mode bookkeeping files. -} diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -28,6 +28,7 @@ import Annex.Perms import Utility.InodeCache import Annex.InodeSentinal +import qualified Utility.RawFilePath as R setIndirect :: Annex () setIndirect = do @@ -86,7 +87,7 @@ - the top of the repo. -} associatedFilesRelative :: Key -> Annex [FilePath] associatedFilesRelative key = do - mapping <- calcRepo $ gitAnnexMapping key + mapping <- fromRawFilePath <$> calcRepo (gitAnnexMapping key) liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> -- Read strictly to ensure the file is closed promptly lines <$> hGetContentsStrict h @@ -96,7 +97,7 @@ removeAssociatedFiles key = do mapping <- calcRepo $ gitAnnexMapping key modifyContent mapping $ - liftIO $ nukeFile mapping + liftIO $ removeWhenExistsWith R.removeLink mapping {- Checks if a file in the tree, associated with a key, has not been modified. - @@ -116,13 +117,27 @@ recordedInodeCache :: Key -> Annex [InodeCache] recordedInodeCache key = withInodeCacheFile key $ \f -> liftIO $ catchDefaultIO [] $ - mapMaybe readInodeCache . lines <$> readFileStrict f + mapMaybe readInodeCache . lines + <$> readFileStrict (fromRawFilePath f) {- Removes an inode cache. -} removeInodeCache :: Key -> Annex () removeInodeCache key = withInodeCacheFile key $ \f -> modifyContent f $ - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith R.removeLink f -withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a +withInodeCacheFile :: Key -> (RawFilePath -> Annex a) -> Annex a withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key) + +{- File that maps from a key to the file(s) in the git repository. -} +gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexMapping key r c = do + loc <- gitAnnexLocation key r c + return $ loc <> ".map" + +{- File that caches information about a key's content, used to determine + - if a file has changed. -} +gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexInodeCache key r c = do + loc <- gitAnnexLocation key r c + return $ loc <> ".cache" diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Upgrade.V7 where @@ -18,7 +19,10 @@ import qualified Git import Git.FilePath import Config +import qualified Utility.RawFilePath as R +import qualified System.FilePath.ByteString as P + upgrade :: Bool -> Annex Bool upgrade automatic = do unless automatic $ @@ -33,7 +37,8 @@ -- new database is not populated. It will be automatically -- populated from the git-annex branch the next time it is used. removeOldDb gitAnnexContentIdentifierDbDirOld - liftIO . nukeFile =<< fromRepo gitAnnexContentIdentifierLockOld + liftIO . removeWhenExistsWith R.removeLink + =<< fromRepo gitAnnexContentIdentifierLockOld -- The export databases are deleted here. The new databases -- will be populated by the next thing that needs them, the same @@ -42,31 +47,33 @@ populateKeysDb removeOldDb gitAnnexKeysDbOld - liftIO . nukeFile =<< fromRepo gitAnnexKeysDbIndexCacheOld - liftIO . nukeFile =<< fromRepo gitAnnexKeysDbLockOld + liftIO . removeWhenExistsWith R.removeLink + =<< fromRepo gitAnnexKeysDbIndexCacheOld + liftIO . removeWhenExistsWith R.removeLink + =<< fromRepo gitAnnexKeysDbLockOld updateSmudgeFilter return True -gitAnnexKeysDbOld :: Git.Repo -> FilePath -gitAnnexKeysDbOld r = fromRawFilePath (gitAnnexDir r) "keys" +gitAnnexKeysDbOld :: Git.Repo -> RawFilePath +gitAnnexKeysDbOld r = gitAnnexDir r P. "keys" -gitAnnexKeysDbLockOld :: Git.Repo -> FilePath -gitAnnexKeysDbLockOld r = gitAnnexKeysDbOld r ++ ".lck" +gitAnnexKeysDbLockOld :: Git.Repo -> RawFilePath +gitAnnexKeysDbLockOld r = gitAnnexKeysDbOld r <> ".lck" -gitAnnexKeysDbIndexCacheOld :: Git.Repo -> FilePath -gitAnnexKeysDbIndexCacheOld r = gitAnnexKeysDbOld r ++ ".cache" +gitAnnexKeysDbIndexCacheOld :: Git.Repo -> RawFilePath +gitAnnexKeysDbIndexCacheOld r = gitAnnexKeysDbOld r <> ".cache" -gitAnnexContentIdentifierDbDirOld :: Git.Repo -> FilePath -gitAnnexContentIdentifierDbDirOld r = fromRawFilePath (gitAnnexDir r) "cids" +gitAnnexContentIdentifierDbDirOld :: Git.Repo -> RawFilePath +gitAnnexContentIdentifierDbDirOld r = gitAnnexDir r P. "cids" -gitAnnexContentIdentifierLockOld :: Git.Repo -> FilePath -gitAnnexContentIdentifierLockOld r = gitAnnexContentIdentifierDbDirOld r ++ ".lck" +gitAnnexContentIdentifierLockOld :: Git.Repo -> RawFilePath +gitAnnexContentIdentifierLockOld r = gitAnnexContentIdentifierDbDirOld r <> ".lck" -removeOldDb :: (Git.Repo -> FilePath) -> Annex () +removeOldDb :: (Git.Repo -> RawFilePath) -> Annex () removeOldDb getdb = do - db <- fromRepo getdb + db <- fromRawFilePath <$> fromRepo getdb whenM (liftIO $ doesDirectoryExist db) $ do v <- liftIO $ tryNonAsync $ #if MIN_VERSION_directory(1,2,7) @@ -121,7 +128,7 @@ -- checked into the repository. updateSmudgeFilter :: Annex () updateSmudgeFilter = do - lf <- Annex.fromRepo Git.attributesLocal + lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal ls <- liftIO $ lines <$> catchDefaultIO "" (readFileStrict lf) let ls' = removedotfilter ls when (ls /= ls') $ diff --git a/Utility/Base64.hs b/Utility/Base64.hs --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -8,6 +8,7 @@ module Utility.Base64 where import Utility.FileSystemEncoding +import Utility.QuickCheck import qualified "sandi" Codec.Binary.Base64 as B64 import Data.Maybe @@ -43,7 +44,9 @@ -- Only ascii strings are tested, because an arbitrary string may contain -- characters not encoded using the FileSystemEncoding, which would thus -- not roundtrip, as decodeBS always generates an output encoded that way. -prop_b64_roundtrips :: String -> Bool -prop_b64_roundtrips s +prop_b64_roundtrips :: TestableString -> Bool +prop_b64_roundtrips ts | all (isAscii) s = s == decodeBS (fromB64' (toB64' (encodeBS s))) | otherwise = True + where + s = fromTestableString ts diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -18,24 +18,14 @@ import System.FilePath import System.PosixCompat.Files import Control.Applicative -import Control.Monad.IO.Class -import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO.Error import Data.Maybe import Prelude -#ifndef mingw32_HOST_OS -import Utility.SafeCommand -#endif - import Utility.SystemDirectory -import Utility.Path -import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative -import Utility.PartialPrelude dirCruft :: FilePath -> Bool dirCruft "." = True @@ -101,130 +91,9 @@ =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs -{- Moves one filename to another. - - First tries a rename, but falls back to moving across devices if needed. -} -moveFile :: FilePath -> FilePath -> IO () -moveFile src dest = tryIO (rename src dest) >>= onrename - where - onrename (Right _) = noop - onrename (Left e) - | isPermissionError e = rethrow - | isDoesNotExistError e = rethrow - | otherwise = viaTmp mv dest () - where - rethrow = throwM e - - mv tmp () = do - -- copyFile is likely not as optimised as - -- the mv command, so we'll use the command. - -- - -- But, while Windows has a "mv", it does not seem very - -- reliable, so use copyFile there. -#ifndef mingw32_HOST_OS - -- If dest is a directory, mv would move the file - -- into it, which is not desired. - whenM (isdir dest) rethrow - ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] - let e' = e -#else - r <- tryIO $ copyFile src tmp - let (ok, e') = case r of - Left err -> (False, err) - Right _ -> (True, e) -#endif - unless ok $ do - -- delete any partial - _ <- tryIO $ removeFile tmp - throwM e' - -#ifndef mingw32_HOST_OS - isdir f = do - r <- tryIO $ getFileStatus f - case r of - (Left _) -> return False - (Right s) -> return $ isDirectory s -#endif - -{- Removes a file (or symlink), which may or may not exist. - - - - Note that an exception is thrown if the file exists but - - cannot be removed, or if its a directory. -} -nukeFile :: FilePath -> IO () -nukeFile file = void $ tryWhenExists go - where -#ifndef mingw32_HOST_OS - go = removeLink file -#else - go = removeFile file -#endif - -{- Like createDirectoryIfMissing True, but it will only create - - missing parent directories up to but not including the directory - - in the first parameter. - - - - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" - - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, - - it will throw an exception. - - - - The exception thrown is the same that createDirectory throws if the - - parent directory does not exist. - - - - If the second FilePath is not under the first - - FilePath (or the same as it), it will fail with an exception - - even if the second FilePath's parent directory already exists. - - - - Either or both of the FilePaths can be relative, or absolute. - - They will be normalized as necessary. +{- Use with an action that removes something, which may or may not exist. - - - Note that, the second FilePath, if relative, is relative to the current - - working directory, not to the first FilePath. + - If an exception is thrown due to it not existing, it is ignored. -} -createDirectoryUnder :: FilePath -> FilePath -> IO () -createDirectoryUnder topdir dir = - createDirectoryUnder' topdir dir createDirectory - -createDirectoryUnder' - :: (MonadIO m, MonadCatch m) - => FilePath - -> FilePath - -> (FilePath -> m ()) - -> m () -createDirectoryUnder' topdir dir0 mkdir = do - p <- liftIO $ relPathDirToFile topdir dir0 - let dirs = splitDirectories p - -- Catch cases where the dir is not beneath the topdir. - -- If the relative path between them starts with "..", - -- it's not. And on Windows, if they are on different drives, - -- the path will not be relative. - if headMaybe dirs == Just ".." || isAbsolute p - then liftIO $ ioError $ customerror userErrorType - ("createDirectoryFrom: not located in " ++ topdir) - -- If dir0 is the same as the topdir, don't try to create - -- it, but make sure it does exist. - else if null dirs - then liftIO $ unlessM (doesDirectoryExist topdir) $ - ioError $ customerror doesNotExistErrorType - "createDirectoryFrom: does not exist" - else createdirs $ - map (topdir ) (reverse (scanl1 () dirs)) - where - customerror t s = mkIOError t s Nothing (Just dir0) - - createdirs [] = pure () - createdirs (dir:[]) = createdir dir (liftIO . ioError) - createdirs (dir:dirs) = createdir dir $ \_ -> do - createdirs dirs - createdir dir (liftIO . ioError) - - -- This is the same method used by createDirectoryIfMissing, - -- in particular the handling of errors that occur when the - -- directory already exists. See its source for explanation - -- of several subtleties. - createdir dir notexisthandler = tryIO (mkdir dir) >>= \case - Right () -> pure () - Left e - | isDoesNotExistError e -> notexisthandler e - | isAlreadyExistsError e || isPermissionError e -> - liftIO $ unlessM (doesDirectoryExist dir) $ - ioError e - | otherwise -> liftIO $ ioError e +removeWhenExistsWith :: (a -> IO ()) -> a -> IO () +removeWhenExistsWith f a = void $ tryWhenExists $ f a diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs new file mode 100644 --- /dev/null +++ b/Utility/Directory/Create.hs @@ -0,0 +1,102 @@ +{- directory creating + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Directory.Create ( + createDirectoryUnder, + createDirectoryUnder', +) where + +import Control.Monad +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.IfElse +import System.IO.Error +import Data.Maybe +import qualified System.FilePath.ByteString as P +import Prelude + +import Utility.SystemDirectory +import Utility.Path.AbsRel +import Utility.Exception +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R +import Utility.PartialPrelude + +{- Like createDirectoryIfMissing True, but it will only create + - missing parent directories up to but not including the directory + - in the first parameter. + - + - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" + - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, + - it will throw an exception. + - + - The exception thrown is the same that createDirectory throws if the + - parent directory does not exist. + - + - If the second FilePath is not under the first + - FilePath (or the same as it), it will fail with an exception + - even if the second FilePath's parent directory already exists. + - + - Either or both of the FilePaths can be relative, or absolute. + - They will be normalized as necessary. + - + - Note that, the second FilePath, if relative, is relative to the current + - working directory, not to the first FilePath. + -} +createDirectoryUnder :: RawFilePath -> RawFilePath -> IO () +createDirectoryUnder topdir dir = + createDirectoryUnder' topdir dir R.createDirectory + +createDirectoryUnder' + :: (MonadIO m, MonadCatch m) + => RawFilePath + -> RawFilePath + -> (RawFilePath -> m ()) + -> m () +createDirectoryUnder' topdir dir0 mkdir = do + p <- liftIO $ relPathDirToFile topdir dir0 + let dirs = P.splitDirectories p + -- Catch cases where the dir is not beneath the topdir. + -- If the relative path between them starts with "..", + -- it's not. And on Windows, if they are on different drives, + -- the path will not be relative. + if headMaybe dirs == Just ".." || P.isAbsolute p + then liftIO $ ioError $ customerror userErrorType + ("createDirectoryFrom: not located in " ++ fromRawFilePath topdir) + -- If dir0 is the same as the topdir, don't try to create + -- it, but make sure it does exist. + else if null dirs + then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ + ioError $ customerror doesNotExistErrorType + "createDirectoryFrom: does not exist" + else createdirs $ + map (topdir P.) (reverse (scanl1 (P.) dirs)) + where + customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) + + createdirs [] = pure () + createdirs (dir:[]) = createdir dir (liftIO . ioError) + createdirs (dir:dirs) = createdir dir $ \_ -> do + createdirs dirs + createdir dir (liftIO . ioError) + + -- This is the same method used by createDirectoryIfMissing, + -- in particular the handling of errors that occur when the + -- directory already exists. See its source for explanation + -- of several subtleties. + createdir dir notexisthandler = tryIO (mkdir dir) >>= \case + Right () -> pure () + Left e + | isDoesNotExistError e -> notexisthandler e + | isAlreadyExistsError e || isPermissionError e -> + liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $ + ioError e + | otherwise -> liftIO $ ioError e diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -13,7 +13,7 @@ normalize, ) where -import Common +import Utility.Split data DottedVersion = DottedVersion String Integer deriving (Eq) diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -22,22 +22,24 @@ import Control.Monad.Catch import Utility.Exception +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R {- Applies a conversion function to a file's mode. -} -modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () +modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert -modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' f convert = do - s <- getFileStatus f + s <- R.getFileStatus f let old = fileMode s let new = convert old when (new /= old) $ - setFileMode f new + R.setFileMode f new return old {- Runs an action after changing a file's mode, then restores the old mode. -} -withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode file convert a = bracket setup cleanup go where setup = modifyFileMode' file convert @@ -70,15 +72,15 @@ ] {- Removes the write bits from a file. -} -preventWrite :: FilePath -> IO () +preventWrite :: RawFilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes {- Turns a file's owner write bit back on. -} -allowWrite :: FilePath -> IO () +allowWrite :: RawFilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] {- Turns a file's owner read bit back on. -} -allowRead :: FilePath -> IO () +allowRead :: RawFilePath -> IO () allowRead f = modifyFileMode f $ addModes [ownerReadMode] {- Allows owner and group to read and write to a file. -} @@ -88,7 +90,7 @@ , ownerReadMode, groupReadMode ] -groupWriteRead :: FilePath -> IO () +groupWriteRead :: RawFilePath -> IO () groupWriteRead f = modifyFileMode f $ addModes groupSharedModes checkMode :: FileMode -> FileMode -> Bool @@ -149,7 +151,7 @@ stickyMode :: FileMode stickyMode = 512 -setSticky :: FilePath -> IO () +setSticky :: RawFilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -162,13 +164,13 @@ - On a filesystem that does not support file permissions, this is the same - as writeFile. -} -writeFileProtected :: FilePath -> String -> IO () +writeFileProtected :: RawFilePath -> String -> IO () writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) -writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () writeFileProtected' file writer = protectedOutput $ - withFile file WriteMode $ \h -> do + withFile (fromRawFilePath file) WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -1,5 +1,7 @@ {- File size. - + - Copyright 2015-2020 Joey Hess + - - License: BSD-2-clause -} @@ -13,9 +15,11 @@ ) where import System.PosixCompat.Files +import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO +import Utility.FileSystemEncoding #endif type FileSize = Integer @@ -26,18 +30,18 @@ - FileOffset which maxes out at 2 gb. - See https://github.com/jystic/unix-compat/issues/16 -} -getFileSize :: FilePath -> IO FileSize +getFileSize :: R.RawFilePath -> IO FileSize #ifndef mingw32_HOST_OS -getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) +getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f) #else -getFileSize f = bracket (openFile f ReadMode) hClose hFileSize +getFileSize f = bracket (openFile (fromRawFilePath f) ReadMode) hClose hFileSize #endif {- Gets the size of the file, when its FileStatus is already known. - - On windows, uses getFileSize. Otherwise, the FileStatus contains the - size, so this does not do any work. -} -getFileSize' :: FilePath -> FileStatus -> IO FileSize +getFileSize' :: R.RawFilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s #else diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -422,7 +422,7 @@ orig <- getEnv var subdir <- makenewdir (1 :: Integer) -- gpg is picky about permissions on its home dir - liftIO $ void $ tryIO $ modifyFileMode subdir $ + liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $ removeModes $ otherGroupModes setEnv var subdir True -- For some reason, recent gpg needs a trustdb to be set up. diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -186,15 +186,15 @@ genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f + toInodeCache delta f =<< R.getFileStatus f -toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) +toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache (TSDelta getdelta) f s | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s #ifdef mingw32_HOST_OS - mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f + mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else let mtime = modificationTimeHiRes s #endif diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -18,7 +18,9 @@ import Utility.Process import Utility.Monad import Utility.Path +import Utility.Path.AbsRel import Utility.Split +import Utility.FileSystemEncoding import Data.Maybe import System.FilePath @@ -35,18 +37,20 @@ ( do installfile top lib checksymlink lib - return $ Just $ parentDir lib + return $ Just $ fromRawFilePath $ parentDir $ toRawFilePath lib , return Nothing ) where checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) - let absl = absPathFrom (parentDir f) l - target <- relPathDirToFile (takeDirectory f) absl - installfile top absl - nukeFile (top ++ f) - createSymbolicLink target (inTop top f) - checksymlink absl + let absl = absPathFrom + (parentDir (toRawFilePath f)) + (toRawFilePath l) + target <- relPathDirToFile (toRawFilePath (takeDirectory f)) absl + installfile top (fromRawFilePath absl) + removeWhenExistsWith removeLink (top ++ f) + createSymbolicLink (fromRawFilePath target) (inTop top f) + checksymlink (fromRawFilePath absl) -- Note that f is not relative, so cannot use inTop :: FilePath -> FilePath -> FilePath diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} + module Utility.LockFile.PidLock ( LockHandle, tryLock, @@ -23,7 +25,7 @@ import Utility.Applicative import Utility.Directory import Utility.Monad -import Utility.Path +import Utility.Path.AbsRel import Utility.FileMode import Utility.LockFile.LockStatus import Utility.ThreadScheduler @@ -34,12 +36,13 @@ import qualified Utility.LockFile.Posix as Posix import System.IO -import System.Posix.IO import System.Posix.Types -import System.Posix.Files +import System.Posix.IO.ByteString +import System.Posix.Files.ByteString import System.Posix.Process import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) +import qualified System.FilePath.ByteString as P import Data.Maybe import Data.List import Network.BSD @@ -47,7 +50,7 @@ import Control.Applicative import Prelude -type LockFile = FilePath +type LockFile = RawFilePath data LockHandle = LockHandle LockFile FileStatus SideLockHandle @@ -67,7 +70,8 @@ <*> getHostName readPidLock :: LockFile -> IO (Maybe PidLock) -readPidLock lockfile = (readish =<<) <$> catchMaybeIO (readFile lockfile) +readPidLock lockfile = (readish =<<) + <$> catchMaybeIO (readFile (fromRawFilePath lockfile)) -- To avoid races when taking over a stale pid lock, a side lock is used. -- This is a regular posix exclusive lock. @@ -100,7 +104,7 @@ -- to take the side lock will only succeed once the file is -- deleted, and so will be able to immediately see that it's taken -- a stale lock. - _ <- tryIO $ removeFile f + _ <- tryIO $ removeFile (fromRawFilePath f) Posix.dropLock h -- The side lock is put in /dev/shm. This will work on most any @@ -108,17 +112,17 @@ -- locks. /tmp is used as a fallback. sideLockFile :: LockFile -> IO LockFile sideLockFile lockfile = do - f <- absPath lockfile + f <- fromRawFilePath <$> absPath lockfile let base = intercalate "_" (splitDirectories (makeRelative "/" f)) let shortbase = reverse $ take 32 $ reverse base let md5sum = if base == shortbase then "" - else show (md5 (encodeBL base)) + else toRawFilePath $ show (md5 (encodeBL base)) dir <- ifM (doesDirectoryExist "/dev/shm") ( return "/dev/shm" , return "/tmp" ) - return $ dir md5sum ++ shortbase ++ ".lck" + return $ dir P. md5sum <> toRawFilePath shortbase <> ".lck" -- | Tries to take a lock; does not block when the lock is already held. -- @@ -138,18 +142,20 @@ _ -> return (Just ParentLocked) where go abslockfile sidelock = do - (tmp, h) <- openTempFile (takeDirectory abslockfile) "locktmp" - setFileMode tmp (combineModes readModes) + let abslockfile' = fromRawFilePath abslockfile + (tmp, h) <- openTempFile (takeDirectory abslockfile') "locktmp" + let tmp' = toRawFilePath tmp + setFileMode tmp' (combineModes readModes) hPutStr h . show =<< mkPidLock hClose h let failedlock st = do - dropLock $ LockHandle tmp st sidelock - nukeFile tmp + dropLock $ LockHandle tmp' st sidelock + removeWhenExistsWith removeLink tmp' return Nothing let tooklock st = return $ Just $ LockHandle abslockfile st sidelock - ifM (linkToLock sidelock tmp abslockfile) + ifM (linkToLock sidelock tmp' abslockfile) ( do - nukeFile tmp + removeWhenExistsWith removeLink tmp' -- May not have made a hard link, so stat -- the lockfile lckst <- getFileStatus abslockfile @@ -157,7 +163,7 @@ , do v <- readPidLock abslockfile hn <- getHostName - tmpst <- getFileStatus tmp + tmpst <- getFileStatus tmp' case v of Just pl | isJust sidelock && hn == lockingHost pl -> do -- Since we have the sidelock, @@ -165,7 +171,7 @@ -- the pidlock was taken on, -- we know that the pidlock is -- stale, and can take it over. - rename tmp abslockfile + rename tmp' abslockfile tooklock tmpst _ -> failedlock tmpst ) @@ -180,12 +186,12 @@ -- -- However, not all filesystems support hard links. So, first probe -- to see if they are supported. If not, use open with O_EXCL. -linkToLock :: SideLockHandle -> FilePath -> FilePath -> IO Bool +linkToLock :: SideLockHandle -> RawFilePath -> RawFilePath -> IO Bool linkToLock Nothing _ _ = return False linkToLock (Just _) src dest = do - let probe = src ++ ".lnk" + let probe = src <> ".lnk" v <- tryIO $ createLink src probe - nukeFile probe + removeWhenExistsWith removeLink probe case v of Right _ -> do _ <- tryIO $ createLink src dest @@ -200,7 +206,8 @@ (defaultFileFlags {exclusive = True}) fdToHandle fd let cleanup = hClose - bracket setup cleanup (\h -> readFile src >>= hPutStr h) + let go h = readFile (fromRawFilePath src) >>= hPutStr h + bracket setup cleanup go return True where checklinked = do @@ -228,16 +235,17 @@ -- We can detect this insanity by getting the directory contents after -- making the link, and checking to see if 2 copies of the dest file, -- with the SAME FILENAME exist. -checkInsaneLustre :: FilePath -> IO Bool +checkInsaneLustre :: RawFilePath -> IO Bool checkInsaneLustre dest = do - fs <- dirContents (takeDirectory dest) - case length (filter (== dest) fs) of + let dest' = fromRawFilePath dest + fs <- dirContents (takeDirectory dest') + case length (filter (== dest') fs) of 1 -> return False -- whew! 0 -> return True -- wtf? _ -> do -- Try to clean up the extra copy we made -- that has the same name. Egads. - _ <- tryIO $ removeFile dest + _ <- tryIO $ removeFile dest' return True -- | Waits as necessary to take a lock. @@ -253,20 +261,20 @@ | n > 0 = liftIO (tryLock lockfile) >>= \case Nothing -> do when (n == pred timeout) $ - displaymessage $ "waiting for pid lock file " ++ lockfile ++ " which is held by another process (or may be stale)" + displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)" liftIO $ threadDelaySeconds (Seconds 1) go (pred n) Just lckh -> return lckh | otherwise = do - displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile - giveup $ "Gave up waiting for pid lock file " ++ lockfile + displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile + giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile dropLock :: LockHandle -> IO () dropLock (LockHandle lockfile _ sidelock) = do -- Drop side lock first, at which point the pid lock will be -- considered stale. dropSideLock sidelock - nukeFile lockfile + removeWhenExistsWith removeLink lockfile dropLock ParentLocked = return () getLockStatus :: LockFile -> IO LockStatus @@ -297,9 +305,9 @@ -- The parent process should keep running as long as the child -- process is running, since the child inherits the environment and will -- not see unsetLockEnv. -pidLockEnv :: FilePath -> IO String +pidLockEnv :: RawFilePath -> IO String pidLockEnv lockfile = do - abslockfile <- absPath lockfile + abslockfile <- fromRawFilePath <$> absPath lockfile return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile pidLockEnvValue :: String diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -25,10 +25,13 @@ import Utility.LockFile.LockStatus import System.IO -import System.Posix +import System.Posix.Types +import System.Posix.IO.ByteString +import System.Posix.Files.ByteString +import System.FilePath.ByteString (RawFilePath) import Data.Maybe -type LockFile = FilePath +type LockFile = RawFilePath newtype LockHandle = LockHandle Fd diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -16,9 +16,12 @@ import System.Win32.Types import System.Win32.File import Control.Concurrent +import System.FilePath.ByteString (RawFilePath) -type LockFile = FilePath +import Utility.FileSystemEncoding +type LockFile = RawFilePath + type LockHandle = HANDLE {- Tries to lock a file with a shared lock, which allows other processes to @@ -51,7 +54,7 @@ -} openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do - h <- withTString f $ \c_f -> + h <- withTString (fromRawFilePath f) $ \c_f -> c_CreateFile c_f gENERIC_READ sharemode security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) return $ if h == iNVALID_HANDLE_VALUE diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs --- a/Utility/LockPool/STM.hs +++ b/Utility/LockPool/STM.hs @@ -22,6 +22,7 @@ import Utility.Monad import System.IO.Unsafe (unsafePerformIO) +import System.FilePath.ByteString (RawFilePath) import qualified Data.Map.Strict as M import Control.Concurrent.STM import Control.Exception @@ -29,7 +30,7 @@ import Control.Applicative import Prelude -type LockFile = FilePath +type LockFile = RawFilePath data LockMode = LockExclusive | LockShared deriving (Eq) diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -223,7 +223,8 @@ p sz watcher sz getsz = catchDefaultIO zeroBytesProcessed $ - toBytesProcessed <$> getFileSize f + toBytesProcessed <$> getFileSize f' + f' = toRawFilePath f data OutputHandler = OutputHandler { quietMode :: Bool diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs new file mode 100644 --- /dev/null +++ b/Utility/MoveFile.hs @@ -0,0 +1,74 @@ +{- moving files + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.MoveFile ( + moveFile, +) where + +import Control.Monad +import System.FilePath +import System.PosixCompat.Files +import Control.Monad.IfElse +import System.IO.Error +import Prelude + +#ifndef mingw32_HOST_OS +import Utility.SafeCommand +#endif + +import Utility.SystemDirectory +import Utility.Tmp +import Utility.Exception +import Utility.Monad + +{- Moves one filename to another. + - First tries a rename, but falls back to moving across devices if needed. -} +moveFile :: FilePath -> FilePath -> IO () +moveFile src dest = tryIO (rename src dest) >>= onrename + where + onrename (Right _) = noop + onrename (Left e) + | isPermissionError e = rethrow + | isDoesNotExistError e = rethrow + | otherwise = viaTmp mv dest () + where + rethrow = throwM e + + mv tmp () = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. +#ifndef mingw32_HOST_OS + -- If dest is a directory, mv would move the file + -- into it, which is not desired. + whenM (isdir dest) rethrow + ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + let e' = e +#else + r <- tryIO $ copyFile src tmp + let (ok, e') = case r of + Left err -> (False, err) + Right _ -> (True, e) +#endif + unless ok $ do + -- delete any partial + _ <- tryIO $ removeFile tmp + throwM e' + +#ifndef mingw32_HOST_OS + isdir f = do + r <- tryIO $ getFileStatus f + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s +#endif diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -5,62 +5,55 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path ( simplifyPath, - absPathFrom, parentDir, upFrom, dirContains, - absPath, - relPathCwdToFile, - relPathDirToFile, - relPathDirToFileAbs, segmentPaths, segmentPaths', runSegmentPaths, runSegmentPaths', - relHome, inPath, searchPath, dotfile, splitShortExtensions, - - prop_upFrom_basics, - prop_relPathDirToFile_basics, - prop_relPathDirToFile_regressionTest, + relPathDirToFileAbs, ) where -import System.FilePath +import System.FilePath.ByteString +import qualified System.FilePath as P +import qualified Data.ByteString as B import Data.List import Data.Maybe -#ifdef mingw32_HOST_OS -import Data.Char -#endif import Control.Applicative import Prelude import Utility.Monad -import Utility.UserInfo import Utility.SystemDirectory -import Utility.Split + +#ifdef mingw32_HOST_OS +import Data.Char import Utility.FileSystemEncoding +#endif {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. - - On Windows, preserves whichever style of path separator might be used in - - the input FilePaths. This is done because some programs in Windows + - the input RawFilePaths. This is done because some programs in Windows - demand a particular path separator -- and which one actually varies! - - This does not guarantee that two paths that refer to the same location, - and are both relative to the same location (or both absolute) will - - yeild the same result. Run both through normalise from System.FilePath + - yeild the same result. Run both through normalise from System.RawFilePath - to ensure that. -} -simplifyPath :: FilePath -> FilePath +simplifyPath :: RawFilePath -> RawFilePath simplifyPath path = dropTrailingPathSeparator $ joinDrive drive $ joinPath $ norm [] $ splitPath path' where @@ -75,134 +68,37 @@ where p' = dropTrailingPathSeparator p -{- Makes a path absolute. - - - - Also simplifies it using simplifyPath. - - - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute, and should itsef be absolute. - - - - Does not attempt to deal with edge cases or ensure security with - - untrusted inputs. - -} -absPathFrom :: FilePath -> FilePath -> FilePath -absPathFrom dir path = simplifyPath (combine dir path) - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} -parentDir :: FilePath -> FilePath +parentDir :: RawFilePath -> RawFilePath parentDir = takeDirectory . dropTrailingPathSeparator {- Just the parent directory of a path, or Nothing if the path has no - parent (ie for "/" or "." or "foo") -} -upFrom :: FilePath -> Maybe FilePath +upFrom :: RawFilePath -> Maybe RawFilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs + | otherwise = Just $ joinDrive drive $ + B.intercalate (B.singleton pathSeparator) $ init dirs where -- on Unix, the drive will be "/" when the dir is absolute, -- otherwise "" (drive, path) = splitDrive dir - s = [pathSeparator] - dirs = filter (not . null) $ split s path - -prop_upFrom_basics :: FilePath -> Bool -prop_upFrom_basics dir - | null dir = True - | dir == "/" = p == Nothing - | otherwise = p /= Just dir - where - p = upFrom dir + dirs = filter (not . B.null) $ B.splitWith isPathSeparator path -{- Checks if the first FilePath is, or could be said to contain the second. +{- Checks if the first RawFilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc - are all equivilant. -} -dirContains :: FilePath -> FilePath -> Bool +dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b || a' == b' - || (addTrailingPathSeparator a') `isPrefixOf` b' + || (addTrailingPathSeparator a') `B.isPrefixOf` b' || a' == "." && normalise ("." b') == b' where a' = norm a b' = norm b norm = normalise . simplifyPath -{- Converts a filename into an absolute path. - - - - Also simplifies it using simplifyPath. - - - - Unlike Directory.canonicalizePath, this does not require the path - - already exists. -} -absPath :: FilePath -> IO FilePath -absPath file - -- Avoid unncessarily getting the current directory when the path - -- is already absolute. absPathFrom uses simplifyPath - -- so also used here for consistency. - | isAbsolute file = return $ simplifyPath file - | otherwise = do - cwd <- getCurrentDirectory - return $ absPathFrom cwd file - -{- Constructs a relative path from the CWD to a file. - - - - For example, assuming CWD is /tmp/foo/bar: - - relPathCwdToFile "/tmp/foo" == ".." - - relPathCwdToFile "/tmp/foo/bar" == "" - -} -relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = do - c <- getCurrentDirectory - relPathDirToFile c f - -{- Constructs a relative path from a directory to a file. -} -relPathDirToFile :: FilePath -> FilePath -> IO FilePath -relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to - -{- This requires the first path to be absolute, and the - - second path cannot contain ../ or ./ - - - - On Windows, if the paths are on different drives, - - a relative path is not possible and the path is simply - - returned as-is. - -} -relPathDirToFileAbs :: FilePath -> FilePath -> FilePath -relPathDirToFileAbs from to -#ifdef mingw32_HOST_OS - | normdrive from /= normdrive to = to -#endif - | otherwise = joinPath $ dotdots ++ uncommon - where - pfrom = sp from - pto = sp to - sp = map dropTrailingPathSeparator . splitPath . dropDrive - common = map fst $ takeWhile same $ zip pfrom pto - same (c,d) = c == d - uncommon = drop numcommon pto - dotdots = replicate (length pfrom - numcommon) ".." - numcommon = length common -#ifdef mingw32_HOST_OS - normdrive = map toLower . takeWhile (/= ':') . takeDrive -#endif - -prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool -prop_relPathDirToFile_basics from to - | null from || null to = True - | from == to = null r - | otherwise = not (null r) - where - r = relPathDirToFileAbs from to - -prop_relPathDirToFile_regressionTest :: Bool -prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - where - {- Two paths have the same directory component at the same - - location, but it's not really the same directory. - - Code used to get this wrong. -} - same_dir_shortcurcuits_at_difference = - relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) - (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) - == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] - {- Given an original list of paths, and an expanded list derived from it, - which may be arbitrarily reordered, generates a list of lists, where - each sublist corresponds to one of the original paths. @@ -228,8 +124,7 @@ (found, rest) = if length is < 100 then partition ini new else break (not . ini) new - ini p = i' `dirContains` fromRawFilePath (c p) - i' = fromRawFilePath i + ini p = i `dirContains` c p {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In @@ -241,14 +136,6 @@ runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]] runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths -{- Converts paths in the home directory to use ~/ -} -relHome :: FilePath -> IO String -relHome path = do - home <- myHomeDir - return $ if dirContains home path - then "~/" ++ relPathDirToFileAbs home path - else path - {- Checks if a command is available in PATH. - - The command may be fully-qualified, in which case, this succeeds as @@ -265,10 +152,10 @@ -} searchPath :: String -> IO (Maybe FilePath) searchPath command - | isAbsolute command = check command - | otherwise = getSearchPath >>= getM indir + | P.isAbsolute command = check command + | otherwise = P.getSearchPath >>= getM indir where - indir d = check $ d command + indir d = check $ d P. command check f = firstM doesFileExist #ifdef mingw32_HOST_OS [f, f ++ ".exe"] @@ -278,26 +165,52 @@ {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} -dotfile :: FilePath -> Bool +dotfile :: RawFilePath -> Bool dotfile file | f == "." = False | f == ".." = False | f == "" = False - | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) + | otherwise = "." `B.isPrefixOf` f || dotfile (takeDirectory file) where f = takeFileName file -{- Similar to splitExtensions, but knows that some things in FilePaths +{- Similar to splitExtensions, but knows that some things in RawFilePaths - after a dot are too long to be extensions. -} -splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" -splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions' maxextension = go [] where go c f - | len > 0 && len <= maxextension && not (null base) = + | len > 0 && len <= maxextension && not (B.null base) = go (ext:c) base | otherwise = (f, c) where (base, ext) = splitExtension f - len = length ext + len = B.length ext + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ + - + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. + -} +relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath +relPathDirToFileAbs from to +#ifdef mingw32_HOST_OS + | normdrive from /= normdrive to = to +#endif + | otherwise = joinPath $ dotdots ++ uncommon + where + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath . dropDrive + common = map fst $ takeWhile same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common +#ifdef mingw32_HOST_OS + normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive +#endif diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs new file mode 100644 --- /dev/null +++ b/Utility/Path/AbsRel.hs @@ -0,0 +1,93 @@ +{- absolute and relative path manipulation + - + - Copyright 2010-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Path.AbsRel ( + absPathFrom, + absPath, + relPathCwdToFile, + relPathDirToFile, + relPathDirToFileAbs, + relHome, +) where + +import System.FilePath.ByteString +#ifdef mingw32_HOST_OS +import System.Directory (getCurrentDirectory) +#else +import System.Posix.Directory.ByteString (getWorkingDirectory) +#endif +import Control.Applicative +import Prelude + +import Utility.Path +import Utility.UserInfo +import Utility.FileSystemEncoding + +{- Makes a path absolute. + - + - Also simplifies it using simplifyPath. + - + - The first parameter is a base directory (ie, the cwd) to use if the path + - is not already absolute, and should itsef be absolute. + - + - Does not attempt to deal with edge cases or ensure security with + - untrusted inputs. + -} +absPathFrom :: RawFilePath -> RawFilePath -> RawFilePath +absPathFrom dir path = simplifyPath (combine dir path) + +{- Converts a filename into an absolute path. + - + - Also simplifies it using simplifyPath. + - + - Unlike Directory.canonicalizePath, this does not require the path + - already exists. -} +absPath :: RawFilePath -> IO RawFilePath +absPath file + -- Avoid unncessarily getting the current directory when the path + -- is already absolute. absPathFrom uses simplifyPath + -- so also used here for consistency. + | isAbsolute file = return $ simplifyPath file + | otherwise = do +#ifdef mingw32_HOST_OS + cwd <- toRawFilePath <$> getCurrentDirectory +#else + cwd <- getWorkingDirectory +#endif + return $ absPathFrom cwd file + +{- Constructs a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: RawFilePath -> IO RawFilePath +relPathCwdToFile f = do +#ifdef mingw32_HOST_OS + c <- toRawFilePath <$> getCurrentDirectory +#else + c <- getWorkingDirectory +#endif + relPathDirToFile c f + +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- Converts paths in the home directory to use ~/ -} +relHome :: FilePath -> IO String +relHome path = do + let path' = toRawFilePath path + home <- toRawFilePath <$> myHomeDir + return $ if dirContains home path' + then fromRawFilePath ("~/" <> relPathDirToFileAbs home path') + else path diff --git a/Utility/Path/Tests.hs b/Utility/Path/Tests.hs new file mode 100644 --- /dev/null +++ b/Utility/Path/Tests.hs @@ -0,0 +1,58 @@ +{- Tests for Utility.Path. Split into a separate module to avoid it needing + - QuickCheck. + - + - Copyright 2010-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Path.Tests ( + prop_upFrom_basics, + prop_relPathDirToFileAbs_basics, + prop_relPathDirToFileAbs_regressionTest, +) where + +import System.FilePath.ByteString +import qualified Data.ByteString as B +import Data.List +import Data.Maybe +import Control.Applicative +import Prelude + +import Utility.Path +import Utility.FileSystemEncoding +import Utility.QuickCheck + +prop_upFrom_basics :: TestableFilePath -> Bool +prop_upFrom_basics tdir + | dir == "/" = p == Nothing + | otherwise = p /= Just dir + where + p = fromRawFilePath <$> upFrom (toRawFilePath dir) + dir = fromTestableFilePath tdir + +prop_relPathDirToFileAbs_basics :: TestableFilePath -> TestableFilePath -> Bool +prop_relPathDirToFileAbs_basics fromt tot + | from == to = null r + | otherwise = not (null r) + where + from = fromTestableFilePath fromt + to = fromTestableFilePath tot + r = fromRawFilePath $ relPathDirToFileAbs + (toRawFilePath from) + (toRawFilePath to) + +prop_relPathDirToFileAbs_regressionTest :: Bool +prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference + where + {- Two paths have the same directory component at the same + - location, but it's not really the same directory. + - Code used to get this wrong. -} + same_dir_shortcurcuits_at_difference = + relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"]) + (joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) + == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -10,15 +10,52 @@ module Utility.QuickCheck ( module X - , module Utility.QuickCheck + , TestableString + , fromTestableString + , TestableFilePath + , fromTestableFilePath + , nonNegative + , positive ) where import Test.QuickCheck as X import Data.Time.Clock.POSIX import Data.Ratio +import Data.Char import System.Posix.Types import Data.List.NonEmpty (NonEmpty(..)) import Prelude + +{- A String, but Arbitrary is limited to ascii. + - + - When in a non-utf8 locale, String does not normally contain any non-ascii + - characters, except for ones in surrogate plane. Converting a string that + - does contain other unicode characters to a ByteString using the + - filesystem encoding (see GHC.IO.Encoding) will throw an exception, + - so use this instead to avoid quickcheck tests breaking unncessarily. + -} +newtype TestableString = TestableString + { fromTestableString :: String } + deriving (Show) + +instance Arbitrary TestableString where + arbitrary = TestableString . filter isAscii <$> arbitrary + +{- FilePath constrained to not be the empty string, not contain a NUL, + - and contain only ascii. + - + - No real-world filename can be empty or contain a NUL. So code can + - well be written that assumes that and using this avoids quickcheck + - tests breaking unncessarily. + -} +newtype TestableFilePath = TestableFilePath + { fromTestableFilePath :: FilePath } + deriving (Show) + +instance Arbitrary TestableFilePath where + arbitrary = (TestableFilePath . fromTestableString <$> arbitrary) + `suchThat` (not . null . fromTestableFilePath) + `suchThat` (not . any (== '\NUL') . fromTestableFilePath) {- Times before the epoch are excluded. Half with decimal and half without. -} instance Arbitrary POSIXTime where diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -1,4 +1,4 @@ -{- Portability shim around System.Posix.Files.ByteString +{- Portability shim for basic operations on RawFilePaths. - - On unix, this makes syscalls using RawFilesPaths as efficiently as - possible. @@ -7,40 +7,68 @@ - decoded. So this library will work, but less efficiently than using - FilePath would. - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.RawFilePath ( RawFilePath, readSymbolicLink, + createSymbolicLink, + createLink, + removeLink, getFileStatus, getSymbolicLinkStatus, doesPathExist, + getCurrentDirectory, + createDirectory, + setFileMode, ) where #ifndef mingw32_HOST_OS import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString +import qualified System.Posix.Directory.ByteString as D --- | Checks if a file or directoy exists. Note that a dangling symlink +-- | Checks if a file or directory exists. Note that a dangling symlink -- will be false. doesPathExist :: RawFilePath -> IO Bool doesPathExist = fileExist +getCurrentDirectory :: IO RawFilePath +getCurrentDirectory = D.getWorkingDirectory + +createDirectory :: RawFilePath -> IO () +createDirectory p = D.createDirectory p 0o777 + #else import qualified Data.ByteString as B -import System.PosixCompat (FileStatus) +import System.PosixCompat (FileStatus, FileMode) import qualified System.PosixCompat as P +import qualified System.PosixCompat.Files as F import qualified System.Directory as D import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) +createSymbolicLink :: RawFilePath -> RawFilePath -> IO () +createSymbolicLink a b = P.createSymbolicLink + (fromRawFilePath a) + (fromRawFilePath b) + +createLink :: RawFilePath -> RawFilePath -> IO () +createLink a b = P.createLink + (fromRawFilePath a) + (fromRawFilePath b) + +removeLink :: RawFilePath -> IO () +removeLink = P.removeLink . fromRawFilePath + getFileStatus :: RawFilePath -> IO FileStatus getFileStatus = P.getFileStatus . fromRawFilePath @@ -49,4 +77,13 @@ doesPathExist :: RawFilePath -> IO Bool doesPathExist = D.doesPathExist . fromRawFilePath + +getCurrentDirectory :: IO RawFilePath +getCurrentDirectory = toRawFilePath <$> D.getCurrentDirectory + +createDirectory :: RawFilePath -> IO () +createDirectory = D.createDirectory . fromRawFilePath + +setFileMode :: RawFilePath -> FileMode -> IO () +setFileMode = F.setFileMode . fromRawFilePath #endif diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -16,18 +16,13 @@ safeSystem, safeSystem', safeSystemEnv, - shellWrap, - shellEscape, - shellUnEscape, segmentXargsOrdered, segmentXargsUnordered, - prop_isomorphic_shellEscape, - prop_isomorphic_shellEscape_multiword, ) where -import System.Exit import Utility.Process -import Utility.Split + +import System.Exit import System.FilePath import Data.Char import Data.List @@ -92,44 +87,6 @@ safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode safeSystemEnv command params environ = safeSystem' command params $ \p -> p { env = environ } - --- | Wraps a shell command line inside sh -c, allowing it to be run in a --- login shell that may not support POSIX shell, eg csh. -shellWrap :: String -> String -shellWrap cmdline = "sh -c " ++ shellEscape cmdline - --- | Escapes a filename or other parameter to be safely able to be exposed to --- the shell. --- --- This method works for POSIX shells, as well as other shells like csh. -shellEscape :: String -> String -shellEscape f = "'" ++ escaped ++ "'" - where - -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ splitc '\'' f - --- | Unescapes a set of shellEscaped words or filenames. -shellUnEscape :: String -> [String] -shellUnEscape [] = [] -shellUnEscape s = word : shellUnEscape rest - where - (word, rest) = findword "" s - findword w [] = (w, "") - findword w (c:cs) - | c == ' ' = (w, cs) - | c == '\'' = inquote c w cs - | c == '"' = inquote c w cs - | otherwise = findword (w++[c]) cs - inquote _ w [] = (w, "") - inquote q w (c:cs) - | c == q = findword w cs - | otherwise = inquote q (w++[c]) cs - --- | For quickcheck. -prop_isomorphic_shellEscape :: String -> Bool -prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s -prop_isomorphic_shellEscape_multiword :: [String] -> Bool -prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s -- | Segments a list of filenames into groups that are all below the maximum -- command-line length limit. diff --git a/Utility/ShellEscape.hs b/Utility/ShellEscape.hs new file mode 100644 --- /dev/null +++ b/Utility/ShellEscape.hs @@ -0,0 +1,65 @@ +{- shell escaping + - + - Copyright 2010-2015 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.ShellEscape ( + shellWrap, + shellEscape, + shellUnEscape, + prop_isomorphic_shellEscape, + prop_isomorphic_shellEscape_multiword, +) where + +import Utility.QuickCheck +import Utility.Split + +import Data.List +import Prelude + +-- | Wraps a shell command line inside sh -c, allowing it to be run in a +-- login shell that may not support POSIX shell, eg csh. +shellWrap :: String -> String +shellWrap cmdline = "sh -c " ++ shellEscape cmdline + +-- | Escapes a filename or other parameter to be safely able to be exposed to +-- the shell. +-- +-- This method works for POSIX shells, as well as other shells like csh. +shellEscape :: String -> String +shellEscape f = "'" ++ escaped ++ "'" + where + -- replace ' with '"'"' + escaped = intercalate "'\"'\"'" $ splitc '\'' f + +-- | Unescapes a set of shellEscaped words or filenames. +shellUnEscape :: String -> [String] +shellUnEscape [] = [] +shellUnEscape s = word : shellUnEscape rest + where + (word, rest) = findword "" s + findword w [] = (w, "") + findword w (c:cs) + | c == ' ' = (w, cs) + | c == '\'' = inquote c w cs + | c == '"' = inquote c w cs + | otherwise = findword (w++[c]) cs + inquote _ w [] = (w, "") + inquote q w (c:cs) + | c == q = findword w cs + | otherwise = inquote q (w++[c]) cs + +prop_isomorphic_shellEscape :: TestableString -> Bool +prop_isomorphic_shellEscape ts = [s] == (shellUnEscape . shellEscape) s + where + s = fromTestableString ts + +prop_isomorphic_shellEscape_multiword :: [TestableString] -> Bool +prop_isomorphic_shellEscape_multiword ts = + l == (shellUnEscape . unwords . map shellEscape) l + where + l = map fromTestableString ts diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -144,7 +144,7 @@ writeSshConfig :: FilePath -> String -> IO () writeSshConfig f s = do writeFile f s - setSshConfigMode f + setSshConfigMode (toRawFilePath f) {- Ensure that the ssh config file lacks any group or other write bits, - since ssh is paranoid about not working if other users can write @@ -153,7 +153,7 @@ - If the chmod fails, ignore the failure, as it might be a filesystem like - Android's that does not support file modes. -} -setSshConfigMode :: FilePath -> IO () +setSshConfigMode :: RawFilePath -> IO () setSshConfigMode f = void $ tryIO $ modifyFileMode f $ removeModes [groupWriteMode, otherWriteMode] diff --git a/Utility/Tor.hs b/Utility/Tor.hs --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -166,7 +166,7 @@ prepHiddenServiceSocketDir appname uid ident = do createDirectoryIfMissing True d setOwnerAndGroup d uid (-1) - modifyFileMode d $ + modifyFileMode (toRawFilePath d) $ addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] where d = takeDirectory $ hiddenServiceSocketFile appname uid ident diff --git a/Utility/Touch.hs b/Utility/Touch.hs --- a/Utility/Touch.hs +++ b/Utility/Touch.hs @@ -14,30 +14,32 @@ #if ! defined(mingw32_HOST_OS) -import System.Posix.Files +import System.FilePath.ByteString (RawFilePath) +import System.Posix.Files.ByteString import Data.Time.Clock.POSIX {- Changes the access and modification times of an existing file. Can follow symlinks, or not. -} -touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO () +touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO () touchBoth file atime mtime follow | follow = setFileTimesHiRes file atime mtime | otherwise = setSymbolicLinkTimesHiRes file atime mtime {- Changes the access and modification times of an existing file - to the same value. Can follow symlinks, or not. -} -touch :: FilePath -> POSIXTime -> Bool -> IO () +touch :: RawFilePath -> POSIXTime -> Bool -> IO () touch file mtime = touchBoth file mtime mtime #else import Data.Time.Clock.POSIX +import Utility.RawFilePath {- Noop for Windows -} -touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO () +touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO () touchBoth _ _ _ _ = return () -touch :: FilePath -> POSIXTime -> Bool -> IO () +touch :: RawFilePath -> POSIXTime -> Bool -> IO () touch _ _ _ = return () #endif diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -52,6 +52,7 @@ import Utility.HttpManagerRestricted #endif import Utility.IPAddress +import qualified Utility.RawFilePath as R import Network.URI import Network.HTTP.Types @@ -309,8 +310,8 @@ =<< curlRestrictedParams r u defport (basecurlparams url') existsfile u = do - let f = unEscapeString (uriPath u) - s <- catchMaybeIO $ getFileStatus f + let f = toRawFilePath (unEscapeString (uriPath u)) + s <- catchMaybeIO $ R.getFileStatus f case s of Just stat -> do sz <- getFileSize' f stat @@ -455,7 +456,7 @@ -} downloadConduit :: MeterUpdate -> Request -> FilePath -> UrlOptions -> IO () downloadConduit meterupdate req file uo = - catchMaybeIO (getFileSize file) >>= \case + catchMaybeIO (getFileSize (toRawFilePath file)) >>= \case Just sz | sz > 0 -> resumedownload sz _ -> join $ runResourceT $ do liftIO $ debugM "url" (show req') diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs --- a/Utility/Verifiable.hs +++ b/Utility/Verifiable.hs @@ -18,6 +18,7 @@ import qualified Data.ByteString as S import Utility.Hash +import Utility.QuickCheck type Secret = S.ByteString type HMACDigest = String @@ -38,8 +39,8 @@ calcDigest :: String -> Secret -> HMACDigest calcDigest v secret = calcMac HmacSha1 secret (fromString v) -{- for quickcheck -} -prop_verifiable_sane :: String -> String -> Bool -prop_verifiable_sane a s = verify (mkVerifiable a secret) secret +prop_verifiable_sane :: TestableString -> TestableString -> Bool +prop_verifiable_sane v ts = + verify (mkVerifiable (fromTestableString v) secret) secret where - secret = fromString s + secret = fromString (fromTestableString ts) diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -189,7 +189,8 @@ {- Creates a html shim file that's used to redirect into the webapp, - to avoid exposing the secret token when launching the web browser. -} writeHtmlShim :: String -> String -> FilePath -> IO () -writeHtmlShim title url file = viaTmp writeFileProtected file $ genHtmlShim title url +writeHtmlShim title url file = + viaTmp (writeFileProtected . toRawFilePath) file $ genHtmlShim title url genHtmlShim :: String -> String -> String genHtmlShim title url = unlines diff --git a/doc/git-annex-examinekey.mdwn b/doc/git-annex-examinekey.mdwn --- a/doc/git-annex-examinekey.mdwn +++ b/doc/git-annex-examinekey.mdwn @@ -22,10 +22,14 @@ use '${var;width}' ; to left-justify a variable, use '${var;-width}'; to escape unusual characters in a variable, use '${escaped_var}' - These variables are available for use in formats: key, backend, - bytesize, humansize, keyname, hashdirlower, hashdirmixed, mtime (for - the mtime field of a WORM key). + To generate a path from the top of the repository to the git-annex + object for a key, use ${objectpath}. To generate the value of a + git-annex pointer file for a key, use ${objectpointer}. + These variables are also available for use in formats: ${key}, ${backend}, + ${bytesize}, ${humansize}, ${keyname}, ${hashdirlower}, ${hashdirmixed}, + ${mtime} (for the mtime field of a WORM key). + Also, '\\n' is a newline, '\\000' is a NULL, etc. * `--json` @@ -38,16 +42,36 @@ Messages that would normally be output to standard error are included in the json instead. +* `--migrate-to-backend=backend` + + Attempt to migrate the input key to the new backend specified. If + successful, outputs information about the migrated key. Otherwise, + outputs information about the input key. + + This only does fast migrations; it will not re-hash the content of a key + or similar expensive operation. + + One way to use it is to add an extension to a key. + + git-annex examinekey SHA256--xxx --migrate-to-backend=SHA256E --filename=foo.tar.gz + + Or to remove the extension from a key: + + git-annex examinekey SHA256E-xxx.tar.gz --migrate-to-backend=SHA256 + +* `--filename=name` + + The name of a file associated with the key, eg a work tree file. + It does not need to exist. This is needed when using `--migrate-to-backend` + to add an extension to the key. + * `--batch` Enable batch mode, in which a line containing a key is read from stdin, the information about it is output to stdout, and repeat. -# EXAMPLES - -The location where the content of a key is stored can be looked up by running: - - git annex examinekey $KEY --format='.git/annex/objects/${hashdirmixed}${key}/${key}' + In order to also provide the name of a file associated with the key, the + line can be in the format "$key $file" # SEE ALSO diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20201103 +Version: 8.20201116 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -298,7 +298,7 @@ custom-setup Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, filepath, exceptions, bytestring, directory, IfElse, data-default, - filepath-bytestring (>= 1.4.2.1.1), + filepath-bytestring (>= 1.4.2.1.4), process (>= 1.6.3), async, utf8-string, transformers, Cabal @@ -817,6 +817,7 @@ Config Config.Cost Config.Files + Config.Files.AutoStart Config.DynamicConfig Config.GitConfig Config.Smudge @@ -1055,6 +1056,7 @@ Utility.DirWatcher Utility.DirWatcher.Types Utility.Directory + Utility.Directory.Create Utility.Directory.Stream Utility.DiskFree Utility.Dot @@ -1088,13 +1090,16 @@ Utility.Metered Utility.Misc Utility.Monad + Utility.MoveFile Utility.Network Utility.NotificationBroadcaster Utility.OptParse Utility.PID Utility.PartialPrelude Utility.Path + Utility.Path.AbsRel Utility.Path.Max + Utility.Path.Tests Utility.Percentage Utility.Process Utility.Process.Shim @@ -1107,6 +1112,7 @@ Utility.Scheduled Utility.Scheduled.QuickCheck Utility.Shell + Utility.ShellEscape Utility.SimpleProtocol Utility.Split Utility.SshConfig