From a5d48edd94187290b0ef017a588d1ce1d1387cc5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 7 Feb 2025 14:46:11 -0400 Subject: [PATCH] more OsPath conversion (602/749) Sponsored-by: Brock Spratlen --- Annex/Link.hs | 2 +- Annex/Magic.hs | 2 +- Backend.hs | 4 +- Command/Fix.hs | 34 ++++++++------ Command/FromKey.hs | 11 +++-- Command/Fsck.hs | 92 +++++++++++++++++++------------------- Command/FuzzTest.hs | 36 ++++++++------- Command/Info.hs | 28 ++++++------ Command/Inprogress.hs | 9 ++-- Command/List.hs | 4 +- Command/Lock.hs | 12 ++--- Command/Log.hs | 28 ++++++------ Command/LookupKey.hs | 10 ++--- Command/Map.hs | 16 +++---- Command/MatchExpression.hs | 2 +- Command/MetaData.hs | 8 ++-- Command/Migrate.hs | 6 +-- Command/Multicast.hs | 55 +++++++++++------------ Command/PreCommit.hs | 4 +- Git/Types.hs | 3 ++ Messages/JSON.hs | 13 +++--- Test/Framework.hs | 5 ++- Types/UUID.hs | 9 ++-- Utility/OsString.hs | 11 ++++- Utility/SafeOutput.hs | 10 +++++ 25 files changed, 227 insertions(+), 187 deletions(-) diff --git a/Annex/Link.hs b/Annex/Link.hs index 7d8ecb7a14..559add24ed 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -71,7 +71,7 @@ getAnnexLinkTarget f = getAnnexLinkTarget' f {- Pass False to force looking inside file, for when git checks out - symlinks as plain files. -} -getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe S.ByteString) +getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe LinkTarget) getAnnexLinkTarget' file coresymlinks = if coresymlinks then check probesymlink $ return Nothing diff --git a/Annex/Magic.hs b/Annex/Magic.hs index c623f219dd..4771adada4 100644 --- a/Annex/Magic.hs +++ b/Annex/Magic.hs @@ -46,7 +46,7 @@ initMagicMime = return Nothing getMagicMime :: Magic -> OsPath -> IO (Maybe (MimeType, MimeEncoding)) #ifdef WITH_MAGICMIME -getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m f) +getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m (fromOsPath f)) where parse s = let (mimetype, rest) = separate (== ';') s diff --git a/Backend.hs b/Backend.hs index dc15733bd7..4a7ace6524 100644 --- a/Backend.hs +++ b/Backend.hs @@ -63,11 +63,11 @@ genKey source meterupdate b = case B.genKey b of Nothing -> giveup $ "Cannot generate a key for backend " ++ decodeBS (formatKeyVariety (B.backendVariety b)) -getBackend :: FilePath -> Key -> Annex (Maybe Backend) +getBackend :: OsPath -> Key -> Annex (Maybe Backend) getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case Just backend -> return $ Just backend Nothing -> do - warning $ "skipping " <> QuotedPath (toOsPath file) <> " (" <> + warning $ "skipping " <> QuotedPath file <> " (" <> UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")" return Nothing diff --git a/Command/Fix.hs b/Command/Fix.hs index eb8f6383e3..a12747ee49 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -44,25 +44,27 @@ seek ps = unlessM crippledFileSystem $ data FixWhat = FixSymlinks | FixAll -start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: FixWhat -> SeekInput -> OsPath -> Key -> CommandStart start fixwhat si file key = do - currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file + currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file' wantlink <- calcRepo $ gitAnnexLink file key case currlink of Just l - | l /= wantlink -> fixby $ fixSymlink file wantlink + | l /= fromOsPath wantlink -> + fixby $ fixSymlink file wantlink | otherwise -> stop Nothing -> case fixwhat of FixAll -> fixthin FixSymlinks -> stop where + file' = fromOsPath file fixby = starting "fix" (mkActionItem (key, file)) si fixthin = do obj <- calcRepo (gitAnnexLocation key) stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do thin <- annexThin <$> Annex.getGitConfig - fs <- liftIO $ catchMaybeIO $ R.getFileStatus file - os <- liftIO $ catchMaybeIO $ R.getFileStatus obj + fs <- liftIO $ catchMaybeIO $ R.getFileStatus file' + os <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath obj) case (linkCount <$> fs, linkCount <$> os, thin) of (Just 1, Just 1, True) -> fixby $ makeHardLink file key @@ -70,10 +72,10 @@ start fixwhat si file key = do fixby $ breakHardLink file key obj _ -> stop -breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform +breakHardLink :: OsPath -> Key -> OsPath -> CommandPerform breakHardLink file key obj = do replaceWorkTreeFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file) unlessM (checkedCopyFile key obj tmp mode) $ giveup "unable to break hard link" thawContent tmp @@ -81,26 +83,30 @@ breakHardLink file key obj = do modifyContentDir obj $ freezeContent obj next $ return True -makeHardLink :: RawFilePath -> Key -> CommandPerform +makeHardLink :: OsPath -> Key -> CommandPerform makeHardLink file key = do replaceWorkTreeFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + mode <- liftIO $ catchMaybeIO $ fileMode + <$> R.getFileStatus (fromOsPath file) linkFromAnnex' key tmp mode >>= \case LinkAnnexFailed -> giveup "unable to make hard link" _ -> noop next $ return True -fixSymlink :: RawFilePath -> RawFilePath -> CommandPerform +fixSymlink :: OsPath -> OsPath -> CommandPerform fixSymlink file link = do #if ! defined(mingw32_HOST_OS) -- preserve mtime of symlink mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes - <$> R.getSymbolicLinkStatus file + <$> R.getSymbolicLinkStatus (fromOsPath file) #endif replaceWorkTreeFile file $ \tmpfile -> do - liftIO $ R.createSymbolicLink link tmpfile + let tmpfile' = fromOsPath tmpfile + liftIO $ R.createSymbolicLink link' tmpfile' #if ! defined(mingw32_HOST_OS) - liftIO $ maybe noop (\t -> touch tmpfile t False) mtime + liftIO $ maybe noop (\t -> touch tmpfile' t False) mtime #endif - stageSymlink file =<< hashSymlink link + stageSymlink file =<< hashSymlink link' next $ return True + where + link' = fromOsPath link diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 292ab179a6..6649b4110e 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -59,7 +59,7 @@ seekBatch matcher fmt = batchInput fmt parse (commandAction . go) let (keyname, file) = separate (== ' ') s if not (null keyname) && not (null file) then do - file' <- liftIO $ relPathCwdToFile (toRawFilePath file) + file' <- liftIO $ relPathCwdToFile (toOsPath file) return $ Right (file', keyOpt keyname) else return $ Left "Expected pairs of key and filename" @@ -75,11 +75,10 @@ start matcher force (si, (keyname, file)) = do inbackend <- inAnnex key unless inbackend $ giveup $ "key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" + let file' = toOsPath file let ai = mkActionItem (key, file') starting "fromkey" ai si $ perform matcher key file' - where - file' = toRawFilePath file -- From user input to a Key. -- User can input either a serialized key, or an url. @@ -99,9 +98,9 @@ keyOpt' s = case parseURIPortable s of Just k -> Right k Nothing -> Left $ "bad key/url " ++ s -perform :: AddUnlockedMatcher -> Key -> RawFilePath -> CommandPerform +perform :: AddUnlockedMatcher -> Key -> OsPath -> CommandPerform perform matcher key file = lookupKeyNotHidden file >>= \case - Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file)) + Nothing -> ifM (liftIO $ doesFileExist file) ( hasothercontent , do contentpresent <- inAnnex key @@ -123,7 +122,7 @@ perform matcher key file = lookupKeyNotHidden file >>= \case else writepointer , do link <- calcRepo $ gitAnnexLink file key - addAnnexLink link file + addAnnexLink (fromOsPath link) file ) next $ return True ) diff --git a/Command/Fsck.hs b/Command/Fsck.hs index f0f833117d..918e85a09d 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -52,7 +52,6 @@ import System.Posix.Types (EpochTime) import qualified Data.Set as S import qualified Data.Map as M import Data.Either -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (fileMode, isSymbolicLink, modificationTime) cmd :: Command @@ -123,8 +122,8 @@ checkDeadRepo u = whenM ((==) DeadTrusted <$> lookupTrust u) $ earlyWarning "Warning: Fscking a repository that is currently marked as dead." -start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> CommandStart -start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case +start :: Maybe Remote -> Incremental -> SeekInput -> OsPath -> Key -> CommandStart +start from inc si file key = Backend.getBackend file key >>= \case Nothing -> stop Just backend -> do (numcopies, _mincopies) <- getFileNumMinCopies file @@ -135,7 +134,7 @@ start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \ go = runFsck inc si (mkActionItem (key, afile)) key afile = AssociatedFile (Just file) -perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool +perform :: Key -> OsPath -> Backend -> NumCopies -> Annex Bool perform key file backend numcopies = do keystatus <- getKeyFileStatus key file check @@ -194,11 +193,11 @@ performRemote key afile numcopies remote = pid <- liftIO getPID t <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory t - let tmp = t P. "fsck" <> toRawFilePath (show pid) <> "." <> keyFile key - let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop) + let tmp = t literalOsPath "fsck" <> toOsPath (show pid) <> literalOsPath "." <> keyFile key + let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) cleanup cleanup `after` a tmp - getfile tmp = ifM (checkDiskSpace Nothing (Just (P.takeDirectory tmp)) key 0 True) + getfile tmp = ifM (checkDiskSpace Nothing (Just (takeDirectory tmp)) key 0 True) ( ifM (getcheap tmp) ( return (Just (Right UnVerified)) , ifM (Annex.getRead Annex.fast) @@ -208,9 +207,9 @@ performRemote key afile numcopies remote = ) , return Nothing ) - getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) nullMeterUpdate (RemoteVerify remote) + getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp nullMeterUpdate (RemoteVerify remote) getcheap tmp = case Remote.retrieveKeyFileCheap remote of - Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp)) + Just a -> isRight <$> tryNonAsync (a key afile tmp) Nothing -> return False startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart @@ -236,10 +235,10 @@ check :: [Annex Bool] -> Annex Bool check cs = and <$> sequence cs {- Checks that symlinks points correctly to the annexed content. -} -fixLink :: Key -> RawFilePath -> Annex Bool +fixLink :: Key -> OsPath -> Annex Bool fixLink key file = do want <- calcRepo $ gitAnnexLink file key - have <- getAnnexLinkTarget file + have <- fmap toOsPath <$> getAnnexLinkTarget file maybe noop (go want) have return True where @@ -247,8 +246,8 @@ fixLink key file = do | want /= fromInternalGitPath have = do showNote "fixing link" createWorkTreeDirectory (parentDir file) - liftIO $ R.removeLink file - addAnnexLink want file + liftIO $ R.removeLink (fromOsPath file) + addAnnexLink (fromOsPath want) file | otherwise = noop {- A repository that supports symlinks and is not bare may have in the past @@ -272,7 +271,7 @@ fixObjectLocation key = do idealloc <- calcRepo (gitAnnexLocation' (const (pure True)) key) if loc == idealloc then return True - else ifM (liftIO $ R.doesPathExist loc) + else ifM (liftIO $ R.doesPathExist $ fromOsPath loc) ( moveobjdir loc idealloc `catchNonAsync` \_e -> return True , return True @@ -291,14 +290,12 @@ fixObjectLocation key = do -- Thaw the content directory to allow renaming it. thawContentDir src createAnnexDirectory (parentDir destdir) - liftIO $ renameDirectory - (fromRawFilePath srcdir) - (fromRawFilePath destdir) + liftIO $ renameDirectory srcdir destdir -- Since the directory was moved, lockContentForRemoval -- will not be able to remove the lock file it -- made. So, remove the lock file here. mlockfile <- contentLockFile key =<< getVersion - liftIO $ maybe noop (removeWhenExistsWith R.removeLink) mlockfile + liftIO $ maybe noop (removeWhenExistsWith removeFile) mlockfile freezeContentDir dest cleanObjectDirs src return True @@ -310,7 +307,7 @@ verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool verifyLocationLog key keystatus ai = do obj <- calcRepo (gitAnnexLocation key) present <- if isKeyUnlockedThin keystatus - then liftIO (doesFileExist (fromRawFilePath obj)) + then liftIO (doesFileExist obj) else inAnnex key u <- getUUID @@ -324,7 +321,7 @@ verifyLocationLog key keystatus ai = do checkContentWritePerm obj >>= \case Nothing -> warning $ "** Unable to set correct write mode for " <> QuotedPath obj <> " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set" _ -> return () - whenM (liftIO $ R.doesPathExist $ parentDir obj) $ + whenM (liftIO $ doesDirectoryExist $ parentDir obj) $ freezeContentDir obj {- Warn when annex.securehashesonly is set and content using an @@ -401,7 +398,7 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = case afile of verifyRequiredContent _ _ = return True {- Verifies the associated file records. -} -verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool +verifyAssociatedFiles :: Key -> KeyStatus -> OsPath -> Annex Bool verifyAssociatedFiles key keystatus file = do when (isKeyUnlockedThin keystatus) $ do f <- inRepo $ toTopFilePath file @@ -410,7 +407,7 @@ verifyAssociatedFiles key keystatus file = do Database.Keys.addAssociatedFile key f return True -verifyWorkTree :: Key -> RawFilePath -> Annex Bool +verifyWorkTree :: Key -> OsPath -> Annex Bool verifyWorkTree key file = do {- Make sure that a pointer file is replaced with its content, - when the content is available. -} @@ -419,7 +416,9 @@ verifyWorkTree key file = do Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" replaceWorkTreeFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus + (fromOsPath file) ifM (annexThin <$> Annex.getGitConfig) ( void $ linkFromAnnex' key tmp mode , do @@ -440,20 +439,20 @@ checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool checkKeySize _ KeyUnlockedThin _ = return True checkKeySize key _ ai = do file <- calcRepo $ gitAnnexLocation key - ifM (liftIO $ R.doesPathExist file) + ifM (liftIO $ R.doesPathExist (fromOsPath file)) ( checkKeySizeOr badContent key file ai , return True ) -withLocalCopy :: Maybe RawFilePath -> (RawFilePath -> Annex Bool) -> Annex Bool +withLocalCopy :: Maybe OsPath -> (OsPath -> Annex Bool) -> Annex Bool withLocalCopy Nothing _ = return True withLocalCopy (Just localcopy) f = f localcopy -checkKeySizeRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool +checkKeySizeRemote :: Key -> Remote -> ActionItem -> OsPath -> Annex Bool checkKeySizeRemote key remote ai localcopy = checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai -checkKeySizeOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool +checkKeySizeOr :: (Key -> Annex String) -> Key -> OsPath -> ActionItem -> Annex Bool checkKeySizeOr bad key file ai = case fromKey keySize key of Nothing -> return True Just size -> do @@ -505,7 +504,7 @@ checkKeyUpgrade _ _ _ (AssociatedFile Nothing) = checkBackend :: Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend key keystatus afile = do content <- calcRepo (gitAnnexLocation key) - ifM (liftIO $ R.doesPathExist content) + ifM (liftIO $ R.doesPathExist (fromOsPath content)) ( ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( nocheck , do @@ -524,11 +523,11 @@ checkBackend key keystatus afile = do ai = mkActionItem (key, afile) -checkBackendRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool +checkBackendRemote :: Key -> Remote -> ActionItem -> OsPath -> Annex Bool checkBackendRemote key remote ai localcopy = checkBackendOr (badContentRemote remote localcopy) key localcopy ai -checkBackendOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool +checkBackendOr :: (Key -> Annex String) -> Key -> OsPath -> ActionItem -> Annex Bool checkBackendOr bad key file ai = ifM (Annex.getRead Annex.fast) ( return True @@ -552,7 +551,7 @@ checkBackendOr bad key file ai = - verified to be correct. The InodeCache is generated again to detect if - the object file was changed while the content was being verified. -} -checkInodeCache :: Key -> RawFilePath -> Maybe InodeCache -> ActionItem -> Annex () +checkInodeCache :: Key -> OsPath -> Maybe InodeCache -> ActionItem -> Annex () checkInodeCache key content mic ai = case mic of Nothing -> noop Just ic -> do @@ -569,7 +568,7 @@ checkInodeCache key content mic ai = case mic of checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool checkKeyNumCopies key afile numcopies = do let (desc, hasafile) = case afile of - AssociatedFile Nothing -> (serializeKey' key, False) + AssociatedFile Nothing -> (toOsPath (serializeKey'' key), False) AssociatedFile (Just af) -> (af, True) locs <- loggedLocations key (untrustedlocations, otherlocations) <- trustPartition UnTrusted locs @@ -590,7 +589,7 @@ checkKeyNumCopies key afile numcopies = do ) else return True -missingNote :: RawFilePath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath +missingNote :: OsPath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath missingNote file 0 _ [] dead = "** No known copies exist of " <> QuotedPath file <> UnquotedString (honorDead dead) missingNote file 0 _ untrusted dead = @@ -615,25 +614,24 @@ honorDead dead badContent :: Key -> Annex String badContent key = do dest <- moveBad key - return $ "moved to " ++ fromRawFilePath dest + return $ "moved to " ++ fromOsPath dest {- Bad content is dropped from the remote. We have downloaded a copy - from the remote to a temp file already (in some cases, it's just a - 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 -> RawFilePath -> Key -> Annex String +badContentRemote :: Remote -> OsPath -> Key -> Annex String badContentRemote remote localcopy key = do bad <- fromRepo gitAnnexBadDir - let destbad = bad P. keyFile key - let destbad' = fromRawFilePath destbad - movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad')) + let destbad = bad keyFile key + movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) ( return False , do createAnnexDirectory (parentDir destbad) liftIO $ catchDefaultIO False $ - ifM (isSymbolicLink <$> R.getSymbolicLinkStatus localcopy) - ( copyFileExternal CopyTimeStamps (fromRawFilePath localcopy) destbad' + ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath localcopy)) + ( copyFileExternal CopyTimeStamps localcopy destbad , do moveFile localcopy destbad return True @@ -645,7 +643,7 @@ badContentRemote remote localcopy key = do Remote.logStatus NoLiveUpdate remote key InfoMissing return $ case (movedbad, dropped) of (True, Right ()) -> "moved from " ++ Remote.name remote ++ - " to " ++ fromRawFilePath destbad + " to " ++ fromOsPath destbad (False, Right ()) -> "dropped from " ++ Remote.name remote (_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e @@ -678,10 +676,10 @@ recordStartTime :: UUID -> Annex () recordStartTime u = do f <- fromRepo (gitAnnexFsckState u) createAnnexDirectory $ parentDir f - liftIO $ removeWhenExistsWith R.removeLink f - liftIO $ F.withFile (toOsPath f) WriteMode $ \h -> do + liftIO $ removeWhenExistsWith removeFile f + liftIO $ F.withFile f WriteMode $ \h -> do #ifndef mingw32_HOST_OS - t <- modificationTime <$> R.getFileStatus f + t <- modificationTime <$> R.getFileStatus (fromOsPath f) #else t <- getPOSIXTime #endif @@ -692,7 +690,7 @@ recordStartTime u = do showTime = show resetStartTime :: UUID -> Annex () -resetStartTime u = liftIO . removeWhenExistsWith R.removeLink +resetStartTime u = liftIO . removeWhenExistsWith removeFile =<< fromRepo (gitAnnexFsckState u) {- Gets the incremental fsck start time. -} @@ -700,9 +698,9 @@ getStartTime :: UUID -> Annex (Maybe EpochTime) getStartTime u = do f <- fromRepo (gitAnnexFsckState u) liftIO $ catchDefaultIO Nothing $ do - timestamp <- modificationTime <$> R.getFileStatus f + timestamp <- modificationTime <$> R.getFileStatus (fromOsPath f) let fromstatus = Just (realToFrac timestamp) - fromfile <- parsePOSIXTime <$> F.readFile' (toOsPath f) + fromfile <- parsePOSIXTime <$> F.readFile' f return $ if matchingtimestamp fromfile fromstatus then Just timestamp else Nothing diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index 8efbda8593..3534e21e63 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -123,13 +123,14 @@ instance ToFilePath FuzzDir where toFilePath (FuzzDir d) = d isFuzzFile :: FilePath -> Bool -isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f +isFuzzFile f = "fuzzfile_" `isPrefixOf` fromOsPath (takeFileName (toOsPath f)) isFuzzDir :: FilePath -> Bool isFuzzDir d = "fuzzdir_" `isPrefixOf` d mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile -mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) ("fuzzfile_" ++ file) +mkFuzzFile file dirs = FuzzFile $ fromOsPath $ + joinPath (map (toOsPath . toFilePath) dirs) toOsPath ("fuzzfile_" ++ file) mkFuzzDir :: Int -> FuzzDir mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n @@ -175,15 +176,15 @@ instance Arbitrary FuzzAction where runFuzzAction :: FuzzAction -> Annex () runFuzzAction (FuzzAdd (FuzzFile f)) = do - createWorkTreeDirectory (parentDir (toRawFilePath f)) + createWorkTreeDirectory (parentDir (toOsPath f)) n <- liftIO (getStdRandom random :: IO Int) liftIO $ writeFile f $ show n ++ "\n" runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ - removeWhenExistsWith R.removeLink (toRawFilePath f) + removeWhenExistsWith removeFile (toOsPath f) runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ R.rename (toRawFilePath src) (toRawFilePath dest) runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ - removeDirectoryRecursive d + removeDirectoryRecursive (toOsPath d) runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ R.rename (toRawFilePath src) (toRawFilePath dest) runFuzzAction (FuzzPause d) = randomDelay d @@ -210,7 +211,7 @@ genFuzzAction = do case md of Nothing -> genFuzzAction Just d -> do - newd <- liftIO $ newDir (parentDir $ toRawFilePath $ toFilePath d) + newd <- liftIO $ newDir (parentDir $ toOsPath $ toFilePath d) maybe genFuzzAction (return . FuzzMoveDir d) newd FuzzDeleteDir _ -> do d <- liftIO existingDir @@ -221,7 +222,8 @@ existingFile :: Int -> FilePath -> IO (Maybe FuzzFile) existingFile 0 _ = return Nothing existingFile n top = do dir <- existingDirIncludingTop - contents <- catchDefaultIO [] (getDirectoryContents dir) + contents <- map fromOsPath + <$> catchDefaultIO [] (getDirectoryContents (toOsPath dir)) let files = filter isFuzzFile contents if null files then do @@ -230,19 +232,21 @@ existingFile n top = do then return Nothing else do i <- getStdRandom $ randomR (0, length dirs - 1) - existingFile (n - 1) (top dirs !! i) + existingFile (n - 1) (fromOsPath (toOsPath top toOsPath (dirs !! i))) else do i <- getStdRandom $ randomR (0, length files - 1) - return $ Just $ FuzzFile $ top dir files !! i + return $ Just $ FuzzFile $ fromOsPath $ + toOsPath top toOsPath dir toOsPath (files !! i) existingDirIncludingTop :: IO FilePath existingDirIncludingTop = do - dirs <- filter isFuzzDir <$> getDirectoryContents "." + dirs <- filter (isFuzzDir . fromOsPath) + <$> getDirectoryContents (literalOsPath ".") if null dirs then return "." else do n <- getStdRandom $ randomR (0, length dirs) - return $ ("." : dirs) !! n + return $ fromOsPath $ (literalOsPath "." : dirs) !! n existingDir :: IO (Maybe FuzzDir) existingDir = do @@ -257,21 +261,21 @@ newFile = go (100 :: Int) go 0 = return Nothing go n = do f <- genFuzzFile - ifM (doesnotexist (toFilePath f)) + ifM (doesnotexist (toOsPath (toFilePath f))) ( return $ Just f , go (n - 1) ) -newDir :: RawFilePath -> IO (Maybe FuzzDir) +newDir :: OsPath -> IO (Maybe FuzzDir) newDir parent = go (100 :: Int) where go 0 = return Nothing go n = do (FuzzDir d) <- genFuzzDir - ifM (doesnotexist (fromRawFilePath parent d)) + ifM (doesnotexist (parent toOsPath d)) ( return $ Just $ FuzzDir d , go (n - 1) ) -doesnotexist :: FilePath -> IO Bool -doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f)) +doesnotexist :: OsPath -> IO Bool +doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (fromOsPath f)) diff --git a/Command/Info.hs b/Command/Info.hs index 1471a18328..3c0b7c030e 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -14,7 +14,7 @@ import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Vector as V -import qualified System.FilePath.ByteString as P +import Data.ByteString.Short (fromShort) import System.PosixCompat.Files (isDirectory) import Data.Ord import qualified Data.Semigroup as Sem @@ -188,9 +188,9 @@ itemInfo o (si, p) = ifM (isdir (toRawFilePath p)) Right r -> remoteInfo o r si Left _ -> Remote.nameToUUID' p >>= \case ([], _) -> do - relp <- liftIO $ relPathCwdToFile (toRawFilePath p) + relp <- liftIO $ relPathCwdToFile (toOsPath p) lookupKey relp >>= \case - Just k -> fileInfo o (fromRawFilePath relp) si k + Just k -> fileInfo o (fromOsPath relp) si k Nothing -> treeishInfo o p si ([u], _) -> uuidInfo o u si (_us, msg) -> noInfo p si msg @@ -203,7 +203,7 @@ noInfo s si msg = do -- The string may not really be a file, but use ActionItemTreeFile, -- rather than ActionItemOther to avoid breaking back-compat of -- json output. - let ai = ActionItemTreeFile (toRawFilePath s) + let ai = ActionItemTreeFile (toOsPath s) showStartMessage (StartMessage "info" ai si) showNote (UnquotedString msg) showEndFail @@ -237,7 +237,7 @@ treeishInfo o t si = do fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex () fileInfo o file si k = do matcher <- Limit.getMatcher - let file' = toRawFilePath file + let file' = toOsPath file whenM (matcher $ MatchingFile $ FileInfo file' file' (Just k)) $ showCustom (unwords ["info", file]) si $ do evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o) @@ -502,17 +502,17 @@ transfer_list = stat desc $ nojson $ lift $ do where desc = "transfers in progress" line qp uuidmap t i = unwords - [ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing" - , fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem + [ decodeBS $ fromShort (formatDirection (transferDirection t)) <> "ing" + , decodeBS $ quote qp $ actionItemDesc $ mkActionItem (transferKey t, associatedFile i) , if transferDirection t == Upload then "to" else "from" , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap ] jsonify t i = object $ map (\(k, v) -> (textKey (packString k), v)) $ - [ ("transfer", toJSON' (formatDirection (transferDirection t))) + [ ("transfer", toJSON' (fromShort (formatDirection (transferDirection t)))) , ("key", toJSON' (transferKey t)) - , ("file", toJSON' (fromRawFilePath <$> afile)) + , ("file", toJSON' ((fromOsPath <$> afile) :: Maybe FilePath)) , ("remote", toJSON' (fromUUID (transferUUID t) :: String)) ] where @@ -522,7 +522,7 @@ disk_size :: Stat disk_size = simpleStat "available local disk space" $ calcfree <$> (lift $ annexDiskReserve <$> Annex.getGitConfig) - <*> (lift $ inRepo $ getDiskFree . fromRawFilePath . gitAnnexDir) + <*> (lift $ inRepo $ getDiskFree . fromOsPath . gitAnnexDir) <*> mkSizer where calcfree reserve (Just have) sizer = unwords @@ -700,7 +700,7 @@ getDirStatInfo o dir = do fast <- Annex.getRead Annex.fast matcher <- Limit.getMatcher (presentdata, referenceddata, numcopiesstats, repodata) <- - Command.Unused.withKeysFilesReferencedIn dir initial + Command.Unused.withKeysFilesReferencedIn (toOsPath dir) initial (update matcher fast) return $ StatInfo (Just presentdata) @@ -797,7 +797,7 @@ updateRepoData key locs m = m' M.fromList $ zip locs (map update locs) update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m) -updateNumCopiesStats :: RawFilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats +updateNumCopiesStats :: OsPath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats updateNumCopiesStats file (NumCopiesStats m) locs = do have <- trustExclude UnTrusted locs !variance <- Variance <$> numCopiesCheck' file (-) have @@ -817,7 +817,7 @@ showSizeKeys d = do "+ " ++ show (unknownSizeKeys d) ++ " unknown size" -staleSize :: String -> (Git.Repo -> RawFilePath) -> Stat +staleSize :: String -> (Git.Repo -> OsPath) -> Stat staleSize label dirspec = go =<< lift (dirKeys dirspec) where go [] = nostat @@ -830,7 +830,7 @@ staleSize label dirspec = go =<< lift (dirKeys dirspec) keysizes keys = do dir <- lift $ fromRepo dirspec liftIO $ forM keys $ \k -> - catchDefaultIO 0 $ getFileSize (dir P. keyFile k) + catchDefaultIO 0 $ getFileSize (dir keyFile k) aside :: String -> String aside s = " (" ++ s ++ ")" diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs index 7b5f1482ea..af30cc0dc4 100644 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -51,14 +51,17 @@ seek o = do where ww = WarnUnmatchLsFiles "inprogress" -start :: IsTerminal -> S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: IsTerminal -> S.Set Key -> SeekInput -> OsPath -> Key -> CommandStart start isterminal s _si _file k | S.member k s = start' isterminal k | otherwise = stop start' :: IsTerminal -> Key -> CommandStart start' (IsTerminal isterminal) k = startingCustomOutput k $ do - tmpf <- fromRawFilePath <$> fromRepo (gitAnnexTmpObjectLocation k) + tmpf <- fromRepo (gitAnnexTmpObjectLocation k) whenM (liftIO $ doesFileExist tmpf) $ - liftIO $ putStrLn (if isterminal then safeOutput tmpf else tmpf) + liftIO $ putStrLn $ + if isterminal + then safeOutput (fromOsPath tmpf) + else fromOsPath tmpf next $ return True diff --git a/Command/List.hs b/Command/List.hs index 46185e6092..c3705dd6fa 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -82,7 +82,7 @@ getList o printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () printHeader l = liftIO $ putStrLn $ safeOutput $ lheader $ map (\(_, n, t) -> (n, t)) l -start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> OsPath -> Key -> CommandStart start l _si file key = do ls <- S.fromList <$> keyLocations key qp <- coreQuotePath <$> Annex.getGitConfig @@ -100,7 +100,7 @@ lheader remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length trust UnTrusted = " (untrusted)" trust _ = "" -format :: [(TrustLevel, Present)] -> RawFilePath -> StringContainingQuotedPath +format :: [(TrustLevel, Present)] -> OsPath -> StringContainingQuotedPath format remotes file = UnquotedString (thereMap) <> " " <> QuotedPath file where thereMap = concatMap there remotes diff --git a/Command/Lock.hs b/Command/Lock.hs index 96aebaab23..c1c67dcf50 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -39,7 +39,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps , usesLocationLog = False } -start :: SeekInput -> RawFilePath -> Key -> CommandStart +start :: SeekInput -> OsPath -> Key -> CommandStart start si file key = ifM (isJust <$> isAnnexLink file) ( stop , starting "lock" (mkActionItem (key, file)) si $ @@ -59,7 +59,7 @@ start si file key = ifM (isJust <$> isAnnexLink file) ) cont = perform file key -perform :: RawFilePath -> Key -> CommandPerform +perform :: OsPath -> Key -> CommandPerform perform file key = do lockdown =<< calcRepo (gitAnnexLocation key) addSymlink file key =<< withTSDelta (liftIO . genInodeCache file) @@ -70,12 +70,14 @@ perform file key = do ( breakhardlink obj , repopulate obj ) - whenM (liftIO $ R.doesPathExist obj) $ + whenM (liftIO $ doesFileExist obj) $ freezeContent obj + getlinkcount obj = linkCount <$> liftIO (R.getFileStatus (fromOsPath 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 + breakhardlink obj = whenM (catchBoolIO $ (> 1) <$> getlinkcount obj) $ do mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do @@ -89,7 +91,7 @@ perform file key = do fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key mfile <- firstM (isUnmodified key) fs - liftIO $ removeWhenExistsWith R.removeLink obj + liftIO $ removeWhenExistsWith removeFile obj case mfile of Just unmodified -> ifM (checkedCopyFile key unmodified obj Nothing) diff --git a/Command/Log.hs b/Command/Log.hs index 8dbbb77247..4b5bec64ab 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -15,7 +15,6 @@ import Data.Char import Data.Time.Clock.POSIX import Data.Time import qualified Data.ByteString.Char8 as B8 -import qualified System.FilePath.ByteString as P import Control.Concurrent.Async import Command @@ -34,6 +33,7 @@ import Git.CatFile import Types.TrustLevel import Utility.DataUnits import Utility.HumanTime +import qualified Utility.FileIO as F data LogChange = Added | Removed @@ -282,15 +282,15 @@ getKeyLog key os = do top <- fromRepo Git.repoPath p <- liftIO $ relPathCwdToFile top config <- Annex.getGitConfig - let logfile = p P. locationLogFile config key - getGitLogAnnex [fromRawFilePath logfile] (Param "--remove-empty" : os) + let logfile = p locationLogFile config key + getGitLogAnnex [logfile] (Param "--remove-empty" : os) -getGitLogAnnex :: [FilePath] -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool) +getGitLogAnnex :: [OsPath] -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool) getGitLogAnnex fs os = do config <- Annex.getGitConfig let fileselector = \_sha f -> - locationLogFileKey config (toRawFilePath f) - inRepo $ getGitLog Annex.Branch.fullname Nothing fs os fileselector + locationLogFileKey config f + inRepo $ getGitLog Annex.Branch.fullname Nothing (map fromOsPath fs) os fileselector showTimeStamp :: TimeZone -> String -> POSIXTime -> String showTimeStamp zone format = formatTime defaultTimeLocale format @@ -320,11 +320,11 @@ sizeHistoryInfo mu o = do -- and to the trust log. getlog = do config <- Annex.getGitConfig - let fileselector = \_sha f -> let f' = toRawFilePath f in - case locationLogFileKey config f' of + let fileselector = \_sha f -> + case locationLogFileKey config f of Just k -> Just (Right k) Nothing - | f' == trustLog -> Just (Left ()) + | f == trustLog -> Just (Left ()) | otherwise -> Nothing inRepo $ getGitLog Annex.Branch.fullname Nothing [] [ Param "--date-order" @@ -409,10 +409,10 @@ sizeHistoryInfo mu o = do displaystart uuidmap zone | gnuplotOption o = do file <- () - <$> fromRepo (fromRawFilePath . gitAnnexDir) - <*> pure "gnuplot" - liftIO $ putStrLn $ "Generating gnuplot script in " ++ file - h <- liftIO $ openFile file WriteMode + <$> fromRepo gitAnnexDir + <*> pure (literalOsPath "gnuplot") + liftIO $ putStrLn $ "Generating gnuplot script in " ++ fromOsPath file + h <- liftIO $ F.openFile file WriteMode liftIO $ mapM_ (hPutStrLn h) [ "set datafile separator ','" , "set timefmt \"%Y-%m-%dT%H:%M:%S\"" @@ -442,7 +442,7 @@ sizeHistoryInfo mu o = do hFlush h putStrLn $ "Running gnuplot..." void $ liftIO $ boolSystem "gnuplot" - [Param "-p", File file] + [Param "-p", File (fromOsPath file)] return (dispst h endaction) | sizesOption o = do liftIO $ putStrLn uuidmapheader diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs index 32df886532..d84eeaa7a4 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -37,7 +37,7 @@ run o _ file | refOption o = catKey (Ref (toRawFilePath file)) >>= display | otherwise = do checkNotBareRepo - seekSingleGitFile file >>= \case + seekSingleGitFile (toOsPath file) >>= \case Nothing -> return False Just file' -> catKeyFile file' >>= display @@ -51,13 +51,13 @@ display Nothing = return False -- To support absolute filenames, pass through git ls-files. -- But, this plumbing command does not recurse through directories. -seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath) +seekSingleGitFile :: OsPath -> Annex (Maybe OsPath) seekSingleGitFile file - | isRelative file = return (Just (toRawFilePath file)) + | isRelative file = return (Just file) | otherwise = do - (l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [toRawFilePath file]) + (l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [file]) r <- case l of - (f:[]) | takeFileName (fromRawFilePath f) == takeFileName file -> + (f:[]) | takeFileName f == takeFileName file -> return (Just f) _ -> return Nothing void $ liftIO cleanup diff --git a/Command/Map.hs b/Command/Map.hs index 2ea732ac5d..71a46db51d 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -49,22 +49,22 @@ start = startingNoMessage (ActionItemOther Nothing) $ do trustmap <- trustMapLoad file <- () - <$> fromRepo (fromRawFilePath . gitAnnexDir) - <*> pure "map.dot" + <$> fromRepo gitAnnexDir + <*> pure (literalOsPath "map.dot") - liftIO $ writeFile file (drawMap rs trustmap umap) + liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap) next $ ifM (Annex.getRead Annex.fast) ( runViewer file [] , runViewer file - [ ("xdot", [File file]) - , ("dot", [Param "-Tx11", File file]) + [ ("xdot", [File (fromOsPath file)]) + , ("dot", [Param "-Tx11", File (fromOsPath file)]) ] ) -runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool +runViewer :: OsPath -> [(String, [CommandParam])] -> Annex Bool runViewer file [] = do - showLongNote $ UnquotedString $ "left map in " ++ file + showLongNote $ UnquotedString $ "left map in " ++ fromOsPath file return True runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c) ( do @@ -244,7 +244,7 @@ tryScan r where remotecmd = "sh -c " ++ shellEscape (cddir ++ " && " ++ "git config --null --list") - dir = fromRawFilePath $ Git.repoPath r + dir = fromOsPath $ Git.repoPath r cddir | "/~" `isPrefixOf` dir = let (userhome, reldir) = span (/= '/') (drop 1 dir) diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs index 9794ad8448..4ece1189c2 100644 --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -39,7 +39,7 @@ optParser desc = MatchExpressionOptions <*> (MatchingUserInfo . addkeysize <$> dataparser) where dataparser = UserProvidedInfo - <$> optinfo "file" (strOption + <$> optinfo "file" ((fmap stringToOsPath . strOption) ( long "file" <> metavar paramFile <> help "specify filename to match against" )) diff --git a/Command/MetaData.hs b/Command/MetaData.hs index e0a16c9249..6e81b4a13c 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -99,7 +99,7 @@ seek o = case batchOption o of ) _ -> giveup "--batch is currently only supported in --json mode" -start :: CandidateVectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: CandidateVectorClock -> MetaDataOptions -> SeekInput -> OsPath -> Key -> CommandStart start c o si file k = startKeys c o (si, k, mkActionItem (k, afile)) where afile = AssociatedFile (Just file) @@ -134,7 +134,7 @@ cleanup k = do unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v)) showmeta (f, vs) = map ((T.unpack f ++ "=") ++) (map decodeBS vs) -parseJSONInput :: String -> Annex (Either String (Either RawFilePath Key, MetaData)) +parseJSONInput :: String -> Annex (Either String (Either OsPath Key, MetaData)) parseJSONInput i = case eitherDecode (BU.fromString i) of Left e -> return (Left e) Right v -> do @@ -145,12 +145,12 @@ parseJSONInput i = case eitherDecode (BU.fromString i) of (Just k, _) -> return $ Right (Right k, m) (Nothing, Just f) -> do - f' <- liftIO $ relPathCwdToFile (toRawFilePath f) + f' <- liftIO $ relPathCwdToFile f return $ Right (Left f', m) (Nothing, Nothing) -> return $ Left "JSON input is missing either file or key" -startBatch :: (SeekInput, (Either RawFilePath Key, MetaData)) -> CommandStart +startBatch :: (SeekInput, (Either OsPath Key, MetaData)) -> CommandStart startBatch (si, (i, (MetaData m))) = case i of Left f -> do mk <- lookupKeyStaged f diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 2af9134081..a2dab7ab00 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -79,10 +79,10 @@ seekDistributedMigrations incremental = -- by multiple jobs. void $ includeCommandAction $ update oldkey newkey -start :: MigrateOptions -> Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: MigrateOptions -> Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart start o ksha si file key = do forced <- Annex.getRead Annex.force - v <- Backend.getBackend (fromRawFilePath file) key + v <- Backend.getBackend file key case v of Nothing -> stop Just oldbackend -> do @@ -118,7 +118,7 @@ start o ksha si file key = do - data cannot get corrupted after the fsck but before the new key is - generated. -} -perform :: Bool -> MigrateOptions -> RawFilePath -> Key -> MigrationRecord -> Backend -> Backend -> CommandPerform +perform :: Bool -> MigrateOptions -> OsPath -> Key -> MigrationRecord -> Backend -> Backend -> CommandPerform perform onlytweaksize o file oldkey oldkeyrec oldbackend newbackend = go =<< genkey (fastMigrate oldbackend) where go Nothing = stop diff --git a/Command/Multicast.hs b/Command/Multicast.hs index abb589e205..280f862fe4 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -28,7 +28,6 @@ import Utility.Hash import Utility.Tmp import Utility.Tmp.Dir import Utility.Process.Transcript -import qualified Utility.RawFilePath as R import Data.Char import qualified Data.ByteString.Lazy.UTF8 as B8 @@ -85,9 +84,9 @@ genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ d (s, ok) <- case k of KeyContainer s -> liftIO $ genkey (Param s) KeyFile f -> do - createAnnexDirectory (toRawFilePath (takeDirectory f)) - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) - liftIO $ protectedOutput $ genkey (File f) + createAnnexDirectory (takeDirectory f) + liftIO $ removeWhenExistsWith removeFile f + liftIO $ protectedOutput $ genkey (File (fromOsPath f)) case (ok, parseFingerprint s) of (False, _) -> giveup $ "uftp_keymgt failed: " ++ s (_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s @@ -130,19 +129,18 @@ send ups fs = do -- the names of keys, and would have to be copied, which is too -- expensive. starting "sending files" (ActionItemOther Nothing) (SeekInput []) $ - withTmpFile (toOsPath "send") $ \t h -> do + withTmpFile (literalOsPath "send") $ \t h -> do let ww = WarnUnmatchLsFiles "multicast" (fs', cleanup) <- seekHelper id ww LsFiles.inRepo =<< workTreeItems ww fs matcher <- Limit.getMatcher let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f Nothing) $ - liftIO $ hPutStrLn h o + liftIO $ hPutStrLn h (fromOsPath o) forM_ fs' $ \(_, f) -> do mk <- lookupKey f case mk of Nothing -> noop - Just k -> withObjectLoc k $ - addlist f . fromRawFilePath + Just k -> withObjectLoc k $ addlist f liftIO $ hClose h liftIO $ void cleanup @@ -161,9 +159,9 @@ send ups fs = do , Param "-k", uftpKeyParam serverkey , Param "-U", Param (uftpUID u) -- only allow clients on the authlist - , Param "-H", Param ("@"++authlist) + , Param "-H", Param ("@"++fromOsPath authlist) -- pass in list of files to send - , Param "-i", File (fromRawFilePath (fromOsPath t)) + , Param "-i", File (fromOsPath t) ] ++ ups liftIO (boolSystem "uftp" ps) >>= showEndResult next $ return True @@ -178,9 +176,9 @@ receive ups = starting "receiving multicast files" ai si $ do (callback, environ, statush) <- liftIO multicastCallbackEnv tmpobjdir <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory tmpobjdir - withTmpDirIn (fromRawFilePath tmpobjdir) (toOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do - abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir) - abscallback <- liftIO $ searchPath callback + withTmpDirIn tmpobjdir (literalOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do + abstmpdir <- liftIO $ absPath tmpdir + abscallback <- liftIO $ searchPath (fromOsPath callback) let ps = -- Avoid it running as a daemon. [ Param "-d" @@ -189,42 +187,43 @@ receive ups = starting "receiving multicast files" ai si $ do , Param "-k", uftpKeyParam clientkey , Param "-U", Param (uftpUID u) -- Only allow servers on the authlist - , Param "-S", Param authlist + , Param "-S", Param (fromOsPath authlist) -- Receive files into tmpdir -- (it needs an absolute path) - , Param "-D", File (fromRawFilePath abstmpdir) + , Param "-D", File (fromOsPath abstmpdir) -- Run callback after each file received -- (it needs an absolute path) - , Param "-s", Param (fromMaybe callback abscallback) + , Param "-s", Param (fromOsPath $ fromMaybe callback abscallback) ] ++ ups runner <- liftIO $ async $ hClose statush `after` boolSystemEnv "uftpd" ps (Just environ) - mapM_ storeReceived . lines =<< liftIO (hGetContents statush) + mapM_ storeReceived . map toOsPath . lines + =<< liftIO (hGetContents statush) showEndResult =<< liftIO (wait runner) next $ return True where ai = ActionItemOther Nothing si = SeekInput [] -storeReceived :: FilePath -> Annex () +storeReceived :: OsPath -> Annex () storeReceived f = do - case deserializeKey (takeFileName f) of + case deserializeKey' (fromOsPath (takeFileName f)) of Nothing -> do - warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file." - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + warning $ "Received a file " <> QuotedPath f <> " that is not a git-annex key. Deleting this file." + liftIO $ removeWhenExistsWith removeFile f Just k -> void $ logStatusAfter NoLiveUpdate k $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ liftIO $ catchBoolIO $ do - R.rename (toRawFilePath f) dest + renameFile f dest return True -- Under Windows, uftp uses key containers, which are not files on the -- filesystem. -data UftpKey = KeyFile FilePath | KeyContainer String +data UftpKey = KeyFile OsPath | KeyContainer String uftpKeyParam :: UftpKey -> CommandParam -uftpKeyParam (KeyFile f) = File f +uftpKeyParam (KeyFile f) = File (fromOsPath f) uftpKeyParam (KeyContainer s) = Param s uftpKey :: Annex UftpKey @@ -233,7 +232,7 @@ uftpKey = do u <- getUUID return $ KeyContainer $ "annex-" ++ fromUUID u #else -uftpKey = KeyFile <$> credsFile "multicast" +uftpKey = KeyFile <$> credsFile (literalOsPath "multicast") #endif -- uftp needs a unique UID for each client and server, which @@ -242,13 +241,13 @@ uftpKey = KeyFile <$> credsFile "multicast" uftpUID :: UUID -> String uftpUID u = "0x" ++ (take 8 $ show $ sha2_256 $ B8.fromString (fromUUID u)) -withAuthList :: (FilePath -> Annex a) -> Annex a +withAuthList :: (OsPath -> Annex a) -> Annex a withAuthList a = do m <- knownFingerPrints - withTmpFile (toOsPath "authlist") $ \t h -> do + withTmpFile (literalOsPath "authlist") $ \t h -> do liftIO $ hPutStr h (genAuthList m) liftIO $ hClose h - a (fromRawFilePath (fromOsPath t)) + a t genAuthList :: M.Map UUID Fingerprint -> String genAuthList = unlines . map fmt . M.toList diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 204a5fa8e2..a58bfc6a70 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -62,14 +62,14 @@ addViewMetaData :: View -> ViewedFile -> Key -> CommandStart addViewMetaData v f k = starting "metadata" ai si $ next $ changeMetaData k $ fromView v f where - ai = mkActionItem (k, toRawFilePath f) + ai = mkActionItem (k, f) si = SeekInput [] removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart removeViewMetaData v f k = starting "metadata" ai si $ next $ changeMetaData k $ unsetMetaData $ fromView v f where - ai = mkActionItem (k, toRawFilePath f) + ai = mkActionItem (k, f) si = SeekInput [] changeMetaData :: Key -> MetaData -> CommandCleanup diff --git a/Git/Types.hs b/Git/Types.hs index 980d259a5e..a32d07d4f7 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE CPP #-} module Git.Types where @@ -107,8 +108,10 @@ instance FromConfigValue S.ByteString where instance FromConfigValue String where fromConfigValue = decodeBS . fromConfigValue +#ifdef WITH_OSPATH instance FromConfigValue OsPath where fromConfigValue v = toOsPath (fromConfigValue v :: S.ByteString) +#endif instance Show ConfigValue where show = fromConfigValue diff --git a/Messages/JSON.hs b/Messages/JSON.hs index 81dcc1f2af..540ba1e9ec 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -34,6 +34,7 @@ module Messages.JSON ( import Control.Applicative import qualified Data.Map as M import qualified Data.Vector as V +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Aeson.KeyMap as HM import System.IO @@ -84,7 +85,7 @@ start command file key si _ = case j of j = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = key - , itemFile = fromOsPath <$> file + , itemFile = file , itemUUID = Nothing , itemFields = Nothing :: Maybe Bool , itemSeekInput = si @@ -98,7 +99,7 @@ startActionItem command ai si _ = case j of j = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = actionItemKey ai - , itemFile = fromOsPath <$> actionItemFile ai + , itemFile = actionItemFile ai , itemUUID = actionItemUUID ai , itemFields = Nothing :: Maybe Bool , itemSeekInput = si @@ -206,7 +207,7 @@ instance ToJSON' a => ToJSON' (ObjectMap a) where data JSONActionItem a = JSONActionItem { itemCommand :: Maybe String , itemKey :: Maybe Key - , itemFile :: Maybe FilePath + , itemFile :: Maybe OsPath , itemUUID :: Maybe UUID , itemFields :: Maybe a , itemSeekInput :: SeekInput @@ -220,7 +221,9 @@ instance ToJSON' a => ToJSON' (JSONActionItem a) where Just k -> Just $ "key" .= toJSON' k Nothing -> Nothing , case itemFile i of - Just f -> Just $ "file" .= toJSON' f + Just f -> + let f' = (fromOsPath f) :: S.ByteString + in Just $ "file" .= toJSON' f' Nothing -> Nothing , case itemFields i of Just f -> Just $ "fields" .= toJSON' f @@ -235,7 +238,7 @@ instance FromJSON a => FromJSON (JSONActionItem a) where parseJSON (Object v) = JSONActionItem <$> (v .:? "command") <*> (maybe (return Nothing) parseJSON =<< (v .:? "key")) - <*> (v .:? "file") + <*> (fmap stringToOsPath <$> (v .:? "file")) <*> (v .:? "uuid") <*> (v .:? "fields") -- ^ fields is used for metadata, which is currently the diff --git a/Test/Framework.hs b/Test/Framework.hs index d063731ec1..71191dffc6 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -432,8 +432,9 @@ checklocationlog f expected = do checkbackend :: FilePath -> Types.Backend -> Assertion checkbackend file expected = do - b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) - =<< Annex.WorkTree.lookupKey (toOsPath file) + let file' = toOsPath file + b <- annexeval $ maybe (return Nothing) (Backend.getBackend file') + =<< Annex.WorkTree.lookupKey file' assertEqual ("backend for " ++ file) (Just expected) b checkispointerfile :: FilePath -> Assertion diff --git a/Types/UUID.hs b/Types/UUID.hs index 6b16e849fe..63eef53a43 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -5,7 +5,9 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} module Types.UUID where @@ -20,11 +22,10 @@ import Data.ByteString.Builder import Control.DeepSeq import qualified Data.Semigroup as Sem +import Common import Git.Types (ConfigValue(..)) -import Utility.FileSystemEncoding import Utility.QuickCheck import Utility.Aeson -import Utility.OsPath import qualified Utility.SimpleProtocol as Proto -- A UUID is either an arbitrary opaque string, or UUID info may be missing. @@ -65,6 +66,7 @@ instance ToUUID SB.ShortByteString where | SB.null b = NoUUID | otherwise = UUID (SB.fromShort b) +#ifdef WITH_OSPATH -- OsPath is a ShortByteString internally, so this is the most -- efficient conversion. instance FromUUID OsPath where @@ -72,6 +74,7 @@ instance FromUUID OsPath where instance ToUUID OsPath where toUUID s = toUUID (fromOsPath s :: SB.ShortByteString) +#endif instance FromUUID String where fromUUID s = decodeBS (fromUUID s) diff --git a/Utility/OsString.hs b/Utility/OsString.hs index e1854adaec..ba563a568e 100644 --- a/Utility/OsString.hs +++ b/Utility/OsString.hs @@ -13,7 +13,10 @@ module Utility.OsString ( module X, - length + length, +#ifndef WITH_OSPATH + toChar, +#endif ) where #ifdef WITH_OSPATH @@ -30,4 +33,10 @@ length = B.length . fromOsPath #else import Data.ByteString as X hiding (length) import Data.ByteString (length) +import Data.Char +import Data.Word +import Prelude (fromIntegral, (.)) + +toChar :: Word8 -> Char +toChar = chr . fromIntegral #endif diff --git a/Utility/SafeOutput.hs b/Utility/SafeOutput.hs index d7813860ef..f0da940dee 100644 --- a/Utility/SafeOutput.hs +++ b/Utility/SafeOutput.hs @@ -17,6 +17,11 @@ module Utility.SafeOutput ( import Data.Char import qualified Data.ByteString as S +#ifdef WITH_OSPATH +import qualified Utility.OsString as OS +import Utility.OsPath +#endif + class SafeOutputtable t where safeOutput :: t -> t @@ -26,6 +31,11 @@ instance SafeOutputtable String where instance SafeOutputtable S.ByteString where safeOutput = S.filter (safeOutputChar . chr . fromIntegral) +#ifdef WITH_OSPATH +instance SafeOutputtable OsString where + safeOutput = OS.filter (safeOutputChar . toChar) +#endif + safeOutputChar :: Char -> Bool safeOutputChar c | not (isControl c) = True