From f1ba21d698c908ad84c08bce24fbbc376190fe83 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Feb 2025 15:24:28 -0400 Subject: [PATCH] OsPath conversion While some RawFilePath and FilePath remain, this converts most of git-annex to using OsPath. (When built without the OsPath build flag, is falls back to using type OsPath = RawFilePath.) The goals are 1) improved performance by using OsPath end-to-end when possible 2) potentially avoiding memory use problems caused by pinned strict ByteString, since OsPath uses ShortByteString 3) eventually eliminating the filepath-bytestring dependency so I don't need to keep maintaining that library (this doesn't get all the way, but close) 4) generally improved type safety, since OsPath is a newtype, while FilePath and RawFilePath are just type aliaes. This is the result of a type checker driven process. I started by converting from System.Directory to System.Directory.OsPath, and from System.FilePath to System.OsPath. Then I fixed all the compile errors, which took 3 weeks of work. Unfortunately, there are several test suite failures at this point. Also, it only has been built on linux, on windows and OSX there are probably ifdefs whose code still needs to be converted. Note that there is a parallel line of commits, starting with 05bdce328d890cbac68a8627aaae262078a8290a which is the incremental progress as I worked on this. It will be merged with this commit. In some cases, commits in that line explain in more details the reasons for some specific changes. --- Annex.hs | 4 +- Annex/AdjustedBranch.hs | 18 +- Annex/AdjustedBranch/Merge.hs | 24 +- Annex/AutoMerge.hs | 75 +-- Annex/Branch.hs | 89 ++-- Annex/BranchState.hs | 6 +- Annex/CatFile.hs | 18 +- Annex/ChangedRefs.hs | 13 +- Annex/CheckAttr.hs | 4 +- Annex/CheckIgnore.hs | 2 +- Annex/Content.hs | 134 +++--- Annex/Content/LowLevel.hs | 38 +- Annex/Content/PointerFile.hs | 19 +- Annex/Content/Presence.hs | 30 +- Annex/Content/Presence/LowLevel.hs | 2 +- Annex/CopyFile.hs | 13 +- Annex/DirHashes.hs | 12 +- Annex/Drop.hs | 2 +- Annex/ExternalAddonProcess.hs | 4 +- Annex/FileMatcher.hs | 13 +- Annex/Fixup.hs | 31 +- Annex/GitOverlay.hs | 14 +- Annex/HashObject.hs | 2 +- Annex/Hook.hs | 38 +- Annex/Import.hs | 22 +- Annex/Ingest.hs | 71 ++- Annex/Init.hs | 74 ++- Annex/InodeSentinal.hs | 10 +- Annex/Journal.hs | 69 ++- Annex/Link.hs | 77 +-- Annex/Locations.hs | 455 +++++++++--------- Annex/LockFile.hs | 23 +- Annex/Magic.hs | 17 +- Annex/MetaData.hs | 6 +- Annex/Multicast.hs | 7 +- Annex/NumCopies.hs | 12 +- Annex/Path.hs | 16 +- Annex/Perms.hs | 76 +-- Annex/Proxy.hs | 27 +- Annex/Queue.hs | 2 +- Annex/ReplaceFile.hs | 20 +- Annex/RepoSize/LiveUpdate.hs | 17 +- Annex/Sim.hs | 47 +- Annex/Ssh.hs | 63 +-- Annex/Tmp.hs | 13 +- Annex/Transfer.hs | 22 +- Annex/TransferrerPool.hs | 2 +- Annex/Url.hs | 4 +- Annex/VariantFile.hs | 21 +- Annex/Verify.hs | 31 +- Annex/View.hs | 45 +- Annex/View/ViewedFile.hs | 36 +- Annex/WorkTree.hs | 12 +- Annex/YoutubeDl.hs | 52 +- Assistant.hs | 21 +- Assistant/Alert.hs | 2 +- Assistant/Changes.hs | 4 +- Assistant/Install.hs | 55 ++- Assistant/Install/AutoStart.hs | 7 +- Assistant/Install/Menu.hs | 28 +- Assistant/MakeRepo.hs | 16 +- Assistant/Pairing/MakeRemote.hs | 6 +- Assistant/Repair.hs | 22 +- Assistant/Restart.hs | 21 +- Assistant/Ssh.hs | 64 +-- Assistant/Threads/Committer.hs | 58 +-- Assistant/Threads/ConfigMonitor.hs | 8 +- Assistant/Threads/Cronner.hs | 4 +- Assistant/Threads/Merger.hs | 31 +- Assistant/Threads/MountWatcher.hs | 10 +- Assistant/Threads/PairListener.hs | 2 +- Assistant/Threads/RemoteControl.hs | 2 +- Assistant/Threads/SanityChecker.hs | 26 +- Assistant/Threads/TransferWatcher.hs | 22 +- Assistant/Threads/UpgradeWatcher.hs | 4 +- Assistant/Threads/Watcher.hs | 106 ++-- Assistant/Threads/WebApp.hs | 18 +- Assistant/TransferSlots.hs | 2 +- Assistant/Types/Changes.hs | 10 +- Assistant/Unused.hs | 6 +- Assistant/Upgrade.hs | 126 ++--- Assistant/WebApp/Configurators/Delete.hs | 7 +- Assistant/WebApp/Configurators/Edit.hs | 6 +- Assistant/WebApp/Configurators/Local.hs | 104 ++-- Assistant/WebApp/Configurators/Pairing.hs | 4 +- Assistant/WebApp/Configurators/Preferences.hs | 6 +- Assistant/WebApp/Configurators/Ssh.hs | 16 +- Assistant/WebApp/Configurators/Unused.hs | 2 +- Assistant/WebApp/Control.hs | 2 +- Assistant/WebApp/DashBoard.hs | 4 +- Assistant/WebApp/Documentation.hs | 6 +- Assistant/WebApp/OtherRepos.hs | 14 +- Backend.hs | 6 +- Backend/External.hs | 6 +- Backend/GitRemoteAnnex.hs | 2 +- Backend/Hash.hs | 8 +- Backend/Utilities.hs | 2 +- Backend/VURL/Utilities.hs | 2 +- Backend/WORM.hs | 4 +- Build/Configure.hs | 5 +- Build/DesktopFile.hs | 19 +- Build/LinuxMkLibs.hs | 5 +- Build/Standalone.hs | 22 +- Build/TestConfig.hs | 9 +- Build/Version.hs | 2 +- CmdLine.hs | 12 +- CmdLine/Batch.hs | 6 +- CmdLine/GitAnnexShell.hs | 2 +- CmdLine/GitAnnexShell/Checks.hs | 20 +- CmdLine/GitRemoteAnnex.hs | 68 +-- CmdLine/Seek.hs | 59 ++- Command.hs | 3 +- Command/Add.hs | 36 +- Command/AddUnused.hs | 2 +- Command/AddUrl.hs | 70 +-- Command/Assist.hs | 3 +- Command/Assistant.hs | 10 +- Command/CalcKey.hs | 2 +- Command/Config.hs | 2 +- Command/ContentLocation.hs | 8 +- Command/Copy.hs | 4 +- Command/DiffDriver.hs | 4 +- Command/Drop.hs | 2 +- Command/DropUnused.hs | 5 +- Command/EnableTor.hs | 4 +- Command/ExamineKey.hs | 8 +- Command/Export.hs | 9 +- Command/FilterBranch.hs | 8 +- Command/FilterProcess.hs | 6 +- Command/Find.hs | 10 +- Command/Fix.hs | 34 +- Command/FromKey.hs | 11 +- Command/Fsck.hs | 92 ++-- Command/FuzzTest.hs | 36 +- Command/Get.hs | 2 +- Command/Import.hs | 30 +- Command/ImportFeed.hs | 44 +- 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/Mirror.hs | 2 +- Command/Move.hs | 2 +- Command/Multicast.hs | 55 ++- Command/P2P.hs | 21 +- Command/P2PHttp.hs | 2 +- Command/PostReceive.hs | 6 +- Command/PreCommit.hs | 4 +- Command/ReKey.hs | 19 +- Command/RecvKey.hs | 2 +- Command/Reinject.hs | 16 +- Command/RemoteDaemon.hs | 2 +- Command/Repair.hs | 3 +- Command/ResolveMerge.hs | 6 +- Command/RmUrl.hs | 21 +- Command/SendKey.hs | 4 +- Command/SetKey.hs | 4 +- Command/Sim.hs | 8 +- Command/Smudge.hs | 24 +- Command/Status.hs | 2 +- Command/Sync.hs | 18 +- Command/TestRemote.hs | 45 +- Command/TransferKey.hs | 4 +- Command/TransferKeys.hs | 6 +- Command/Transferrer.hs | 4 +- Command/Unannex.hs | 23 +- Command/Undo.hs | 18 +- Command/Uninit.hs | 16 +- Command/Unlock.hs | 8 +- Command/Unused.hs | 16 +- Command/Vicfg.hs | 24 +- Command/View.hs | 7 +- Command/WebApp.hs | 37 +- Command/WhereUsed.hs | 4 +- Command/Whereis.hs | 2 +- Common.hs | 1 - Config.hs | 4 +- Config/Files.hs | 21 +- Config/Files/AutoStart.hs | 24 +- Config/Smudge.hs | 11 +- Creds.hs | 20 +- Crypto.hs | 4 +- Database/Benchmark.hs | 11 +- Database/ContentIdentifier.hs | 8 +- Database/Export.hs | 27 +- Database/Fsck.hs | 8 +- Database/Handle.hs | 27 +- Database/ImportFeed.hs | 6 +- Database/Init.hs | 23 +- Database/Keys.hs | 31 +- Database/Keys/SQL.hs | 11 +- Database/Queue.hs | 4 +- Database/RepoSize.hs | 6 +- Git.hs | 44 +- Git/CatFile.hs | 4 +- Git/CheckAttr.hs | 13 +- Git/CheckIgnore.hs | 6 +- Git/Command.hs | 11 +- Git/Config.hs | 17 +- Git/Construct.hs | 82 ++-- Git/CurrentRepo.hs | 16 +- Git/DiffTree.hs | 6 +- Git/Env.hs | 4 +- Git/FilePath.hs | 29 +- Git/FilterProcess.hs | 6 +- Git/HashObject.hs | 23 +- Git/Hook.hs | 22 +- Git/Index.hs | 22 +- Git/LockFile.hs | 14 +- Git/Log.hs | 11 +- Git/LsFiles.hs | 86 ++-- Git/LsTree.hs | 7 +- Git/Objects.hs | 41 +- Git/Queue.hs | 6 +- Git/Quote.hs | 15 +- Git/Ref.hs | 22 +- Git/Repair.hs | 87 ++-- Git/Status.hs | 12 +- Git/Tree.hs | 10 +- Git/Types.hs | 16 +- Git/UnionMerge.hs | 4 +- Git/UpdateIndex.hs | 15 +- Key.hs | 12 +- Limit.hs | 45 +- Logs.hs | 206 ++++---- Logs/Export.hs | 2 +- Logs/File.hs | 45 +- Logs/FsckResults.hs | 7 +- Logs/Location.hs | 6 +- Logs/MetaData.hs | 8 +- Logs/Migrate.hs | 19 +- Logs/PreferredContent/Raw.hs | 2 +- Logs/Presence.hs | 14 +- Logs/Restage.hs | 18 +- Logs/Schedule.hs | 2 +- Logs/SingleValue.hs | 6 +- Logs/Smudge.hs | 4 +- Logs/Transfer.hs | 82 ++-- Logs/Transitions.hs | 6 +- Logs/Unused.hs | 18 +- Logs/Upgrade.hs | 4 +- Logs/View.hs | 2 +- Messages.hs | 2 +- Messages/JSON.hs | 17 +- Messages/Progress.hs | 4 +- P2P/Address.hs | 14 +- P2P/Annex.hs | 15 +- P2P/Auth.hs | 11 +- P2P/Http/Client.hs | 5 +- P2P/Http/Types.hs | 6 +- P2P/IO.hs | 11 +- P2P/Protocol.hs | 34 +- Remote/Adb.hs | 36 +- Remote/BitTorrent.hs | 62 ++- Remote/Borg.hs | 47 +- Remote/Bup.hs | 15 +- Remote/Ddar.hs | 6 +- Remote/Directory.hs | 198 ++++---- Remote/Directory/LegacyChunked.hs | 39 +- Remote/External.hs | 31 +- Remote/External/Types.hs | 8 +- Remote/GCrypt.hs | 44 +- Remote/Git.hs | 53 +- Remote/GitLFS.hs | 15 +- Remote/Glacier.hs | 2 +- Remote/Helper/AWS.hs | 2 +- Remote/Helper/Chunked.hs | 28 +- Remote/Helper/Chunked/Legacy.hs | 2 +- Remote/Helper/Git.hs | 12 +- Remote/Helper/Hooks.hs | 3 +- Remote/Helper/Http.hs | 11 +- Remote/Helper/P2P.hs | 6 +- Remote/Helper/Path.hs | 2 +- Remote/Helper/ReadOnly.hs | 6 +- Remote/Helper/Special.hs | 24 +- Remote/Helper/Ssh.hs | 2 +- Remote/Helper/ThirdPartyPopulated.hs | 26 +- Remote/Hook.hs | 8 +- Remote/HttpAlso.hs | 12 +- Remote/Rsync.hs | 77 +-- Remote/Rsync/RsyncUrl.hs | 14 +- Remote/S3.hs | 39 +- Remote/Tahoe.hs | 33 +- Remote/Web.hs | 6 +- Remote/WebDAV.hs | 14 +- Remote/WebDAV/DavLocation.hs | 28 +- RemoteDaemon/Transport/Tor.hs | 2 +- Test.hs | 218 +++++---- Test/Framework.hs | 74 +-- Types/ActionItem.hs | 10 +- Types/Backend.hs | 3 +- Types/BranchState.hs | 4 +- Types/Direction.hs | 6 +- Types/Export.hs | 50 +- Types/FileMatcher.hs | 12 +- Types/GitConfig.hs | 4 +- Types/Import.hs | 23 +- Types/Key.hs | 7 +- Types/KeySource.hs | 6 +- Types/LockCache.hs | 4 +- Types/Remote.hs | 18 +- Types/StoreRetrieve.hs | 4 +- Types/Transfer.hs | 4 +- Types/Transferrer.hs | 4 +- Types/Transitions.hs | 4 +- Types/UUID.hs | 26 +- Types/UrlContents.hs | 5 +- Upgrade.hs | 4 +- Upgrade/V0.hs | 14 +- Upgrade/V1.hs | 87 ++-- Upgrade/V2.hs | 50 +- Upgrade/V5.hs | 12 +- Upgrade/V5/Direct.hs | 34 +- Upgrade/V7.hs | 51 +- Upgrade/V9.hs | 2 +- Utility/Aeson.hs | 9 + Utility/CopyFile.hs | 12 +- Utility/Daemon.hs | 48 +- Utility/DirWatcher.hs | 9 +- Utility/DirWatcher/FSEvents.hs | 3 +- Utility/DirWatcher/INotify.hs | 38 +- Utility/DirWatcher/Types.hs | 10 +- Utility/DirWatcher/Win32Notify.hs | 3 +- Utility/Directory.hs | 40 +- Utility/Directory/Create.hs | 30 +- Utility/Directory/Stream.hs | 5 +- Utility/FileIO.hs | 65 ++- Utility/FileMode.hs | 33 +- Utility/FileSize.hs | 10 +- Utility/FileSystemEncoding.hs | 13 +- Utility/FreeDesktop.hs | 56 +-- Utility/Gpg.hs | 10 +- Utility/HtmlDetect.hs | 5 +- Utility/InodeCache.hs | 23 +- Utility/LinuxMkLibs.hs | 27 +- Utility/LockFile/PidLock.hs | 63 ++- Utility/LockFile/Posix.hs | 8 +- Utility/LockFile/Windows.hs | 4 +- Utility/LockPool/STM.hs | 4 +- Utility/LogFile.hs | 4 +- Utility/Lsof.hs | 15 +- Utility/Metered.hs | 11 +- Utility/MoveFile.hs | 20 +- Utility/OSX.hs | 18 +- Utility/OsPath.hs | 123 ++++- Utility/OsString.hs | 42 ++ Utility/Path.hs | 97 ++-- Utility/Path/AbsRel.hs | 28 +- Utility/Path/Tests.hs | 57 +-- Utility/Path/Windows.hs | 9 +- Utility/RawFilePath.hs | 2 +- Utility/SafeOutput.hs | 10 + Utility/Shell.hs | 7 +- Utility/SshConfig.hs | 16 +- Utility/StatelessOpenPGP.hs | 9 +- Utility/Su.hs | 2 +- Utility/SystemDirectory.hs | 103 +++- Utility/Tmp.hs | 26 +- Utility/Tmp/Dir.hs | 23 +- Utility/Tor.hs | 71 +-- Utility/Url.hs | 25 +- Utility/WebApp.hs | 6 +- git-annex.cabal | 1 + 369 files changed, 4453 insertions(+), 4046 deletions(-) create mode 100644 Utility/OsString.hs diff --git a/Annex.hs b/Annex.hs index 9e4d0a45c3..582ffd644d 100644 --- a/Annex.hs +++ b/Annex.hs @@ -221,7 +221,7 @@ data AnnexState = AnnexState , existinghooks :: M.Map Git.Hook.Hook Bool , workers :: Maybe (TMVar (WorkerPool (AnnexState, AnnexRead))) , cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) - , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) + , cachedgitenv :: Maybe (AltIndexFile, OsPath, [(String, String)]) , urloptions :: Maybe UrlOptions , insmudgecleanfilter :: Bool , getvectorclock :: IO CandidateVectorClock @@ -465,7 +465,7 @@ withCurrentState a = do - because the git repo paths are stored relative. - Instead, use this. -} -changeDirectory :: FilePath -> Annex () +changeDirectory :: OsPath -> Annex () changeDirectory d = do r <- liftIO . Git.adjustPath absPath =<< gitRepo liftIO $ setCurrentDirectory d diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index 5d5458fa82..99cd40e835 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -161,7 +161,7 @@ adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case Database.Keys.addAssociatedFile k f exe <- catchDefaultIO False $ (isExecutable . fileMode) <$> - (liftIO . R.getFileStatus + (liftIO . R.getFileStatus . fromOsPath =<< calcRepo (gitAnnexLocation k)) let mode = fromTreeItemType $ if exe then TreeExecutable else TreeFile @@ -171,13 +171,13 @@ adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem) adjustToSymlink = adjustToSymlink' gitAnnexLink -adjustToSymlink' :: (RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath) -> TreeItem -> Annex (Maybe TreeItem) +adjustToSymlink' :: (OsPath -> Key -> Git.Repo -> GitConfig -> IO OsPath) -> TreeItem -> Annex (Maybe TreeItem) adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case Just k -> do absf <- inRepo $ \r -> absPath $ fromTopFilePath f r linktarget <- calcRepo $ gitannexlink absf k Just . TreeItem f (fromTreeItemType TreeSymlink) - <$> hashSymlink linktarget + <$> hashSymlink (fromOsPath linktarget) Nothing -> return (Just ti) -- This is a hidden branch ref, that's used as the basis for the AdjBranch, @@ -269,7 +269,7 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch -- origbranch. _ <- propigateAdjustedCommits' True origbranch adj commitlck - origheadfile <- inRepo $ F.readFile' . toOsPath . Git.Ref.headFile + origheadfile <- inRepo $ F.readFile' . Git.Ref.headFile origheadsha <- inRepo (Git.Ref.sha currbranch) b <- adjustBranch adj origbranch @@ -282,7 +282,7 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch Just s -> do inRepo $ \r -> do let newheadfile = fromRef' s - F.writeFile' (toOsPath (Git.Ref.headFile r)) newheadfile + F.writeFile' (Git.Ref.headFile r) newheadfile return (Just newheadfile) _ -> return Nothing @@ -296,9 +296,9 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch unless ok $ case newheadfile of Nothing -> noop Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do - v' <- F.readFile' (toOsPath (Git.Ref.headFile r)) + v' <- F.readFile' (Git.Ref.headFile r) when (v == v') $ - F.writeFile' (toOsPath (Git.Ref.headFile r)) origheadfile + F.writeFile' (Git.Ref.headFile r) origheadfile return ok | otherwise = preventCommits $ \commitlck -> do @@ -451,7 +451,7 @@ preventCommits = bracket setup cleanup where setup = do lck <- fromRepo $ indexFileLock . indexFile - liftIO $ Git.LockFile.openLock (fromRawFilePath lck) + liftIO $ Git.LockFile.openLock lck cleanup = liftIO . Git.LockFile.closeLock {- Commits a given adjusted tree, with the provided parent ref. @@ -631,7 +631,7 @@ reverseAdjustedTree basis adj csha = do where m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $ map diffTreeToTreeItem changes - norm = normalise . fromRawFilePath . getTopFilePath + norm = normalise . getTopFilePath diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem diffTreeToTreeItem dti = TreeItem diff --git a/Annex/AdjustedBranch/Merge.hs b/Annex/AdjustedBranch/Merge.hs index 7817bdbeca..dd9ac19a0c 100644 --- a/Annex/AdjustedBranch/Merge.hs +++ b/Annex/AdjustedBranch/Merge.hs @@ -29,11 +29,8 @@ import Annex.GitOverlay import Utility.Tmp.Dir import Utility.CopyFile import Utility.Directory.Create -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F -import qualified System.FilePath.ByteString as P - canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool canMergeToAdjustedBranch tomerge (origbranch, adj) = inRepo $ Git.Branch.changed currbranch tomerge @@ -74,23 +71,24 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do git_dir <- fromRepo Git.localGitDir tmpwt <- fromRepo gitAnnexMergeDir - withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $ + withTmpDirIn othertmpdir (literalOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $ withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do - let tmpgit' = toRawFilePath tmpgit - liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) + liftIO $ F.writeFile' + (tmpgit literalOsPath "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 $ emptyWhenDoesNotExist $ dirContentsRecursive $ - git_dir P. "refs" - let refs' = (git_dir P. "packed-refs") : refs + git_dir literalOsPath "refs" + let refs' = (git_dir literalOsPath "packed-refs") : refs liftIO $ forM_ refs' $ \src -> do - whenM (R.doesPathExist src) $ do + whenM (doesFileExist src) $ do dest <- relPathDirToFile git_dir src - let dest' = tmpgit' P. dest + let dest' = tmpgit dest createDirectoryUnder [git_dir] - (P.takeDirectory dest') + (takeDirectory dest') void $ createLinkOrCopy src dest' -- This reset makes git merge not care -- that the work tree is empty; otherwise @@ -107,7 +105,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm if merged then do !mergecommit <- liftIO $ extractSha - <$> F.readFile' (toOsPath (tmpgit' P. "HEAD")) + <$> F.readFile' (tmpgit literalOsPath "HEAD") -- This is run after the commit lock is dropped. return $ postmerge mergecommit else return $ return False @@ -118,7 +116,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm setup = do whenM (doesDirectoryExist d) $ removeDirectoryRecursive d - createDirectoryUnder [git_dir] (toRawFilePath d) + createDirectoryUnder [git_dir] d cleanup _ = removeDirectoryRecursive d {- A merge commit has been made between the basisbranch and diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index 0c0c203688..b097f03dff 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -133,7 +133,7 @@ autoMergeFrom' branch currbranch mergeconfig commitmode willresolvemerge toresol resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool resolveMerge us them inoverlay = do top <- if inoverlay - then pure "." + then pure (literalOsPath ".") else fromRepo Git.repoPath (fs, cleanup) <- inRepo (LsFiles.unmerged [top]) srcmap <- if inoverlay @@ -150,7 +150,7 @@ resolveMerge us them inoverlay = do unless (null deleted) $ Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] - (map fromRawFilePath deleted) + (map fromOsPath deleted) void $ liftIO cleanup2 when merged $ do @@ -167,7 +167,7 @@ resolveMerge us them inoverlay = do , LsFiles.unmergedSiblingFile u ] -resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath) +resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe OsPath) resolveMerge' _ Nothing _ _ _ = return ([], Nothing) resolveMerge' unstagedmap (Just us) them inoverlay u = do kus <- getkey LsFiles.valUs @@ -182,7 +182,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do -- files, so delete here. unless inoverlay $ unless (islocked LsFiles.valUs) $ - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath file) + liftIO $ removeWhenExistsWith removeFile file | otherwise -> resolveby [keyUs, keyThem] $ -- Only resolve using symlink when both -- were locked, otherwise use unlocked @@ -204,8 +204,8 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do -- Neither side is annexed file; cannot resolve. (Nothing, Nothing) -> return ([], Nothing) where - file = fromRawFilePath $ LsFiles.unmergedFile u - sibfile = fromRawFilePath <$> LsFiles.unmergedSiblingFile u + file = LsFiles.unmergedFile u + sibfile = LsFiles.unmergedSiblingFile u getkey select = case select (LsFiles.unmergedSha u) of @@ -230,16 +230,15 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do dest = variantFile file key destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u) - stagefile :: FilePath -> Annex FilePath + stagefile :: OsPath -> Annex OsPath stagefile f - | inoverlay = ( f) . fromRawFilePath <$> fromRepo Git.repoPath + | inoverlay = ( f) <$> fromRepo Git.repoPath | otherwise = pure f makesymlink key dest = do - let rdest = toRawFilePath dest - l <- calcRepo $ gitAnnexLink rdest key - unless inoverlay $ replacewithsymlink rdest l - dest' <- toRawFilePath <$> stagefile dest + l <- fromOsPath <$> calcRepo (gitAnnexLink dest key) + unless inoverlay $ replacewithsymlink dest l + dest' <- stagefile dest stageSymlink dest' =<< hashSymlink l replacewithsymlink dest link = replaceWorkTreeFile dest $ @@ -248,27 +247,27 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do makepointer key dest destmode = do unless inoverlay $ unlessM (reuseOldFile unstagedmap key file dest) $ - linkFromAnnex key (toRawFilePath dest) destmode >>= \case + linkFromAnnex key dest destmode >>= \case LinkAnnexFailed -> liftIO $ - writePointerFile (toRawFilePath dest) key destmode + writePointerFile dest key destmode _ -> noop - dest' <- toRawFilePath <$> stagefile dest + dest' <- stagefile dest stagePointerFile dest' destmode =<< hashPointerFile key unless inoverlay $ Database.Keys.addAssociatedFile key - =<< inRepo (toTopFilePath (toRawFilePath dest)) + =<< inRepo (toTopFilePath dest) {- Stage a graft of a directory or file from a branch - and update the work tree. -} graftin b item selectwant selectwant' selectunwant = do Annex.Queue.addUpdateIndex - =<< fromRepo (UpdateIndex.lsSubTree b item) - + =<< fromRepo (UpdateIndex.lsSubTree b (fromOsPath item)) + let replacefile isexecutable = case selectwant' (LsFiles.unmergedSha u) of Nothing -> noop - Just sha -> replaceWorkTreeFile (toRawFilePath item) $ \tmp -> do + Just sha -> replaceWorkTreeFile item $ \tmp -> do c <- catObject sha - liftIO $ F.writeFile (toOsPath tmp) c + liftIO $ F.writeFile tmp c when isexecutable $ liftIO $ void $ tryIO $ modifyFileMode tmp $ @@ -281,7 +280,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do Nothing -> noop Just sha -> do link <- catSymLinkTarget sha - replacewithsymlink (toRawFilePath item) link + replacewithsymlink item (fromOsPath link) (Just TreeFile, Just TreeSymlink) -> replacefile False (Just TreeExecutable, Just TreeSymlink) -> replacefile True _ -> ifM (liftIO $ doesDirectoryExist item) @@ -305,9 +304,9 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do , Param "--cached" , Param "--" ] - (catMaybes [Just file, sibfile]) + (map fromOsPath $ catMaybes [Just file, sibfile]) liftIO $ maybe noop - (removeWhenExistsWith R.removeLink . toRawFilePath) + (removeWhenExistsWith removeFile) sibfile void a return (ks, Just file) @@ -322,13 +321,13 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do - C) are pointers to or have the content of keys that were involved - in the merge. -} -cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex () +cleanConflictCruft :: [Key] -> [OsPath] -> InodeMap -> Annex () cleanConflictCruft resolvedks resolvedfs unstagedmap = do is <- S.fromList . map (inodeCacheToKey Strongly) . concat <$> mapM Database.Keys.getInodeCaches resolvedks forM_ (M.toList unstagedmap) $ \(i, f) -> whenM (matchesresolved is i f) $ - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + liftIO $ removeWhenExistsWith removeFile f where fs = S.fromList resolvedfs ks = S.fromList resolvedks @@ -336,19 +335,24 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do matchesresolved is i f | S.member f fs || S.member (conflictCruftBase f) fs = anyM id [ pure $ either (const False) (`S.member` is) i - , inks <$> isAnnexLink (toRawFilePath f) - , inks <$> liftIO (isPointerFile (toRawFilePath f)) + , inks <$> isAnnexLink f + , inks <$> liftIO (isPointerFile f) ] | otherwise = return False -conflictCruftBase :: FilePath -> FilePath -conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f +conflictCruftBase :: OsPath -> OsPath +conflictCruftBase = toOsPath + . reverse + . drop 1 + . dropWhile (/= '~') + . reverse + . fromOsPath {- When possible, reuse an existing file from the srcmap as the - content of a worktree file in the resolved merge. It must have the - same name as the origfile, or a name that git would use for conflict - cruft. And, its inode cache must be a known one for the key. -} -reuseOldFile :: InodeMap -> Key -> FilePath -> FilePath -> Annex Bool +reuseOldFile :: InodeMap -> Key -> OsPath -> OsPath -> Annex Bool reuseOldFile srcmap key origfile destfile = do is <- map (inodeCacheToKey Strongly) <$> Database.Keys.getInodeCaches key @@ -374,19 +378,18 @@ commitResolvedMerge commitmode = do , Param "git-annex automatic merge conflict fix" ] -type InodeMap = M.Map (Either FilePath InodeCacheKey) FilePath +type InodeMap = M.Map (Either OsPath InodeCacheKey) OsPath -inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap +inodeMap :: Annex ([OsPath], IO Bool) -> Annex InodeMap inodeMap getfiles = do (fs, cleanup) <- getfiles fsis <- forM fs $ \f -> do - s <- liftIO $ R.getSymbolicLinkStatus f - let f' = fromRawFilePath f + s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath f) if isSymbolicLink s - then pure $ Just (Left f', f') + then pure $ Just (Left f, f) else withTSDelta (\d -> liftIO $ toInodeCache d f s) >>= return . \case - Just i -> Just (Right (inodeCacheToKey Strongly i), f') + Just i -> Just (Right (inodeCacheToKey Strongly i), f) Nothing -> Nothing void $ liftIO cleanup return $ M.fromList $ catMaybes fsis diff --git a/Annex/Branch.hs b/Annex/Branch.hs index dd7dc03255..9cdb1267fa 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -54,7 +54,6 @@ import Data.Char import Data.ByteString.Builder import Control.Concurrent (threadDelay) import Control.Concurrent.MVar -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (isRegularFile) import Annex.Common @@ -313,7 +312,7 @@ updateTo' pairs = do - transitions that have not been applied to all refs will be applied on - the fly. -} -get :: RawFilePath -> Annex L.ByteString +get :: OsPath -> Annex L.ByteString get file = do st <- update case getCache file st of @@ -353,7 +352,7 @@ getUnmergedRefs = unmergedRefs <$> update - using some optimised method. The journal has to be checked, in case - it has a newer version of the file that has not reached the branch yet. -} -precache :: RawFilePath -> L.ByteString -> Annex () +precache :: OsPath -> L.ByteString -> Annex () precache file branchcontent = do st <- getState content <- if journalIgnorable st @@ -369,12 +368,12 @@ precache file branchcontent = do - reflect changes in remotes. - (Changing the value this returns, and then merging is always the - same as using get, and then changing its value.) -} -getLocal :: RawFilePath -> Annex L.ByteString +getLocal :: OsPath -> Annex L.ByteString getLocal = getLocal' (GetPrivate True) -getLocal' :: GetPrivate -> RawFilePath -> Annex L.ByteString +getLocal' :: GetPrivate -> OsPath -> Annex L.ByteString getLocal' getprivate file = do - fastDebug "Annex.Branch" ("read " ++ fromRawFilePath file) + fastDebug "Annex.Branch" ("read " ++ fromOsPath file) go =<< getJournalFileStale getprivate file where go NoJournalledContent = getRef fullname file @@ -384,14 +383,14 @@ getLocal' getprivate file = do return (v <> journalcontent) {- Gets the content of a file as staged in the branch's index. -} -getStaged :: RawFilePath -> Annex L.ByteString +getStaged :: OsPath -> Annex L.ByteString getStaged = getRef indexref where -- This makes git cat-file be run with ":file", -- so it looks at the index. indexref = Ref "" -getHistorical :: RefDate -> RawFilePath -> Annex L.ByteString +getHistorical :: RefDate -> OsPath -> Annex L.ByteString getHistorical date file = -- This check avoids some ugly error messages when the reflog -- is empty. @@ -400,7 +399,7 @@ getHistorical date file = , getRef (Git.Ref.dateRef fullname date) file ) -getRef :: Ref -> RawFilePath -> Annex L.ByteString +getRef :: Ref -> OsPath -> Annex L.ByteString getRef ref file = withIndex $ catFile ref file {- Applies a function to modify the content of a file. @@ -408,7 +407,7 @@ getRef ref file = withIndex $ catFile ref file - Note that this does not cause the branch to be merged, it only - modifies the current content of the file on the branch. -} -change :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> content) -> Annex () +change :: Journalable content => RegardingUUID -> OsPath -> (L.ByteString -> content) -> Annex () change ru file f = lockJournal $ \jl -> f <$> getToChange ru file >>= set jl ru file {- Applies a function which can modify the content of a file, or not. @@ -416,7 +415,7 @@ change ru file f = lockJournal $ \jl -> f <$> getToChange ru file >>= set jl ru - When the file was modified, runs the onchange action, and returns - True. The action is run while the journal is still locked, - so another concurrent call to this cannot happen while it is running. -} -maybeChange :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> Maybe content) -> Annex () -> Annex Bool +maybeChange :: Journalable content => RegardingUUID -> OsPath -> (L.ByteString -> Maybe content) -> Annex () -> Annex Bool maybeChange ru file f onchange = lockJournal $ \jl -> do v <- getToChange ru file case f v of @@ -449,7 +448,7 @@ data ChangeOrAppend t = Change t | Append t - state that would confuse the older version. This is planned to be - changed in a future repository version. -} -changeOrAppend :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> ChangeOrAppend content) -> Annex () +changeOrAppend :: Journalable content => RegardingUUID -> OsPath -> (L.ByteString -> ChangeOrAppend content) -> Annex () changeOrAppend ru file f = lockJournal $ \jl -> checkCanAppendJournalFile jl ru file >>= \case Just appendable -> ifM (annexAlwaysCompact <$> Annex.getGitConfig) @@ -481,7 +480,7 @@ changeOrAppend ru file f = lockJournal $ \jl -> oldc <> journalableByteString toappend {- Only get private information when the RegardingUUID is itself private. -} -getToChange :: RegardingUUID -> RawFilePath -> Annex L.ByteString +getToChange :: RegardingUUID -> OsPath -> Annex L.ByteString getToChange ru f = flip getLocal' f . GetPrivate =<< regardingPrivateUUID ru {- Records new content of a file into the journal. @@ -493,11 +492,11 @@ getToChange ru f = flip getLocal' f . GetPrivate =<< regardingPrivateUUID ru - git-annex index, and should not be written to the public git-annex - branch. -} -set :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex () +set :: Journalable content => JournalLocked -> RegardingUUID -> OsPath -> content -> Annex () set jl ru f c = do journalChanged setJournalFile jl ru f c - fastDebug "Annex.Branch" ("set " ++ fromRawFilePath f) + fastDebug "Annex.Branch" ("set " ++ fromOsPath f) -- Could cache the new content, but it would involve -- evaluating a Journalable Builder twice, which is not very -- efficient. Instead, assume that it's not common to need to read @@ -505,11 +504,11 @@ set jl ru f c = do invalidateCache f {- Appends content to the journal file. -} -append :: Journalable content => JournalLocked -> RawFilePath -> AppendableJournalFile -> content -> Annex () +append :: Journalable content => JournalLocked -> OsPath -> AppendableJournalFile -> content -> Annex () append jl f appendable toappend = do journalChanged appendJournalFile jl appendable toappend - fastDebug "Annex.Branch" ("append " ++ fromRawFilePath f) + fastDebug "Annex.Branch" ("append " ++ fromOsPath f) invalidateCache f {- Commit message used when making a commit of whatever data has changed @@ -611,7 +610,7 @@ commitIndex' jl branchref message basemessage retrynum parents = do - not been merged in, returns Nothing, because it's not possible to - efficiently handle that. -} -files :: Annex (Maybe ([RawFilePath], IO Bool)) +files :: Annex (Maybe ([OsPath], IO Bool)) files = do st <- update if not (null (unmergedRefs st)) @@ -629,10 +628,10 @@ files = do {- Lists all files currently in the journal, but not files in the private - journal. -} -journalledFiles :: Annex [RawFilePath] +journalledFiles :: Annex [OsPath] journalledFiles = getJournalledFilesStale gitAnnexJournalDir -journalledFilesPrivate :: Annex [RawFilePath] +journalledFilesPrivate :: Annex [OsPath] journalledFilesPrivate = ifM privateUUIDsKnown ( getJournalledFilesStale gitAnnexPrivateJournalDir , return [] @@ -640,11 +639,11 @@ journalledFilesPrivate = ifM privateUUIDsKnown {- Files in the branch, not including any from journalled changes, - and without updating the branch. -} -branchFiles :: Annex ([RawFilePath], IO Bool) +branchFiles :: Annex ([OsPath], IO Bool) branchFiles = withIndex $ inRepo branchFiles' -branchFiles' :: Git.Repo -> IO ([RawFilePath], IO Bool) -branchFiles' = Git.Command.pipeNullSplit' $ +branchFiles' :: Git.Repo -> IO ([OsPath], IO Bool) +branchFiles' = Git.Command.pipeNullSplit'' toOsPath $ lsTreeParams Git.LsTree.LsTreeRecursive (Git.LsTree.LsTreeLong False) fullname [Param "--name-only"] @@ -681,7 +680,8 @@ mergeIndex jl branches = do prepareModifyIndex :: JournalLocked -> Annex () prepareModifyIndex _jl = do index <- fromRepo gitAnnexIndex - void $ liftIO $ tryIO $ R.removeLink (index <> ".lock") + void $ liftIO $ tryIO $ + removeFile (index <> literalOsPath ".lock") {- Runs an action using the branch's index file. -} withIndex :: Annex a -> Annex a @@ -690,7 +690,7 @@ withIndex' :: Bool -> Annex a -> Annex a withIndex' bootstrapping a = withIndexFile AnnexIndexFile $ \f -> do checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do unless bootstrapping create - createAnnexDirectory $ toRawFilePath $ takeDirectory f + createAnnexDirectory $ takeDirectory f unless bootstrapping $ inRepo genIndex a @@ -712,7 +712,7 @@ forceUpdateIndex jl branchref = do {- Checks if the index needs to be updated. -} needUpdateIndex :: Git.Ref -> Annex Bool needUpdateIndex branchref = do - f <- toOsPath <$> fromRepo gitAnnexIndexStatus + f <- fromRepo gitAnnexIndexStatus committedref <- Git.Ref . firstLine' <$> liftIO (catchDefaultIO mempty $ F.readFile' f) return (committedref /= branchref) @@ -748,19 +748,20 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do Git.UpdateIndex.streamUpdateIndex g [genstream dir h jh jlogh] commitindex - liftIO $ cleanup (fromRawFilePath dir) jlogh jlogf + liftIO $ cleanup dir jlogh jlogf where genstream dir h jh jlogh streamer = readDirectory jh >>= \case Nothing -> return () Just file -> do - let path = dir P. file - unless (dirCruft file) $ whenM (isfile path) $ do + let file' = toOsPath file + let path = dir file' + unless (file' `elem` dirCruft) $ whenM (isfile path) $ do sha <- Git.HashObject.hashFile h path B.hPutStr jlogh (file <> "\n") streamer $ Git.UpdateIndex.updateIndexLine - sha TreeFile (asTopFilePath $ fileJournal file) + sha TreeFile (asTopFilePath $ fileJournal file') genstream dir h jh jlogh streamer - isfile file = isRegularFile <$> R.getFileStatus file + isfile file = isRegularFile <$> R.getFileStatus (fromOsPath file) -- Clean up the staged files, as listed in the temp log file. -- The temp file is used to avoid needing to buffer all the -- filenames in memory. @@ -768,10 +769,10 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do hFlush jlogh hSeek jlogh AbsoluteSeek 0 stagedfs <- lines <$> hGetContents jlogh - mapM_ (removeFile . (dir )) stagedfs + mapM_ (removeFile . (dir ) . toOsPath) stagedfs hClose jlogh - removeWhenExistsWith (R.removeLink) (fromOsPath jlogf) - openjlog tmpdir = liftIO $ openTmpFileIn (toOsPath tmpdir) (toOsPath "jlog") + removeWhenExistsWith removeFile jlogf + openjlog tmpdir = liftIO $ openTmpFileIn tmpdir (literalOsPath "jlog") getLocalTransitions :: Annex Transitions getLocalTransitions = @@ -932,7 +933,7 @@ getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . fileLines' <$> content where content = do - f <- toOsPath <$> fromRepo gitAnnexIgnoredRefs + f <- fromRepo gitAnnexIgnoredRefs liftIO $ catchDefaultIO mempty $ F.readFile' f addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex () @@ -950,7 +951,7 @@ getMergedRefs = S.fromList . map fst <$> getMergedRefs' getMergedRefs' :: Annex [(Git.Sha, Git.Branch)] getMergedRefs' = do - f <- toOsPath <$> fromRepo gitAnnexMergedRefs + f <- fromRepo gitAnnexMergedRefs s <- liftIO $ catchDefaultIO mempty $ F.readFile' f return $ map parse $ fileLines' s where @@ -999,7 +1000,7 @@ data UnmergedBranches t = UnmergedBranches t | NoUnmergedBranches t -type FileContents t b = Maybe (t, RawFilePath, Maybe (L.ByteString, Maybe b)) +type FileContents t b = Maybe (t, OsPath, Maybe (L.ByteString, Maybe b)) {- Runs an action on the content of selected files from the branch. - This is much faster than reading the content of each file in turn, @@ -1022,7 +1023,7 @@ overBranchFileContents -- the callback can be run more than once on the same filename, -- and in this case it's also possible for the callback to be -- passed some of the same file content repeatedly. - -> (RawFilePath -> Maybe v) + -> (OsPath -> Maybe v) -> (Annex (FileContents v Bool) -> Annex a) -> Annex (UnmergedBranches (a, Git.Sha)) overBranchFileContents ignorejournal select go = do @@ -1036,7 +1037,7 @@ overBranchFileContents ignorejournal select go = do else NoUnmergedBranches v overBranchFileContents' - :: (RawFilePath -> Maybe v) + :: (OsPath -> Maybe v) -> (Annex (FileContents v Bool) -> Annex a) -> BranchState -> Annex (a, Git.Sha) @@ -1086,11 +1087,11 @@ combineStaleJournalWithBranch branchcontent journalledcontent = - files. -} overJournalFileContents - :: (RawFilePath -> L.ByteString -> Annex (L.ByteString, Maybe b)) + :: (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b)) -- ^ Called with the journalled file content when the journalled -- content may be stale or lack information committed to the -- git-annex branch. - -> (RawFilePath -> Maybe v) + -> (OsPath -> Maybe v) -> (Annex (FileContents v b) -> Annex a) -> Annex a overJournalFileContents handlestale select go = do @@ -1098,9 +1099,9 @@ overJournalFileContents handlestale select go = do go $ overJournalFileContents' buf handlestale select overJournalFileContents' - :: MVar ([RawFilePath], [RawFilePath]) - -> (RawFilePath -> L.ByteString -> Annex (L.ByteString, Maybe b)) - -> (RawFilePath -> Maybe a) + :: MVar ([OsPath], [OsPath]) + -> (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b)) + -> (OsPath -> Maybe a) -> Annex (FileContents a b) overJournalFileContents' buf handlestale select = liftIO (tryTakeMVar buf) >>= \case diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs index 0f0e553259..bd8016968f 100644 --- a/Annex/BranchState.hs +++ b/Annex/BranchState.hs @@ -118,7 +118,7 @@ enableInteractiveBranchAccess = changeState $ \s -> s , journalIgnorable = False } -setCache :: RawFilePath -> L.ByteString -> Annex () +setCache :: OsPath -> L.ByteString -> Annex () setCache file content = changeState $ \s -> s { cachedFileContents = add (cachedFileContents s) } where @@ -126,7 +126,7 @@ setCache file content = changeState $ \s -> s | length l < logFilesToCache = (file, content) : l | otherwise = (file, content) : Prelude.init l -getCache :: RawFilePath -> BranchState -> Maybe L.ByteString +getCache :: OsPath -> BranchState -> Maybe L.ByteString getCache file state = go (cachedFileContents state) where go [] = Nothing @@ -134,7 +134,7 @@ getCache file state = go (cachedFileContents state) | f == file && not (needInteractiveAccess state) = Just c | otherwise = go rest -invalidateCache :: RawFilePath -> Annex () +invalidateCache :: OsPath -> Annex () invalidateCache f = changeState $ \s -> s { cachedFileContents = filter (\(f', _) -> f' /= f) (cachedFileContents s) diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs index 35162b91a1..4392ba3d11 100644 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -45,11 +45,11 @@ import Types.AdjustedBranch import Types.CatFileHandles import Utility.ResourcePool -catFile :: Git.Branch -> RawFilePath -> Annex L.ByteString +catFile :: Git.Branch -> OsPath -> Annex L.ByteString catFile branch file = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catFile h branch file -catFileDetails :: Git.Branch -> RawFilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: Git.Branch -> OsPath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails branch file = withCatFileHandle $ \h -> liftIO $ Git.CatFile.catFileDetails h branch file @@ -167,8 +167,8 @@ catKey' ref sz catKey' _ _ = return Nothing {- Gets a symlink target. -} -catSymLinkTarget :: Sha -> Annex RawFilePath -catSymLinkTarget sha = fromInternalGitPath . L.toStrict <$> get +catSymLinkTarget :: Sha -> Annex OsPath +catSymLinkTarget sha = fromInternalGitPath . toOsPath . L.toStrict <$> get where -- Avoid buffering the whole file content, which might be large. -- 8192 is enough if it really is a symlink. @@ -195,25 +195,25 @@ catSymLinkTarget sha = fromInternalGitPath . L.toStrict <$> get - - So, this gets info from the index, unless running as a daemon. -} -catKeyFile :: RawFilePath -> Annex (Maybe Key) +catKeyFile :: OsPath -> Annex (Maybe Key) catKeyFile f = ifM (Annex.getState Annex.daemon) ( catKeyFileHEAD f , maybe (pure Nothing) catKey =<< inRepo (Git.Ref.fileRef f) ) -catKeyFileHEAD :: RawFilePath -> Annex (Maybe Key) +catKeyFileHEAD :: OsPath -> Annex (Maybe Key) catKeyFileHEAD f = maybe (pure Nothing) catKey =<< inRepo (Git.Ref.fileFromRef Git.Ref.headRef f) {- Look in the original branch from whence an adjusted branch is based - to find the file. But only when the adjustment hides some files. -} -catKeyFileHidden :: RawFilePath -> CurrBranch -> Annex (Maybe Key) +catKeyFileHidden :: OsPath -> CurrBranch -> Annex (Maybe Key) catKeyFileHidden = hiddenCat catKey -catObjectMetaDataHidden :: RawFilePath -> CurrBranch -> Annex (Maybe (Sha, Integer, ObjectType)) +catObjectMetaDataHidden :: OsPath -> CurrBranch -> Annex (Maybe (Sha, Integer, ObjectType)) catObjectMetaDataHidden = hiddenCat catObjectMetaData -hiddenCat :: (Ref -> Annex (Maybe a)) -> RawFilePath -> CurrBranch -> Annex (Maybe a) +hiddenCat :: (Ref -> Annex (Maybe a)) -> OsPath -> CurrBranch -> Annex (Maybe a) hiddenCat a f (Just origbranch, Just adj) | adjustmentHidesFiles adj = maybe (pure Nothing) a diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs index 073686fb01..377be3bf73 100644 --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -24,11 +24,11 @@ import qualified Git import Git.Sha import qualified Utility.SimpleProtocol as Proto import qualified Utility.FileIO as F +import qualified Utility.OsString as OS import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.STM.TBMChan -import qualified System.FilePath.ByteString as P newtype ChangedRefs = ChangedRefs [Git.Ref] deriving (Show) @@ -82,7 +82,7 @@ watchChangedRefs = do g <- gitRepo let gittop = Git.localGitDir g - let refdir = gittop P. "refs" + let refdir = gittop literalOsPath "refs" liftIO $ createDirectoryUnder [gittop] refdir let notifyhook = Just $ notifyHook chan @@ -93,18 +93,17 @@ watchChangedRefs = do if canWatch then do - h <- liftIO $ watchDir - (fromRawFilePath refdir) + h <- liftIO $ watchDir refdir (const False) True hooks id return $ Just $ ChangedRefsHandle h chan else return Nothing -notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO () +notifyHook :: TBMChan Git.Sha -> OsPath -> Maybe FileStatus -> IO () notifyHook chan reffile _ - | ".lock" `isSuffixOf` reffile = noop + | literalOsPath ".lock" `OS.isSuffixOf` reffile = noop | otherwise = void $ do sha <- catchDefaultIO Nothing $ - extractSha <$> F.readFile' (toOsPath (toRawFilePath reffile)) + extractSha <$> F.readFile' reffile -- When the channel is full, there is probably no reader -- running, or ref changes have been occurring very fast, -- so it's ok to not write the change to it. diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs index 6ad8fafce6..8561493cdd 100644 --- a/Annex/CheckAttr.hs +++ b/Annex/CheckAttr.hs @@ -29,14 +29,14 @@ annexAttrs = , "annex.mincopies" ] -checkAttr :: Git.Attr -> RawFilePath -> Annex String +checkAttr :: Git.Attr -> OsPath -> Annex String checkAttr attr file = withCheckAttrHandle $ \h -> do r <- liftIO $ Git.checkAttr h attr file if r == Git.unspecifiedAttr then return "" else return r -checkAttrs :: [Git.Attr] -> RawFilePath -> Annex [String] +checkAttrs :: [Git.Attr] -> OsPath -> Annex [String] checkAttrs attrs file = withCheckAttrHandle $ \h -> liftIO $ Git.checkAttrs h attrs file diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs index d3c03f210a..c280a31494 100644 --- a/Annex/CheckIgnore.hs +++ b/Annex/CheckIgnore.hs @@ -22,7 +22,7 @@ import Annex.Concurrent.Utility newtype CheckGitIgnore = CheckGitIgnore Bool -checkIgnored :: CheckGitIgnore -> RawFilePath -> Annex Bool +checkIgnored :: CheckGitIgnore -> OsPath -> Annex Bool checkIgnored (CheckGitIgnore False) _ = pure False checkIgnored (CheckGitIgnore True) file = ifM (Annex.getRead Annex.force) diff --git a/Annex/Content.hs b/Annex/Content.hs index 3f26c0f0a8..dc6b2edcc7 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -110,7 +110,6 @@ import Utility.FileMode import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (isSymbolicLink, linkCount) import Data.Time.Clock.POSIX @@ -248,7 +247,7 @@ lockContentForRemoval key fallback a = lockContentUsing lock key fallback $ {- Passed the object content file, and maybe a separate lock file to use, - when the content file itself should not be locked. -} type ContentLocker - = RawFilePath + = OsPath -> Maybe LockFile -> ( Annex (Maybe LockHandle) @@ -260,7 +259,7 @@ type ContentLocker -- and prior to deleting the lock file, in order to -- ensure that no other processes also have a shared lock. #else - , Maybe (RawFilePath -> Annex ()) + , Maybe (OsPath -> Annex ()) -- ^ On Windows, this is called after the lock is dropped, -- but before the lock file is cleaned up. #endif @@ -278,7 +277,7 @@ winLocker takelock _ (Just lockfile) = let lck = do modifyContentDir lockfile $ void $ liftIO $ tryIO $ - writeFile (fromRawFilePath lockfile) "" + writeFile (fromOsPath lockfile) "" liftIO $ takelock lockfile in (lck, Nothing) -- never reached; windows always uses a separate lock file @@ -371,13 +370,13 @@ lockContentUsing contentlocker key fallback a = withContentLockFile key $ \mlock cleanuplockfile lockfile = void $ tryNonAsync $ do thawContentDir lockfile - liftIO $ removeWhenExistsWith R.removeLink lockfile + liftIO $ removeWhenExistsWith removeFile lockfile cleanObjectDirs 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 -> AssociatedFile -> Maybe FileSize -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> Maybe FileSize -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool getViaTmp rsp v key af sz action = checkDiskSpaceToGet key sz False $ getViaTmpFromDisk rsp v key af action @@ -385,10 +384,10 @@ getViaTmp rsp v key af sz 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 -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool getViaTmpFromDisk rsp v key af action = checkallowed $ do tmpfile <- prepTmp key - resuming <- liftIO $ R.doesPathExist tmpfile + resuming <- liftIO $ R.doesPathExist $ fromOsPath 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 @@ -434,11 +433,11 @@ getViaTmpFromDisk rsp v key af action = checkallowed $ do - left off, and so if the bad content were not deleted, repeated downloads - would continue to fail. -} -verificationOfContentFailed :: RawFilePath -> Annex () +verificationOfContentFailed :: OsPath -> Annex () verificationOfContentFailed tmpfile = do warning "Verification of content failed" pruneTmpWorkDirBefore tmpfile - (liftIO . removeWhenExistsWith R.removeLink) + (liftIO . removeWhenExistsWith removeFile) {- Checks if there is enough free disk space to download a key - to its temp file. @@ -451,7 +450,7 @@ verificationOfContentFailed tmpfile = do checkDiskSpaceToGet :: Key -> Maybe FileSize -> a -> Annex a -> Annex a checkDiskSpaceToGet key sz unabletoget getkey = do tmp <- fromRepo (gitAnnexTmpObjectLocation key) - e <- liftIO $ doesFileExist (fromRawFilePath tmp) + e <- liftIO $ doesFileExist tmp alreadythere <- liftIO $ if e then getFileSize tmp else return 0 @@ -463,7 +462,7 @@ checkDiskSpaceToGet key sz unabletoget getkey = do , return unabletoget ) -prepTmp :: Key -> Annex RawFilePath +prepTmp :: Key -> Annex OsPath prepTmp key = do tmp <- fromRepo $ gitAnnexTmpObjectLocation key createAnnexDirectory (parentDir tmp) @@ -473,11 +472,11 @@ prepTmp key = do - the temp file. If the action throws an exception, the temp file is - left behind, which allows for resuming. -} -withTmp :: Key -> (RawFilePath -> Annex a) -> Annex a +withTmp :: Key -> (OsPath -> Annex a) -> Annex a withTmp key action = do tmp <- prepTmp key res <- action tmp - pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) + pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeFile) return res {- Moves a key's content into .git/annex/objects/ @@ -508,7 +507,7 @@ withTmp key action = do - accepted into the repository. Will display a warning message in this - case. May also throw exceptions in some cases. -} -moveAnnex :: Key -> AssociatedFile -> RawFilePath -> Annex Bool +moveAnnex :: Key -> AssociatedFile -> OsPath -> Annex Bool moveAnnex key af src = ifM (checkSecureHashes' key) ( do #ifdef mingw32_HOST_OS @@ -522,7 +521,7 @@ moveAnnex key af src = ifM (checkSecureHashes' key) , return False ) where - storeobject dest = ifM (liftIO $ R.doesPathExist dest) + storeobject dest = ifM (liftIO $ R.doesPathExist $ fromOsPath dest) ( alreadyhave , adjustedBranchRefresh af $ modifyContentDir dest $ do liftIO $ moveFile src dest @@ -540,7 +539,7 @@ moveAnnex key af src = ifM (checkSecureHashes' key) Database.Keys.addInodeCaches key (catMaybes (destic:ics)) ) - alreadyhave = liftIO $ R.removeLink src + alreadyhave = liftIO $ removeFile src checkSecureHashes :: Key -> Annex (Maybe String) checkSecureHashes key = ifM (Backend.isCryptographicallySecureKey key) @@ -563,7 +562,7 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop {- Populates the annex object file by hard linking or copying a source - file to it. -} -linkToAnnex :: Key -> RawFilePath -> Maybe InodeCache -> Annex LinkAnnexResult +linkToAnnex :: Key -> OsPath -> Maybe InodeCache -> Annex LinkAnnexResult linkToAnnex key src srcic = ifM (checkSecureHashes' key) ( do dest <- calcRepo (gitAnnexLocation key) @@ -580,13 +579,13 @@ linkToAnnex key src srcic = ifM (checkSecureHashes' key) - afterwards. Note that a consequence of this is that, if the file - already exists, it will be overwritten. -} -linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult +linkFromAnnex :: Key -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult linkFromAnnex key dest destmode = replaceFile' (const noop) dest (== LinkAnnexOk) $ \tmp -> linkFromAnnex' key tmp destmode {- This is only safe to use when dest is not a worktree file. -} -linkFromAnnex' :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult +linkFromAnnex' :: Key -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult linkFromAnnex' key dest destmode = do src <- calcRepo (gitAnnexLocation key) srcic <- withTSDelta (liftIO . genInodeCache src) @@ -606,7 +605,7 @@ data FromTo = From | To - - Nothing is done if the destination file already exists. -} -linkAnnex :: FromTo -> Key -> RawFilePath -> Maybe InodeCache -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult +linkAnnex :: FromTo -> Key -> OsPath -> Maybe InodeCache -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed linkAnnex fromto key src (Just srcic) dest destmode = withTSDelta (liftIO . genInodeCache dest) >>= \case @@ -636,7 +635,7 @@ linkAnnex fromto key src (Just srcic) dest destmode = catMaybes [destic, Just srcic] return LinkAnnexOk _ -> do - liftIO $ removeWhenExistsWith R.removeLink dest + liftIO $ removeWhenExistsWith removeFile dest failed {- Removes the annex object file for a key. Lowlevel. -} @@ -645,7 +644,7 @@ unlinkAnnex key = do obj <- calcRepo (gitAnnexLocation key) modifyContentDir obj $ do secureErase obj - liftIO $ removeWhenExistsWith R.removeLink obj + liftIO $ removeWhenExistsWith removeFile obj {- Runs an action to transfer an object's content. The action is also - passed the size of the object. @@ -654,7 +653,7 @@ unlinkAnnex key = do - If this happens, runs the rollback action and throws an exception. - The rollback action should remove the data that was transferred. -} -sendAnnex :: Key -> Maybe FilePath -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a +sendAnnex :: Key -> Maybe OsPath -> Annex () -> (OsPath -> FileSize -> Annex a) -> Annex a sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o where go (Just (f, sz, check)) = do @@ -677,10 +676,10 @@ sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o - Annex monad of the remote that is receiving the object, rather than - the sender. So it cannot rely on Annex state. -} -prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool)) +prepSendAnnex :: Key -> Maybe OsPath -> Annex (Maybe (OsPath, FileSize, Annex Bool)) prepSendAnnex key Nothing = withObjectLoc key $ \f -> do let retval c cs = return $ Just - ( fromRawFilePath f + ( f , inodeCacheFileSize c , sameInodeCache f cs ) @@ -705,19 +704,18 @@ prepSendAnnex key Nothing = withObjectLoc key $ \f -> do Nothing -> return Nothing -- If the provided object file is the annex object file, handle as above. prepSendAnnex key (Just o) = withObjectLoc key $ \aof -> - let o' = toRawFilePath o - in if aof == o' + if aof == o then prepSendAnnex key Nothing else do - withTSDelta (liftIO . genInodeCache o') >>= \case + withTSDelta (liftIO . genInodeCache o) >>= \case Nothing -> return Nothing Just c -> return $ Just ( o , inodeCacheFileSize c - , sameInodeCache o' [c] + , sameInodeCache o [c] ) -prepSendAnnex' :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String))) +prepSendAnnex' :: Key -> Maybe OsPath -> Annex (Maybe (OsPath, FileSize, Annex (Maybe String))) prepSendAnnex' key o = prepSendAnnex key o >>= \case Just (f, sz, checksuccess) -> let checksuccess' = ifM checksuccess @@ -751,7 +749,7 @@ cleanObjectLoc key cleaner = do - - Does nothing if the object directory is not empty, and does not - throw an exception if it's unable to remove a directory. -} -cleanObjectDirs :: RawFilePath -> Annex () +cleanObjectDirs :: OsPath -> Annex () cleanObjectDirs f = do HashLevels n <- objectHashLevels <$> Annex.getGitConfig liftIO $ go f (succ n) @@ -761,14 +759,14 @@ cleanObjectDirs f = do let dir = parentDir file maybe noop (const $ go dir (n-1)) <=< catchMaybeIO $ tryWhenExists $ - removeDirectory (fromRawFilePath dir) + removeDirectory dir {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: ContentRemovalLock -> Annex () removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> cleanObjectLoc key $ do secureErase file - liftIO $ removeWhenExistsWith R.removeLink file + liftIO $ removeWhenExistsWith removeFile file g <- Annex.gitRepo mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) =<< Database.Keys.getAssociatedFiles key @@ -776,7 +774,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> where -- Check associated pointer file for modifications, and reset if -- it's unmodified. - resetpointer file = unlessM (liftIO $ isSymbolicLink <$> R.getSymbolicLinkStatus file) $ + resetpointer file = unlessM (liftIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath file)) $ ifM (isUnmodified key file) ( adjustedBranchRefresh (AssociatedFile (Just file)) $ depopulatePointerFile key file @@ -789,11 +787,11 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -} -moveBad :: Key -> Annex RawFilePath +moveBad :: Key -> Annex OsPath moveBad key = do src <- calcRepo (gitAnnexLocation key) bad <- fromRepo gitAnnexBadDir - let dest = bad P. P.takeFileName src + let dest = bad takeFileName src createAnnexDirectory (parentDir dest) cleanObjectLoc key $ liftIO $ moveFile src dest @@ -826,7 +824,7 @@ listKeys' keyloc want = do then do contents' <- filterM present contents keys <- filterM (Annex.eval s . want) $ - mapMaybe (fileKey . P.takeFileName) contents' + mapMaybe (fileKey . takeFileName) contents' continue keys [] else do let deeper = walk s (depth - 1) @@ -844,8 +842,8 @@ listKeys' keyloc want = do present _ | inanywhere = pure True present d = presentInAnnex d - presentInAnnex = R.doesPathExist . contentfile - contentfile d = d P. P.takeFileName d + presentInAnnex = R.doesPathExist . fromOsPath . contentfile + contentfile d = d takeFileName d {- Things to do to record changes to content when shutting down. - @@ -868,11 +866,11 @@ saveState nocommit = doSideAction $ do - Otherwise, only displays one error message, from one of the urls - that failed. -} -downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool +downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex Bool downloadUrl listfailedurls k p iv urls file uo = -- Poll the file to handle configurations where an external -- download command is used. - meteredFile (toRawFilePath file) (Just p) k (go urls []) + meteredFile file (Just p) k (go urls []) where go (u:us) errs p' = Url.download' p' iv u file uo >>= \case Right () -> return True @@ -898,18 +896,18 @@ downloadUrl listfailedurls k p iv urls file uo = {- Copies a key's content, when present, to a temp file. - This is used to speed up some rsyncs. -} -preseedTmp :: Key -> FilePath -> Annex Bool +preseedTmp :: Key -> OsPath -> Annex Bool preseedTmp key file = go =<< inAnnex key where go False = return False go True = do ok <- copy - when ok $ thawContent (toRawFilePath file) + when ok $ thawContent file return ok copy = ifM (liftIO $ doesFileExist file) ( return True , do - s <- fromRawFilePath <$> (calcRepo $ gitAnnexLocation key) + s <- calcRepo $ gitAnnexLocation key liftIO $ ifM (doesFileExist s) ( copyFileExternal CopyTimeStamps s file , return False @@ -918,15 +916,15 @@ preseedTmp key file = go =<< inAnnex key {- Finds files directly inside a directory like gitAnnexBadDir - (not in subdirectories) and returns the corresponding keys. -} -dirKeys :: (Git.Repo -> RawFilePath) -> Annex [Key] +dirKeys :: (Git.Repo -> OsPath) -> Annex [Key] dirKeys dirspec = do - dir <- fromRawFilePath <$> fromRepo dirspec + dir <- fromRepo dirspec ifM (liftIO $ doesDirectoryExist dir) ( do contents <- liftIO $ getDirectoryContents dir files <- liftIO $ filterM doesFileExist $ map (dir ) contents - return $ mapMaybe (fileKey . P.takeFileName . toRawFilePath) files + return $ mapMaybe (fileKey . takeFileName) files , return [] ) @@ -936,7 +934,7 @@ dirKeys dirspec = do - Also, stale keys that can be proven to have no value - (ie, their content is already present) are deleted. -} -staleKeysPrune :: (Git.Repo -> RawFilePath) -> Bool -> Annex [Key] +staleKeysPrune :: (Git.Repo -> OsPath) -> Bool -> Annex [Key] staleKeysPrune dirspec nottransferred = do contents <- dirKeys dirspec @@ -945,8 +943,8 @@ staleKeysPrune dirspec nottransferred = do dir <- fromRepo dirspec forM_ dups $ \k -> - pruneTmpWorkDirBefore (dir P. keyFile k) - (liftIO . R.removeLink) + pruneTmpWorkDirBefore (dir keyFile k) + (liftIO . removeFile) if nottransferred then do @@ -961,9 +959,9 @@ staleKeysPrune dirspec nottransferred = do - This preserves the invariant that the workdir never exists without - the content file. -} -pruneTmpWorkDirBefore :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a +pruneTmpWorkDirBefore :: OsPath -> (OsPath -> Annex a) -> Annex a pruneTmpWorkDirBefore f action = do - let workdir = fromRawFilePath $ gitAnnexTmpWorkDir f + let workdir = gitAnnexTmpWorkDir f liftIO $ whenM (doesDirectoryExist workdir) $ removeDirectoryRecursive workdir action f @@ -978,22 +976,21 @@ pruneTmpWorkDirBefore f action = do - the temporary work directory is retained (unless - empty), so anything in it can be used on resume. -} -withTmpWorkDir :: Key -> (RawFilePath -> Annex (Maybe a)) -> Annex (Maybe a) +withTmpWorkDir :: Key -> (OsPath -> 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 - let obj' = fromRawFilePath obj - unlessM (liftIO $ doesFileExist obj') $ do - liftIO $ writeFile obj' "" + unlessM (liftIO $ doesFileExist obj) $ do + liftIO $ writeFile (fromOsPath obj) "" setAnnexFilePerm obj let tmpdir = gitAnnexTmpWorkDir obj createAnnexDirectory tmpdir res <- action tmpdir case res of - Just _ -> liftIO $ removeDirectoryRecursive (fromRawFilePath tmpdir) - Nothing -> liftIO $ void $ tryIO $ removeDirectory (fromRawFilePath tmpdir) + Just _ -> liftIO $ removeDirectoryRecursive tmpdir + Nothing -> liftIO $ void $ tryIO $ removeDirectory tmpdir return res {- Finds items in the first, smaller list, that are not @@ -1028,12 +1025,12 @@ getKeyStatus :: Key -> Annex KeyStatus getKeyStatus key = catchDefaultIO KeyMissing $ do afs <- not . null <$> Database.Keys.getAssociatedFiles key obj <- calcRepo (gitAnnexLocation key) - multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus obj)) + multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus (fromOsPath obj))) return $ if multilink && afs then KeyUnlockedThin else KeyPresent -getKeyFileStatus :: Key -> RawFilePath -> Annex KeyStatus +getKeyFileStatus :: Key -> OsPath -> Annex KeyStatus getKeyFileStatus key file = do s <- getKeyStatus key case s of @@ -1071,23 +1068,22 @@ contentSize key = catchDefaultIO Nothing $ - timestamp. The file is written atomically, so when it contained an - earlier timestamp, a reader will always see one or the other timestamp. -} -writeContentRetentionTimestamp :: Key -> RawFilePath -> POSIXTime -> Annex () +writeContentRetentionTimestamp :: Key -> OsPath -> POSIXTime -> Annex () writeContentRetentionTimestamp key rt t = do lckfile <- calcRepo (gitAnnexContentRetentionTimestampLock key) modifyContentDirWhenExists lckfile $ bracket (lock lckfile) unlock $ \_ -> readContentRetentionTimestamp rt >>= \case Just ts | ts >= t -> return () _ -> replaceFile (const noop) rt $ \tmp -> - liftIO $ writeFile (fromRawFilePath tmp) $ show t + liftIO $ writeFile (fromOsPath tmp) $ show t where lock = takeExclusiveLock unlock = liftIO . dropLock {- Does not need locking because the file is written atomically. -} -readContentRetentionTimestamp :: RawFilePath -> Annex (Maybe POSIXTime) +readContentRetentionTimestamp :: OsPath -> Annex (Maybe POSIXTime) readContentRetentionTimestamp rt = - liftIO $ join <$> tryWhenExists - (parsePOSIXTime <$> F.readFile' (toOsPath rt)) + liftIO $ join <$> tryWhenExists (parsePOSIXTime <$> F.readFile' rt) {- Checks if the retention timestamp is in the future, if so returns - Nothing. @@ -1118,8 +1114,8 @@ checkRetentionTimestamp key locker = do {- Remove the retention timestamp and its lock file. Another lock must - be held, that prevents anything else writing to the file at the same - time. -} -removeRetentionTimeStamp :: Key -> RawFilePath -> Annex () +removeRetentionTimeStamp :: Key -> OsPath -> Annex () removeRetentionTimeStamp key rt = modifyContentDirWhenExists rt $ do - liftIO $ removeWhenExistsWith R.removeLink rt + liftIO $ removeWhenExistsWith removeFile rt rtl <- calcRepo (gitAnnexContentRetentionTimestampLock key) - liftIO $ removeWhenExistsWith R.removeLink rtl + liftIO $ removeWhenExistsWith removeFile rtl diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs index 69baf19957..49fc442a80 100644 --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -19,13 +19,12 @@ import Utility.DataUnits import Utility.CopyFile import qualified Utility.RawFilePath as R -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (linkCount) {- 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 :: RawFilePath -> Annex () +secureErase :: OsPath -> Annex () secureErase = void . runAnnexPathHook "%file" secureEraseAnnexHook annexSecureEraseCommand @@ -44,45 +43,48 @@ data LinkedOrCopied = Linked | Copied - execute bit will be set. The mode is not fully copied over because - git doesn't support file modes beyond execute. -} -linkOrCopy :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) +linkOrCopy :: Key -> OsPath -> OsPath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig) -linkOrCopy' :: Annex Bool -> Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) +linkOrCopy' :: Annex Bool -> Key -> OsPath -> OsPath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) linkOrCopy' canhardlink key src dest destmode = catchDefaultIO Nothing $ ifM canhardlink - ( hardlink + ( hardlinkorcopy , copy =<< getstat ) where - hardlink = do + hardlinkorcopy = do s <- getstat if linkCount s > 1 then copy s - else liftIO (R.createLink src dest >> preserveGitMode dest destmode >> return (Just Linked)) - `catchIO` const (copy s) + else hardlink `catchIO` const (copy s) + hardlink = liftIO $ do + R.createLink (fromOsPath src) (fromOsPath dest) + void $ preserveGitMode dest destmode + return (Just Linked) copy s = ifM (checkedCopyFile' key src dest destmode s) ( return (Just Copied) , return Nothing ) - getstat = liftIO $ R.getFileStatus src + getstat = liftIO $ R.getFileStatus (fromOsPath src) {- Checks disk space before copying. -} -checkedCopyFile :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex Bool +checkedCopyFile :: Key -> OsPath -> OsPath -> Maybe FileMode -> Annex Bool checkedCopyFile key src dest destmode = catchBoolIO $ checkedCopyFile' key src dest destmode - =<< liftIO (R.getFileStatus src) + =<< liftIO (R.getFileStatus (fromOsPath src)) -checkedCopyFile' :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> FileStatus -> Annex Bool +checkedCopyFile' :: Key -> OsPath -> OsPath -> Maybe FileMode -> FileStatus -> Annex Bool checkedCopyFile' key src dest destmode s = catchBoolIO $ do sz <- liftIO $ getFileSize' src s - ifM (checkDiskSpace' sz (Just $ P.takeDirectory dest) key 0 True) + ifM (checkDiskSpace' sz (Just $ takeDirectory dest) key 0 True) ( liftIO $ - copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest) + copyFileExternal CopyAllMetaData src dest <&&> preserveGitMode dest destmode , return False ) -preserveGitMode :: RawFilePath -> Maybe FileMode -> IO Bool +preserveGitMode :: OsPath -> Maybe FileMode -> IO Bool preserveGitMode f (Just mode) | isExecutable mode = catchBoolIO $ do modifyFileMode f $ addModes executeModes @@ -100,12 +102,12 @@ preserveGitMode _ _ = return True - to be downloaded from the free space. This way, we avoid overcommitting - when doing concurrent downloads. -} -checkDiskSpace :: Maybe FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace :: Maybe FileSize -> Maybe OsPath -> Key -> Integer -> Bool -> Annex Bool checkDiskSpace msz destdir key = checkDiskSpace' sz destdir key where sz = fromMaybe 1 (fromKey keySize key <|> msz) -checkDiskSpace' :: FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace' :: FileSize -> Maybe OsPath -> Key -> Integer -> Bool -> Annex Bool checkDiskSpace' sz destdir key alreadythere samefilesystem = ifM (Annex.getRead Annex.force) ( return True , do @@ -118,7 +120,7 @@ checkDiskSpace' sz destdir key alreadythere samefilesystem = ifM (Annex.getRead inprogress <- if samefilesystem then sizeOfDownloadsInProgress (/= key) else pure 0 - dir >>= liftIO . getDiskFree . fromRawFilePath >>= \case + dir >>= liftIO . getDiskFree . fromOsPath >>= \case Just have -> do reserve <- annexDiskReserve <$> Annex.getGitConfig let delta = sz + reserve - have - alreadythere + inprogress diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs index 5dc4d0210b..c37614be94 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -30,12 +30,14 @@ import System.PosixCompat.Files (fileMode) - - Returns an InodeCache if it populated the pointer file. -} -populatePointerFile :: Restage -> Key -> RawFilePath -> RawFilePath -> Annex (Maybe InodeCache) +populatePointerFile :: Restage -> Key -> OsPath -> OsPath -> Annex (Maybe InodeCache) populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) where go (Just k') | k == k' = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f - liftIO $ removeWhenExistsWith R.removeLink f + let f' = fromOsPath f + destmode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus f' + liftIO $ removeWhenExistsWith R.removeLink f' (ic, populated) <- replaceWorkTreeFile f $ \tmp -> do ok <- linkOrCopy k obj tmp destmode >>= \case Just _ -> thawContent tmp >> return True @@ -47,23 +49,24 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) then return ic else return Nothing go _ = return Nothing - + {- Removes the content from a pointer file, replacing it with a pointer. - - Does not check if the pointer file is modified. -} -depopulatePointerFile :: Key -> RawFilePath -> Annex () +depopulatePointerFile :: Key -> OsPath -> Annex () depopulatePointerFile key file = do - st <- liftIO $ catchMaybeIO $ R.getFileStatus file + let file' = fromOsPath file + st <- liftIO $ catchMaybeIO $ R.getFileStatus file' let mode = fmap fileMode st secureErase file - liftIO $ removeWhenExistsWith R.removeLink file + liftIO $ removeWhenExistsWith R.removeLink file' ic <- replaceWorkTreeFile file $ \tmp -> do liftIO $ writePointerFile tmp key mode #if ! defined(mingw32_HOST_OS) -- Don't advance mtime; this avoids unnecessary re-smudging -- by git in some cases. liftIO $ maybe noop - (\t -> touch tmp t False) + (\t -> touch (fromOsPath tmp) t False) (fmap Posix.modificationTimeHiRes st) #endif withTSDelta (liftIO . genInodeCache tmp) diff --git a/Annex/Content/Presence.hs b/Annex/Content/Presence.hs index 2eb0016ddd..9dfc68a202 100644 --- a/Annex/Content/Presence.hs +++ b/Annex/Content/Presence.hs @@ -41,18 +41,16 @@ import Config import Annex.Perms #endif -import qualified System.FilePath.ByteString as P - {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool -inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist +inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist . fromOsPath {- Runs an arbitrary check on a key's content. -} -inAnnexCheck :: Key -> (RawFilePath -> Annex Bool) -> Annex Bool +inAnnexCheck :: Key -> (OsPath -> Annex Bool) -> Annex Bool inAnnexCheck key check = inAnnex' id False check key {- inAnnex that performs an arbitrary check of the key's content. -} -inAnnex' :: (a -> Bool) -> a -> (RawFilePath -> Annex a) -> Key -> Annex a +inAnnex' :: (a -> Bool) -> a -> (OsPath -> Annex a) -> Key -> Annex a inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do r <- check loc if isgood r @@ -75,7 +73,7 @@ inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do objectFileExists :: Key -> Annex Bool objectFileExists key = calcRepo (gitAnnexLocation key) - >>= liftIO . R.doesPathExist + >>= liftIO . doesFileExist {- A safer check; the key's content must not only be present, but - is not in the process of being removed. -} @@ -93,7 +91,7 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key {- 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 (fromRawFilePath contentfile)) + ifM (liftIO $ doesFileExist contentfile) ( checkOr is_unlocked lockfile , return is_missing ) @@ -102,7 +100,7 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key Just True -> is_locked Just False -> is_unlocked #else - checklock Nothing contentfile = liftIO $ ifM (doesFileExist (fromRawFilePath contentfile)) + checklock Nothing contentfile = liftIO $ ifM (doesFileExist contentfile) ( lockShared contentfile >>= \case Nothing -> return is_locked Just lockhandle -> do @@ -113,7 +111,7 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key {- 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 (fromRawFilePath contentfile)) + ifM (liftIO $ doesFileExist contentfile) ( modifyContentDir lockfile $ liftIO $ lockShared lockfile >>= \case Nothing -> return is_locked @@ -134,7 +132,7 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key - content locking works, from running at the same time as content is locked - using the old method. -} -withContentLockFile :: Key -> (Maybe RawFilePath -> Annex a) -> Annex a +withContentLockFile :: Key -> (Maybe OsPath -> Annex a) -> Annex a withContentLockFile k a = do v <- getVersion if versionNeedsWritableContentFiles v @@ -146,7 +144,7 @@ withContentLockFile k a = do - will switch over to v10 content lock files at the - right time. -} gitdir <- fromRepo Git.localGitDir - let gitconfig = gitdir P. "config" + let gitconfig = gitdir literalOsPath "config" ic <- withTSDelta (liftIO . genInodeCache gitconfig) oldic <- Annex.getState Annex.gitconfiginodecache v' <- if fromMaybe False (compareStrong <$> ic <*> oldic) @@ -161,7 +159,7 @@ withContentLockFile k a = do where go v = contentLockFile k v >>= a -contentLockFile :: Key -> Maybe RepoVersion -> Annex (Maybe RawFilePath) +contentLockFile :: Key -> Maybe RepoVersion -> Annex (Maybe OsPath) #ifndef mingw32_HOST_OS {- Older versions of git-annex locked content files themselves, but newer - versions use a separate lock file, to better support repos shared @@ -177,7 +175,7 @@ contentLockFile key _ = Just <$> calcRepo (gitAnnexContentLock key) #endif {- Performs an action, passing it the location to use for a key's content. -} -withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a +withObjectLoc :: Key -> (OsPath -> Annex a) -> Annex a withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) {- Check if a file contains the unmodified content of the key. @@ -185,7 +183,7 @@ withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) - The expensive way to tell is to do a verification of its content. - The cheaper way is to see if the InodeCache for the key matches the - file. -} -isUnmodified :: Key -> RawFilePath -> Annex Bool +isUnmodified :: Key -> OsPath -> Annex Bool isUnmodified key f = withTSDelta (liftIO . genInodeCache f) >>= \case Just fc -> do @@ -193,7 +191,7 @@ isUnmodified key f = isUnmodified' key f fc ic Nothing -> return False -isUnmodified' :: Key -> RawFilePath -> InodeCache -> [InodeCache] -> Annex Bool +isUnmodified' :: Key -> OsPath -> InodeCache -> [InodeCache] -> Annex Bool isUnmodified' = isUnmodifiedLowLevel Database.Keys.addInodeCaches {- Cheap check if a file contains the unmodified content of the key, @@ -206,7 +204,7 @@ isUnmodified' = isUnmodifiedLowLevel Database.Keys.addInodeCaches - this may report a false positive when repeated edits are made to a file - within a small time window (eg 1 second). -} -isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool +isUnmodifiedCheap :: Key -> OsPath -> Annex Bool isUnmodifiedCheap key f = maybe (pure False) (isUnmodifiedCheap' key) =<< withTSDelta (liftIO . genInodeCache f) diff --git a/Annex/Content/Presence/LowLevel.hs b/Annex/Content/Presence/LowLevel.hs index 6f50c187b2..1def5173f9 100644 --- a/Annex/Content/Presence/LowLevel.hs +++ b/Annex/Content/Presence/LowLevel.hs @@ -12,7 +12,7 @@ import Annex.Verify import Annex.InodeSentinal import Utility.InodeCache -isUnmodifiedLowLevel :: (Key -> [InodeCache] -> Annex ()) -> Key -> RawFilePath -> InodeCache -> [InodeCache] -> Annex Bool +isUnmodifiedLowLevel :: (Key -> [InodeCache] -> Annex ()) -> Key -> OsPath -> InodeCache -> [InodeCache] -> Annex Bool isUnmodifiedLowLevel addinodecaches key f fc ic = isUnmodifiedCheapLowLevel fc ic <||> expensivecheck where diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs index 55c7d908e2..76bf5d25e9 100644 --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -51,7 +51,7 @@ tryCopyCoW (CopyCoWTried copycowtried) src dest meterupdate = -- CoW is known to work, so delete -- dest if it exists in order to do a fast -- CoW copy. - void $ tryIO $ removeFile dest + void $ tryIO $ removeFile dest' docopycow , return False ) @@ -60,18 +60,18 @@ tryCopyCoW (CopyCoWTried copycowtried) src dest meterupdate = docopycow = watchFileSize dest' meterupdate $ const $ copyCoW CopyTimeStamps src dest - dest' = toRawFilePath dest + dest' = toOsPath dest -- Check if the dest file already exists, which would prevent -- probing CoW. If the file exists but is empty, there's no benefit -- to resuming from it when CoW does not work, so remove it. destfilealreadypopulated = - tryIO (R.getFileStatus dest') >>= \case + tryIO (R.getFileStatus (toRawFilePath dest)) >>= \case Left _ -> return False Right st -> do sz <- getFileSize' dest' st if sz == 0 - then tryIO (removeFile dest) >>= \case + then tryIO (removeFile dest') >>= \case Right () -> return False Left _ -> return True else return True @@ -111,14 +111,15 @@ fileCopier copycowtried src dest meterupdate iv = docopy = do -- The file might have had the write bit removed, -- so make sure we can write to it. - void $ tryIO $ allowWrite dest' + void $ tryIO $ allowWrite (toOsPath dest) withBinaryFile src ReadMode $ \hsrc -> fileContentCopier hsrc dest meterupdate iv -- Copy src mode and mtime. mode <- fileMode <$> R.getFileStatus (toRawFilePath src) - mtime <- utcTimeToPOSIXSeconds <$> getModificationTime src + mtime <- utcTimeToPOSIXSeconds + <$> getModificationTime (toOsPath src) R.setFileMode dest' mode touch dest' mtime False diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs index 0c6e932711..470c8fae98 100644 --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -23,7 +23,6 @@ import qualified Data.List.NonEmpty as NE import qualified Data.ByteArray as BA import qualified Data.ByteArray.Encoding as BA import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P import Common import Key @@ -32,7 +31,7 @@ import Types.Difference import Utility.Hash import Utility.MD5 -type Hasher = Key -> RawFilePath +type Hasher = Key -> OsPath -- Number of hash levels to use. 2 is the default. newtype HashLevels = HashLevels Int @@ -51,7 +50,7 @@ configHashLevels d config | hasDifference d (annexDifferences config) = HashLevels 1 | otherwise = def -branchHashDir :: GitConfig -> Key -> S.ByteString +branchHashDir :: GitConfig -> Key -> OsPath branchHashDir = hashDirLower . branchHashLevels {- Two different directory hashes may be used. The mixed case hash @@ -64,9 +63,10 @@ branchHashDir = hashDirLower . branchHashLevels dirHashes :: NE.NonEmpty (HashLevels -> Hasher) dirHashes = hashDirLower NE.:| [hashDirMixed] -hashDirs :: HashLevels -> Int -> S.ByteString -> RawFilePath -hashDirs (HashLevels 1) sz s = P.addTrailingPathSeparator $ S.take sz s -hashDirs _ sz s = P.addTrailingPathSeparator $ h P. t +hashDirs :: HashLevels -> Int -> S.ByteString -> OsPath +hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ + toOsPath (S.take sz s) +hashDirs _ sz s = addTrailingPathSeparator $ toOsPath h toOsPath t where (h, t) = S.splitAt sz s diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 49c15746c4..285ddf50c3 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -108,7 +108,7 @@ handleDropsFrom locs rs reason fromhere key afile si preverified runner = do [ "dropped" , case afile of AssociatedFile Nothing -> serializeKey key - AssociatedFile (Just af) -> fromRawFilePath af + AssociatedFile (Just af) -> fromOsPath af , "(from " ++ maybe "here" show u ++ ")" , "(copies now " ++ show (have - 1) ++ ")" , ": " ++ reason diff --git a/Annex/ExternalAddonProcess.hs b/Annex/ExternalAddonProcess.hs index e573d2261d..887f9f6466 100644 --- a/Annex/ExternalAddonProcess.hs +++ b/Annex/ExternalAddonProcess.hs @@ -85,9 +85,9 @@ startExternalAddonProcess basecmd ps pid = do runerr (Just cmd) = return $ Left $ ProgramFailure $ - "Cannot run " ++ cmd ++ " -- Make sure it's executable and that its dependencies are installed." + "Cannot run " ++ fromOsPath cmd ++ " -- Make sure it's executable and that its dependencies are installed." runerr Nothing = do - path <- intercalate ":" <$> getSearchPath + path <- intercalate ":" . map fromOsPath <$> getSearchPath return $ Left $ ProgramNotInstalled $ "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")" diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index 3d175875eb..6157efa3f0 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Annex.FileMatcher ( @@ -56,14 +57,14 @@ import Data.Either import qualified Data.Set as S import Control.Monad.Writer -type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex) +type GetFileMatcher = OsPath -> Annex (FileMatcher Annex) -checkFileMatcher :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool +checkFileMatcher :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool checkFileMatcher lu getmatcher file = checkFileMatcher' lu getmatcher file (return True) -- | Allows running an action when no matcher is configured for the file. -checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool +checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool -> Annex Bool checkFileMatcher' lu getmatcher file notconfigured = do matcher <- getmatcher file checkMatcher matcher Nothing afile lu S.empty notconfigured d @@ -120,7 +121,7 @@ checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi lu notpresent = fromMaybe mempty descmsg <> UnquotedString s return False -fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo +fileMatchInfo :: OsPath -> Maybe Key -> Annex MatchInfo fileMatchInfo file mkey = do matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) return $ MatchingFile FileInfo @@ -160,7 +161,7 @@ parseToken l t = case syntaxToken t of tokenizeMatcher :: String -> [String] tokenizeMatcher = filter (not . null) . concatMap splitparens . words where - splitparens = segmentDelim (`elem` "()") + splitparens = segmentDelim (`elem` ("()" :: String)) commonTokens :: LimitBy -> [ParseToken (MatchFiles Annex)] commonTokens lb = @@ -201,7 +202,7 @@ preferredContentTokens pcd = , ValueToken "fullysizebalanced" (usev $ limitFullySizeBalanced (repoUUID pcd) (getGroupMap pcd)) ] ++ commonTokens LimitAnnexFiles where - preferreddir = maybe "public" fromProposedAccepted $ + preferreddir = toOsPath $ maybe "public" fromProposedAccepted $ M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)] diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs index 112c55224a..f27ab45e38 100644 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -18,10 +18,11 @@ import Utility.SafeCommand import Utility.Directory import Utility.Exception import Utility.Monad -import Utility.FileSystemEncoding import Utility.SystemDirectory +import Utility.OsPath import qualified Utility.RawFilePath as R import Utility.PartialPrelude +import qualified Utility.OsString as OS import System.IO import Data.List @@ -29,8 +30,6 @@ import Data.Maybe import Control.Monad import Control.Monad.IfElse import qualified Data.Map as M -import qualified Data.ByteString as S -import System.FilePath.ByteString import Control.Applicative import Prelude @@ -109,28 +108,30 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d , return r ) where - dotgit = w ".git" + dotgit = w literalOsPath ".git" - replacedotgit = whenM (doesFileExist (fromRawFilePath dotgit)) $ do + replacedotgit = whenM (doesFileExist dotgit) $ do linktarget <- relPathDirToFile w d - removeWhenExistsWith R.removeLink dotgit - R.createSymbolicLink linktarget dotgit + let dotgit' = fromOsPath dotgit + removeWhenExistsWith R.removeLink dotgit' + R.createSymbolicLink (fromOsPath linktarget) dotgit' -- Unsetting a config fails if it's not set, so ignore failure. unsetcoreworktree = void $ Git.Config.unset "core.worktree" r - worktreefixup = + worktreefixup = do -- 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 "commondir"))) >>= \case + let commondirfile = fromOsPath (d literalOsPath "commondir") + catchDefaultIO Nothing (headMaybe . lines <$> readFile commondirfile) >>= \case Just gd -> do -- Make the worktree's git directory -- contain an annex symlink to the main -- repository's annex directory. - let linktarget = toRawFilePath gd "annex" - R.createSymbolicLink linktarget - (dotgit "annex") + let linktarget = toOsPath gd literalOsPath "annex" + R.createSymbolicLink (fromOsPath linktarget) $ + fromOsPath $ dotgit literalOsPath "annex" Nothing -> return () -- Repo adjusted, so that symlinks to objects that get checked @@ -143,7 +144,7 @@ fixupUnusualRepos r _ = return r needsSubmoduleFixup :: Repo -> Bool needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) = - (".git" "modules") `S.isInfixOf` d + (literalOsPath ".git" literalOsPath "modules") `OS.isInfixOf` d needsSubmoduleFixup _ = False needsGitLinkFixup :: Repo -> IO Bool @@ -151,6 +152,6 @@ needsGitLinkFixup (Repo { location = (Local { worktree = Just wt, gitdir = d }) -- 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 ".git" == d = return False - | otherwise = doesFileExist (fromRawFilePath (wt ".git")) + | wt literalOsPath ".git" == d = return False + | otherwise = doesFileExist (wt literalOsPath ".git") needsGitLinkFixup _ = return False diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs index 5388c1bfc6..384feed39a 100644 --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -23,7 +23,7 @@ import qualified Annex.Queue import Config.Smudge {- Runs an action using a different git index file. -} -withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a +withIndexFile :: AltIndexFile -> (OsPath -> Annex a) -> Annex a withIndexFile i = withAltRepo usecachedgitenv restoregitenv where -- This is an optimisation. Since withIndexFile is run repeatedly, @@ -58,7 +58,7 @@ withIndexFile i = withAltRepo usecachedgitenv restoregitenv f <- indexEnvVal $ case i of AnnexIndexFile -> gitAnnexIndex g ViewIndexFile -> gitAnnexViewIndex g - g' <- addGitEnv g indexEnv f + g' <- addGitEnv g indexEnv (fromOsPath f) return (g', f) restoregitenv g g' = g' { gitEnv = gitEnv g } @@ -66,13 +66,13 @@ withIndexFile i = withAltRepo usecachedgitenv restoregitenv {- Runs an action using a different git work tree. - - Smudge and clean filters are disabled in this work tree. -} -withWorkTree :: FilePath -> Annex a -> Annex a +withWorkTree :: OsPath -> Annex a -> Annex a withWorkTree d a = withAltRepo (\g -> return $ (g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ bypassSmudgeConfig }, ())) (\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g }) (const a) where - modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) } + modlocation l@(Local {}) = l { worktree = Just d } modlocation _ = giveup "withWorkTree of non-local git repo" {- Runs an action with the git index file and HEAD, and a few other @@ -83,13 +83,13 @@ withWorkTree d a = withAltRepo - - Needs git 2.2.0 or newer. -} -withWorkTreeRelated :: FilePath -> Annex a -> Annex a +withWorkTreeRelated :: OsPath -> Annex a -> Annex a withWorkTreeRelated d a = withAltRepo modrepo unmodrepo (const a) where modrepo g = liftIO $ do - g' <- addGitEnv g "GIT_COMMON_DIR" . fromRawFilePath + g' <- addGitEnv g "GIT_COMMON_DIR" . fromOsPath =<< absPath (localGitDir g) - g'' <- addGitEnv g' "GIT_DIR" d + g'' <- addGitEnv g' "GIT_DIR" (fromOsPath d) return (g'' { gitEnvOverridesGitDir = True }, ()) unmodrepo g g' = g' { gitEnv = gitEnv g diff --git a/Annex/HashObject.hs b/Annex/HashObject.hs index 4a0ea187ed..7c1a9a1dd1 100644 --- a/Annex/HashObject.hs +++ b/Annex/HashObject.hs @@ -28,7 +28,7 @@ hashObjectStop = maybe noop stop =<< Annex.getState Annex.hashobjecthandle liftIO $ freeResourcePool p Git.HashObject.hashObjectStop Annex.changeState $ \s -> s { Annex.hashobjecthandle = Nothing } -hashFile :: RawFilePath -> Annex Sha +hashFile :: OsPath -> Annex Sha hashFile f = withHashObjectHandle $ \h -> liftIO $ Git.HashObject.hashFile h f diff --git a/Annex/Hook.hs b/Annex/Hook.hs index 3241d3b556..086665abce 100644 --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -21,10 +21,11 @@ import Utility.Shell import qualified Data.Map as M preCommitHook :: Git.Hook -preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .") [] +preCommitHook = Git.Hook (literalOsPath "pre-commit") + (mkHookScript "git annex pre-commit .") [] postReceiveHook :: Git.Hook -postReceiveHook = Git.Hook "post-receive" +postReceiveHook = Git.Hook (literalOsPath "post-receive") -- Only run git-annex post-receive when git-annex supports it, -- to avoid failing if the repository with this hook is used -- with an older version of git-annex. @@ -34,10 +35,10 @@ postReceiveHook = Git.Hook "post-receive" ] postCheckoutHook :: Git.Hook -postCheckoutHook = Git.Hook "post-checkout" smudgeHook [] +postCheckoutHook = Git.Hook (literalOsPath "post-checkout") smudgeHook [] postMergeHook :: Git.Hook -postMergeHook = Git.Hook "post-merge" smudgeHook [] +postMergeHook = Git.Hook (literalOsPath "post-merge") smudgeHook [] -- Older versions of git-annex didn't support this command, but neither did -- they support v7 repositories. @@ -45,28 +46,28 @@ smudgeHook :: String smudgeHook = mkHookScript "git annex smudge --update" preCommitAnnexHook :: Git.Hook -preCommitAnnexHook = Git.Hook "pre-commit-annex" "" [] +preCommitAnnexHook = Git.Hook (literalOsPath "pre-commit-annex") "" [] postUpdateAnnexHook :: Git.Hook -postUpdateAnnexHook = Git.Hook "post-update-annex" "" [] +postUpdateAnnexHook = Git.Hook (literalOsPath "post-update-annex") "" [] preInitAnnexHook :: Git.Hook -preInitAnnexHook = Git.Hook "pre-init-annex" "" [] +preInitAnnexHook = Git.Hook (literalOsPath "pre-init-annex") "" [] freezeContentAnnexHook :: Git.Hook -freezeContentAnnexHook = Git.Hook "freezecontent-annex" "" [] +freezeContentAnnexHook = Git.Hook (literalOsPath "freezecontent-annex") "" [] thawContentAnnexHook :: Git.Hook -thawContentAnnexHook = Git.Hook "thawcontent-annex" "" [] +thawContentAnnexHook = Git.Hook (literalOsPath "thawcontent-annex") "" [] secureEraseAnnexHook :: Git.Hook -secureEraseAnnexHook = Git.Hook "secure-erase-annex" "" [] +secureEraseAnnexHook = Git.Hook (literalOsPath "secure-erase-annex") "" [] commitMessageAnnexHook :: Git.Hook -commitMessageAnnexHook = Git.Hook "commitmessage-annex" "" [] +commitMessageAnnexHook = Git.Hook (literalOsPath "commitmessage-annex") "" [] httpHeadersAnnexHook :: Git.Hook -httpHeadersAnnexHook = Git.Hook "http-headers-annex" "" [] +httpHeadersAnnexHook = Git.Hook (literalOsPath "http-headers-annex") "" [] mkHookScript :: String -> String mkHookScript s = unlines @@ -87,8 +88,8 @@ hookWarning :: Git.Hook -> String -> Annex () hookWarning h msg = do r <- gitRepo warning $ UnquotedString $ - fromRawFilePath (Git.hookName h) ++ - " hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg + fromOsPath (Git.hookName h) ++ + " hook (" ++ fromOsPath (Git.hookFile h r) ++ ") " ++ msg {- To avoid checking if the hook exists every time, the existing hooks - are cached. -} @@ -121,7 +122,7 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook) ( return Nothing , do h <- fromRepo (Git.hookFile hook) - commandfailed (fromRawFilePath h) + commandfailed (fromOsPath h) ) runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case Nothing -> return Nothing @@ -132,18 +133,19 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook) ) commandfailed c = return $ Just c -runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> RawFilePath -> Annex Bool +runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex Bool runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook) ( runhook , runcommandcfg ) where - runhook = inRepo $ Git.runHook boolSystem hook [ File (fromRawFilePath p) ] + runhook = inRepo $ Git.runHook boolSystem hook [ File p' ] runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case Nothing -> return True Just basecmd -> liftIO $ boolSystem "sh" [Param "-c", Param $ gencmd basecmd] - gencmd = massReplace [ (pathtoken, shellEscape (fromRawFilePath p)) ] + gencmd = massReplace [ (pathtoken, shellEscape p') ] + p' = fromOsPath p outputOfAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String) outputOfAnnexHook hook commandcfg = ifM (doesAnnexHookExist hook) diff --git a/Annex/Import.hs b/Annex/Import.hs index 587d866a96..497a868c15 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -69,7 +69,6 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified System.FilePath.Posix.ByteString as Posix -import qualified System.FilePath.ByteString as P import qualified Data.ByteArray.Encoding as BA {- Configures how to build an import tree. -} @@ -154,7 +153,7 @@ recordImportTree remote importtreeconfig addunlockedmatcher imported = do let subtreeref = Ref $ fromRef' finaltree <> ":" - <> getTopFilePath dir + <> fromOsPath (getTopFilePath dir) in fromMaybe emptyTree <$> inRepo (Git.Ref.tree subtreeref) updateexportdb importedtree @@ -349,11 +348,11 @@ mkImportTreeItem maddunlockedmatcher msubdir loc v = case v of lf = fromImportLocation loc treepath = asTopFilePath lf topf = asTopFilePath $ - maybe lf (\sd -> getTopFilePath sd P. lf) msubdir + maybe lf (\sd -> getTopFilePath sd lf) msubdir mklink k = do relf <- fromRepo $ fromTopFilePath topf symlink <- calcRepo $ gitAnnexLink relf k - linksha <- hashSymlink symlink + linksha <- hashSymlink (fromOsPath symlink) return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha mkpointer k = TreeItem treepath (fromTreeItemType TreeFile) <$> hashPointerFile k @@ -429,7 +428,8 @@ buildImportTreesGeneric converttree basetree msubdir importable@(ImportableConte -- Full directory prefix where the sub tree is located. let fullprefix = asTopFilePath $ case msubdir of Nothing -> subdir - Just d -> getTopFilePath d Posix. subdir + Just d -> toOsPath $ + fromOsPath (getTopFilePath d) Posix. fromOsPath subdir Tree ts <- converttree (Just fullprefix) $ map (\(p, i) -> (mkImportLocation p, i)) (importableContentsSubTree c) @@ -853,7 +853,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec let af = AssociatedFile (Just f) let downloader p' tmpfile = do _ <- Remote.retrieveExportWithContentIdentifier - ia loc [cid] (fromRawFilePath tmpfile) + ia loc [cid] tmpfile (Left k) (combineMeterUpdate p' p) ok <- moveAnnex k af tmpfile @@ -871,7 +871,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec doimportsmall cidmap loc cid sz p = do let downloader tmpfile = do (k, _) <- Remote.retrieveExportWithContentIdentifier - ia loc [cid] (fromRawFilePath tmpfile) + ia loc [cid] tmpfile (Right (mkkey tmpfile)) p case keyGitSha k of @@ -894,7 +894,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec let af = AssociatedFile (Just f) let downloader tmpfile p = do (k, _) <- Remote.retrieveExportWithContentIdentifier - ia loc [cid] (fromRawFilePath tmpfile) + ia loc [cid] tmpfile (Right (mkkey tmpfile)) p case keyGitSha k of @@ -950,7 +950,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec case importtreeconfig of ImportTree -> fromImportLocation loc ImportSubTree subdir _ -> - getTopFilePath subdir P. fromImportLocation loc + getTopFilePath subdir fromImportLocation loc getcidkey cidmap db cid = liftIO $ -- Avoiding querying the database when it's empty speeds up @@ -1091,7 +1091,7 @@ getImportableContents r importtreeconfig ci matcher = do isknown <||> (matches <&&> notignored) where -- Checks, from least to most expensive. - ingitdir = ".git" `elem` Posix.splitDirectories (fromImportLocation loc) + ingitdir = ".git" `elem` Posix.splitDirectories (fromOsPath (fromImportLocation loc)) matches = matchesImportLocation matcher loc sz isknown = isKnownImportLocation dbhandle loc notignored = notIgnoredImportLocation importtreeconfig ci loc @@ -1120,6 +1120,6 @@ notIgnoredImportLocation importtreeconfig ci loc = not <$> checkIgnored ci f where f = case importtreeconfig of ImportSubTree dir _ -> - getTopFilePath dir P. fromImportLocation loc + getTopFilePath dir fromImportLocation loc ImportTree -> fromImportLocation loc diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index ed7479526f..47399567fc 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -66,7 +66,7 @@ data LockedDown = LockedDown data LockDownConfig = LockDownConfig { lockingFile :: Bool -- ^ write bit removed during lock down - , hardlinkFileTmpDir :: Maybe RawFilePath + , hardlinkFileTmpDir :: Maybe OsPath -- ^ hard link to temp directory , checkWritePerms :: Bool -- ^ check that write perms are successfully removed @@ -87,13 +87,13 @@ data LockDownConfig = LockDownConfig - Lockdown can fail if a file gets deleted, or if it's unable to remove - write permissions, and Nothing will be returned. -} -lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown) +lockDown :: LockDownConfig-> OsPath -> Annex (Maybe LockedDown) lockDown cfg file = either (\e -> warning (UnquotedString (show e)) >> return Nothing) (return . Just) =<< lockDown' cfg file -lockDown' :: LockDownConfig -> FilePath -> Annex (Either SomeException LockedDown) +lockDown' :: LockDownConfig -> OsPath -> Annex (Either SomeException LockedDown) lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem ( nohardlink , case hardlinkFileTmpDir cfg of @@ -101,49 +101,46 @@ lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem Just tmpdir -> withhardlink tmpdir ) where - file' = toRawFilePath file - nohardlink = do setperms withTSDelta $ liftIO . nohardlink' nohardlink' delta = do - cache <- genInodeCache file' delta + cache <- genInodeCache file delta return $ LockedDown cfg $ KeySource - { keyFilename = file' - , contentLocation = file' + { keyFilename = file + , contentLocation = file , inodeCache = cache } withhardlink tmpdir = do setperms withTSDelta $ \delta -> liftIO $ do - (tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $ - relatedTemplate $ toRawFilePath $ - "ingest-" ++ takeFileName file + (tmpfile, h) <- openTmpFileIn tmpdir $ + relatedTemplate $ fromOsPath $ + literalOsPath "ingest-" <> takeFileName file hClose h - let tmpfile' = fromOsPath tmpfile - removeWhenExistsWith R.removeLink tmpfile' - withhardlink' delta tmpfile' + removeWhenExistsWith R.removeLink (fromOsPath tmpfile) + withhardlink' delta tmpfile `catchIO` const (nohardlink' delta) withhardlink' delta tmpfile = do - R.createLink file' tmpfile + R.createLink (fromOsPath file) (fromOsPath tmpfile) cache <- genInodeCache tmpfile delta return $ LockedDown cfg $ KeySource - { keyFilename = file' + { keyFilename = file , contentLocation = tmpfile , inodeCache = cache } setperms = when (lockingFile cfg) $ do - freezeContent file' + freezeContent file when (checkWritePerms cfg) $ do qp <- coreQuotePath <$> Annex.getGitConfig maybe noop (giveup . decodeBS . quote qp) - =<< checkLockedDownWritePerms file' file' + =<< checkLockedDownWritePerms file file -checkLockedDownWritePerms :: RawFilePath -> RawFilePath -> Annex (Maybe StringContainingQuotedPath) +checkLockedDownWritePerms :: OsPath -> OsPath -> Annex (Maybe StringContainingQuotedPath) checkLockedDownWritePerms file displayfile = checkContentWritePerm file >>= return . \case Just False -> Just $ "Unable to remove all write permissions from " <> QuotedPath displayfile @@ -167,7 +164,8 @@ ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do then addSymlink f k mic else do mode <- liftIO $ catchMaybeIO $ - fileMode <$> R.getFileStatus (contentLocation source) + fileMode <$> R.getFileStatus + (fromOsPath (contentLocation source)) stagePointerFile f mode =<< hashPointerFile k return (Just k) @@ -188,7 +186,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage = fst <$> genKey source meterupdate backend Just k -> return k let src = contentLocation source - ms <- liftIO $ catchMaybeIO $ R.getFileStatus src + ms <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath src) mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms case (mcache, inodeCache source) of (_, Nothing) -> go k mcache @@ -263,12 +261,12 @@ populateUnlockedFiles key source restage _ = do cleanCruft :: KeySource -> Annex () cleanCruft source = when (contentLocation source /= keyFilename source) $ - liftIO $ removeWhenExistsWith R.removeLink $ contentLocation source + liftIO $ removeWhenExistsWith removeFile $ 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 -- content. Clean up from that. -cleanOldKeys :: RawFilePath -> Key -> Annex () +cleanOldKeys :: OsPath -> Key -> Annex () cleanOldKeys file newkey = do g <- Annex.gitRepo topf <- inRepo (toTopFilePath file) @@ -293,37 +291,38 @@ cleanOldKeys file newkey = do {- 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 :: RawFilePath -> Key -> SomeException -> Annex a +restoreFile :: OsPath -> Key -> SomeException -> Annex a restoreFile file key e = do whenM (inAnnex key) $ do - liftIO $ removeWhenExistsWith R.removeLink file + liftIO $ removeWhenExistsWith removeFile 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 (fromRawFilePath file)) $ - warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath (toRawFilePath obj) + obj <- calcRepo (gitAnnexLocation key) + unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $ + warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath obj thawContent file throwM e {- Creates the symlink to the annexed content, returns the link target. -} -makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget +makeLink :: OsPath -> Key -> Maybe InodeCache -> Annex LinkTarget makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do - l <- calcRepo $ gitAnnexLink file key + l <- fromOsPath <$> calcRepo (gitAnnexLink file key) replaceWorkTreeFile file $ makeAnnexLink l -- touch symlink to have same time as the original file, -- as provided in the InodeCache case mcache of - Just c -> liftIO $ touch file (inodeCacheToMtime c) False + Just c -> liftIO $ + touch (fromOsPath file) (inodeCacheToMtime c) False Nothing -> noop return l {- Creates the symlink to the annexed content, and stages it in git. -} -addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex () +addSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex () addSymlink file key mcache = stageSymlink file =<< genSymlink file key mcache -genSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex Git.Sha +genSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex Git.Sha genSymlink file key mcache = do linktarget <- makeLink file key mcache hashSymlink linktarget @@ -368,12 +367,12 @@ addUnlocked matcher mi contentpresent = - - When the content of the key is not accepted into the annex, returns False. -} -addAnnexedFile :: AddUnlockedMatcher -> RawFilePath -> Key -> Maybe RawFilePath -> Annex Bool +addAnnexedFile :: AddUnlockedMatcher -> OsPath -> Key -> Maybe OsPath -> Annex Bool addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp)) ( do mode <- maybe (pure Nothing) - (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp) + (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath tmp)) mtmp stagePointerFile file mode =<< hashPointerFile key Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) @@ -411,7 +410,7 @@ addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp) {- 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 :: OsPath -> Key -> Annex a -> Annex a addingExistingLink f k a = do unlessM (isKnownKey k <||> inAnnex k) $ do islink <- isJust <$> isAnnexLink f diff --git a/Annex/Init.hs b/Annex/Init.hs index ea7cd09765..81b07b54d1 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -56,6 +56,7 @@ import Annex.Perms #ifndef mingw32_HOST_OS import Utility.ThreadScheduler import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F import Utility.FileMode import System.Posix.User import qualified Utility.LockFile.Posix as Posix @@ -66,7 +67,6 @@ import Control.Monad.IO.Class (MonadIO) #ifndef mingw32_HOST_OS import System.PosixCompat.Files (ownerReadMode, isNamedPipe) import Data.Either -import qualified System.FilePath.ByteString as P import Control.Concurrent.Async #endif @@ -99,21 +99,20 @@ initializeAllowed = noAnnexFileContent' >>= \case Just _ -> return False noAnnexFileContent' :: Annex (Maybe String) -noAnnexFileContent' = inRepo $ - noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree +noAnnexFileContent' = inRepo $ noAnnexFileContent . Git.repoWorkTree genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d genDescription Nothing = do - reldir <- liftIO . relHome . fromRawFilePath + reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath hostname <- fromMaybe "" <$> liftIO getHostname let at = if null hostname then "" else "@" v <- liftIO myUserName return $ UUIDDesc $ encodeBS $ concat $ case v of - Right username -> [username, at, hostname, ":", reldir] - Left _ -> [hostname, ":", reldir] + Right username -> [username, at, hostname, ":", fromOsPath reldir] + Left _ -> [hostname, ":", fromOsPath reldir] initialize :: Annex () -> Maybe String -> Maybe RepoVersion -> Annex () initialize startupannex mdescription mversion = checkInitializeAllowed $ \initallowed -> do @@ -238,12 +237,12 @@ autoInitializeAllowed = Annex.Branch.hasSibling <&&> objectDirNotPresent objectDirNotPresent :: Annex Bool objectDirNotPresent = do - d <- fromRawFilePath <$> fromRepo gitAnnexObjectDir + d <- fromRepo gitAnnexObjectDir exists <- liftIO $ doesDirectoryExist d when exists $ guardSafeToUseRepo $ giveup $ unwords $ [ "This repository is not initialized for use" - , "by git-annex, but " ++ d ++ " exists," + , "by git-annex, but " ++ fromOsPath d ++ " exists," , "which indicates this repository was used by" , "git-annex before, and may have lost its" , "annex.uuid and annex.version configs. Either" @@ -263,7 +262,7 @@ guardSafeToUseRepo a = ifM (inRepo Git.Config.checkRepoConfigInaccessible) , "" -- This mirrors git's wording. , "To add an exception for this directory, call:" - , "\tgit config --global --add safe.directory " ++ fromRawFilePath p + , "\tgit config --global --add safe.directory " ++ fromOsPath p ] , a ) @@ -301,40 +300,39 @@ probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do probeCrippledFileSystem' :: (MonadIO m, MonadCatch m) - => RawFilePath - -> Maybe (RawFilePath -> m ()) - -> Maybe (RawFilePath -> m ()) + => OsPath + -> Maybe (OsPath -> m ()) + -> Maybe (OsPath -> m ()) -> Bool -> m (Bool, [String]) #ifdef mingw32_HOST_OS probeCrippledFileSystem' _ _ _ _ = return (True, []) #else probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do - let f = tmp P. "gaprobe" - let f' = fromRawFilePath f - liftIO $ writeFile f' "" - r <- probe f' + let f = tmp literalOsPath "gaprobe" + liftIO $ F.writeFile' f "" + r <- probe f void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f - liftIO $ removeFile f' + liftIO $ removeFile f return r where probe f = catchDefaultIO (True, []) $ do - let f2 = f ++ "2" - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2) - liftIO $ R.createSymbolicLink (toRawFilePath f) (toRawFilePath f2) - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2) - (fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f) + let f2 = f <> literalOsPath "2" + liftIO $ removeWhenExistsWith removeFile f2 + liftIO $ R.createSymbolicLink (fromOsPath f) (fromOsPath f2) + liftIO $ removeWhenExistsWith removeFile f2 + (fromMaybe (liftIO . preventWrite) freezecontent) f -- Should be unable to write to the file (unless -- running as root). But some crippled -- filesystems ignore write bit removals or ignore -- permissions entirely. - ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing hasfreezehook)) + ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared f Nothing hasfreezehook)) ( return (True, ["Filesystem does not allow removing write bit from files."]) , liftIO $ ifM ((== 0) <$> getRealUserID) ( return (False, []) , do r <- catchBoolIO $ do - writeFile f "2" + F.writeFile' f "2" return True if r then return (True, ["Filesystem allows writing to files whose write bit is not set."]) @@ -363,19 +361,19 @@ probeLockSupport :: Annex Bool probeLockSupport = return True #else probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do - let f = tmp P. "lockprobe" + let f = tmp literalOsPath "lockprobe" mode <- annexFileMode annexrunner <- Annex.makeRunner liftIO $ withAsync (warnstall annexrunner) (const (go f mode)) where go f mode = do - removeWhenExistsWith R.removeLink f + removeWhenExistsWith removeFile f let locktest = bracket (Posix.lockExclusive (Just mode) f) Posix.dropLock (const noop) ok <- isRight <$> tryNonAsync locktest - removeWhenExistsWith R.removeLink f + removeWhenExistsWith removeFile f return ok warnstall annexrunner = do @@ -391,17 +389,17 @@ probeFifoSupport = do return False #else withEventuallyCleanedOtherTmp $ \tmp -> do - let f = tmp P. "gaprobe" - let f2 = tmp P. "gaprobe2" + let f = tmp literalOsPath "gaprobe" + let f2 = tmp literalOsPath "gaprobe2" liftIO $ do - removeWhenExistsWith R.removeLink f - removeWhenExistsWith R.removeLink f2 + removeWhenExistsWith removeFile f + removeWhenExistsWith removeFile f2 ms <- tryIO $ do - R.createNamedPipe f ownerReadMode - R.createLink f f2 - R.getFileStatus f - removeWhenExistsWith R.removeLink f - removeWhenExistsWith R.removeLink f2 + R.createNamedPipe (fromOsPath f) ownerReadMode + R.createLink (fromOsPath f) (fromOsPath f2) + R.getFileStatus (fromOsPath f) + removeWhenExistsWith removeFile f + removeWhenExistsWith removeFile f2 return $ either (const False) isNamedPipe ms #endif @@ -473,14 +471,14 @@ autoEnableSpecialRemotes remotelist = do -- could result in password prompts for http credentials, -- which would then not end up cached in this process's state. _ <- remotelist - rp <- fromRawFilePath <$> fromRepo Git.repoPath + rp <- fromRepo Git.repoPath withNullHandle $ \nullh -> gitAnnexChildProcess "init" [ Param "--autoenable" ] (\p -> p { std_out = UseHandle nullh , std_err = UseHandle nullh , std_in = UseHandle nullh - , cwd = Just rp + , cwd = Just (fromOsPath rp) } ) (\_ _ _ pid -> void $ waitForProcess pid) diff --git a/Annex/InodeSentinal.hs b/Annex/InodeSentinal.hs index 129dd08b71..165c8df65d 100644 --- a/Annex/InodeSentinal.hs +++ b/Annex/InodeSentinal.hs @@ -30,22 +30,22 @@ compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly ) {- Checks if one of the provided old InodeCache matches the current - version of a file. -} -sameInodeCache :: RawFilePath -> [InodeCache] -> Annex Bool +sameInodeCache :: OsPath -> [InodeCache] -> Annex Bool sameInodeCache file [] = do fastDebug "Annex.InodeSentinal" $ - fromRawFilePath file ++ " inode cache empty" + fromOsPath file ++ " inode cache empty" return False sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file) where go Nothing = do fastDebug "Annex.InodeSentinal" $ - fromRawFilePath file ++ " not present, cannot compare with inode cache" + fromOsPath file ++ " not present, cannot compare with inode cache" return False go (Just curr) = ifM (elemInodeCaches curr old) ( return True , do fastDebug "Annex.InodeSentinal" $ - fromRawFilePath file ++ " (" ++ show curr ++ ") does not match inode cache (" ++ show old ++ ")" + fromOsPath file ++ " (" ++ show curr ++ ") does not match inode cache (" ++ show old ++ ")" return False ) @@ -99,7 +99,7 @@ createInodeSentinalFile evenwithobjects = alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile hasobjects | evenwithobjects = pure False - | otherwise = liftIO . doesDirectoryExist . fromRawFilePath + | otherwise = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir annexSentinalFile :: Annex SentinalFile diff --git a/Annex/Journal.hs b/Annex/Journal.hs index cfa582c65e..370652769f 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -26,13 +26,12 @@ import Annex.LockFile import Annex.BranchState import Types.BranchState import Utility.Directory.Stream -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F +import qualified Utility.OsString as OS import qualified Data.Set as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P import Data.ByteString.Builder import Data.Char @@ -83,7 +82,7 @@ privateUUIDsKnown' = not . S.null . annexPrivateRepos . Annex.gitconfig - interrupted write truncating information that was earlier read from the - file, and so losing data. -} -setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex () +setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> OsPath -> content -> Annex () setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do st <- getState jd <- fromRepo =<< ifM (regardingPrivateUUID ru) @@ -92,10 +91,10 @@ setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do ) -- journal file is written atomically let jfile = journalFile file - let tmpfile = tmp P. jfile - liftIO $ F.withFile (toOsPath tmpfile) WriteMode $ \h -> + let tmpfile = tmp jfile + liftIO $ F.withFile tmpfile WriteMode $ \h -> writeJournalHandle h content - let dest = jd P. jfile + let dest = jd jfile let mv = do liftIO $ moveFile tmpfile dest setAnnexFilePerm dest @@ -103,20 +102,20 @@ setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do -- exists mv `catchIO` (const (createAnnexDirectory jd >> mv)) -newtype AppendableJournalFile = AppendableJournalFile (RawFilePath, RawFilePath) +newtype AppendableJournalFile = AppendableJournalFile (OsPath, OsPath) {- If the journal file does not exist, it cannot be appended to, because - that would overwrite whatever content the file has in the git-annex - branch. -} -checkCanAppendJournalFile :: JournalLocked -> RegardingUUID -> RawFilePath -> Annex (Maybe AppendableJournalFile) +checkCanAppendJournalFile :: JournalLocked -> RegardingUUID -> OsPath -> Annex (Maybe AppendableJournalFile) checkCanAppendJournalFile _jl ru file = do st <- getState jd <- fromRepo =<< ifM (regardingPrivateUUID ru) ( return (gitAnnexPrivateJournalDir st) , return (gitAnnexJournalDir st) ) - let jfile = jd P. journalFile file - ifM (liftIO $ R.doesPathExist jfile) + let jfile = jd journalFile file + ifM (liftIO $ doesFileExist jfile) ( return (Just (AppendableJournalFile (jd, jfile))) , return Nothing ) @@ -134,7 +133,7 @@ checkCanAppendJournalFile _jl ru file = do -} appendJournalFile :: Journalable content => JournalLocked -> AppendableJournalFile -> content -> Annex () appendJournalFile _jl (AppendableJournalFile (jd, jfile)) content = do - let write = liftIO $ F.withFile (toOsPath jfile) ReadWriteMode $ \h -> do + let write = liftIO $ F.withFile jfile ReadWriteMode $ \h -> do sz <- hFileSize h when (sz /= 0) $ do hSeek h SeekFromEnd (-1) @@ -161,7 +160,7 @@ data JournalledContent -- information that were made after that journal file was written. {- Gets any journalled content for a file in the branch. -} -getJournalFile :: JournalLocked -> GetPrivate -> RawFilePath -> Annex JournalledContent +getJournalFile :: JournalLocked -> GetPrivate -> OsPath -> Annex JournalledContent getJournalFile _jl = getJournalFileStale data GetPrivate = GetPrivate Bool @@ -179,7 +178,7 @@ data GetPrivate = GetPrivate Bool - (or is in progress when this is called), if the file content does not end - with a newline, it is truncated back to the previous newline. -} -getJournalFileStale :: GetPrivate -> RawFilePath -> Annex JournalledContent +getJournalFileStale :: GetPrivate -> OsPath -> Annex JournalledContent getJournalFileStale (GetPrivate getprivate) file = do st <- Annex.getState id let repo = Annex.repo st @@ -205,7 +204,7 @@ getJournalFileStale (GetPrivate getprivate) file = do jfile = journalFile file getfrom d = catchMaybeIO $ discardIncompleteAppend . L.fromStrict - <$> F.readFile' (toOsPath (d P. jfile)) + <$> F.readFile' (d jfile) -- Note that this forces read of the whole lazy bytestring. discardIncompleteAppend :: L.ByteString -> L.ByteString @@ -224,18 +223,18 @@ discardIncompleteAppend v {- List of existing journal files in a journal directory, but without locking, - may miss new ones just being added, or may have false positives if the - journal is staged as it is run. -} -getJournalledFilesStale :: (BranchState -> Git.Repo -> RawFilePath) -> Annex [RawFilePath] +getJournalledFilesStale :: (BranchState -> Git.Repo -> OsPath) -> Annex [OsPath] getJournalledFilesStale getjournaldir = do bs <- getState repo <- Annex.gitRepo let d = getjournaldir bs repo fs <- liftIO $ catchDefaultIO [] $ - getDirectoryContents (fromRawFilePath d) - return $ filter (`notElem` [".", ".."]) $ - map (fileJournal . toRawFilePath) fs + getDirectoryContents d + return $ filter (`notElem` dirCruft) $ + map fileJournal fs {- Directory handle open on a journal directory. -} -withJournalHandle :: (BranchState -> Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a +withJournalHandle :: (BranchState -> Git.Repo -> OsPath) -> (DirectoryHandle -> IO a) -> Annex a withJournalHandle getjournaldir a = do bs <- getState repo <- Annex.gitRepo @@ -244,15 +243,15 @@ withJournalHandle getjournaldir a = do where -- avoid overhead of creating the journal directory when it already -- exists - opendir d = liftIO (openDirectory d) + opendir d = liftIO (openDirectory (fromOsPath d)) `catchIO` (const (createAnnexDirectory d >> opendir d)) {- Checks if there are changes in the journal. -} -journalDirty :: (BranchState -> Git.Repo -> RawFilePath) -> Annex Bool +journalDirty :: (BranchState -> Git.Repo -> OsPath) -> Annex Bool journalDirty getjournaldir = do st <- getState d <- fromRepo (getjournaldir st) - liftIO $ isDirectoryPopulated d + liftIO $ isDirectoryPopulated (fromOsPath d) {- Produces a filename to use in the journal for a file on the branch. - The filename does not include the journal directory. @@ -261,33 +260,33 @@ journalDirty getjournaldir = do - used in the branch is not necessary, and all the files are put directly - in the journal directory. -} -journalFile :: RawFilePath -> RawFilePath -journalFile file = B.concatMap mangle file +journalFile :: OsPath -> OsPath +journalFile file = OS.concat $ map mangle $ OS.unpack file where mangle c - | P.isPathSeparator c = B.singleton underscore - | c == underscore = B.pack [underscore, underscore] - | otherwise = B.singleton c - underscore = fromIntegral (ord '_') + | isPathSeparator c = OS.singleton underscore + | c == underscore = OS.pack [underscore, underscore] + | otherwise = OS.singleton c + underscore = unsafeFromChar '_' {- Converts a journal file (relative to the journal dir) back to the - filename on the branch. -} -fileJournal :: RawFilePath -> RawFilePath +fileJournal :: OsPath -> OsPath fileJournal = go where go b = - let (h, t) = B.break (== underscore) b - in h <> case B.uncons t of + let (h, t) = OS.break (== underscore) b + in h <> case OS.uncons t of Nothing -> t - Just (_u, t') -> case B.uncons t' of + Just (_u, t') -> case OS.uncons t' of Nothing -> t' Just (w, t'') | w == underscore -> - B.cons underscore (go t'') + OS.cons underscore (go t'') | otherwise -> - B.cons P.pathSeparator (go t') + OS.cons pathSeparator (go t') - underscore = fromIntegral (ord '_') + underscore = unsafeFromChar '_' {- Sentinal value, only produced by lockJournal; required - as a parameter by things that need to ensure the journal is diff --git a/Annex/Link.hs b/Annex/Link.hs index 4c2a76ffc2..559add24ed 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -39,11 +39,11 @@ import Utility.CopyFile import qualified Database.Keys.Handle import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F +import qualified Utility.OsString as OS import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import qualified System.FilePath.ByteString as P #ifndef mingw32_HOST_OS #if MIN_VERSION_unix(2,8,0) #else @@ -54,7 +54,7 @@ import System.PosixCompat.Files (isSymbolicLink) type LinkTarget = S.ByteString {- Checks if a file is a link to a key. -} -isAnnexLink :: RawFilePath -> Annex (Maybe Key) +isAnnexLink :: OsPath -> Annex (Maybe Key) isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file {- Gets the link target of a symlink. @@ -65,13 +65,13 @@ isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget - Returns Nothing if the file is not a symlink, or not a link to annex - content. -} -getAnnexLinkTarget :: RawFilePath -> Annex (Maybe LinkTarget) +getAnnexLinkTarget :: OsPath -> Annex (Maybe LinkTarget) getAnnexLinkTarget f = getAnnexLinkTarget' f =<< (coreSymlinks <$> Annex.getGitConfig) {- Pass False to force looking inside file, for when git checks out - symlinks as plain files. -} -getAnnexLinkTarget' :: RawFilePath -> Bool -> Annex (Maybe S.ByteString) +getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe LinkTarget) getAnnexLinkTarget' file coresymlinks = if coresymlinks then check probesymlink $ return Nothing @@ -86,9 +86,9 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks | otherwise -> return Nothing Nothing -> fallback - probesymlink = R.readSymbolicLink file + probesymlink = R.readSymbolicLink (fromOsPath file) - probefilecontent = F.withFile (toOsPath file) ReadMode $ \h -> do + probefilecontent = F.withFile file ReadMode $ \h -> do s <- S.hGet h maxSymlinkSz -- If we got the full amount, the file is too large -- to be a symlink target. @@ -103,7 +103,7 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks then mempty else s -makeAnnexLink :: LinkTarget -> RawFilePath -> Annex () +makeAnnexLink :: LinkTarget -> OsPath -> Annex () makeAnnexLink = makeGitLink {- Creates a link on disk. @@ -113,26 +113,31 @@ makeAnnexLink = makeGitLink - it's staged as such, so use addAnnexLink when adding a new file or - modified link to git. -} -makeGitLink :: LinkTarget -> RawFilePath -> Annex () +makeGitLink :: LinkTarget -> OsPath -> Annex () makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) ( liftIO $ do - void $ tryIO $ R.removeLink file - R.createSymbolicLink linktarget file - , liftIO $ F.writeFile' (toOsPath file) linktarget + void $ tryIO $ R.removeLink file' + R.createSymbolicLink linktarget file' + , liftIO $ F.writeFile' file linktarget ) + where + file' = fromOsPath file {- Creates a link on disk, and additionally stages it in git. -} -addAnnexLink :: LinkTarget -> RawFilePath -> Annex () +addAnnexLink :: LinkTarget -> OsPath -> Annex () addAnnexLink linktarget file = do makeAnnexLink linktarget file stageSymlink file =<< hashSymlink linktarget {- Injects a symlink target into git, returning its Sha. -} hashSymlink :: LinkTarget -> Annex Sha -hashSymlink = hashBlob . toInternalGitPath +hashSymlink = go . fromOsPath . toInternalGitPath . toOsPath + where + go :: LinkTarget -> Annex Sha + go = hashBlob {- Stages a symlink to an annexed object, using a Sha of its target. -} -stageSymlink :: RawFilePath -> Sha -> Annex () +stageSymlink :: OsPath -> Sha -> Annex () stageSymlink file sha = Annex.Queue.addUpdateIndex =<< inRepo (Git.UpdateIndex.stageSymlink file sha) @@ -142,7 +147,7 @@ hashPointerFile :: Key -> Annex Sha hashPointerFile key = hashBlob $ formatPointer key {- Stages a pointer file, using a Sha of its content -} -stagePointerFile :: RawFilePath -> Maybe FileMode -> Sha -> Annex () +stagePointerFile :: OsPath -> Maybe FileMode -> Sha -> Annex () stagePointerFile file mode sha = Annex.Queue.addUpdateIndex =<< inRepo (Git.UpdateIndex.stageFile sha treeitemtype file) @@ -151,10 +156,10 @@ stagePointerFile file mode sha = | maybe False isExecutable mode = TreeExecutable | otherwise = TreeFile -writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO () +writePointerFile :: OsPath -> Key -> Maybe FileMode -> IO () writePointerFile file k mode = do - F.writeFile' (toOsPath file) (formatPointer k) - maybe noop (R.setFileMode file) mode + F.writeFile' file (formatPointer k) + maybe noop (R.setFileMode (fromOsPath file)) mode newtype Restage = Restage Bool @@ -187,7 +192,7 @@ newtype Restage = Restage Bool - if the process is interrupted before the git queue is fulushed, the - restage will be taken care of later. -} -restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex () +restagePointerFile :: Restage -> OsPath -> InodeCache -> Annex () restagePointerFile (Restage False) f orig = do flip writeRestageLog orig =<< inRepo (toTopFilePath f) toplevelWarning True $ unableToRestage $ Just f @@ -225,17 +230,18 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do =<< Annex.getRead Annex.keysdbhandle realindex <- liftIO $ Git.Index.currentIndexFile r numsz@(numfiles, _) <- calcnumsz - let lock = fromRawFilePath (Git.Index.indexFileLock realindex) + let lock = Git.Index.indexFileLock realindex lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock unlockindex = liftIO . maybe noop Git.LockFile.closeLock showwarning = warning $ unableToRestage Nothing go Nothing = showwarning go (Just _) = withtmpdir $ \tmpdir -> do tsd <- getTSDelta - let tmpindex = toRawFilePath (tmpdir "index") + let tmpindex = tmpdir literalOsPath "index" let replaceindex = liftIO $ moveFile tmpindex realindex let updatetmpindex = do r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv + . fromOsPath =<< Git.Index.indexEnvVal tmpindex configfilterprocess numsz $ runupdateindex tsd r' replaceindex @@ -247,8 +253,8 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do bracket lockindex unlockindex go where withtmpdir = withTmpDirIn - (fromRawFilePath $ Git.localGitDir r) - (toOsPath "annexindex") + (Git.localGitDir r) + (literalOsPath "annexindex") isunmodified tsd f orig = genInodeCache f tsd >>= return . \case @@ -325,7 +331,7 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do ck = ConfigKey "filter.annex.process" ckd = ConfigKey "filter.annex.process-temp-disabled" -unableToRestage :: Maybe RawFilePath -> StringContainingQuotedPath +unableToRestage :: Maybe OsPath -> StringContainingQuotedPath unableToRestage mf = "git status will show " <> maybe "some files" QuotedPath mf <> " to be modified, since content availability has changed" @@ -361,7 +367,8 @@ parseLinkTargetOrPointer' b = Nothing -> Right Nothing where parsekey l - | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l + | isLinkToAnnex l = fileKey $ toOsPath $ + snd $ S8.breakEnd pathsep l | otherwise = Nothing restvalid r @@ -400,9 +407,9 @@ parseLinkTargetOrPointerLazy' b = in parseLinkTargetOrPointer' (L.toStrict b') formatPointer :: Key -> S.ByteString -formatPointer k = prefix <> keyFile k <> nl +formatPointer k = fromOsPath prefix <> fromOsPath (keyFile k) <> nl where - prefix = toInternalGitPath $ P.pathSeparator `S.cons` objectDir + prefix = toInternalGitPath $ pathSeparator `OS.cons` objectDir nl = S8.singleton '\n' {- Maximum size of a file that could be a pointer to a key. @@ -434,21 +441,21 @@ maxSymlinkSz = 8192 - an object that looks like a pointer file. Or that a non-annex - symlink does. Avoids a false positive in those cases. - -} -isPointerFile :: RawFilePath -> IO (Maybe Key) +isPointerFile :: OsPath -> IO (Maybe Key) isPointerFile f = catchDefaultIO Nothing $ #if defined(mingw32_HOST_OS) - F.withFile (toOsPath f) ReadMode readhandle + F.withFile f ReadMode readhandle #else #if MIN_VERSION_unix(2,8,0) let open = do - fd <- openFd (fromRawFilePath f) ReadOnly + fd <- openFd (fromOsPath f) ReadOnly (defaultFileFlags { nofollow = True }) fdToHandle fd in bracket open hClose readhandle #else - ifM (isSymbolicLink <$> R.getSymbolicLinkStatus f) + ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f)) ( return Nothing - , F.withFile (toOsPath f) ReadMode readhandle + , F.withFile f ReadMode readhandle ) #endif #endif @@ -463,13 +470,13 @@ isPointerFile f = catchDefaultIO Nothing $ - than .git to be used. -} isLinkToAnnex :: S.ByteString -> Bool -isLinkToAnnex s = p `S.isInfixOf` s +isLinkToAnnex s = p `OS.isInfixOf` (toOsPath s) #ifdef mingw32_HOST_OS -- '/' is used inside pointer files on Windows, not the native '\' - || p' `S.isInfixOf` s + || p' `OS.isInfixOf` s #endif where - p = P.pathSeparator `S.cons` objectDir + p = pathSeparator `OS.cons` objectDir #ifdef mingw32_HOST_OS p' = toInternalGitPath p #endif diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 5d7e75f58c..77b761b6de 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -120,7 +120,7 @@ import Data.Char import Data.Default import qualified Data.List.NonEmpty as NE import qualified Data.ByteString.Char8 as S8 -import qualified System.FilePath.ByteString as P +import qualified Data.ByteString.Short as SB import Common import Key @@ -134,7 +134,6 @@ import qualified Git.Types as Git import Git.FilePath import Annex.DirHashes import Annex.Fixup -import qualified Utility.RawFilePath as R {- Conventions: - @@ -151,13 +150,13 @@ import qualified Utility.RawFilePath as R {- The directory git annex uses for local state, relative to the .git - directory -} -annexDir :: RawFilePath -annexDir = P.addTrailingPathSeparator "annex" +annexDir :: OsPath +annexDir = addTrailingPathSeparator (literalOsPath "annex") {- The directory git annex uses for locally available object content, - relative to the .git directory -} -objectDir :: RawFilePath -objectDir = P.addTrailingPathSeparator $ annexDir P. "objects" +objectDir :: OsPath +objectDir = addTrailingPathSeparator $ annexDir literalOsPath "objects" {- Annexed file's possible locations relative to the .git directory - in a non-bare eepository. @@ -165,24 +164,24 @@ objectDir = P.addTrailingPathSeparator $ annexDir P. "objects" - Normally it is hashDirMixed. However, it's always possible that a - bare repository was converted to non-bare, or that the cripped - filesystem setting changed, so still need to check both. -} -annexLocationsNonBare :: GitConfig -> Key -> [RawFilePath] +annexLocationsNonBare :: GitConfig -> Key -> [OsPath] annexLocationsNonBare config key = map (annexLocation config key) [hashDirMixed, hashDirLower] {- Annexed file's possible locations relative to a bare repository. -} -annexLocationsBare :: GitConfig -> Key -> [RawFilePath] +annexLocationsBare :: GitConfig -> Key -> [OsPath] annexLocationsBare config key = map (annexLocation config key) [hashDirLower, hashDirMixed] -annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> RawFilePath -annexLocation config key hasher = objectDir P. keyPath key (hasher $ objectHashLevels config) +annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> OsPath +annexLocation config key hasher = objectDir keyPath key (hasher $ objectHashLevels config) {- For exportree remotes with annexobjects=true, objects are stored - in this location as well as in the exported tree. -} exportAnnexObjectLocation :: GitConfig -> Key -> ExportLocation exportAnnexObjectLocation gc k = mkExportLocation $ - ".git" P. annexLocation gc k hashDirLower + literalOsPath ".git" annexLocation gc k hashDirLower {- Number of subdirectories from the gitAnnexObjectDir - to the gitAnnexLocation. -} @@ -199,17 +198,17 @@ gitAnnexLocationDepth config = hashlevels + 1 - When the file is not present, returns the location where the file should - be stored. -} -gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO RawFilePath -gitAnnexLocation = gitAnnexLocation' R.doesPathExist +gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO OsPath +gitAnnexLocation = gitAnnexLocation' doesPathExist -gitAnnexLocation' :: (RawFilePath -> IO Bool) -> Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexLocation' :: (OsPath -> IO Bool) -> Key -> Git.Repo -> GitConfig -> IO OsPath gitAnnexLocation' checker key r config = gitAnnexLocation'' key r config (annexCrippledFileSystem config) (coreSymlinks config) checker (Git.localGitDir r) -gitAnnexLocation'' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (RawFilePath -> IO Bool) -> RawFilePath -> IO RawFilePath +gitAnnexLocation'' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (OsPath -> IO Bool) -> OsPath -> IO OsPath gitAnnexLocation'' key r config crippled symlinkssupported checker gitdir {- Bare repositories default to hashDirLower for new - content, as it's more portable. But check all locations. -} @@ -228,14 +227,14 @@ gitAnnexLocation'' key r config crippled symlinkssupported checker gitdir only = return . inrepo . annexLocation config key checkall f = check $ map inrepo $ f config key - inrepo d = gitdir P. d + inrepo d = gitdir d check locs@(l:_) = fromMaybe l <$> firstM checker locs check [] = error "internal" {- Calculates a symlink target to link a file to an annexed object. -} -gitAnnexLink :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexLink :: OsPath -> Key -> Git.Repo -> GitConfig -> IO OsPath gitAnnexLink file key r config = do - currdir <- R.getCurrentDirectory + currdir <- getCurrentDirectory let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir loc <- gitAnnexLocation'' key r config False False (\_ -> return True) gitdir @@ -246,19 +245,19 @@ gitAnnexLink file key r config = do - supporting symlinks; generate link target that will - work portably. -} | not (coreSymlinks config) && needsSubmoduleFixup r = - absNormPathUnix currdir (Git.repoPath r P. ".git") + absNormPathUnix currdir (Git.repoPath r literalOsPath ".git") | otherwise = Git.localGitDir r 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 :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexLinkCanonical :: OsPath -> Key -> Git.Repo -> GitConfig -> IO OsPath gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config' where r' = case r of Git.Repo { Git.location = l@Git.Local { Git.worktree = Just wt } } -> - r { Git.location = l { Git.gitdir = wt P. ".git" } } + r { Git.location = l { Git.gitdir = wt literalOsPath ".git" } } _ -> r config' = config { annexCrippledFileSystem = False @@ -266,23 +265,23 @@ gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config' } {- File used to lock a key's content. -} -gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO OsPath gitAnnexContentLock key r config = do loc <- gitAnnexLocation key r config - return $ loc <> ".lck" + return $ loc <> literalOsPath ".lck" {- File used to indicate a key's content should not be dropped until after - a specified time. -} -gitAnnexContentRetentionTimestamp :: Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexContentRetentionTimestamp :: Key -> Git.Repo -> GitConfig -> IO OsPath gitAnnexContentRetentionTimestamp key r config = do loc <- gitAnnexLocation key r config - return $ loc <> ".rtm" + return $ loc <> literalOsPath ".rtm" {- Lock file for gitAnnexContentRetentionTimestamp -} -gitAnnexContentRetentionTimestampLock :: Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexContentRetentionTimestampLock :: Key -> Git.Repo -> GitConfig -> IO OsPath gitAnnexContentRetentionTimestampLock key r config = do loc <- gitAnnexLocation key r config - return $ loc <> ".rtl" + return $ loc <> literalOsPath ".rtl" {- Lock that is held when taking the gitAnnexContentLock to support the v10 - upgrade. @@ -292,52 +291,52 @@ gitAnnexContentRetentionTimestampLock key r config = do - is mounted read-only. The gitAnnexInodeSentinal is created by git-annex - init, so should already exist. -} -gitAnnexContentLockLock :: Git.Repo -> RawFilePath +gitAnnexContentLockLock :: Git.Repo -> OsPath gitAnnexContentLockLock = gitAnnexInodeSentinal -gitAnnexInodeSentinal :: Git.Repo -> RawFilePath -gitAnnexInodeSentinal r = gitAnnexDir r P. "sentinal" +gitAnnexInodeSentinal :: Git.Repo -> OsPath +gitAnnexInodeSentinal r = gitAnnexDir r literalOsPath "sentinal" -gitAnnexInodeSentinalCache :: Git.Repo -> RawFilePath -gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> ".cache" +gitAnnexInodeSentinalCache :: Git.Repo -> OsPath +gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> literalOsPath ".cache" {- The annex directory of a repository. -} -gitAnnexDir :: Git.Repo -> RawFilePath -gitAnnexDir r = P.addTrailingPathSeparator $ Git.localGitDir r P. annexDir +gitAnnexDir :: Git.Repo -> OsPath +gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r annexDir {- The part of the annex directory where file contents are stored. -} -gitAnnexObjectDir :: Git.Repo -> RawFilePath -gitAnnexObjectDir r = P.addTrailingPathSeparator $ - Git.localGitDir r P. objectDir +gitAnnexObjectDir :: Git.Repo -> OsPath +gitAnnexObjectDir r = addTrailingPathSeparator $ + Git.localGitDir r objectDir {- .git/annex/tmp/ is used for temp files for key's contents -} -gitAnnexTmpObjectDir :: Git.Repo -> RawFilePath -gitAnnexTmpObjectDir r = P.addTrailingPathSeparator $ - gitAnnexDir r P. "tmp" +gitAnnexTmpObjectDir :: Git.Repo -> OsPath +gitAnnexTmpObjectDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "tmp" {- .git/annex/othertmp/ is used for other temp files -} -gitAnnexTmpOtherDir :: Git.Repo -> RawFilePath -gitAnnexTmpOtherDir r = P.addTrailingPathSeparator $ - gitAnnexDir r P. "othertmp" +gitAnnexTmpOtherDir :: Git.Repo -> OsPath +gitAnnexTmpOtherDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "othertmp" {- Lock file for gitAnnexTmpOtherDir. -} -gitAnnexTmpOtherLock :: Git.Repo -> RawFilePath -gitAnnexTmpOtherLock r = gitAnnexDir r P. "othertmp.lck" +gitAnnexTmpOtherLock :: Git.Repo -> OsPath +gitAnnexTmpOtherLock r = gitAnnexDir r literalOsPath "othertmp.lck" {- .git/annex/misctmp/ was used by old versions of git-annex and is still - used during initialization -} -gitAnnexTmpOtherDirOld :: Git.Repo -> RawFilePath -gitAnnexTmpOtherDirOld r = P.addTrailingPathSeparator $ - gitAnnexDir r P. "misctmp" +gitAnnexTmpOtherDirOld :: Git.Repo -> OsPath +gitAnnexTmpOtherDirOld r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "misctmp" {- .git/annex/watchtmp/ is used by the watcher and assistant -} -gitAnnexTmpWatcherDir :: Git.Repo -> RawFilePath -gitAnnexTmpWatcherDir r = P.addTrailingPathSeparator $ - gitAnnexDir r P. "watchtmp" +gitAnnexTmpWatcherDir :: Git.Repo -> OsPath +gitAnnexTmpWatcherDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "watchtmp" {- The temp file to use for a given key's content. -} -gitAnnexTmpObjectLocation :: Key -> Git.Repo -> RawFilePath -gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r P. keyFile key +gitAnnexTmpObjectLocation :: Key -> Git.Repo -> OsPath +gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r 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 @@ -346,339 +345,351 @@ gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r P. keyFile key - There are ordering requirements for creating these directories; - use Annex.Content.withTmpWorkDir to set them up. -} -gitAnnexTmpWorkDir :: RawFilePath -> RawFilePath +gitAnnexTmpWorkDir :: OsPath -> OsPath gitAnnexTmpWorkDir p = - let (dir, f) = P.splitFileName p + let (dir, f) = splitFileName p -- Using a prefix avoids name conflict with any other keys. - in dir P. "work." <> f + in dir literalOsPath "work." <> f {- .git/annex/bad/ is used for bad files found during fsck -} -gitAnnexBadDir :: Git.Repo -> RawFilePath -gitAnnexBadDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "bad" +gitAnnexBadDir :: Git.Repo -> OsPath +gitAnnexBadDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "bad" {- The bad file to use for a given key. -} -gitAnnexBadLocation :: Key -> Git.Repo -> RawFilePath -gitAnnexBadLocation key r = gitAnnexBadDir r P. keyFile key +gitAnnexBadLocation :: Key -> Git.Repo -> OsPath +gitAnnexBadLocation key r = gitAnnexBadDir r keyFile key {- .git/annex/foounused is used to number possibly unused keys -} -gitAnnexUnusedLog :: RawFilePath -> Git.Repo -> RawFilePath -gitAnnexUnusedLog prefix r = gitAnnexDir r P. (prefix <> "unused") +gitAnnexUnusedLog :: OsPath -> Git.Repo -> OsPath +gitAnnexUnusedLog prefix r = + gitAnnexDir r (prefix <> literalOsPath "unused") {- .git/annex/keysdb/ contains a database of information about keys. -} -gitAnnexKeysDbDir :: Git.Repo -> GitConfig -> RawFilePath -gitAnnexKeysDbDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P. "keysdb" +gitAnnexKeysDbDir :: Git.Repo -> GitConfig -> OsPath +gitAnnexKeysDbDir r c = + fromMaybe (gitAnnexDir r) (annexDbDir c) literalOsPath "keysdb" {- Lock file for the keys database. -} -gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> RawFilePath -gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> ".lck" +gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> OsPath +gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> literalOsPath ".lck" {- Contains the stat of the last index file that was - reconciled with the keys database. -} -gitAnnexKeysDbIndexCache :: Git.Repo -> GitConfig -> RawFilePath -gitAnnexKeysDbIndexCache r c = gitAnnexKeysDbDir r c <> ".cache" +gitAnnexKeysDbIndexCache :: Git.Repo -> GitConfig -> OsPath +gitAnnexKeysDbIndexCache r c = + gitAnnexKeysDbDir r c <> literalOsPath ".cache" {- .git/annex/fsck/uuid/ is used to store information about incremental - fscks. -} -gitAnnexFsckDir :: UUID -> Git.Repo -> Maybe GitConfig -> RawFilePath +gitAnnexFsckDir :: UUID -> Git.Repo -> Maybe GitConfig -> OsPath gitAnnexFsckDir u r mc = case annexDbDir =<< mc of Nothing -> go (gitAnnexDir r) Just d -> go d where - go d = d P. "fsck" P. fromUUID u + go d = d literalOsPath "fsck" fromUUID u {- used to store information about incremental fscks. -} -gitAnnexFsckState :: UUID -> Git.Repo -> RawFilePath -gitAnnexFsckState u r = gitAnnexFsckDir u r Nothing P. "state" +gitAnnexFsckState :: UUID -> Git.Repo -> OsPath +gitAnnexFsckState u r = gitAnnexFsckDir u r Nothing literalOsPath "state" {- Directory containing database used to record fsck info. -} -gitAnnexFsckDbDir :: UUID -> Git.Repo -> GitConfig -> RawFilePath -gitAnnexFsckDbDir u r c = gitAnnexFsckDir u r (Just c) P. "fsckdb" +gitAnnexFsckDbDir :: UUID -> Git.Repo -> GitConfig -> OsPath +gitAnnexFsckDbDir u r c = gitAnnexFsckDir u r (Just c) literalOsPath "fsckdb" {- Directory containing old database used to record fsck info. -} -gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> GitConfig -> RawFilePath -gitAnnexFsckDbDirOld u r c = gitAnnexFsckDir u r (Just c) P. "db" +gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> GitConfig -> OsPath +gitAnnexFsckDbDirOld u r c = gitAnnexFsckDir u r (Just c) literalOsPath "db" {- Lock file for the fsck database. -} -gitAnnexFsckDbLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath -gitAnnexFsckDbLock u r c = gitAnnexFsckDir u r (Just c) P. "fsck.lck" +gitAnnexFsckDbLock :: UUID -> Git.Repo -> GitConfig -> OsPath +gitAnnexFsckDbLock u r c = gitAnnexFsckDir u r (Just c) literalOsPath "fsck.lck" {- .git/annex/fsckresults/uuid is used to store results of git fscks -} -gitAnnexFsckResultsLog :: UUID -> Git.Repo -> RawFilePath +gitAnnexFsckResultsLog :: UUID -> Git.Repo -> OsPath gitAnnexFsckResultsLog u r = - gitAnnexDir r P. "fsckresults" P. fromUUID u + gitAnnexDir r literalOsPath "fsckresults" fromUUID u {- .git/annex/upgrade.log is used to record repository version upgrades. -} -gitAnnexUpgradeLog :: Git.Repo -> RawFilePath -gitAnnexUpgradeLog r = gitAnnexDir r P. "upgrade.log" +gitAnnexUpgradeLog :: Git.Repo -> OsPath +gitAnnexUpgradeLog r = gitAnnexDir r literalOsPath "upgrade.log" -gitAnnexUpgradeLock :: Git.Repo -> RawFilePath -gitAnnexUpgradeLock r = gitAnnexDir r P. "upgrade.lck" +gitAnnexUpgradeLock :: Git.Repo -> OsPath +gitAnnexUpgradeLock r = gitAnnexDir r literalOsPath "upgrade.lck" {- .git/annex/smudge.log is used to log smudged worktree files that need to - be updated. -} -gitAnnexSmudgeLog :: Git.Repo -> RawFilePath -gitAnnexSmudgeLog r = gitAnnexDir r P. "smudge.log" +gitAnnexSmudgeLog :: Git.Repo -> OsPath +gitAnnexSmudgeLog r = gitAnnexDir r literalOsPath "smudge.log" -gitAnnexSmudgeLock :: Git.Repo -> RawFilePath -gitAnnexSmudgeLock r = gitAnnexDir r P. "smudge.lck" +gitAnnexSmudgeLock :: Git.Repo -> OsPath +gitAnnexSmudgeLock r = gitAnnexDir r literalOsPath "smudge.lck" {- .git/annex/restage.log is used to log worktree files that need to be - restaged in git -} -gitAnnexRestageLog :: Git.Repo -> RawFilePath -gitAnnexRestageLog r = gitAnnexDir r P. "restage.log" +gitAnnexRestageLog :: Git.Repo -> OsPath +gitAnnexRestageLog r = gitAnnexDir r literalOsPath "restage.log" {- .git/annex/restage.old is used while restaging files in git -} -gitAnnexRestageLogOld :: Git.Repo -> RawFilePath -gitAnnexRestageLogOld r = gitAnnexDir r P. "restage.old" +gitAnnexRestageLogOld :: Git.Repo -> OsPath +gitAnnexRestageLogOld r = gitAnnexDir r literalOsPath "restage.old" -gitAnnexRestageLock :: Git.Repo -> RawFilePath -gitAnnexRestageLock r = gitAnnexDir r P. "restage.lck" +gitAnnexRestageLock :: Git.Repo -> OsPath +gitAnnexRestageLock r = gitAnnexDir r literalOsPath "restage.lck" {- .git/annex/adjust.log is used to log when the adjusted branch needs to - be updated. -} -gitAnnexAdjustedBranchUpdateLog :: Git.Repo -> RawFilePath -gitAnnexAdjustedBranchUpdateLog r = gitAnnexDir r P. "adjust.log" +gitAnnexAdjustedBranchUpdateLog :: Git.Repo -> OsPath +gitAnnexAdjustedBranchUpdateLog r = gitAnnexDir r literalOsPath "adjust.log" -gitAnnexAdjustedBranchUpdateLock :: Git.Repo -> RawFilePath -gitAnnexAdjustedBranchUpdateLock r = gitAnnexDir r P. "adjust.lck" +gitAnnexAdjustedBranchUpdateLock :: Git.Repo -> OsPath +gitAnnexAdjustedBranchUpdateLock r = gitAnnexDir r literalOsPath "adjust.lck" {- .git/annex/migrate.log is used to log migrations before committing them. -} -gitAnnexMigrateLog :: Git.Repo -> RawFilePath -gitAnnexMigrateLog r = gitAnnexDir r P. "migrate.log" +gitAnnexMigrateLog :: Git.Repo -> OsPath +gitAnnexMigrateLog r = gitAnnexDir r literalOsPath "migrate.log" -gitAnnexMigrateLock :: Git.Repo -> RawFilePath -gitAnnexMigrateLock r = gitAnnexDir r P. "migrate.lck" +gitAnnexMigrateLock :: Git.Repo -> OsPath +gitAnnexMigrateLock r = gitAnnexDir r literalOsPath "migrate.lck" {- .git/annex/migrations.log is used to log committed migrations. -} -gitAnnexMigrationsLog :: Git.Repo -> RawFilePath -gitAnnexMigrationsLog r = gitAnnexDir r P. "migrations.log" +gitAnnexMigrationsLog :: Git.Repo -> OsPath +gitAnnexMigrationsLog r = gitAnnexDir r literalOsPath "migrations.log" -gitAnnexMigrationsLock :: Git.Repo -> RawFilePath -gitAnnexMigrationsLock r = gitAnnexDir r P. "migrations.lck" +gitAnnexMigrationsLock :: Git.Repo -> OsPath +gitAnnexMigrationsLock r = gitAnnexDir r literalOsPath "migrations.lck" {- .git/annex/move.log is used to log moves that are in progress, - to better support resuming an interrupted move. -} -gitAnnexMoveLog :: Git.Repo -> RawFilePath -gitAnnexMoveLog r = gitAnnexDir r P. "move.log" +gitAnnexMoveLog :: Git.Repo -> OsPath +gitAnnexMoveLog r = gitAnnexDir r literalOsPath "move.log" -gitAnnexMoveLock :: Git.Repo -> RawFilePath -gitAnnexMoveLock r = gitAnnexDir r P. "move.lck" +gitAnnexMoveLock :: Git.Repo -> OsPath +gitAnnexMoveLock r = gitAnnexDir r literalOsPath "move.lck" {- .git/annex/export/ is used to store information about - exports to special remotes. -} -gitAnnexExportDir :: Git.Repo -> GitConfig -> RawFilePath -gitAnnexExportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P. "export" +gitAnnexExportDir :: Git.Repo -> GitConfig -> OsPath +gitAnnexExportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) + literalOsPath "export" {- Directory containing database used to record export info. -} -gitAnnexExportDbDir :: UUID -> Git.Repo -> GitConfig -> RawFilePath +gitAnnexExportDbDir :: UUID -> Git.Repo -> GitConfig -> OsPath gitAnnexExportDbDir u r c = - gitAnnexExportDir r c P. fromUUID u P. "exportdb" + gitAnnexExportDir r c fromUUID u literalOsPath "exportdb" {- Lock file for export database. -} -gitAnnexExportLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath -gitAnnexExportLock u r c = gitAnnexExportDbDir u r c <> ".lck" +gitAnnexExportLock :: UUID -> Git.Repo -> GitConfig -> OsPath +gitAnnexExportLock u r c = gitAnnexExportDbDir u r c <> literalOsPath ".lck" {- Lock file for updating the export database with information from the - repository. -} -gitAnnexExportUpdateLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath -gitAnnexExportUpdateLock u r c = gitAnnexExportDbDir u r c <> ".upl" +gitAnnexExportUpdateLock :: UUID -> Git.Repo -> GitConfig -> OsPath +gitAnnexExportUpdateLock u r c = gitAnnexExportDbDir u r c <> literalOsPath ".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 -> RawFilePath -gitAnnexExportExcludeLog u r = gitAnnexDir r P. "export.ex" P. fromUUID u +gitAnnexExportExcludeLog :: UUID -> Git.Repo -> OsPath +gitAnnexExportExcludeLog u r = gitAnnexDir r + literalOsPath "export.ex" 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 -> GitConfig -> RawFilePath +gitAnnexContentIdentifierDbDir :: Git.Repo -> GitConfig -> OsPath gitAnnexContentIdentifierDbDir r c = - fromMaybe (gitAnnexDir r) (annexDbDir c) P. "cidsdb" + fromMaybe (gitAnnexDir r) (annexDbDir c) literalOsPath "cidsdb" {- Lock file for writing to the content id database. -} -gitAnnexContentIdentifierLock :: Git.Repo -> GitConfig -> RawFilePath -gitAnnexContentIdentifierLock r c = gitAnnexContentIdentifierDbDir r c <> ".lck" +gitAnnexContentIdentifierLock :: Git.Repo -> GitConfig -> OsPath +gitAnnexContentIdentifierLock r c = + gitAnnexContentIdentifierDbDir r c <> literalOsPath ".lck" {- .git/annex/import/ is used to store information about - imports from special remotes. -} -gitAnnexImportDir :: Git.Repo -> GitConfig -> RawFilePath -gitAnnexImportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P. "import" +gitAnnexImportDir :: Git.Repo -> GitConfig -> OsPath +gitAnnexImportDir r c = + fromMaybe (gitAnnexDir r) (annexDbDir c) literalOsPath "import" {- File containing state about the last import done from a remote. -} -gitAnnexImportLog :: UUID -> Git.Repo -> GitConfig -> RawFilePath -gitAnnexImportLog u r c = - gitAnnexImportDir r c P. fromUUID u P. "log" +gitAnnexImportLog :: UUID -> Git.Repo -> GitConfig -> OsPath +gitAnnexImportLog u r c = + gitAnnexImportDir r c fromUUID u literalOsPath "log" {- Directory containing database used by importfeed. -} -gitAnnexImportFeedDbDir :: Git.Repo -> GitConfig -> RawFilePath +gitAnnexImportFeedDbDir :: Git.Repo -> GitConfig -> OsPath gitAnnexImportFeedDbDir r c = - fromMaybe (gitAnnexDir r) (annexDbDir c) P. "importfeed" + fromMaybe (gitAnnexDir r) (annexDbDir c) literalOsPath "importfeed" {- Lock file for writing to the importfeed database. -} -gitAnnexImportFeedDbLock :: Git.Repo -> GitConfig -> RawFilePath -gitAnnexImportFeedDbLock r c = gitAnnexImportFeedDbDir r c <> ".lck" +gitAnnexImportFeedDbLock :: Git.Repo -> GitConfig -> OsPath +gitAnnexImportFeedDbLock r c = + gitAnnexImportFeedDbDir r c <> literalOsPath ".lck" {- Directory containing reposize database. -} -gitAnnexRepoSizeDbDir :: Git.Repo -> GitConfig -> RawFilePath +gitAnnexRepoSizeDbDir :: Git.Repo -> GitConfig -> OsPath gitAnnexRepoSizeDbDir r c = - fromMaybe (gitAnnexDir r) (annexDbDir c) P. "reposize" P. "db" + fromMaybe (gitAnnexDir r) (annexDbDir c) literalOsPath "reposize" literalOsPath "db" {- Lock file for the reposize database. -} -gitAnnexRepoSizeDbLock :: Git.Repo -> GitConfig -> RawFilePath +gitAnnexRepoSizeDbLock :: Git.Repo -> GitConfig -> OsPath gitAnnexRepoSizeDbLock r c = - fromMaybe (gitAnnexDir r) (annexDbDir c) P. "reposize" P. "lock" + fromMaybe (gitAnnexDir r) (annexDbDir c) literalOsPath "reposize" literalOsPath "lock" {- Directory containing liveness pid files. -} -gitAnnexRepoSizeLiveDir :: Git.Repo -> GitConfig -> RawFilePath +gitAnnexRepoSizeLiveDir :: Git.Repo -> GitConfig -> OsPath gitAnnexRepoSizeLiveDir r c = - fromMaybe (gitAnnexDir r) (annexDbDir c) P. "reposize" P. "live" + fromMaybe (gitAnnexDir r) (annexDbDir c) literalOsPath "reposize" literalOsPath "live" {- .git/annex/schedulestate is used to store information about when - scheduled jobs were last run. -} -gitAnnexScheduleState :: Git.Repo -> RawFilePath -gitAnnexScheduleState r = gitAnnexDir r P. "schedulestate" +gitAnnexScheduleState :: Git.Repo -> OsPath +gitAnnexScheduleState r = gitAnnexDir r literalOsPath "schedulestate" {- .git/annex/creds/ is used to store credentials to access some special - remotes. -} -gitAnnexCredsDir :: Git.Repo -> RawFilePath -gitAnnexCredsDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "creds" +gitAnnexCredsDir :: Git.Repo -> OsPath +gitAnnexCredsDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "creds" {- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp - when HTTPS is enabled -} -gitAnnexWebCertificate :: Git.Repo -> FilePath -gitAnnexWebCertificate r = fromRawFilePath $ gitAnnexDir r P. "certificate.pem" -gitAnnexWebPrivKey :: Git.Repo -> FilePath -gitAnnexWebPrivKey r = fromRawFilePath $ gitAnnexDir r P. "privkey.pem" +gitAnnexWebCertificate :: Git.Repo -> OsPath +gitAnnexWebCertificate r = gitAnnexDir r literalOsPath "certificate.pem" +gitAnnexWebPrivKey :: Git.Repo -> OsPath +gitAnnexWebPrivKey r = gitAnnexDir r literalOsPath "privkey.pem" {- .git/annex/feeds/ is used to record per-key (url) state by importfeed -} -gitAnnexFeedStateDir :: Git.Repo -> RawFilePath -gitAnnexFeedStateDir r = P.addTrailingPathSeparator $ - gitAnnexDir r P. "feedstate" +gitAnnexFeedStateDir :: Git.Repo -> OsPath +gitAnnexFeedStateDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "feedstate" -gitAnnexFeedState :: Key -> Git.Repo -> RawFilePath -gitAnnexFeedState k r = gitAnnexFeedStateDir r P. keyFile k +gitAnnexFeedState :: Key -> Git.Repo -> OsPath +gitAnnexFeedState k r = gitAnnexFeedStateDir r keyFile k {- .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" +gitAnnexMergeDir :: Git.Repo -> OsPath +gitAnnexMergeDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "merge" {- .git/annex/transfer/ is used to record keys currently - being transferred, and other transfer bookkeeping info. -} -gitAnnexTransferDir :: Git.Repo -> RawFilePath +gitAnnexTransferDir :: Git.Repo -> OsPath gitAnnexTransferDir r = - P.addTrailingPathSeparator $ gitAnnexDir r P. "transfer" + addTrailingPathSeparator $ gitAnnexDir r literalOsPath "transfer" {- .git/annex/journal/ is used to journal changes made to the git-annex - branch -} -gitAnnexJournalDir :: BranchState -> Git.Repo -> RawFilePath -gitAnnexJournalDir st r = P.addTrailingPathSeparator $ +gitAnnexJournalDir :: BranchState -> Git.Repo -> OsPath +gitAnnexJournalDir st r = addTrailingPathSeparator $ case alternateJournal st of - Nothing -> gitAnnexDir r P. "journal" + Nothing -> gitAnnexDir r literalOsPath "journal" Just d -> d {- .git/annex/journal.private/ is used to journal changes regarding private - repositories. -} -gitAnnexPrivateJournalDir :: BranchState -> Git.Repo -> RawFilePath -gitAnnexPrivateJournalDir st r = P.addTrailingPathSeparator $ +gitAnnexPrivateJournalDir :: BranchState -> Git.Repo -> OsPath +gitAnnexPrivateJournalDir st r = addTrailingPathSeparator $ case alternateJournal st of - Nothing -> gitAnnexDir r P. "journal-private" + Nothing -> gitAnnexDir r literalOsPath "journal-private" Just d -> d {- Lock file for the journal. -} -gitAnnexJournalLock :: Git.Repo -> RawFilePath -gitAnnexJournalLock r = gitAnnexDir r P. "journal.lck" +gitAnnexJournalLock :: Git.Repo -> OsPath +gitAnnexJournalLock r = gitAnnexDir r literalOsPath "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 -> RawFilePath -gitAnnexGitQueueLock r = gitAnnexDir r P. "gitqueue.lck" +gitAnnexGitQueueLock :: Git.Repo -> OsPath +gitAnnexGitQueueLock r = gitAnnexDir r literalOsPath "gitqueue.lck" {- .git/annex/index is used to stage changes to the git-annex branch -} -gitAnnexIndex :: Git.Repo -> RawFilePath -gitAnnexIndex r = gitAnnexDir r P. "index" +gitAnnexIndex :: Git.Repo -> OsPath +gitAnnexIndex r = gitAnnexDir r literalOsPath "index" {- .git/annex/index-private is used to store information that is not to - be exposed to the git-annex branch. -} -gitAnnexPrivateIndex :: Git.Repo -> RawFilePath -gitAnnexPrivateIndex r = gitAnnexDir r P. "index-private" +gitAnnexPrivateIndex :: Git.Repo -> OsPath +gitAnnexPrivateIndex r = gitAnnexDir r literalOsPath "index-private" {- Holds the sha 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 -> RawFilePath -gitAnnexIndexStatus r = gitAnnexDir r P. "index.lck" +gitAnnexIndexStatus :: Git.Repo -> OsPath +gitAnnexIndexStatus r = gitAnnexDir r literalOsPath "index.lck" {- The index file used to generate a filtered branch view._-} -gitAnnexViewIndex :: Git.Repo -> RawFilePath -gitAnnexViewIndex r = gitAnnexDir r P. "viewindex" +gitAnnexViewIndex :: Git.Repo -> OsPath +gitAnnexViewIndex r = gitAnnexDir r literalOsPath "viewindex" {- File containing a log of recently accessed views. -} -gitAnnexViewLog :: Git.Repo -> RawFilePath -gitAnnexViewLog r = gitAnnexDir r P. "viewlog" +gitAnnexViewLog :: Git.Repo -> OsPath +gitAnnexViewLog r = gitAnnexDir r literalOsPath "viewlog" {- List of refs that have already been merged into the git-annex branch. -} -gitAnnexMergedRefs :: Git.Repo -> RawFilePath -gitAnnexMergedRefs r = gitAnnexDir r P. "mergedrefs" +gitAnnexMergedRefs :: Git.Repo -> OsPath +gitAnnexMergedRefs r = gitAnnexDir r literalOsPath "mergedrefs" {- List of refs that should not be merged into the git-annex branch. -} -gitAnnexIgnoredRefs :: Git.Repo -> RawFilePath -gitAnnexIgnoredRefs r = gitAnnexDir r P. "ignoredrefs" +gitAnnexIgnoredRefs :: Git.Repo -> OsPath +gitAnnexIgnoredRefs r = gitAnnexDir r literalOsPath "ignoredrefs" {- Pid file for daemon mode. -} -gitAnnexPidFile :: Git.Repo -> RawFilePath -gitAnnexPidFile r = gitAnnexDir r P. "daemon.pid" +gitAnnexPidFile :: Git.Repo -> OsPath +gitAnnexPidFile r = gitAnnexDir r literalOsPath "daemon.pid" {- Pid lock file for pidlock mode -} -gitAnnexPidLockFile :: Git.Repo -> RawFilePath -gitAnnexPidLockFile r = gitAnnexDir r P. "pidlock" +gitAnnexPidLockFile :: Git.Repo -> OsPath +gitAnnexPidLockFile r = gitAnnexDir r literalOsPath "pidlock" {- Status file for daemon mode. -} gitAnnexDaemonStatusFile :: Git.Repo -> FilePath -gitAnnexDaemonStatusFile r = fromRawFilePath $ - gitAnnexDir r P. "daemon.status" +gitAnnexDaemonStatusFile r = fromOsPath $ + gitAnnexDir r literalOsPath "daemon.status" {- Log file for daemon mode. -} -gitAnnexDaemonLogFile :: Git.Repo -> RawFilePath -gitAnnexDaemonLogFile r = gitAnnexDir r P. "daemon.log" +gitAnnexDaemonLogFile :: Git.Repo -> OsPath +gitAnnexDaemonLogFile r = gitAnnexDir r literalOsPath "daemon.log" {- Log file for fuzz test. -} gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath -gitAnnexFuzzTestLogFile r = fromRawFilePath $ - gitAnnexDir r P. "fuzztest.log" +gitAnnexFuzzTestLogFile r = fromOsPath $ + gitAnnexDir r literalOsPath "fuzztest.log" {- Html shim file used to launch the webapp. -} -gitAnnexHtmlShim :: Git.Repo -> RawFilePath -gitAnnexHtmlShim r = gitAnnexDir r P. "webapp.html" +gitAnnexHtmlShim :: Git.Repo -> OsPath +gitAnnexHtmlShim r = gitAnnexDir r literalOsPath "webapp.html" {- File containing the url to the webapp. -} -gitAnnexUrlFile :: Git.Repo -> RawFilePath -gitAnnexUrlFile r = gitAnnexDir r P. "url" +gitAnnexUrlFile :: Git.Repo -> OsPath +gitAnnexUrlFile r = gitAnnexDir r literalOsPath "url" {- Temporary file used to edit configuriation from the git-annex branch. -} -gitAnnexTmpCfgFile :: Git.Repo -> RawFilePath -gitAnnexTmpCfgFile r = gitAnnexDir r P. "config.tmp" +gitAnnexTmpCfgFile :: Git.Repo -> OsPath +gitAnnexTmpCfgFile r = gitAnnexDir r literalOsPath "config.tmp" {- .git/annex/ssh/ is used for ssh connection caching -} -gitAnnexSshDir :: Git.Repo -> RawFilePath -gitAnnexSshDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "ssh" +gitAnnexSshDir :: Git.Repo -> OsPath +gitAnnexSshDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "ssh" {- .git/annex/remotes/ is used for remote-specific state. -} -gitAnnexRemotesDir :: Git.Repo -> RawFilePath -gitAnnexRemotesDir r = - P.addTrailingPathSeparator $ gitAnnexDir r P. "remotes" +gitAnnexRemotesDir :: Git.Repo -> OsPath +gitAnnexRemotesDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "remotes" {- This is the base directory name used by the assistant when making - repositories, by default. -} -gitAnnexAssistantDefaultDir :: FilePath -gitAnnexAssistantDefaultDir = "annex" +gitAnnexAssistantDefaultDir :: OsPath +gitAnnexAssistantDefaultDir = literalOsPath "annex" -gitAnnexSimDir :: Git.Repo -> RawFilePath -gitAnnexSimDir r = P.addTrailingPathSeparator $ gitAnnexDir r P. "sim" +gitAnnexSimDir :: Git.Repo -> OsPath +gitAnnexSimDir r = addTrailingPathSeparator $ + gitAnnexDir r literalOsPath "sim" {- Sanitizes a String that will be used as part of a Key's keyName, - dealing with characters that cause problems. @@ -730,23 +741,26 @@ reSanitizeKeyName = preSanitizeKeyName' True - Changing what this function escapes and how is not a good idea, as it - can cause existing objects to get lost. -} -keyFile :: Key -> RawFilePath +keyFile :: Key -> OsPath keyFile k = - let b = serializeKey' k - in if S8.any (`elem` ['&', '%', ':', '/']) b - then S8.concatMap esc b + let b = serializeKey'' k + in toOsPath $ if SB.any (`elem` needesc) b + then SB.concat $ map esc (SB.unpack b) else b where - esc '&' = "&a" - esc '%' = "&s" - esc ':' = "&c" - esc '/' = "%" - esc c = S8.singleton c + esc w = case chr (fromIntegral w) of + '&' -> "&a" + '%' -> "&s" + ':' -> "&c" + '/' -> "%" + _ -> SB.singleton w + + needesc = map (fromIntegral . ord) ['&', '%', ':', '/'] {- Reverses keyFile, converting a filename fragment (ie, the basename of - the symlink target) into a key. -} -fileKey :: RawFilePath -> Maybe Key -fileKey = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' +fileKey :: OsPath -> Maybe Key +fileKey = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' . fromOsPath where go = S8.concat . unescafterfirst . S8.split '&' unescafterfirst [] = [] @@ -765,8 +779,8 @@ fileKey = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' - The file is put in a directory with the same name, this allows - write-protecting the directory to avoid accidental deletion of the file. -} -keyPath :: Key -> Hasher -> RawFilePath -keyPath key hasher = hasher key P. f P. f +keyPath :: Key -> Hasher -> OsPath +keyPath key hasher = hasher key f f where f = keyFile key @@ -776,5 +790,6 @@ keyPath key hasher = hasher key P. f P. f - This is compatible with the annexLocationsNonBare and annexLocationsBare, - for interoperability between special remotes and git-annex repos. -} -keyPaths :: Key -> NE.NonEmpty RawFilePath +keyPaths :: Key -> NE.NonEmpty OsPath keyPaths key = NE.map (\h -> keyPath key (h def)) dirHashes + diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs index 9e8d1b8105..079f6a57f3 100644 --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -26,11 +26,10 @@ import Annex.Perms 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 :: RawFilePath -> Annex () +lockFileCached :: OsPath -> Annex () lockFileCached file = go =<< fromLockCache file where go (Just _) = noop -- already locked @@ -43,7 +42,7 @@ lockFileCached file = go =<< fromLockCache file #endif changeLockCache $ M.insert file lockhandle -unlockFile :: RawFilePath -> Annex () +unlockFile :: OsPath -> Annex () unlockFile file = maybe noop go =<< fromLockCache file where go lockhandle = do @@ -53,7 +52,7 @@ unlockFile file = maybe noop go =<< fromLockCache file getLockCache :: Annex LockCache getLockCache = getState lockcache -fromLockCache :: RawFilePath -> Annex (Maybe LockHandle) +fromLockCache :: OsPath -> Annex (Maybe LockHandle) fromLockCache file = M.lookup file <$> getLockCache changeLockCache :: (LockCache -> LockCache) -> Annex () @@ -63,9 +62,9 @@ changeLockCache a = do {- Runs an action with a shared lock held. If an exclusive lock is held, - blocks until it becomes free. -} -withSharedLock :: RawFilePath -> Annex a -> Annex a +withSharedLock :: OsPath -> Annex a -> Annex a withSharedLock lockfile a = debugLocks $ do - createAnnexDirectory $ P.takeDirectory lockfile + createAnnexDirectory $ takeDirectory lockfile mode <- annexFileMode bracket (lock mode lockfile) (liftIO . dropLock) (const a) where @@ -77,16 +76,16 @@ withSharedLock lockfile a = debugLocks $ do {- Runs an action with an exclusive lock held. If the lock is already - held, blocks until it becomes free. -} -withExclusiveLock :: RawFilePath -> Annex a -> Annex a +withExclusiveLock :: OsPath -> Annex a -> Annex a withExclusiveLock lockfile a = bracket (takeExclusiveLock lockfile) (liftIO . dropLock) (const a) {- Takes an exclusive lock, blocking until it's free. -} -takeExclusiveLock :: RawFilePath -> Annex LockHandle +takeExclusiveLock :: OsPath -> Annex LockHandle takeExclusiveLock lockfile = debugLocks $ do - createAnnexDirectory $ P.takeDirectory lockfile + createAnnexDirectory $ takeDirectory lockfile mode <- annexFileMode lock mode lockfile where @@ -98,9 +97,9 @@ takeExclusiveLock lockfile = debugLocks $ do {- Tries to take an exclusive lock and run an action. If the lock is - already held, returns Nothing. -} -tryExclusiveLock :: RawFilePath -> Annex a -> Annex (Maybe a) +tryExclusiveLock :: OsPath -> Annex a -> Annex (Maybe a) tryExclusiveLock lockfile a = debugLocks $ do - createAnnexDirectory $ P.takeDirectory lockfile + createAnnexDirectory $ takeDirectory lockfile mode <- annexFileMode bracket (lock mode lockfile) (liftIO . unlock) go where @@ -118,7 +117,7 @@ tryExclusiveLock lockfile a = debugLocks $ do - Does not create the lock directory or lock file if it does not exist, - taking an exclusive lock will create them. -} -trySharedLock :: RawFilePath -> Annex (Maybe LockHandle) +trySharedLock :: OsPath -> Annex (Maybe LockHandle) trySharedLock lockfile = debugLocks $ #ifndef mingw32_HOST_OS tryLockShared Nothing lockfile diff --git a/Annex/Magic.hs b/Annex/Magic.hs index c408cd50d0..4771adada4 100644 --- a/Annex/Magic.hs +++ b/Annex/Magic.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Annex.Magic ( @@ -16,6 +17,7 @@ module Annex.Magic ( getMagicMimeEncoding, ) where +import Common import Types.Mime import Control.Monad.IO.Class #ifdef WITH_MAGICMIME @@ -23,7 +25,6 @@ import Magic import Utility.Env import Control.Concurrent import System.IO.Unsafe (unsafePerformIO) -import Common #else type Magic = () #endif @@ -34,16 +35,18 @@ initMagicMime = catchMaybeIO $ do m <- magicOpen [MagicMime] liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case Nothing -> magicLoadDefault m - Just d -> magicLoad m - (d "magic" "magic.mgc") + Just d -> magicLoad m $ fromOsPath $ + toOsPath d + literalOsPath "magic" + literalOsPath "magic.mgc" return m #else initMagicMime = return Nothing #endif -getMagicMime :: Magic -> FilePath -> IO (Maybe (MimeType, MimeEncoding)) +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 @@ -55,10 +58,10 @@ getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m f) getMagicMime _ _ = return Nothing #endif -getMagicMimeType :: MonadIO m => Magic -> FilePath -> m (Maybe MimeType) +getMagicMimeType :: MonadIO m => Magic -> OsPath -> m (Maybe MimeType) getMagicMimeType m f = liftIO $ fmap fst <$> getMagicMime m f -getMagicMimeEncoding :: MonadIO m => Magic -> FilePath -> m(Maybe MimeEncoding) +getMagicMimeEncoding :: MonadIO m => Magic -> OsPath -> m(Maybe MimeEncoding) getMagicMimeEncoding m f = liftIO $ fmap snd <$> getMagicMime m f #ifdef WITH_MAGICMIME diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs index 1eba836455..ac93d4988b 100644 --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -38,7 +38,7 @@ import Text.Read - - Also, can generate new metadata, if configured to do so. -} -genMetaData :: Key -> RawFilePath -> Maybe POSIXTime -> Annex () +genMetaData :: Key -> OsPath -> Maybe POSIXTime -> Annex () genMetaData key file mmtime = do catKeyFileHEAD file >>= \case Nothing -> noop @@ -57,8 +57,8 @@ genMetaData key file mmtime = do Nothing -> noop where warncopied = warning $ UnquotedString $ - "Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++ - "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file + "Copied metadata from old version of " ++ fromOsPath file ++ " to new version. " ++ + "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromOsPath file -- If the only fields copied were date metadata, and they'll -- be overwritten with the current mtime, no need to warn about -- copying. diff --git a/Annex/Multicast.hs b/Annex/Multicast.hs index 1443de776c..bc3b2eb3f6 100644 --- a/Annex/Multicast.hs +++ b/Annex/Multicast.hs @@ -7,20 +7,17 @@ module Annex.Multicast where +import Common import Annex.Path import Utility.Env -import Utility.PartialPrelude import System.Process -import System.IO import GHC.IO.Handle.FD -import Control.Applicative -import Prelude multicastReceiveEnv :: String multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE" -multicastCallbackEnv :: IO (FilePath, [(String, String)], Handle) +multicastCallbackEnv :: IO (OsPath, [(String, String)], Handle) multicastCallbackEnv = do gitannex <- programPath -- This will even work on Windows diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 6ec339cae8..a3885415c5 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -88,7 +88,7 @@ getMinCopies = fromSourcesOr defaultMinCopies {- NumCopies and MinCopies value for a file, from any configuration source, - including .gitattributes. -} -getFileNumMinCopies :: RawFilePath -> Annex (NumCopies, MinCopies) +getFileNumMinCopies :: OsPath -> Annex (NumCopies, MinCopies) getFileNumMinCopies f = do fnumc <- getForcedNumCopies fminc <- getForcedMinCopies @@ -141,7 +141,7 @@ getSafestNumMinCopies afile k = Database.Keys.getAssociatedFilesIncluding afile k >>= getSafestNumMinCopies' afile k -getSafestNumMinCopies' :: AssociatedFile -> Key -> [RawFilePath] -> Annex (NumCopies, MinCopies) +getSafestNumMinCopies' :: AssociatedFile -> Key -> [OsPath] -> Annex (NumCopies, MinCopies) getSafestNumMinCopies' afile k fs = do l <- mapM getFileNumMinCopies fs let l' = zip l fs @@ -174,13 +174,13 @@ getSafestNumMinCopies' afile k fs = do {- 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 :: RawFilePath -> Annex NumCopies +getGlobalFileNumCopies :: OsPath -> Annex NumCopies getGlobalFileNumCopies f = fromSourcesOr defaultNumCopies [ fst <$> getNumMinCopiesAttr f , getGlobalNumCopies ] -getNumMinCopiesAttr :: RawFilePath -> Annex (Maybe NumCopies, Maybe MinCopies) +getNumMinCopiesAttr :: OsPath -> Annex (Maybe NumCopies, Maybe MinCopies) getNumMinCopiesAttr file = checkAttrs ["annex.numcopies", "annex.mincopies"] file >>= \case (n:m:[]) -> return @@ -196,12 +196,12 @@ getNumMinCopiesAttr file = - This is good enough for everything except dropping the file, which - requires active verification of the copies. -} -numCopiesCheck :: RawFilePath -> Key -> (Int -> Int -> v) -> Annex v +numCopiesCheck :: OsPath -> Key -> (Int -> Int -> v) -> Annex v numCopiesCheck file key vs = do have <- trustExclude UnTrusted =<< Remote.keyLocations key numCopiesCheck' file vs have -numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v +numCopiesCheck' :: OsPath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' file vs have = do needed <- fst <$> getFileNumMinCopies file let nhave = numCopiesCount have diff --git a/Annex/Path.hs b/Annex/Path.hs index d3cca7c503..802ab9c043 100644 --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -40,20 +40,20 @@ import qualified Data.Map as M - git-annex-shell or git-remote-annex, this finds a git-annex program - instead. -} -programPath :: IO FilePath +programPath :: IO OsPath programPath = go =<< getEnv "GIT_ANNEX_DIR" where go (Just dir) = do name <- reqgitannex <$> getProgName - return (dir name) + return (toOsPath dir toOsPath name) go Nothing = do name <- getProgName exe <- if isgitannex name then getExecutablePath else pure "git-annex" - p <- if isAbsolute exe + p <- if isAbsolute (toOsPath exe) then return exe - else fromMaybe exe <$> readProgramFile + else maybe exe fromOsPath <$> readProgramFile maybe cannotFindProgram return =<< searchPath p reqgitannex name @@ -62,15 +62,15 @@ programPath = go =<< getEnv "GIT_ANNEX_DIR" isgitannex = flip M.notMember otherMulticallCommands {- Returns the path for git-annex that is recorded in the programFile. -} -readProgramFile :: IO (Maybe FilePath) +readProgramFile :: IO (Maybe OsPath) readProgramFile = catchDefaultIO Nothing $ do programfile <- programFile - headMaybe . lines <$> readFile programfile + fmap toOsPath . headMaybe . lines <$> readFile (fromOsPath programfile) cannotFindProgram :: IO a cannotFindProgram = do f <- programFile - giveup $ "cannot find git-annex program in PATH or in " ++ f + giveup $ "cannot find git-annex program in PATH or in " ++ fromOsPath f {- Runs a git-annex child process. - @@ -88,7 +88,7 @@ gitAnnexChildProcess gitAnnexChildProcess subcmd ps f a = do cmd <- liftIO programPath ps' <- gitAnnexChildProcessParams subcmd ps - pidLockChildProcess cmd ps' f a + pidLockChildProcess (fromOsPath cmd) ps' f a {- Parameters to pass to a git-annex child process to run a subcommand - with some parameters. diff --git a/Annex/Perms.hs b/Annex/Perms.hs index 03bce4fe83..9674873248 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -49,20 +49,20 @@ import System.PosixCompat.Files (fileMode, intersectFileModes, nullFileMode, gro withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig -setAnnexFilePerm :: RawFilePath -> Annex () +setAnnexFilePerm :: OsPath -> Annex () setAnnexFilePerm = setAnnexPerm False -setAnnexDirPerm :: RawFilePath -> Annex () +setAnnexDirPerm :: OsPath -> 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 -> RawFilePath -> Annex () +setAnnexPerm :: Bool -> OsPath -> Annex () setAnnexPerm isdir file = setAnnexPerm' Nothing isdir >>= \go -> liftIO (go file) -setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (RawFilePath -> IO ()) +setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (OsPath -> IO ()) setAnnexPerm' modef isdir = ifM crippledFileSystem ( return (const noop) , withShared $ \s -> return $ \file -> go s file @@ -79,11 +79,12 @@ setAnnexPerm' modef isdir = ifM crippledFileSystem Nothing -> noop Just f -> void $ tryIO $ modifyFileMode file $ f [] - go (UmaskShared n) file = void $ tryIO $ R.setFileMode file $ - if isdir then umaskSharedDirectory n else n + go (UmaskShared n) file = void $ tryIO $ + R.setFileMode (fromOsPath file) $ + if isdir then umaskSharedDirectory n else n modef' = fromMaybe addModes modef -resetAnnexFilePerm :: RawFilePath -> Annex () +resetAnnexFilePerm :: OsPath -> Annex () resetAnnexFilePerm = resetAnnexPerm False {- Like setAnnexPerm, but ignores the current mode of the file entirely, @@ -94,7 +95,7 @@ resetAnnexFilePerm = resetAnnexPerm False - which is going to be moved to a non-temporary location and needs - usual modes. -} -resetAnnexPerm :: Bool -> RawFilePath -> Annex () +resetAnnexPerm :: Bool -> OsPath -> Annex () resetAnnexPerm isdir file = unlessM crippledFileSystem $ do defmode <- liftIO defaultFileMode let modef moremodes _oldmode = addModes moremodes defmode @@ -115,7 +116,7 @@ annexFileMode = do {- Creates a directory inside the gitAnnexDir (or possibly the dbdir), - creating any parent directories up to and including the gitAnnexDir. - Makes directories with appropriate permissions. -} -createAnnexDirectory :: RawFilePath -> Annex () +createAnnexDirectory :: OsPath -> Annex () createAnnexDirectory dir = do top <- parentDir <$> fromRepo gitAnnexDir tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case @@ -124,7 +125,7 @@ createAnnexDirectory dir = do createDirectoryUnder' tops dir createdir where createdir p = do - liftIO $ R.createDirectory p + liftIO $ createDirectory p setAnnexDirPerm p {- Create a directory in the git work tree, creating any parent @@ -132,7 +133,7 @@ createAnnexDirectory dir = do - - Uses default permissions. -} -createWorkTreeDirectory :: RawFilePath -> Annex () +createWorkTreeDirectory :: OsPath -> Annex () createWorkTreeDirectory dir = do fromRepo repoWorkTree >>= liftIO . \case Just wt -> createDirectoryUnder [wt] dir @@ -159,16 +160,16 @@ createWorkTreeDirectory dir = do - it should not normally have. checkContentWritePerm can detect when - that happens with write permissions. -} -freezeContent :: RawFilePath -> Annex () +freezeContent :: OsPath -> Annex () freezeContent file = withShared $ \sr -> freezeContent' sr file -freezeContent' :: SharedRepository -> RawFilePath -> Annex () +freezeContent' :: SharedRepository -> OsPath -> Annex () freezeContent' sr file = freezeContent'' sr file =<< getVersion -freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex () +freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex () freezeContent'' sr file rv = do - fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file) + fastDebug "Annex.Perms" ("freezing content " ++ fromOsPath file) unlessM crippledFileSystem $ go sr freezeHook file where @@ -211,7 +212,7 @@ freezeContent'' sr file rv = do - support removing write permissions, so when there is such a hook - write permissions are ignored. -} -checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool) +checkContentWritePerm :: OsPath -> Annex (Maybe Bool) checkContentWritePerm file = ifM crippledFileSystem ( return (Just True) , do @@ -221,7 +222,7 @@ checkContentWritePerm file = ifM crippledFileSystem liftIO $ checkContentWritePerm' sr file rv hasfreezehook ) -checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool) +checkContentWritePerm' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool) checkContentWritePerm' sr file rv hasfreezehook | hasfreezehook = return (Just True) | otherwise = case sr of @@ -240,7 +241,7 @@ checkContentWritePerm' sr file rv hasfreezehook | otherwise -> want sharedret (\havemode -> havemode == removeModes writeModes n) where - want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file) + want mk f = catchMaybeIO (fileMode <$> R.getFileStatus (fromOsPath file)) >>= return . \case Just havemode -> mk (f havemode) Nothing -> mk True @@ -253,18 +254,19 @@ checkContentWritePerm' sr file rv hasfreezehook {- Allows writing to an annexed file that freezeContent was called on - before. -} -thawContent :: RawFilePath -> Annex () +thawContent :: OsPath -> Annex () thawContent file = withShared $ \sr -> thawContent' sr file -thawContent' :: SharedRepository -> RawFilePath -> Annex () +thawContent' :: SharedRepository -> OsPath -> Annex () thawContent' sr file = do - fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file) + fastDebug "Annex.Perms" ("thawing content " ++ fromOsPath file) thawPerms (go sr) (thawHook file) where go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file go AllShared = liftIO $ void $ tryIO $ groupWriteRead file go UnShared = liftIO $ allowWrite file - go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode file n + go (UmaskShared n) = liftIO $ void $ tryIO $ + R.setFileMode (fromOsPath file) n {- Runs an action that thaws a file's permissions. This will probably - fail on a crippled filesystem. But, if file modes are supported on a @@ -281,9 +283,9 @@ thawPerms a hook = ifM crippledFileSystem - is set, this is not done, since the group must be allowed to delete the - file without being able to thaw the directory. -} -freezeContentDir :: RawFilePath -> Annex () +freezeContentDir :: OsPath -> Annex () freezeContentDir file = do - fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir) + fastDebug "Annex.Perms" ("freezing content directory " ++ fromOsPath dir) unlessM crippledFileSystem $ withShared go freezeHook dir where @@ -291,29 +293,29 @@ freezeContentDir file = do go UnShared = liftIO $ preventWrite dir go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir - go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode dir $ + go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode (fromOsPath dir) $ umaskSharedDirectory $ - -- If n includes group or other write mode, leave them set - -- to allow them to delete the file without being able to - -- thaw the directory. + -- If n includes group or other write mode, leave + -- them set to allow them to delete the file without + -- being able to thaw the directory. removeModes [ownerWriteMode] n -thawContentDir :: RawFilePath -> Annex () +thawContentDir :: OsPath -> Annex () thawContentDir file = do - fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir) + fastDebug "Annex.Perms" ("thawing content directory " ++ fromOsPath dir) thawPerms (withShared (liftIO . go)) (thawHook dir) where dir = parentDir file go UnShared = allowWrite dir go GroupShared = allowWrite dir go AllShared = allowWrite dir - go (UmaskShared n) = R.setFileMode dir n + go (UmaskShared n) = R.setFileMode (fromOsPath dir) n {- Makes the directory tree to store an annexed file's content, - with appropriate permissions on each level. -} -createContentDir :: RawFilePath -> Annex () +createContentDir :: OsPath -> Annex () createContentDir dest = do - unlessM (liftIO $ R.doesPathExist dir) $ + unlessM (liftIO $ doesDirectoryExist dir) $ createAnnexDirectory dir -- might have already existed with restricted perms thawHook dir @@ -324,7 +326,7 @@ createContentDir dest = do {- 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 a file in the - directory, and finally, freezes the content directory. -} -modifyContentDir :: RawFilePath -> Annex a -> Annex a +modifyContentDir :: OsPath -> Annex a -> Annex a modifyContentDir f a = do createContentDir f -- also thaws it v <- tryNonAsync a @@ -333,7 +335,7 @@ modifyContentDir f a = do {- Like modifyContentDir, but avoids creating the content directory if it - does not already exist. In that case, the action will probably fail. -} -modifyContentDirWhenExists :: RawFilePath -> Annex a -> Annex a +modifyContentDirWhenExists :: OsPath -> Annex a -> Annex a modifyContentDirWhenExists f a = do thawContentDir f v <- tryNonAsync a @@ -352,11 +354,11 @@ hasThawHook = <||> (doesAnnexHookExist thawContentAnnexHook) -freezeHook :: RawFilePath -> Annex () +freezeHook :: OsPath -> Annex () freezeHook = void . runAnnexPathHook "%path" freezeContentAnnexHook annexFreezeContentCommand -thawHook :: RawFilePath -> Annex () +thawHook :: OsPath -> Annex () thawHook = void . runAnnexPathHook "%path" thawContentAnnexHook annexThawContentCommand diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs index 6fb739b30c..d6c3fe8f12 100644 --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -40,12 +40,13 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.Async import qualified Data.ByteString as B -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L -import qualified System.FilePath.ByteString as P import qualified Data.Map as M import qualified Data.Set as S +#ifndef mingw32_HOST_OS +import qualified Data.ByteString as BS import System.IO.Unsafe +#endif proxyRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide proxyRemoteSide clientmaxversion bypass r @@ -175,8 +176,8 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go -- independently. Also, this key is not getting added into the -- local annex objects. withproxytmpfile k a = withOtherTmp $ \othertmpdir -> - withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir -> - a (toRawFilePath tmpdir P. keyFile k) + withTmpDirIn othertmpdir (literalOsPath "proxy") $ \tmpdir -> + a (tmpdir keyFile k) proxyput af k = do liftIO $ sendmessage $ PUT_FROM (Offset 0) @@ -186,14 +187,14 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go -- the client, to avoid bad content -- being stored in the special remote. iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k - h <- liftIO $ F.openFile (toOsPath tmpfile) WriteMode - let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile) + h <- liftIO $ F.openFile tmpfile WriteMode + let nuketmp = liftIO $ removeWhenExistsWith removeFile tmpfile gotall <- liftIO $ receivetofile iv h len liftIO $ hClose h verified <- if gotall then fst <$> finishVerifyKeyContentIncrementally' True iv else pure False - let store = tryNonAsync (storeput k af (decodeBS tmpfile)) >>= \case + let store = tryNonAsync (storeput k af tmpfile) >>= \case Right () -> liftIO $ sendmessage SUCCESS Left err -> liftIO $ propagateerror err if protoversion > ProtocolVersion 1 @@ -260,9 +261,13 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go storetofile iv h (n - fromIntegral (B.length b)) bs proxyget offset af k = withproxytmpfile k $ \tmpfile -> do - let retrieve = tryNonAsync $ Remote.retrieveKeyFile r k af - (fromRawFilePath tmpfile) nullMeterUpdate vc + let retrieve = tryNonAsync $ Remote.retrieveKeyFile + r k af tmpfile nullMeterUpdate vc +#ifndef mingw32_HOST_OS ordered <- Remote.retrieveKeyFileInOrder r +#else + _ <- Remote.retrieveKeyFileInOrder r +#endif case fromKey keySize k of #ifndef mingw32_HOST_OS Just size | size > 0 && ordered -> do @@ -292,7 +297,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go sendlen offset size waitforfile x <- tryNonAsync $ do - h <- openFileBeingWritten f + h <- openFileBeingWritten (fromOsPath f) hSeek h AbsoluteSeek offset senddata' h (getcontents size) case x of @@ -344,7 +349,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go senddata (Offset offset) f = do size <- fromIntegral <$> getFileSize f sendlen offset size - withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do + F.withBinaryFile f ReadMode $ \h -> do hSeek h AbsoluteSeek offset senddata' h L.hGetContents diff --git a/Annex/Queue.hs b/Annex/Queue.hs index b2b28bccb5..02883cef32 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -31,7 +31,7 @@ addCommand commonparams command params files = do store =<< flushWhenFull =<< (Git.Queue.addCommand commonparams command params files q =<< gitRepo) -addFlushAction :: Git.Queue.FlushActionRunner Annex -> [RawFilePath] -> Annex () +addFlushAction :: Git.Queue.FlushActionRunner Annex -> [OsPath] -> Annex () addFlushAction runner files = do q <- get store =<< flushWhenFull =<< diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs index 5cb46b17dd..bd2b313046 100644 --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -21,20 +21,18 @@ import Utility.Tmp import Utility.Tmp.Dir import Utility.Directory.Create -import qualified System.FilePath.ByteString as P - {- replaceFile on a file located inside the gitAnnexDir. -} -replaceGitAnnexDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a +replaceGitAnnexDirFile :: OsPath -> (OsPath -> Annex a) -> Annex a replaceGitAnnexDirFile = replaceFile createAnnexDirectory {- replaceFile on a file located inside the .git directory. -} -replaceGitDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a +replaceGitDirFile :: OsPath -> (OsPath -> Annex a) -> Annex a replaceGitDirFile = replaceFile $ \dir -> do top <- fromRepo localGitDir liftIO $ createDirectoryUnder [top] dir {- replaceFile on a worktree file. -} -replaceWorkTreeFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a +replaceWorkTreeFile :: OsPath -> (OsPath -> Annex a) -> Annex a replaceWorkTreeFile = replaceFile createWorkTreeDirectory {- Replaces a possibly already existing file with a new version, @@ -52,20 +50,20 @@ replaceWorkTreeFile = replaceFile createWorkTreeDirectory - The createdirectory action is only run when moving the file into place - fails, and can create any parent directory structure needed. -} -replaceFile :: (RawFilePath -> Annex ()) -> RawFilePath -> (RawFilePath -> Annex a) -> Annex a +replaceFile :: (OsPath -> Annex ()) -> OsPath -> (OsPath -> Annex a) -> Annex a replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action -replaceFile' :: (RawFilePath -> Annex ()) -> RawFilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a +replaceFile' :: (OsPath -> Annex ()) -> OsPath -> (a -> Bool) -> (OsPath -> Annex a) -> Annex a replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do - let basetmp = relatedTemplate' (P.takeFileName file) - withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath basetmp) $ \tmpdir -> do - let tmpfile = toRawFilePath tmpdir P. basetmp + let basetmp = relatedTemplate (fromOsPath (takeFileName file)) + withTmpDirIn othertmpdir basetmp $ \tmpdir -> do + let tmpfile = tmpdir basetmp r <- action tmpfile when (checkres r) $ replaceFileFrom tmpfile file createdirectory return r -replaceFileFrom :: RawFilePath -> RawFilePath -> (RawFilePath -> Annex ()) -> Annex () +replaceFileFrom :: OsPath -> OsPath -> (OsPath -> Annex ()) -> Annex () replaceFileFrom src dest createdirectory = go `catchIO` fallback where go = liftIO $ moveFile src dest diff --git a/Annex/RepoSize/LiveUpdate.hs b/Annex/RepoSize/LiveUpdate.hs index 8710282999..6d2def8a2e 100644 --- a/Annex/RepoSize/LiveUpdate.hs +++ b/Annex/RepoSize/LiveUpdate.hs @@ -23,8 +23,6 @@ import Utility.PID import Control.Concurrent import Text.Read import Data.Time.Clock.POSIX -import qualified Utility.RawFilePath as R -import qualified System.FilePath.ByteString as P {- Called when a location log change is journalled, so the LiveUpdate - is done. This is called with the journal still locked, so no concurrent @@ -146,12 +144,11 @@ checkStaleSizeChanges :: RepoSizeHandle -> Annex () checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do livedir <- calcRepo' gitAnnexRepoSizeLiveDir pid <- liftIO getPID - let pidlockfile = show pid + let pidlockfile = toOsPath (show pid) now <- liftIO getPOSIXTime liftIO (takeMVar livev) >>= \case Nothing -> do - lck <- takeExclusiveLock $ - livedir P. toRawFilePath pidlockfile + lck <- takeExclusiveLock $ livedir pidlockfile go livedir lck pidlockfile now Just v@(lck, lastcheck) | now >= lastcheck + 60 -> @@ -161,11 +158,11 @@ checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do where go livedir lck pidlockfile now = do void $ tryNonAsync $ do - lockfiles <- liftIO $ filter (not . dirCruft . toRawFilePath) - <$> getDirectoryContents (fromRawFilePath livedir) + lockfiles <- liftIO $ filter (`notElem` dirCruft) + <$> getDirectoryContents livedir stale <- forM lockfiles $ \lockfile -> if (lockfile /= pidlockfile) - then case readMaybe lockfile of + then case readMaybe (fromOsPath lockfile) of Nothing -> return Nothing Just pid -> checkstale livedir lockfile pid else return Nothing @@ -176,7 +173,7 @@ checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do liftIO $ putMVar livev (Just (lck, now)) checkstale livedir lockfile pid = - let f = livedir P. toRawFilePath lockfile + let f = livedir lockfile in trySharedLock f >>= \case Nothing -> return Nothing Just lck -> do @@ -184,6 +181,6 @@ checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do ( StaleSizeChanger (SizeChangeProcessId pid) , do dropLock lck - removeWhenExistsWith R.removeLink f + removeWhenExistsWith removeFile f ) checkStaleSizeChanges (RepoSizeHandle Nothing _) = noop diff --git a/Annex/Sim.hs b/Annex/Sim.hs index 08293152fb..823d991ad2 100644 --- a/Annex/Sim.hs +++ b/Annex/Sim.hs @@ -55,8 +55,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.UUID as U import qualified Data.UUID.V5 as U5 -import qualified Utility.RawFilePath as R -import qualified System.FilePath.ByteString as P data SimState t = SimState { simRepos :: M.Map RepoName UUID @@ -342,7 +340,7 @@ applySimCommand c@(CommandVisit repo cmdparams) st _ = _ -> return ("sh", ["-c", unwords cmdparams]) exitcode <- liftIO $ safeSystem' cmd (map Param params) - (\p -> p { cwd = Just dir }) + (\p -> p { cwd = Just (fromOsPath dir) }) when (null cmdparams) $ showLongNote "Finished visit to simulated repository." if null cmdparams @@ -431,7 +429,7 @@ applySimCommand' (CommandAddTree repo expr) st _ = <$> inRepo (toTopFilePath f) ifM (checkMatcher matcher (Just k) afile NoLiveUpdate mempty (pure False) (pure False)) ( let st'' = setPresentKey True (u, repo) k u $ st' - { simFiles = M.insert f k (simFiles st') + { simFiles = M.insert (fromOsPath f) k (simFiles st') } in go matcher u st'' fs , go matcher u st' fs @@ -758,7 +756,7 @@ overFilesRemote r u remote remotepred localpred checkwant handlewanted st = Right (Left (st, map (go remoteu) $ M.toList $ simFiles st)) where go remoteu (f, k) st' = - let af = AssociatedFile $ Just f + let af = AssociatedFile $ Just $ toOsPath f in liftIO $ runSimRepo u st' $ \st'' rst -> case M.lookup remoteu (simRepoState st'') of Nothing -> return (st'', False) @@ -814,7 +812,7 @@ simulateDropUnwanted st u dropfromname dropfrom = Right $ Left (st, map go $ M.toList $ simFiles st) where go (f, k) st' = liftIO $ runSimRepo u st' $ \st'' rst -> - let af = AssociatedFile $ Just f + let af = AssociatedFile $ Just $ toOsPath f in if present dropfrom rst k then updateLiveSizeChanges rst $ ifM (wantDrop NoLiveUpdate False (Just dropfrom) (Just k) af Nothing) @@ -1104,7 +1102,7 @@ initNewSimRepos = \st -> go st (M.toList $ simRepoState st) go st ((u, rst):rest) = case simRepo rst of Nothing -> do - let d = simRepoDirectory st u + let d = fromOsPath $ simRepoDirectory st u sr <- initSimRepo (simRepoName rst) u d st let rst' = rst { simRepo = Just sr } let st' = st @@ -1114,8 +1112,8 @@ initNewSimRepos = \st -> go st (M.toList $ simRepoState st) go st' rest _ -> go st rest -simRepoDirectory :: SimState t -> UUID -> FilePath -simRepoDirectory st u = simRootDirectory st fromUUID u +simRepoDirectory :: SimState t -> UUID -> OsPath +simRepoDirectory st u = toOsPath (simRootDirectory st) fromUUID u initSimRepo :: RepoName -> UUID -> FilePath -> SimState SimRepo -> IO SimRepo initSimRepo simreponame u dest st = do @@ -1126,7 +1124,7 @@ initSimRepo simreponame u dest st = do ] unless inited $ giveup "git init failed" - simrepo <- Git.Construct.fromPath (toRawFilePath dest) + simrepo <- Git.Construct.fromPath (toOsPath dest) ast <- Annex.new simrepo ((), ast') <- Annex.run ast $ doQuietAction $ do storeUUID u @@ -1301,15 +1299,14 @@ updateSimRepoState newst sr = do setdesc r u = describeUUID u $ toUUIDDesc $ simulatedRepositoryDescription r stageannexedfile f k = do - let f' = annexedfilepath f + let f' = annexedfilepath (toOsPath f) l <- calcRepo $ gitAnnexLink f' k - liftIO $ createDirectoryIfMissing True $ - takeDirectory $ fromRawFilePath f' - addAnnexLink l f' - unstageannexedfile f = do - liftIO $ removeWhenExistsWith R.removeLink $ - annexedfilepath f - annexedfilepath f = repoPath (simRepoGitRepo sr) P. f + liftIO $ createDirectoryIfMissing True $ takeDirectory f' + addAnnexLink (fromOsPath l) f' + unstageannexedfile f = + liftIO $ removeWhenExistsWith removeFile $ + annexedfilepath (toOsPath f) + annexedfilepath f = repoPath (simRepoGitRepo sr) f getlocations = maybe mempty simLocations . M.lookup (simRepoUUID sr) . simRepoState @@ -1359,19 +1356,21 @@ suspendSim st = do let st'' = st' { simRepoState = M.map freeze (simRepoState st') } - writeFile (simRootDirectory st'' "state") (show st'') + let statefile = fromOsPath $ + toOsPath (simRootDirectory st'') literalOsPath "state" + writeFile statefile (show st'') where freeze :: SimRepoState SimRepo -> SimRepoState () freeze rst = rst { simRepo = Nothing } -restoreSim :: RawFilePath -> IO (Either String (SimState SimRepo)) +restoreSim :: OsPath -> IO (Either String (SimState SimRepo)) restoreSim rootdir = - tryIO (readFile (fromRawFilePath rootdir "state")) >>= \case + tryIO (readFile statefile) >>= \case Left err -> return (Left (show err)) Right c -> case readMaybe c :: Maybe (SimState ()) of Nothing -> return (Left "unable to parse sim state file") Just st -> do - let st' = st { simRootDirectory = fromRawFilePath rootdir } + let st' = st { simRootDirectory = fromOsPath rootdir } repostate <- M.fromList <$> mapM (thaw st') (M.toList (simRepoState st)) let st'' = st' @@ -1380,12 +1379,12 @@ restoreSim rootdir = } return (Right st'') where + statefile = fromOsPath $ rootdir literalOsPath "state" thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case Left _ -> (u, rst { simRepo = Nothing }) Right r -> (u, rst { simRepo = Just r }) thaw' st u = do - simrepo <- Git.Construct.fromPath $ toRawFilePath $ - simRepoDirectory st u + simrepo <- Git.Construct.fromPath $ simRepoDirectory st u ast <- Annex.new simrepo return $ SimRepo { simRepoGitRepo = simrepo diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 6cdfba7b02..fc6e3de61e 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -40,14 +40,14 @@ import Types.Concurrency import Git.Env import Git.Ssh import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS import Annex.Perms #ifndef mingw32_HOST_OS import Annex.LockPool #endif import Control.Concurrent.STM -import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P +import qualified Data.ByteString.Short as SBS {- 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 @@ -101,15 +101,15 @@ consumeStdinParams NoConsumeStdin = [Param "-n"] {- Returns a filename to use for a ssh connection caching socket, and - parameters to enable ssh connection caching. -} -sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe RawFilePath, [CommandParam]) +sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe OsPath, [CommandParam]) sshCachingInfo (host, port) = go =<< sshCacheDir' where go (Right dir) = - liftIO (bestSocketPath $ dir P. hostport2socket host port) >>= return . \case + liftIO (bestSocketPath $ dir hostport2socket host port) >>= return . \case Nothing -> (Nothing, []) Just socketfile -> (Just socketfile - , sshConnectionCachingParams (fromRawFilePath socketfile) + , sshConnectionCachingParams (fromOsPath socketfile) ) -- No connection caching with concurrency is not a good -- combination, so warn the user. @@ -137,10 +137,10 @@ sshCachingInfo (host, port) = go =<< sshCacheDir' - file. - - If no path can be constructed that is a valid socket, returns Nothing. -} -bestSocketPath :: RawFilePath -> IO (Maybe RawFilePath) +bestSocketPath :: OsPath -> IO (Maybe OsPath) bestSocketPath abssocketfile = do relsocketfile <- liftIO $ relPathCwdToFile abssocketfile - let socketfile = if S.length abssocketfile <= S.length relsocketfile + let socketfile = if OS.length abssocketfile <= OS.length relsocketfile then abssocketfile else relsocketfile return $ if valid_unix_socket_path socketfile sshgarbagelen @@ -167,10 +167,10 @@ sshSocketDirEnv = "GIT_ANNEX_SSH_SOCKET_DIR" - - The directory will be created if it does not exist. -} -sshCacheDir :: Annex (Maybe RawFilePath) +sshCacheDir :: Annex (Maybe OsPath) sshCacheDir = eitherToMaybe <$> sshCacheDir' -sshCacheDir' :: Annex (Either String RawFilePath) +sshCacheDir' :: Annex (Either String OsPath) sshCacheDir' = ifM (fromMaybe BuildInfo.sshconnectioncaching . annexSshCaching <$> Annex.getGitConfig) ( ifM crippledFileSystem @@ -191,9 +191,9 @@ sshCacheDir' = gettmpdir = liftIO $ getEnv sshSocketDirEnv usetmpdir tmpdir = do - let socktmp = tmpdir "ssh" + let socktmp = toOsPath tmpdir literalOsPath "ssh" createDirectoryIfMissing True socktmp - return (toRawFilePath socktmp) + return socktmp crippledfswarning = unwords [ "This repository is on a crippled filesystem, so unix named" @@ -216,7 +216,7 @@ portParams (Just port) = [Param "-p", Param $ show port] - Locks the socket lock file to prevent other git-annex processes from - stopping the ssh multiplexer on this socket. -} -prepSocket :: RawFilePath -> SshHost -> [CommandParam] -> Annex () +prepSocket :: OsPath -> SshHost -> [CommandParam] -> Annex () prepSocket socketfile sshhost sshparams = do -- There could be stale ssh connections hanging around -- from a previous git-annex run that was interrupted. @@ -288,11 +288,11 @@ prepSocket socketfile sshhost sshparams = do - and this check makes such files be skipped since the corresponding lock - file won't exist. -} -enumSocketFiles :: Annex [RawFilePath] +enumSocketFiles :: Annex [OsPath] enumSocketFiles = liftIO . go =<< sshCacheDir where go Nothing = return [] - go (Just dir) = filterM (R.doesPathExist . socket2lock) + go (Just dir) = filterM (R.doesPathExist . fromOsPath . socket2lock) =<< filter (not . isLock) <$> catchDefaultIO [] (dirContents dir) @@ -326,45 +326,45 @@ sshCleanup = mapM_ cleanup =<< enumSocketFiles forceSshCleanup :: Annex () forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles -forceStopSsh :: RawFilePath -> Annex () +forceStopSsh :: OsPath -> Annex () forceStopSsh socketfile = withNullHandle $ \nullh -> do - let (dir, base) = splitFileName (fromRawFilePath socketfile) + let (dir, base) = splitFileName socketfile let p = (proc "ssh" $ toCommand $ [ Param "-O", Param "stop" ] ++ - sshConnectionCachingParams base ++ + sshConnectionCachingParams (fromOsPath base) ++ [Param "localhost"]) - { cwd = Just dir + { cwd = Just (fromOsPath dir) -- "ssh -O stop" is noisy on stderr even with -q , std_out = UseHandle nullh , std_err = UseHandle nullh } void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid -> forceSuccessProcess p pid - liftIO $ removeWhenExistsWith R.removeLink socketfile + liftIO $ removeWhenExistsWith removeFile 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 -> RawFilePath +hostport2socket :: SshHost -> Maybe Integer -> OsPath hostport2socket host Nothing = hostport2socket' $ fromSshHost host hostport2socket host (Just port) = hostport2socket' $ fromSshHost host ++ "!" ++ show port -hostport2socket' :: String -> RawFilePath +hostport2socket' :: String -> OsPath hostport2socket' s - | length s > lengthofmd5s = toRawFilePath $ show $ md5 $ encodeBL s - | otherwise = toRawFilePath s + | length s > lengthofmd5s = toOsPath $ show $ md5 $ encodeBL s + | otherwise = toOsPath s where lengthofmd5s = 32 -socket2lock :: RawFilePath -> RawFilePath +socket2lock :: OsPath -> OsPath socket2lock socket = socket <> lockExt -isLock :: RawFilePath -> Bool -isLock f = lockExt `S.isSuffixOf` f +isLock :: OsPath -> Bool +isLock f = lockExt `OS.isSuffixOf` f -lockExt :: S.ByteString -lockExt = ".lock" +lockExt :: OsPath +lockExt = literalOsPath ".lock" {- This is the size of the sun_path component of sockaddr_un, which - is the limit to the total length of the filename of a unix socket. @@ -376,8 +376,9 @@ sizeof_sockaddr_un_sun_path = 100 {- Note that this looks at the true length of the path in bytes, as it will - appear on disk. -} -valid_unix_socket_path :: RawFilePath -> Int -> Bool -valid_unix_socket_path f n = S.length f + n < sizeof_sockaddr_un_sun_path +valid_unix_socket_path :: OsPath -> Int -> Bool +valid_unix_socket_path f n = + SBS.length (fromOsPath 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. -} @@ -463,7 +464,7 @@ sshOptionsTo remote gc localr liftIO $ do localr' <- addGitEnv localr sshOptionsEnv (toSshOptionsEnv sshopts) - addGitEnv localr' gitSshEnv command + addGitEnv localr' gitSshEnv (fromOsPath command) runSshOptions :: [String] -> String -> IO () runSshOptions args s = do diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs index 6f9f28b8b6..6a1fd99f7e 100644 --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -23,7 +23,7 @@ import System.PosixCompat.Files (modificationTime) -- 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 :: (RawFilePath -> Annex a) -> Annex a +withOtherTmp :: (OsPath -> Annex a) -> Annex a withOtherTmp a = do Annex.addCleanupAction OtherTmpCleanup cleanupOtherTmp tmpdir <- fromRepo gitAnnexTmpOtherDir @@ -40,14 +40,14 @@ withOtherTmp a = do -- 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 :: (RawFilePath -> Annex a) -> Annex a +withEventuallyCleanedOtherTmp :: (OsPath -> Annex a) -> Annex a withEventuallyCleanedOtherTmp = bracket setup cleanup where setup = do tmpdir <- fromRepo gitAnnexTmpOtherDirOld void $ createAnnexDirectory tmpdir return tmpdir - cleanup = liftIO . void . tryIO . removeDirectory . fromRawFilePath + cleanup = liftIO . void . tryIO . removeDirectory -- | Cleans up any tmp files that were left by a previous -- git-annex process that got interrupted or failed to clean up after @@ -58,14 +58,13 @@ cleanupOtherTmp :: Annex () cleanupOtherTmp = do tmplck <- fromRepo gitAnnexTmpOtherLock void $ tryIO $ tryExclusiveLock tmplck $ do - tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir + tmpdir <- fromRepo gitAnnexTmpOtherDir void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir oldtmp <- fromRepo gitAnnexTmpOtherDirOld - liftIO $ mapM_ cleanold + liftIO $ mapM_ (cleanold . fromOsPath) =<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp) -- remove when empty - liftIO $ void $ tryIO $ - removeDirectory (fromRawFilePath oldtmp) + liftIO $ void $ tryIO $ removeDirectory oldtmp where cleanold f = do now <- liftIO getPOSIXTime diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 1c1abf4fd5..c2fbfa5786 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -44,13 +44,11 @@ import Annex.TransferrerPool import Annex.StallDetection import Backend (isCryptographicallySecureKey) import Types.StallDetection -import qualified Utility.RawFilePath as R import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM hiding (retry) import qualified Data.Map.Strict as M -import qualified System.FilePath.ByteString as P import Data.Ord -- Upload, supporting canceling detected stalls. @@ -83,7 +81,7 @@ download r key f d witness = go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f Nothing $ \dest -> download' (Remote.uuid r) key f sd d (go' dest) witness go' dest p = verifiedAction $ - Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc + Remote.retrieveKeyFile r key f dest p vc vc = Remote.RemoteVerify r -- Download, not supporting canceling detected stalls. @@ -146,10 +144,10 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran else recordFailedTransfer t info return v - prep :: RawFilePath -> Maybe RawFilePath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool) + prep :: OsPath -> Maybe OsPath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool) #ifndef mingw32_HOST_OS prep lckfile moldlckfile createtfile mode = catchPermissionDenied (const prepfailed) $ do - createAnnexDirectory $ P.takeDirectory lckfile + createAnnexDirectory $ takeDirectory lckfile tryLockExclusive (Just mode) lckfile >>= \case Nothing -> return (Nothing, True) -- Since the lock file is removed in cleanup, @@ -163,7 +161,7 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran createtfile return (Just (lockhandle, Nothing), False) Just oldlckfile -> do - createAnnexDirectory $ P.takeDirectory oldlckfile + createAnnexDirectory $ takeDirectory oldlckfile tryLockExclusive (Just mode) oldlckfile >>= \case Nothing -> do liftIO $ dropLock lockhandle @@ -183,14 +181,14 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran ) #else prep lckfile moldlckfile createtfile _mode = catchPermissionDenied (const prepfailed) $ do - createAnnexDirectory $ P.takeDirectory lckfile + createAnnexDirectory $ takeDirectory lckfile catchMaybeIO (liftIO $ lockExclusive lckfile) >>= \case Just (Just lockhandle) -> case moldlckfile of Nothing -> do createtfile return (Just (lockhandle, Nothing), False) Just oldlckfile -> do - createAnnexDirectory $ P.takeDirectory oldlckfile + createAnnexDirectory $ takeDirectory oldlckfile catchMaybeIO (liftIO $ lockExclusive oldlckfile) >>= \case Just (Just oldlockhandle) -> do createtfile @@ -204,10 +202,10 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran cleanup _ _ _ Nothing = noop cleanup tfile lckfile moldlckfile (Just (lockhandle, moldlockhandle)) = do - void $ tryIO $ R.removeLink tfile + void $ tryIO $ removeFile tfile #ifndef mingw32_HOST_OS - void $ tryIO $ R.removeLink lckfile - maybe noop (void . tryIO . R.removeLink) moldlckfile + void $ tryIO $ removeFile lckfile + maybe noop (void . tryIO . removeFile) moldlckfile maybe noop dropLock moldlockhandle dropLock lockhandle #else @@ -219,7 +217,7 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran maybe noop dropLock moldlockhandle dropLock lockhandle void $ tryIO $ R.removeLink lckfile - maybe noop (void . tryIO . R.removeLink) moldlckfile + maybe noop (void . tryIO . removeFile) moldlckfile #endif retry numretries oldinfo metervar run = diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs index 481e08e9f7..0c5190f45e 100644 --- a/Annex/TransferrerPool.hs +++ b/Annex/TransferrerPool.hs @@ -43,7 +43,7 @@ data RunTransferrer = RunTransferrer String [CommandParam] BatchCommandMaker mkRunTransferrer :: BatchCommandMaker -> Annex RunTransferrer mkRunTransferrer batchmaker = RunTransferrer - <$> liftIO programPath + <$> liftIO (fromOsPath <$> programPath) <*> gitAnnexChildProcessParams "transferrer" [] <*> pure batchmaker diff --git a/Annex/Url.hs b/Annex/Url.hs index e796b314b9..795b4b7b97 100644 --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -174,13 +174,13 @@ checkBoth url expected_size uo = Right r -> return r Left err -> warning (UnquotedString err) >> return False -download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool +download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex Bool download meterupdate iv url file uo = liftIO (U.download meterupdate iv url file uo) >>= \case Right () -> return True Left err -> warning (UnquotedString err) >> return False -download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ()) +download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex (Either String ()) download' meterupdate iv url file uo = liftIO (U.download meterupdate iv url file uo) diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs index 781732368d..fac1a6ca7a 100644 --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -5,21 +5,24 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.VariantFile where import Annex.Common import Utility.Hash +import qualified Utility.OsString as OS import qualified Data.ByteString as S -variantMarker :: String -variantMarker = ".variant-" +variantMarker :: OsPath +variantMarker = literalOsPath ".variant-" -mkVariant :: FilePath -> String -> FilePath +mkVariant :: OsPath -> OsPath -> OsPath mkVariant file variant = takeDirectory file dropExtension (takeFileName file) - ++ variantMarker ++ variant - ++ takeExtension file + <> variantMarker <> variant + <> takeExtension file {- The filename to use when resolving a conflicted merge of a file, - that points to a key. @@ -34,12 +37,12 @@ mkVariant file variant = takeDirectory file - conflicted merge resolution code. That case is detected, and the full - key is used in the filename. -} -variantFile :: FilePath -> Key -> FilePath +variantFile :: OsPath -> Key -> OsPath variantFile file key - | doubleconflict = mkVariant file (fromRawFilePath (keyFile key)) - | otherwise = mkVariant file (shortHash $ serializeKey' key) + | doubleconflict = mkVariant file (keyFile key) + | otherwise = mkVariant file (toOsPath (shortHash $ serializeKey' key)) where - doubleconflict = variantMarker `isInfixOf` file + doubleconflict = variantMarker `OS.isInfixOf` file shortHash :: S.ByteString -> String shortHash = take 4 . show . md5s diff --git a/Annex/Verify.hs b/Annex/Verify.hs index 697ffeadc0..001529eb68 100644 --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -39,13 +39,13 @@ import Utility.Metered import Annex.WorkerPool import Types.WorkerPool import Types.Key +import qualified Utility.FileIO as F import Control.Concurrent.STM import Control.Concurrent.Async import qualified Data.ByteString as S #if WITH_INOTIFY import qualified System.INotify as INotify -import qualified System.FilePath.ByteString as P #endif shouldVerify :: VerifyConfig -> Annex Bool @@ -73,7 +73,7 @@ shouldVerify (RemoteVerify r) = - If the RetrievalSecurityPolicy requires verification and the key's - backend doesn't support it, the verification will fail. -} -verifyKeyContentPostRetrieval :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool +verifyKeyContentPostRetrieval :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> OsPath -> Annex Bool verifyKeyContentPostRetrieval rsp v verification k f = case (rsp, verification) of (_, Verified) -> return True (RetrievalVerifiableKeysSecure, _) -> ifM (isVerifiable k) @@ -105,11 +105,11 @@ verifyKeyContentPostRetrieval rsp v verification k f = case (rsp, verification) -- When possible, does an incremental verification, because that can be -- faster. Eg, the VURL backend can need to try multiple checksums and only -- with an incremental verification does it avoid reading files twice. -verifyKeyContent :: Key -> RawFilePath -> Annex Bool +verifyKeyContent :: Key -> OsPath -> Annex Bool verifyKeyContent k f = verifyKeySize k f <&&> verifyKeyContent' k f -- Does not verify size. -verifyKeyContent' :: Key -> RawFilePath -> Annex Bool +verifyKeyContent' :: Key -> OsPath -> Annex Bool verifyKeyContent' k f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case Nothing -> return True @@ -119,7 +119,7 @@ verifyKeyContent' k f = iv <- mkiv k showAction (UnquotedString (descIncrementalVerifier iv)) res <- liftIO $ catchDefaultIO Nothing $ - withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do + F.withBinaryFile f ReadMode $ \h -> do feedIncrementalVerifier h iv finalizeIncrementalVerifier iv case res of @@ -129,7 +129,7 @@ verifyKeyContent' k f = Just verifier -> verifier k f (Nothing, Just verifier) -> verifier k f -resumeVerifyKeyContent :: Key -> RawFilePath -> IncrementalVerifier -> Annex Bool +resumeVerifyKeyContent :: Key -> OsPath -> IncrementalVerifier -> Annex Bool resumeVerifyKeyContent k f iv = liftIO (positionIncrementalVerifier iv) >>= \case Nothing -> fallback Just endpos -> do @@ -151,7 +151,7 @@ resumeVerifyKeyContent k f iv = liftIO (positionIncrementalVerifier iv) >>= \cas | otherwise = do showAction (UnquotedString (descIncrementalVerifier iv)) liftIO $ catchDefaultIO (Just False) $ - withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do + F.withBinaryFile f ReadMode $ \h -> do hSeek h AbsoluteSeek endpos feedIncrementalVerifier h iv finalizeIncrementalVerifier iv @@ -167,7 +167,7 @@ feedIncrementalVerifier h iv = do where chunk = 65536 -verifyKeySize :: Key -> RawFilePath -> Annex Bool +verifyKeySize :: Key -> OsPath -> Annex Bool verifyKeySize k f = case fromKey keySize k of Just size -> do size' <- liftIO $ catchDefaultIO 0 $ getFileSize f @@ -295,7 +295,7 @@ resumeVerifyFromOffset o incrementalverifier meterupdate h -- and if the disk is slow, the reader may never catch up to the writer, -- and the disk cache may never speed up reads. So this should only be -- used when there's not a better way to incrementally verify. -tailVerify :: Maybe IncrementalVerifier -> RawFilePath -> Annex a -> Annex a +tailVerify :: Maybe IncrementalVerifier -> OsPath -> Annex a -> Annex a tailVerify (Just iv) f writer = do finished <- liftIO newEmptyTMVarIO t <- liftIO $ async $ tailVerify' iv f finished @@ -305,7 +305,7 @@ tailVerify (Just iv) f writer = do writer `finally` finishtail tailVerify Nothing _ writer = writer -tailVerify' :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO () +tailVerify' :: IncrementalVerifier -> OsPath -> TMVar () -> IO () #if WITH_INOTIFY tailVerify' iv f finished = tryNonAsync go >>= \case @@ -318,15 +318,16 @@ tailVerify' iv f finished = -- of resuming, and waiting for modification deals with such -- situations. inotifydirchange i cont = - INotify.addWatch i [INotify.Modify] dir $ \case + INotify.addWatch i [INotify.Modify] (fromOsPath dir) $ \case -- Ignore changes to other files in the directory. INotify.Modified { INotify.maybeFilePath = fn } - | fn == Just basef -> cont + | fn == Just basef' -> cont _ -> noop where - (dir, basef) = P.splitFileName f + (dir, basef) = splitFileName f + basef' = fromOsPath basef - inotifyfilechange i = INotify.addWatch i [INotify.Modify] f . const + inotifyfilechange i = INotify.addWatch i [INotify.Modify] (fromOsPath f) . const go = INotify.withINotify $ \i -> do modified <- newEmptyTMVarIO @@ -354,7 +355,7 @@ tailVerify' iv f finished = case v of Just () -> do r <- tryNonAsync $ - tryWhenExists (openBinaryFile (fromRawFilePath f) ReadMode) >>= \case + tryWhenExists (F.openBinaryFile f ReadMode) >>= \case Just h -> return (Just h) -- File does not exist, must have been -- deleted. Wait for next modification diff --git a/Annex/View.hs b/Annex/View.hs index 0f9a759acb..563419d88b 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -40,13 +40,12 @@ import Logs.View import Utility.Glob import Types.Command import CmdLine.Action -import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS 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 Control.Concurrent.Async import "mtl" Control.Monad.Writer @@ -251,7 +250,7 @@ combineViewFilter (ExcludeValues _) new@(FilterGlobOrUnset _ _) = (new, Widening - evaluate this function with the view parameter and reuse - the result. The globs in the view will then be compiled and memoized. -} -viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile] +viewedFiles :: View -> MkViewedFile -> OsPath -> MetaData -> [ViewedFile] viewedFiles view = let matchers = map viewComponentMatcher (viewComponents view) in \mkviewedfile file metadata -> @@ -260,7 +259,8 @@ viewedFiles view = then [] else let paths = pathProduct $ - map (map toviewpath) (visible matches) + map (map (toOsPath . toviewpath)) + (visible matches) in if null paths then [mkviewedfile file] else map ( mkviewedfile file) paths @@ -346,7 +346,7 @@ fromViewPath = toMetaValue . encodeBS . deescapepseudo [] prop_viewPath_roundtrips :: MetaValue -> Bool prop_viewPath_roundtrips v = fromViewPath (toViewPath v) == v -pathProduct :: [[FilePath]] -> [FilePath] +pathProduct :: [[OsPath]] -> [OsPath] pathProduct [] = [] pathProduct (l:ls) = foldl combinel l ls where @@ -364,7 +364,7 @@ fromView view f = MetaData $ m `M.difference` derived filter (not . isviewunset) (zip visible values) visible = filter viewVisible (viewComponents view) paths = splitDirectories (dropFileName f) - values = map (S.singleton . fromViewPath) paths + values = map (S.singleton . fromViewPath . fromOsPath) paths MetaData derived = getViewedFileMetaData f convfield (vc, v) = (viewField vc, v) @@ -385,9 +385,9 @@ fromView view f = MetaData $ m `M.difference` derived 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) + [ OS.null (takeFileName f) && OS.null (takeDirectory f) , viewTooLarge view - , all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) (fromRawFilePath f) metadata) + , all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) f metadata) ] where view = View (Git.Ref "foo") $ @@ -402,19 +402,19 @@ prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or - Note that this may generate MetaFields that legalField rejects. - This is necessary to have a 1:1 mapping between directory names and - fields. So this MetaData cannot safely be serialized. -} -getDirMetaData :: FilePath -> MetaData +getDirMetaData :: OsPath -> MetaData getDirMetaData d = MetaData $ M.fromList $ zip fields values where dirs = splitDirectories d - fields = map (mkMetaFieldUnchecked . T.pack . addTrailingPathSeparator . joinPath) + fields = map (mkMetaFieldUnchecked . T.pack . fromOsPath . addTrailingPathSeparator . joinPath) (inits dirs) values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe) - (tails dirs) + (tails (map fromOsPath dirs)) -getWorkTreeMetaData :: FilePath -> MetaData +getWorkTreeMetaData :: OsPath -> MetaData getWorkTreeMetaData = getDirMetaData . dropFileName -getViewedFileMetaData :: FilePath -> MetaData +getViewedFileMetaData :: OsPath -> MetaData getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName {- Applies a view to the currently checked out branch, generating a new @@ -439,7 +439,7 @@ narrowView = applyView' viewedFileReuse getViewedFileMetaData - Look up the metadata of annexed files, and generate any ViewedFiles, - and stage them. -} -applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch +applyView' :: MkViewedFile -> (OsPath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch applyView' mkviewedfile getfilemetadata view madj = do top <- fromRepo Git.repoPath (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] @@ -452,7 +452,7 @@ applyView' mkviewedfile getfilemetadata view madj = do applyView'' :: MkViewedFile - -> (FilePath -> MetaData) + -> (OsPath -> MetaData) -> View -> Maybe Adjustment -> [t] @@ -488,18 +488,18 @@ applyView'' mkviewedfile getfilemetadata view madj l clean conv = do -- Git.UpdateIndex.streamUpdateIndex' -- here would race with process's calls -- to it. - | "." `B.isPrefixOf` getTopFilePath topf -> - feed "dummy" + | literalOsPath "." `OS.isPrefixOf` getTopFilePath topf -> + feed (literalOsPath "dummy") | otherwise -> noop getmetadata gc mdfeeder mdcloser ts process uh mdreader = liftIO mdreader >>= \case Just ((topf, _, mtreeitemtype, Just k), mdlog) -> do let metadata = maybe emptyMetaData parseCurrentMetaData mdlog - let f = fromRawFilePath $ getTopFilePath topf + let f = getTopFilePath topf let metadata' = getfilemetadata f `unionMetaData` metadata forM_ (genviewedfiles f metadata') $ \fv -> do - f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) + f' <- fromRepo (fromTopFilePath $ asTopFilePath fv) stagefile uh f' k mtreeitemtype process uh mdreader Just ((topf, sha, Just treeitemtype, Nothing), _) -> do @@ -527,7 +527,7 @@ applyView'' mkviewedfile getfilemetadata view madj l clean conv = do _ -> stagesymlink uh f k stagesymlink uh f k = do - linktarget <- calcRepo (gitAnnexLink f k) + linktarget <- fromOsPath <$> calcRepo (gitAnnexLink f k) sha <- hashSymlink linktarget liftIO . Git.UpdateIndex.streamUpdateIndex' uh =<< inRepo (Git.UpdateIndex.stageSymlink f sha) @@ -609,7 +609,7 @@ withViewChanges addmeta removemeta = do =<< catKey (DiffTree.dstsha item) | otherwise = noop handlechange item a = maybe noop - (void . commandAction . a (fromRawFilePath $ getTopFilePath $ DiffTree.file item)) + (void . commandAction . a (getTopFilePath $ DiffTree.file item)) {- Runs an action using the view index file. - Note that the file does not necessarily exist, or can contain @@ -619,7 +619,8 @@ withViewIndex = withIndexFile ViewIndexFile . const withNewViewIndex :: Annex a -> Annex a withNewViewIndex a = do - liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex + liftIO . removeWhenExistsWith removeFile + =<< fromRepo gitAnnexViewIndex withViewIndex a {- Generates a branch for a view, using the view index file diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs index 84dcbc897a..4ac872fb46 100644 --- a/Annex/View/ViewedFile.hs +++ b/Annex/View/ViewedFile.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Annex.View.ViewedFile ( @@ -20,13 +21,13 @@ module Annex.View.ViewedFile ( import Annex.Common import Utility.QuickCheck import Backend.Utilities (maxExtensions) +import qualified Utility.OsString as OS import qualified Data.ByteString as S -type FileName = String -type ViewedFile = FileName +type ViewedFile = OsPath -type MkViewedFile = FilePath -> ViewedFile +type MkViewedFile = OsPath -> ViewedFile {- Converts a filepath used in a reference branch to the - filename that will be used in the view. @@ -43,24 +44,27 @@ viewedFileFromReference g = viewedFileFromReference' (annexMaxExtensions g) viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile -viewedFileFromReference' maxextlen maxextensions f = concat $ - [ escape (fromRawFilePath base') - , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%" +viewedFileFromReference' maxextlen maxextensions f = toOsPath $ concat $ + [ escape (fromOsPath base') + , if null dirs + then "" + else "_%" ++ intercalate "%" (map (escape . fromOsPath) dirs) ++ "%" , escape $ fromRawFilePath $ S.concat extensions' ] where (path, basefile) = splitFileName f - dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path) + dirs = filter (/= literalOsPath ".") $ + map dropTrailingPathSeparator (splitPath path) (base, extensions) = case maxextlen of - Nothing -> splitShortExtensions (toRawFilePath basefile') - Just n -> splitShortExtensions' (n+1) (toRawFilePath basefile') + Nothing -> splitShortExtensions basefile' + Just n -> splitShortExtensions' (n+1) basefile' {- Limit number of extensions. -} maxextensions' = fromMaybe maxExtensions maxextensions (base', extensions') | length extensions <= maxextensions' = (base, extensions) | otherwise = let (es,more) = splitAt maxextensions' (reverse extensions) - in (base <> mconcat (reverse more), reverse es) + in (base <> toOsPath (mconcat (reverse more)), reverse es) {- On Windows, if the filename looked like "dir/c:foo" then - basefile would look like it contains a drive letter, which will - not work. There cannot really be a filename like that, probably, @@ -89,8 +93,8 @@ viewedFileReuse = takeFileName {- Extracts from a ViewedFile the directory where the file is located on - in the reference branch. -} -dirFromViewedFile :: ViewedFile -> FilePath -dirFromViewedFile = joinPath . drop 1 . sep [] "" +dirFromViewedFile :: ViewedFile -> OsPath +dirFromViewedFile = joinPath . map toOsPath . drop 1 . sep [] "" . fromOsPath where sep l _ [] = reverse l sep l curr (c:cs) @@ -103,10 +107,10 @@ dirFromViewedFile = joinPath . drop 1 . sep [] "" prop_viewedFile_roundtrips :: TestableFilePath -> Bool prop_viewedFile_roundtrips tf -- Relative filenames wanted, not directories. - | any (isPathSeparator) (end f ++ beginning f) = True - | isAbsolute f || isDrive f = True + | OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True + | isAbsolute (toOsPath f) || isDrive (toOsPath f) = True | otherwise = dir == dirFromViewedFile - (viewedFileFromReference' Nothing Nothing f) + (viewedFileFromReference' Nothing Nothing (toOsPath f)) where f = fromTestableFilePath tf - dir = joinPath $ beginning $ splitDirectories f + dir = joinPath $ beginning $ splitDirectories (toOsPath f) diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index 41abc2471e..ce9cb449a7 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -22,11 +22,11 @@ import qualified Database.Keys - When in an adjusted branch that may have hidden the file, looks for a - pointer to a key in the original branch. -} -lookupKey :: RawFilePath -> Annex (Maybe Key) +lookupKey :: OsPath -> Annex (Maybe Key) lookupKey = lookupKey' catkeyfile where catkeyfile file = - ifM (liftIO $ doesFileExist $ fromRawFilePath file) + ifM (liftIO $ doesFileExist file) ( catKeyFile file , catKeyFileHidden file =<< getCurrentBranch ) @@ -35,22 +35,22 @@ lookupKey = lookupKey' catkeyfile - changes in the work tree. This means it's slower, but it also has - consistently the same behavior for locked files as for unlocked files. -} -lookupKeyStaged :: RawFilePath -> Annex (Maybe Key) +lookupKeyStaged :: OsPath -> Annex (Maybe Key) lookupKeyStaged file = catKeyFile file >>= \case Just k -> return (Just k) Nothing -> catKeyFileHidden file =<< getCurrentBranch {- Like lookupKey, but does not find keys for hidden files. -} -lookupKeyNotHidden :: RawFilePath -> Annex (Maybe Key) +lookupKeyNotHidden :: OsPath -> Annex (Maybe Key) lookupKeyNotHidden = lookupKey' catkeyfile where catkeyfile file = - ifM (liftIO $ doesFileExist $ fromRawFilePath file) + ifM (liftIO $ doesFileExist file) ( catKeyFile file , return Nothing ) -lookupKey' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key) +lookupKey' :: (OsPath -> Annex (Maybe Key)) -> OsPath -> Annex (Maybe Key) lookupKey' catkeyfile file = isAnnexLink file >>= \case Just key -> return (Just key) Nothing -> catkeyfile file diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 6544f3d1f5..60245eec9d 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} module Annex.YoutubeDl ( @@ -30,7 +31,6 @@ import Utility.Metered import Utility.Tmp import Messages.Progress import Logs.Transfer -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F import Network.URI @@ -72,20 +72,21 @@ youtubeDlNotAllowedMessage = unwords -- (This can fail, but youtube-dl is deprecated, and they closed my -- issue requesting something like --print-to-file; -- ) -youtubeDl :: URLString -> FilePath -> MeterUpdate -> Annex (Either String (Maybe FilePath)) +youtubeDl :: URLString -> OsPath -> MeterUpdate -> Annex (Either String (Maybe OsPath)) youtubeDl url workdir p = ifM ipAddressesUnlimited ( withUrlOptions $ youtubeDl' url workdir p , return $ Left youtubeDlNotAllowedMessage ) -youtubeDl' :: URLString -> FilePath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe FilePath)) +youtubeDl' :: URLString -> OsPath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe OsPath)) youtubeDl' url workdir p uo | supportedScheme uo url = do cmd <- youtubeDlCommand ifM (liftIO $ inSearchPath cmd) ( runcmd cmd >>= \case Right True -> downloadedfiles cmd >>= \case - (f:[]) -> return (Right (Just f)) + (f:[]) -> return $ + Right (Just (toOsPath f)) [] -> return (nofiles cmd) fs -> return (toomanyfiles cmd fs) Right False -> workdirfiles >>= \case @@ -100,13 +101,13 @@ youtubeDl' url workdir p uo toomanyfiles cmd fs = Left $ cmd ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs downloadedfiles cmd | isytdlp cmd = liftIO $ - (nub . lines <$> readFile filelistfile) + (nub . lines <$> readFile (fromOsPath filelistfile)) `catchIO` (pure . const []) - | otherwise = map fromRawFilePath <$> workdirfiles - workdirfiles = liftIO $ filter (/= toRawFilePath filelistfile) - <$> (filterM R.doesPathExist =<< dirContents (toRawFilePath workdir)) + | otherwise = map fromOsPath <$> workdirfiles + workdirfiles = liftIO $ filter (/= filelistfile) + <$> (filterM doesFileExist =<< dirContents workdir) filelistfile = workdir filelistfilebase - filelistfilebase = "git-annex-file-list-file" + filelistfilebase = literalOsPath "git-annex-file-list-file" isytdlp cmd = cmd == "yt-dlp" runcmd cmd = youtubeDlMaxSize workdir >>= \case Left msg -> return (Left msg) @@ -122,7 +123,7 @@ youtubeDl' url workdir p uo liftIO $ commandMeter' (if isytdlp cmd then parseYtdlpProgress else parseYoutubeDlProgress) oh (Just meter) meterupdate cmd opts - (\pr -> pr { cwd = Just workdir }) + (\pr -> pr { cwd = Just (fromOsPath workdir) }) return (Right ok) dlopts cmd = [ Param url @@ -145,7 +146,7 @@ youtubeDl' url workdir p uo , Param progressTemplate , Param "--print-to-file" , Param "after_move:filepath" - , Param filelistfilebase + , Param (fromOsPath filelistfilebase) ] else [] @@ -153,14 +154,14 @@ youtubeDl' url workdir p uo -- large a media file. Factors in other downloads that are in progress, -- and any files in the workdir that it may have partially downloaded -- before. -youtubeDlMaxSize :: FilePath -> Annex (Either String [CommandParam]) +youtubeDlMaxSize :: OsPath -> Annex (Either String [CommandParam]) youtubeDlMaxSize workdir = ifM (Annex.getRead Annex.force) ( return $ Right [] - , liftIO (getDiskFree workdir) >>= \case + , liftIO (getDiskFree (fromOsPath workdir)) >>= \case Just have -> do inprogress <- sizeOfDownloadsInProgress (const True) partial <- liftIO $ sum - <$> (mapM getFileSize =<< dirContents (toRawFilePath workdir)) + <$> (mapM getFileSize =<< dirContents workdir) reserve <- annexDiskReserve <$> Annex.getGitConfig let maxsize = have - reserve - inprogress + partial if maxsize > 0 @@ -175,12 +176,12 @@ youtubeDlMaxSize workdir = ifM (Annex.getRead Annex.force) ) -- Download a media file to a destination, -youtubeDlTo :: Key -> URLString -> FilePath -> MeterUpdate -> Annex Bool +youtubeDlTo :: Key -> URLString -> OsPath -> MeterUpdate -> Annex Bool youtubeDlTo key url dest p = do res <- withTmpWorkDir key $ \workdir -> - youtubeDl url (fromRawFilePath workdir) p >>= \case + youtubeDl url workdir p >>= \case Right (Just mediafile) -> do - liftIO $ moveFile (toRawFilePath mediafile) (toRawFilePath dest) + liftIO $ moveFile mediafile dest return (Just True) Right Nothing -> return (Just False) Left msg -> do @@ -225,7 +226,7 @@ youtubeDlCheck' url uo -- Ask youtube-dl for the filename of media in an url. -- -- (This is not always identical to the filename it uses when downloading.) -youtubeDlFileName :: URLString -> Annex (Either String FilePath) +youtubeDlFileName :: URLString -> Annex (Either String OsPath) youtubeDlFileName url = withUrlOptions go where go uo @@ -236,10 +237,10 @@ youtubeDlFileName url = withUrlOptions go -- Does not check if the url contains htmlOnly; use when that's already -- been verified. -youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String FilePath) +youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String OsPath) youtubeDlFileNameHtmlOnly = withUrlOptions . youtubeDlFileNameHtmlOnly' -youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String FilePath) +youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String OsPath) youtubeDlFileNameHtmlOnly' url uo | supportedScheme uo url = flip catchIO (pure . Left . show) go | otherwise = return nomedia @@ -269,7 +270,7 @@ youtubeDlFileNameHtmlOnly' url uo ok <- liftIO $ checkSuccessProcess pid wait errt return $ case (ok, lines output) of - (True, (f:_)) | not (null f) -> Right f + (True, (f:_)) | not (null f) -> Right (toOsPath f) _ -> nomedia waitproc _ _ _ _ = error "internal" @@ -353,7 +354,7 @@ youtubePlaylist url = do else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem]) -youtubePlaylist' url cmd = withTmpFile (toOsPath (toRawFilePath "yt-dlp")) $ \tmpfile h -> do +youtubePlaylist' url cmd = withTmpFile (literalOsPath "yt-dlp") $ \tmpfile h -> do hClose h (outerr, ok) <- processTranscript cmd [ "--simulate" @@ -363,7 +364,7 @@ youtubePlaylist' url cmd = withTmpFile (toOsPath (toRawFilePath "yt-dlp")) $ \tm , "--print-to-file" -- Write json with selected fields. , "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j" - , fromRawFilePath (fromOsPath tmpfile) + , fromOsPath tmpfile , url ] Nothing @@ -407,5 +408,6 @@ data YoutubePlaylistItem = YoutubePlaylistItem instance Aeson.FromJSON YoutubePlaylistItem where parseJSON = Aeson.genericParseJSON Aeson.defaultOptions - { Aeson.fieldLabelModifier = drop (length "youtube_") } - + { Aeson.fieldLabelModifier = + drop (length ("youtube_" :: String)) + } diff --git a/Assistant.hs b/Assistant.hs index 2e50a79ff1..41553c6949 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -62,40 +62,39 @@ import qualified Utility.Debug as Debug import Network.Socket (HostName, PortNumber) stopDaemon :: Annex () -stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath - =<< fromRepo gitAnnexPidFile +stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile {- Starts the daemon. If the daemon is run in the foreground, once it's - running, can start the browser. - - startbrowser is passed the url and html shim file, as well as the original - stdout and stderr descriptors. -} -startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () +startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> OsPath -> IO ()) -> Annex () startDaemon assistant foreground startdelay cannotrun listenhost listenport startbrowser = do Annex.changeState $ \s -> s { Annex.daemon = True } enableInteractiveBranchAccess pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile + liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile createAnnexDirectory (parentDir pidfile) #ifndef mingw32_HOST_OS createAnnexDirectory (parentDir logfile) - let logfd = handleToFd =<< openLog (fromRawFilePath logfile) + let logfd = handleToFd =<< openLog (fromOsPath logfile) if foreground then do origout <- liftIO $ catchMaybeIO $ fdToHandle =<< dup stdOutput origerr <- liftIO $ catchMaybeIO $ fdToHandle =<< dup stdError - let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile)) + let undaemonize = Utility.Daemon.foreground logfd (Just pidfile) start undaemonize $ case startbrowser of Nothing -> Nothing Just a -> Just $ a origout origerr else do - git_annex <- liftIO programPath + git_annex <- fromOsPath <$> liftIO programPath ps <- gitAnnexDaemonizeParams - start (Utility.Daemon.daemonize git_annex ps logfd (Just (fromRawFilePath pidfile)) False) Nothing + start (Utility.Daemon.daemonize git_annex ps logfd (Just 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. @@ -104,7 +103,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star createAnnexDirectory (parentDir logfile) ifM (liftIO $ isNothing <$> getEnv flag) ( liftIO $ withNullHandle $ \nullh -> do - loghandle <- openLog (fromRawFilePath logfile) + loghandle <- openLog (fromOsPath logfile) e <- getEnvironment cmd <- programPath ps <- getArgs @@ -117,7 +116,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star exitcode <- withCreateProcess p $ \_ _ _ pid -> waitForProcess pid exitWith exitcode - , start (Utility.Daemon.foreground (Just (fromRawFilePath pidfile))) $ + , start (Utility.Daemon.foreground (Just (fromOsPath pidfile))) $ case startbrowser of Nothing -> Nothing Just a -> Just $ a Nothing Nothing @@ -128,7 +127,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star checkCanWatch dstatus <- startDaemonStatus logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile + liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile liftIO $ daemonize $ flip runAssistant (go webappwaiter) =<< newAssistantData st dstatus diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index ead791dcc9..aba957958f 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -395,7 +395,7 @@ fileAlert msg files = (activityAlert Nothing shortfiles) maxfilesshown = 10 (!somefiles, !counter) = splitcounter (dedupadjacent files) - !shortfiles = map (fromString . shortFile . takeFileName) somefiles + !shortfiles = map (fromString . shortFile . fromOsPath . takeFileName . toOsPath) somefiles renderer alert = tenseWords $ msg : alertData alert ++ showcounter where diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs index 4a20850fa0..a1a98b2e98 100644 --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -15,14 +15,14 @@ import Data.Time.Clock import Control.Concurrent.STM {- Handlers call this when they made a change that needs to get committed. -} -madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change) +madeChange :: OsPath -> ChangeInfo -> Assistant (Maybe Change) madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t) noChange :: Assistant (Maybe Change) noChange = return Nothing {- Indicates an add needs to be done, but has not started yet. -} -pendingAddChange :: FilePath -> Assistant (Maybe Change) +pendingAddChange :: OsPath -> Assistant (Maybe Change) pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f) {- Gets all unhandled changes. diff --git a/Assistant/Install.hs b/Assistant/Install.hs index db34000672..c1827ae541 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Assistant.Install where @@ -31,8 +32,8 @@ import Utility.Android import System.PosixCompat.Files (ownerExecuteMode) import qualified Data.ByteString.Char8 as S8 -standaloneAppBase :: IO (Maybe FilePath) -standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE" +standaloneAppBase :: IO (Maybe OsPath) +standaloneAppBase = fmap toOsPath <$> getEnv "GIT_ANNEX_APP_BASE" {- The standalone app does not have an installation process. - So when it's run, it needs to set up autostarting of the assistant @@ -51,13 +52,12 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") , go =<< standaloneAppBase ) where - go Nothing = installFileManagerHooks "git-annex" + go Nothing = installFileManagerHooks (literalOsPath "git-annex") go (Just base) = do - let program = base "git-annex" + let program = base literalOsPath "git-annex" programfile <- programFile - createDirectoryIfMissing True $ - fromRawFilePath (parentDir (toRawFilePath programfile)) - writeFile programfile program + createDirectoryIfMissing True (parentDir programfile) + writeFile (fromOsPath programfile) (fromOsPath program) #ifdef darwin_HOST_OS autostartfile <- userAutoStart osxAutoStartLabel @@ -67,24 +67,24 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") ( do -- Integration with the Termux:Boot app. home <- myHomeDir - let bootfile = home ".termux" "boot" "git-annex" + let bootfile = toOsPath home literalOsPath ".termux" literalOsPath "boot" literalOsPath "git-annex" unlessM (doesFileExist bootfile) $ do createDirectoryIfMissing True (takeDirectory bootfile) - writeFile bootfile "git-annex assistant --autostart" + writeFile (fromOsPath bootfile) "git-annex assistant --autostart" , do menufile <- desktopMenuFilePath "git-annex" <$> userDataDir icondir <- iconDir <$> userDataDir - installMenu program menufile base icondir + installMenu (fromOsPath program) menufile base icondir autostartfile <- autoStartPath "git-annex" <$> userConfigDir - installAutoStart program autostartfile + installAutoStart (fromOsPath program) autostartfile ) #endif sshdir <- sshDir - let runshell var = "exec " ++ base "runshell " ++ var + let runshell var = "exec " ++ fromOsPath (base literalOsPath "runshell ") ++ var let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\"" - installWrapper (toRawFilePath (sshdir "git-annex-shell")) $ + installWrapper (sshdir literalOsPath "git-annex-shell") $ [ shebang , "set -e" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" @@ -93,7 +93,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") , rungitannexshell "$@" , "fi" ] - installWrapper (toRawFilePath (sshdir "git-annex-wrapper")) $ + installWrapper (sshdir literalOsPath "git-annex-wrapper") $ [ shebang , "set -e" , runshell "\"$@\"" @@ -101,47 +101,46 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") installFileManagerHooks program -installWrapper :: RawFilePath -> [String] -> IO () +installWrapper :: OsPath -> [String] -> IO () installWrapper file content = do let content' = map encodeBS content - curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' (toOsPath file) + curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' file when (curr /= content') $ do - createDirectoryIfMissing True (fromRawFilePath (parentDir file)) - viaTmp F.writeFile' (toOsPath file) $ - linesFile' (S8.unlines content') + createDirectoryIfMissing True (parentDir file) + viaTmp F.writeFile' file $ linesFile' (S8.unlines content') modifyFileMode file $ addModes [ownerExecuteMode] -installFileManagerHooks :: FilePath -> IO () +installFileManagerHooks :: OsPath -> IO () #ifdef linux_HOST_OS installFileManagerHooks program = unlessM osAndroid $ do let actions = ["get", "drop", "undo"] -- Gnome - nautilusScriptdir <- (\d -> d "nautilus" "scripts") <$> userDataDir + nautilusScriptdir <- (\d -> d literalOsPath "nautilus" literalOsPath "scripts") <$> userDataDir createDirectoryIfMissing True nautilusScriptdir forM_ actions $ genNautilusScript nautilusScriptdir -- KDE userdata <- userDataDir - let kdeServiceMenusdir = userdata "kservices5" "ServiceMenus" + let kdeServiceMenusdir = userdata literalOsPath "kservices5" literalOsPath "ServiceMenus" createDirectoryIfMissing True kdeServiceMenusdir - writeFile (kdeServiceMenusdir "git-annex.desktop") + writeFile (fromOsPath (kdeServiceMenusdir literalOsPath "git-annex.desktop")) (kdeDesktopFile actions) where genNautilusScript scriptdir action = - installscript (toRawFilePath (scriptdir scriptname action)) $ unlines + installscript (scriptdir toOsPath (scriptname action)) $ unlines [ shebang , autoaddedcomment - , "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" + , "exec " ++ fromOsPath program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" ] scriptname action = "git-annex " ++ action installscript f c = whenM (safetoinstallscript f) $ do - writeFile (fromRawFilePath f) c + writeFile (fromOsPath f) c modifyFileMode f $ addModes [ownerExecuteMode] safetoinstallscript f = catchDefaultIO True $ elem (encodeBS autoaddedcomment) . fileLines' - <$> F.readFile' (toOsPath f) + <$> F.readFile' f autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)" autoaddedmsg = "Automatically added by git-annex, do not edit." @@ -167,7 +166,7 @@ installFileManagerHooks program = unlessM osAndroid $ do , "Icon=git-annex" , unwords [ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&" - , program + , fromOsPath program , command , "--notify-start --notify-finish -- \"$1\"'" , "false" -- this becomes $0 in sh, so unused diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs index 59fb7b674d..366e202731 100644 --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -10,6 +10,7 @@ module Assistant.Install.AutoStart where +import Common import Utility.FreeDesktop #ifdef darwin_HOST_OS import Utility.OSX @@ -18,11 +19,11 @@ import Utility.SystemDirectory import Utility.FileSystemEncoding #endif -installAutoStart :: FilePath -> FilePath -> IO () +installAutoStart :: String -> OsPath -> IO () installAutoStart command file = do #ifdef darwin_HOST_OS - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file))) - writeFile file $ genOSXAutoStartFile osxAutoStartLabel command + createDirectoryIfMissing True (parentDir file) + writeFile (fromOsPath file) $ genOSXAutoStartFile osxAutoStartLabel command ["assistant", "--autostart"] #else writeDesktopMenuFile (fdoAutostart command) file diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs index 91fcd3baf5..04261838ef 100644 --- a/Assistant/Install/Menu.hs +++ b/Assistant/Install/Menu.hs @@ -5,31 +5,25 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} 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 () +installMenu :: String -> OsPath -> OsPath -> OsPath -> IO () #ifdef darwin_HOST_OS installMenu _command _menufile _iconsrcdir _icondir = return () #else installMenu command menufile iconsrcdir icondir = do writeDesktopMenuFile (fdoDesktopMenu command) menufile - installIcon (iconsrcdir "logo.svg") $ - iconFilePath (iconBaseName ++ ".svg") "scalable" icondir - installIcon (iconsrcdir "logo_16x16.png") $ - iconFilePath (iconBaseName ++ ".png") "16x16" icondir + installIcon (iconsrcdir literalOsPath "logo.svg") $ + iconFilePath (toOsPath (iconBaseName ++ ".svg")) "scalable" icondir + installIcon (iconsrcdir literalOsPath "logo_16x16.png") $ + iconFilePath (toOsPath (iconBaseName ++ ".png")) "16x16" icondir #endif {- The command can be either just "git-annex", or the full path to use @@ -43,11 +37,11 @@ fdoDesktopMenu command = genDesktopEntry (Just iconBaseName) ["Network", "FileTransfer"] -installIcon :: FilePath -> FilePath -> IO () +installIcon :: OsPath -> OsPath -> IO () installIcon src dest = do - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath dest))) - withBinaryFile src ReadMode $ \hin -> - withBinaryFile dest WriteMode $ \hout -> + createDirectoryIfMissing True (parentDir dest) + withBinaryFile (fromOsPath src) ReadMode $ \hin -> + withBinaryFile (fromOsPath dest) WriteMode $ \hout -> hGetContents hin >>= hPutStr hout iconBaseName :: String diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs index 47bf5488a6..b027d6a53a 100644 --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -28,7 +28,7 @@ import Config {- Makes a new git repository. Or, if a git repository already - exists, returns False. -} -makeRepo :: FilePath -> Bool -> IO Bool +makeRepo :: OsPath -> Bool -> IO Bool makeRepo path bare = ifM (probeRepoExists path) ( return False , do @@ -41,19 +41,19 @@ makeRepo path bare = ifM (probeRepoExists path) where baseparams = [Param "init", Param "--quiet"] params - | bare = baseparams ++ [Param "--bare", File path] - | otherwise = baseparams ++ [File path] + | bare = baseparams ++ [Param "--bare", File (fromOsPath path)] + | otherwise = baseparams ++ [File (fromOsPath path)] {- Runs an action in the git repository in the specified directory. -} -inDir :: FilePath -> Annex a -> IO a +inDir :: OsPath -> Annex a -> IO a inDir dir a = do state <- Annex.new =<< Git.Config.read - =<< Git.Construct.fromPath (toRawFilePath dir) + =<< Git.Construct.fromPath dir Annex.eval state $ a `finally` quiesce True {- Creates a new repository, and returns its UUID. -} -initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID +initRepo :: Bool -> Bool -> OsPath -> Maybe String -> Maybe StandardGroup -> IO UUID initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do initRepo' desc mgroup {- Initialize the master branch, so things that expect @@ -94,6 +94,6 @@ initRepo' desc mgroup = unlessM isInitialized $ do Annex.Branch.commit =<< Annex.Branch.commitMessage {- Checks if a git repo exists at a location. -} -probeRepoExists :: FilePath -> IO Bool +probeRepoExists :: OsPath -> IO Bool probeRepoExists dir = isJust <$> - catchDefaultIO Nothing (Git.Construct.checkForRepo (encodeBS dir)) + catchDefaultIO Nothing (Git.Construct.checkForRepo dir) diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 69402e2e3d..f4468bc07c 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -22,11 +22,11 @@ import qualified Data.Text as T {- Authorized keys are set up before pairing is complete, so that the other - side can immediately begin syncing. -} -setupAuthorizedKeys :: PairMsg -> FilePath -> IO () +setupAuthorizedKeys :: PairMsg -> OsPath -> IO () setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of Left err -> giveup err Right pubkey -> do - absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir) + absdir <- absPath repodir unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $ giveup "failed setting up ssh authorized keys" @@ -66,7 +66,7 @@ pairMsgToSshData msg = do { sshHostName = T.pack hostname , sshUserName = Just (T.pack $ remoteUserName d) , sshDirectory = T.pack dir - , sshRepoName = genSshRepoName hostname dir + , sshRepoName = genSshRepoName hostname (toOsPath dir) , sshPort = 22 , needsPubKey = True , sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs index 4c37227c8d..c024f93e6f 100644 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -31,11 +31,9 @@ import qualified Data.Text as T #endif import qualified Utility.Lsof as Lsof import Utility.ThreadScheduler -import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS import Control.Concurrent.Async -import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P {- When the FsckResults require a repair, tries to do a non-destructive - repair. If that fails, pops up an alert. -} @@ -98,7 +96,7 @@ runRepair u mrmt destructiverepair = do thisrepopath <- liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath) a <- liftAnnex $ mkrepair $ - repair fsckresults (Just (fromRawFilePath thisrepopath)) + repair fsckresults (Just (fromOsPath thisrepopath)) liftIO $ catchBoolIO a repair fsckresults referencerepo = do @@ -110,7 +108,7 @@ runRepair u mrmt destructiverepair = do backgroundfsck params = liftIO $ void $ async $ do program <- programPath - batchCommand program (Param "fsck" : params) + batchCommand (fromOsPath program) (Param "fsck" : params) {- Detect when a git lock file exists and has no git process currently - writing to it. This strongly suggests it is a stale lock file. @@ -135,26 +133,26 @@ repairStaleGitLocks r = do repairStaleLocks lockfiles return $ not $ null lockfiles where - findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir islock f - | "gc.pid" `S.isInfixOf` f = False - | ".lock" `S.isSuffixOf` f = True - | P.takeFileName f == "MERGE_HEAD" = True + | literalOsPath "gc.pid" `OS.isInfixOf` f = False + | literalOsPath ".lock" `OS.isSuffixOf` f = True + | takeFileName f == literalOsPath "MERGE_HEAD" = True | otherwise = False -repairStaleLocks :: [RawFilePath] -> Assistant () +repairStaleLocks :: [OsPath] -> Assistant () repairStaleLocks lockfiles = go =<< getsizes where getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize lf getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles go [] = return () - go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromRawFilePath . fst) l)) + go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromOsPath . fst) l)) ( do waitforit "to check stale git lock file" l' <- getsizes if l' == l - then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l + then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l else go l' , do waitforit "for git lock file writer" diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs index 65b6fe64aa..658d1ddf18 100644 --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -18,7 +18,6 @@ import Utility.NotificationBroadcaster import Utility.Url import Utility.Url.Parse import Utility.PID -import qualified Utility.RawFilePath as R import qualified Git.Construct import qualified Git.Config import qualified Annex @@ -41,8 +40,8 @@ import Network.URI prepRestart :: Assistant () prepRestart = do liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread - liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile) - liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile) + liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) + liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexPidFile) {- To finish a restart, send a global redirect to the new url - to any web browsers that are displaying the webapp. @@ -66,21 +65,21 @@ terminateSelf = runRestart :: Assistant URLString runRestart = liftIO . newAssistantUrl - =<< liftAnnex (Git.repoLocation <$> Annex.gitRepo) + =<< liftAnnex (Git.repoPath <$> Annex.gitRepo) {- Starts up the assistant in the repository, and waits for it to create - a gitAnnexUrlFile. Waits for the assistant to be up and listening for - connections by testing the url. -} -newAssistantUrl :: FilePath -> IO URLString +newAssistantUrl :: OsPath -> IO URLString newAssistantUrl repo = do startAssistant repo geturl where geturl = do - r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo) - waiturl $ fromRawFilePath $ gitAnnexUrlFile r + r <- Git.Config.read =<< Git.Construct.fromPath repo + waiturl $ gitAnnexUrlFile r waiturl urlfile = do - v <- tryIO $ readFile urlfile + v <- tryIO $ readFile (fromOsPath urlfile) case v of Left _ -> delayed $ waiturl urlfile Right url -> ifM (assistantListening url) @@ -112,8 +111,8 @@ assistantListening url = catchBoolIO $ do - On windows, the assistant does not daemonize, which is why the forkIO is - done. -} -startAssistant :: FilePath -> IO () +startAssistant :: OsPath -> IO () startAssistant repo = void $ forkIO $ do - program <- programPath - let p = (proc program ["assistant"]) { cwd = Just repo } + program <- fromOsPath <$> programPath + let p = (proc program ["assistant"]) { cwd = Just (fromOsPath repo) } withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 3a9235c76d..420e1efdab 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.Ssh where import Annex.Common @@ -18,6 +20,7 @@ import Git.Remote import Utility.SshHost import Utility.Process.Transcript import qualified Utility.FileIO as F +import qualified Utility.OsString as OS import Data.Text (Text) import qualified Data.Text as T @@ -94,14 +97,14 @@ genSshUrl sshdata = case sshRepoUrl sshdata of {- Reverses genSshUrl -} parseSshUrl :: String -> Maybe SshData parseSshUrl u - | "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u) + | "ssh://" `isPrefixOf` u = fromssh (drop (length ("ssh://" :: String)) u) | otherwise = fromrsync u where mkdata (userhost, dir) = Just $ SshData { sshHostName = T.pack host , sshUserName = if null user then Nothing else Just $ T.pack user , sshDirectory = T.pack dir - , sshRepoName = genSshRepoName host dir + , sshRepoName = genSshRepoName host (toOsPath dir) -- dummy values, cannot determine from url , sshPort = 22 , needsPubKey = True @@ -118,10 +121,10 @@ parseSshUrl u fromssh = mkdata . break (== '/') {- Generates a git remote name, like host_dir or host -} -genSshRepoName :: String -> FilePath -> String +genSshRepoName :: String -> OsPath -> String genSshRepoName host dir - | null dir = makeLegalName host - | otherwise = makeLegalName $ host ++ "_" ++ dir + | OS.null dir = makeLegalName host + | otherwise = makeLegalName $ host ++ "_" ++ fromOsPath dir {- The output of ssh, including both stdout and stderr. -} sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool) @@ -149,17 +152,17 @@ validateSshPubKey pubkey where (ssh, keytype) = separate (== '-') prefix -addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool +addAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO Bool addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh" [ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ] {- Should only be used within the same process that added the line; - the layout of the line is not kepy stable across versions. -} -removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO () +removeAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO () removeAuthorizedKeys gitannexshellonly dir pubkey = do let keyline = authorizedKeysLine gitannexshellonly dir pubkey sshdir <- sshDir - let keyfile = toOsPath $ toRawFilePath $ sshdir "authorized_keys" + let keyfile = sshdir literalOsPath "authorized_keys" tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case Just ls -> viaTmp writeSshConfig keyfile $ unlines $ filter (/= keyline) ls @@ -171,7 +174,7 @@ removeAuthorizedKeys gitannexshellonly dir pubkey = do - The ~/.ssh/git-annex-shell wrapper script is created if not already - present. -} -addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String +addAuthorizedKeysCommand :: Bool -> OsPath -> SshPubKey -> String addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&" [ "mkdir -p ~/.ssh" , intercalate "; " @@ -202,27 +205,27 @@ addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&" ] runshell var = "exec git-annex-shell -c \"" ++ var ++ "\"" -authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String +authorizedKeysLine :: Bool -> OsPath -> SshPubKey -> String authorizedKeysLine gitannexshellonly dir pubkey | gitannexshellonly = limitcommand ++ pubkey {- TODO: Locking down rsync is difficult, requiring a rather - long perl script. -} | otherwise = pubkey where - limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty " + limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape (fromOsPath dir)++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty " {- Generates a ssh key pair. -} genSshKeyPair :: IO SshKeyPair -genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do +genSshKeyPair = withTmpDir (literalOsPath "git-annex-keygen") $ \dir -> do ok <- boolSystem "ssh-keygen" [ Param "-P", Param "" -- no password - , Param "-f", File $ dir "key" + , Param "-f", File $ fromOsPath (dir literalOsPath "key") ] unless ok $ giveup "ssh-keygen failed" SshKeyPair - <$> readFile (dir "key.pub") - <*> readFile (dir "key") + <$> readFile (fromOsPath (dir literalOsPath "key.pub")) + <*> readFile (fromOsPath (dir literalOsPath "key")) {- Installs a ssh key pair, and sets up ssh config with a mangled hostname - that will enable use of the key. This way we avoid changing the user's @@ -245,25 +248,28 @@ genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir installSshKeyPair :: SshKeyPair -> SshData -> IO SshData installSshKeyPair sshkeypair sshdata = do sshdir <- sshDir - createDirectoryIfMissing True $ fromRawFilePath $ - parentDir $ toRawFilePath $ sshdir sshPrivKeyFile sshdata + createDirectoryIfMissing True $ + parentDir $ sshdir sshPrivKeyFile sshdata unlessM (doesFileExist $ sshdir sshPrivKeyFile sshdata) $ - writeFileProtected (toRawFilePath (sshdir sshPrivKeyFile sshdata)) (sshPrivKey sshkeypair) + writeFileProtected (sshdir sshPrivKeyFile sshdata) + (sshPrivKey sshkeypair) unlessM (doesFileExist $ sshdir sshPubKeyFile sshdata) $ - writeFile (sshdir sshPubKeyFile sshdata) (sshPubKey sshkeypair) + writeFile (fromOsPath (sshdir sshPubKeyFile sshdata)) + (sshPubKey sshkeypair) setSshConfig sshdata - [ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata) + [ ("IdentityFile", "~/.ssh/" ++ fromOsPath (sshPrivKeyFile sshdata)) , ("IdentitiesOnly", "yes") , ("StrictHostKeyChecking", "yes") ] -sshPrivKeyFile :: SshData -> FilePath -sshPrivKeyFile sshdata = "git-annex" "key." ++ mangleSshHostName sshdata +sshPrivKeyFile :: SshData -> OsPath +sshPrivKeyFile sshdata = literalOsPath "git-annex" + literalOsPath "key." <> toOsPath (mangleSshHostName sshdata) -sshPubKeyFile :: SshData -> FilePath -sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub" +sshPubKeyFile :: SshData -> OsPath +sshPubKeyFile sshdata = sshPrivKeyFile sshdata <> literalOsPath ".pub" {- Generates an installs a new ssh key pair if one is not already - installed. Returns the modified SshData that will use the key pair, @@ -271,8 +277,8 @@ sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub" setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair) setupSshKeyPair sshdata = do sshdir <- sshDir - mprivkey <- catchMaybeIO $ readFile (sshdir sshPrivKeyFile sshdata) - mpubkey <- catchMaybeIO $ readFile (sshdir sshPubKeyFile sshdata) + mprivkey <- catchMaybeIO $ readFile (fromOsPath (sshdir sshPrivKeyFile sshdata)) + mpubkey <- catchMaybeIO $ readFile (fromOsPath (sshdir sshPubKeyFile sshdata)) keypair <- case (mprivkey, mpubkey) of (Just privkey, Just pubkey) -> return $ SshKeyPair { sshPubKey = pubkey @@ -324,7 +330,7 @@ setSshConfig :: SshData -> [(String, String)] -> IO SshData setSshConfig sshdata config = do sshdir <- sshDir createDirectoryIfMissing True sshdir - let configfile = sshdir "config" + let configfile = fromOsPath (sshdir literalOsPath "config") unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do appendFile configfile $ unlines $ [ "" @@ -332,7 +338,7 @@ setSshConfig sshdata config = do , "Host " ++ mangledhost ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) (settings ++ config) - setSshConfigMode (toRawFilePath configfile) + setSshConfigMode (toOsPath configfile) return $ sshdata { sshHostName = T.pack mangledhost @@ -403,7 +409,7 @@ unMangleSshHostName h = case splitc '-' h of knownHost :: Text -> IO Bool knownHost hostname = do sshdir <- sshDir - ifM (doesFileExist $ sshdir "known_hosts") + ifM (doesFileExist $ sshdir literalOsPath "known_hosts") ( not . null <$> checkhost , return False ) diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 85692767e7..6ffc9eb0e1 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -67,11 +67,10 @@ commitThread = namedThread "Committer" $ do liftAnnex $ do -- Clean up anything left behind by a previous process -- on unclean shutdown. - void $ liftIO $ tryIO $ removeDirectoryRecursive - (fromRawFilePath lockdowndir) + void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir void $ createAnnexDirectory lockdowndir waitChangeTime $ \(changes, time) -> do - readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher annexdotfiles delayadd $ + readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd $ simplifyChanges changes if shouldCommit False time (length readychanges) readychanges then do @@ -276,12 +275,12 @@ commitStaged msg = do - Any pending adds that are not ready yet are put back into the ChangeChan, - where they will be retried later. -} -handleAdds :: FilePath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change] +handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change] handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do let (pending, inprocess) = partition isPendingAddChange incomplete let lockdownconfig = LockDownConfig { lockingFile = False - , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) + , hardlinkFileTmpDir = Just lockdowndir , checkWritePerms = True } (postponed, toadd) <- partitionEithers @@ -307,12 +306,13 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret | otherwise = a checkpointerfile change = do - let file = toRawFilePath $ changeFile change + let file = changeFile change mk <- liftIO $ isPointerFile file case mk of Nothing -> return (Right change) Just key -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus (fromOsPath file) liftAnnex $ stagePointerFile file mode =<< hashPointerFile key return $ Left $ Change (changeTime change) @@ -328,7 +328,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret else checkmatcher | otherwise = checkmatcher where - f = toRawFilePath (changeFile change) + f = changeFile change checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f) ( return (Left change) , return (Right change) @@ -336,9 +336,9 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret addsmall [] = noop addsmall toadd = liftAnnex $ void $ tryIO $ - forM (map (toRawFilePath . changeFile) toadd) $ \f -> + forM (map changeFile toadd) $ \f -> Command.Add.addFile Command.Add.Small f - =<< liftIO (R.getSymbolicLinkStatus f) + =<< liftIO (R.getSymbolicLinkStatus (fromOsPath f)) {- Avoid overhead of re-injesting a renamed unlocked file, by - examining the other Changes to see if a removed file has the @@ -353,13 +353,13 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret delta <- liftAnnex getTSDelta let cfg = LockDownConfig { lockingFile = False - , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) + , hardlinkFileTmpDir = Just lockdowndir , checkWritePerms = True } if M.null m then forM toadd (addannexed' cfg) else forM toadd $ \c -> do - mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta + mcache <- liftIO $ genInodeCache (changeFile c) delta case mcache of Nothing -> addannexed' cfg c Just cache -> @@ -376,19 +376,19 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret (mkey, _mcache) <- liftAnnex $ do showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput [])) ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing - maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey + maybe (failedingest change) (done change $ keyFilename ks) mkey addannexed' _ _ = return Nothing fastadd :: Change -> Key -> Assistant (Maybe Change) fastadd change key = do let source = keySource $ lockedDown change liftAnnex $ finishIngestUnlocked key source - done change (fromRawFilePath $ keyFilename source) key + done change (keyFilename source) key removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap ct l = do mks <- forM (filter isRmChange l) $ \c -> - catKeyFile $ toRawFilePath $ changeFile c + catKeyFile $ changeFile c M.fromList . concat <$> mapM mkpairs (catMaybes mks) where mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> @@ -401,8 +401,9 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret done change file key = liftAnnex $ do logStatus NoLiveUpdate key InfoPresent - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) - stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus (fromOsPath file) + stagePointerFile file mode =<< hashPointerFile key showEndOk return $ Just $ finishedChange change key @@ -410,14 +411,14 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret - and is still a hard link to its contentLocation, - before ingesting it. -} sanitycheck keysource a = do - fs <- liftIO $ R.getSymbolicLinkStatus $ keyFilename keysource - ks <- liftIO $ R.getSymbolicLinkStatus $ contentLocation keysource + fs <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ keyFilename keysource + ks <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ contentLocation keysource if deviceID ks == deviceID fs && fileID ks == fileID fs then a else do -- remove the hard link when (contentLocation keysource /= keyFilename keysource) $ - void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation keysource + void $ liftIO $ tryIO $ removeFile $ contentLocation keysource return Nothing {- Shown an alert while performing an action to add a file or @@ -430,7 +431,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret - the add succeeded. -} addaction [] a = a - addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $ + addaction toadd a = alertWhile' (addFileAlert $ map (fromOsPath . changeFile) toadd) $ (,) <$> pure True <*> a @@ -440,7 +441,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret - - Check by running lsof on the repository. -} -safeToAdd :: FilePath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] +safeToAdd :: OsPath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] safeToAdd _ _ _ _ [] [] = return [] safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do maybe noop (liftIO . threadDelaySeconds) delayadd @@ -451,7 +452,8 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do then S.fromList . map fst3 . filter openwrite <$> findopenfiles (map (keySource . lockedDown) inprocess') else pure S.empty - let checked = map (check openfiles) inprocess' + let openfiles' = S.map toOsPath openfiles + let checked = map (check openfiles') inprocess' {- If new events are received when files are closed, - there's no need to retry any changes that cannot @@ -463,7 +465,7 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do else return checked where check openfiles change@(InProcessAddChange { lockedDown = ld }) - | S.member (fromRawFilePath (contentLocation (keySource ld))) openfiles = Left change + | S.member (contentLocation (keySource ld)) openfiles = Left change check _ change = Right change mkinprocess (c, Just ld) = Just InProcessAddChange @@ -478,7 +480,7 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do <> " still has writers, not adding" -- remove the hard link when (contentLocation ks /= keyFilename ks) $ - void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks + void $ liftIO $ tryIO $ removeFile $ contentLocation ks canceladd _ = noop openwrite (_file, mode, _pid) @@ -498,9 +500,9 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do findopenfiles keysources = ifM crippledFileSystem ( liftIO $ do let segments = segmentXargsUnordered $ - map (fromRawFilePath . keyFilename) keysources + map (fromOsPath . keyFilename) keysources concat <$> forM segments (\fs -> Lsof.query $ "--" : fs) - , liftIO $ Lsof.queryDir lockdowndir + , liftIO $ Lsof.queryDir (fromOsPath lockdowndir) ) {- After a Change is committed, queue any necessary transfers or drops @@ -521,5 +523,5 @@ checkChangeContent change@(Change { changeInfo = i }) = handleDrops "file renamed" present k af [] where f = changeFile change - af = AssociatedFile (Just (toRawFilePath f)) + af = AssociatedFile (Just f) checkChangeContent _ = noop diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index 9f1e03f8d1..97cd4af8bb 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -44,7 +44,7 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs when (old /= new) $ do let changedconfigs = new `S.difference` old debug $ "reloading config" : - map (fromRawFilePath . fst) + map (fromOsPath . fst) (S.toList changedconfigs) reloadConfigs new {- Record a commit to get this config @@ -54,10 +54,10 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs loop new {- Config files, and their checksums. -} -type Configs = S.Set (RawFilePath, Sha) +type Configs = S.Set (OsPath, Sha) {- All git-annex's config files, and actions to run when they change. -} -configFilesActions :: [(RawFilePath, Assistant ())] +configFilesActions :: [(OsPath, Assistant ())] configFilesActions = [ (uuidLog, void $ liftAnnex uuidDescMapLoad) , (remoteLog, void $ liftAnnex remotesChanged) @@ -91,5 +91,5 @@ getConfigs :: Assistant Configs getConfigs = S.fromList . map extract <$> liftAnnex (inRepo $ LsTree.lsTreeFiles (LsTree.LsTreeLong False) Annex.Branch.fullname files) where - files = map (fromRawFilePath . fst) configFilesActions + files = map (fromOsPath . fst) configFilesActions extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index c3dd8acfb5..9b063b5882 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -181,7 +181,7 @@ runActivity urlrenderer activity nowt = do runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant () runActivity' urlrenderer (ScheduledSelfFsck _ d) = do - program <- liftIO programPath + program <- fromOsPath <$> liftIO programPath g <- liftAnnex gitRepo fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do void $ batchCommand program (Param "fsck" : annexFsckParams d) @@ -196,7 +196,7 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (r dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of Nothing -> go rmt $ do - program <- programPath + program <- fromOsPath <$> programPath void $ batchCommand program $ [ Param "fsck" -- avoid downloading files diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 7b9db70abf..a68d01a94d 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -24,8 +24,7 @@ import qualified Git import qualified Git.Branch import qualified Git.Ref import qualified Command.Sync - -import qualified System.FilePath.ByteString as P +import qualified Utility.OsString as OS {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} @@ -33,7 +32,7 @@ mergeThread :: NamedThread mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo let gitd = Git.localGitDir g - let dir = gitd P. "refs" + let dir = gitd literalOsPath "refs" liftIO $ createDirectoryUnder [gitd] dir let hook a = Just <$> asIO2 (runHandler a) changehook <- hook onChange @@ -43,21 +42,21 @@ mergeThread = namedThread "Merger" $ do , modifyHook = changehook , errHook = errhook } - void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id - debug ["watching", fromRawFilePath dir] + void $ liftIO $ watchDir dir (const False) True hooks id + debug ["watching", fromOsPath dir] -type Handler = FilePath -> Assistant () +type Handler t = t -> Assistant () {- Runs an action handler. - - Exceptions are ignored, otherwise a whole thread could be crashed. -} -runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () +runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant () runHandler handler file _filestatus = either (liftIO . print) (const noop) =<< tryIO <~> handler file {- Called when there's an error with inotify. -} -onErr :: Handler +onErr :: Handler String onErr = giveup {- Called when a new branch ref is written, or a branch ref is modified. @@ -66,9 +65,9 @@ onErr = giveup - ok; it ensures that any changes pushed since the last time the assistant - ran are merged in. -} -onChange :: Handler +onChange :: Handler OsPath onChange file - | ".lock" `isSuffixOf` file = noop + | literalOsPath ".lock" `OS.isSuffixOf` file = noop | isAnnexBranch file = do branchChanged diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case @@ -112,7 +111,7 @@ onChange file - to the second branch, which should be merged into it? -} isRelatedTo :: Git.Ref -> Git.Ref -> Bool isRelatedTo x y - | basex /= takeDirectory basex ++ "/" ++ basey = False + | basex /= fromOsPath (takeDirectory (toOsPath basex)) ++ "/" ++ basey = False | "/synced/" `isInfixOf` Git.fromRef x = True | "refs/remotes/" `isPrefixOf` Git.fromRef x = True | otherwise = False @@ -120,12 +119,12 @@ isRelatedTo x y basex = Git.fromRef $ Git.Ref.base x basey = Git.fromRef $ Git.Ref.base y -isAnnexBranch :: FilePath -> Bool -isAnnexBranch f = n `isSuffixOf` f +isAnnexBranch :: OsPath -> Bool +isAnnexBranch f = n `isSuffixOf` fromOsPath f where n = '/' : Git.fromRef Annex.Branch.name -fileToBranch :: FilePath -> Git.Ref -fileToBranch f = Git.Ref $ encodeBS $ "refs" base +fileToBranch :: OsPath -> Git.Ref +fileToBranch f = Git.Ref $ fromOsPath $ literalOsPath "refs" toOsPath base where - base = Prelude.last $ split "/refs/" f + base = Prelude.last $ split "/refs/" (fromOsPath f) diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 11997fbd71..eb8e770a8c 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -138,12 +138,12 @@ pollingThread urlrenderer = go =<< liftIO currentMountPoints handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant () handleMounts urlrenderer wasmounted nowmounted = - mapM_ (handleMount urlrenderer . mnt_dir) $ + mapM_ (handleMount urlrenderer . toOsPath . mnt_dir) $ S.toList $ newMountPoints wasmounted nowmounted -handleMount :: UrlRenderer -> FilePath -> Assistant () +handleMount :: UrlRenderer -> OsPath -> Assistant () handleMount urlrenderer dir = do - debug ["detected mount of", dir] + debug ["detected mount of", fromOsPath dir] rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo) =<< remotesUnder dir mapM_ (fsckNudge urlrenderer . Just) rs @@ -157,7 +157,7 @@ handleMount urlrenderer dir = do - at startup time, or may have changed (it could even be a different - repository at the same remote location..) -} -remotesUnder :: FilePath -> Assistant [Remote] +remotesUnder :: OsPath -> Assistant [Remote] remotesUnder dir = do repotop <- liftAnnex $ fromRepo Git.repoPath rs <- liftAnnex remoteList @@ -169,7 +169,7 @@ remotesUnder dir = do return $ mapMaybe snd $ filter fst pairs where checkremote repotop r = case Remote.localpath r of - Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) -> + Just p | dirContains dir (absPathFrom repotop p) -> (,) <$> pure True <*> updateRemote r _ -> return (False, Just r) diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 0199b79f84..fe39c62972 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -121,7 +121,7 @@ pairReqReceived False urlrenderer msg = do pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress] pairAckReceived True (Just pip) msg cache = do stopSending pip - repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo + repodir <- repoPath <$> liftAnnex gitRepo liftIO $ setupAuthorizedKeys msg repodir finishedLocalPairing msg (inProgressSshKeyPair pip) startSending pip PairDone $ multicastPairMsg diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs index 51f5e4b9b4..bfd888955a 100644 --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -28,7 +28,7 @@ import qualified Data.Set as S remoteControlThread :: NamedThread remoteControlThread = namedThread "RemoteControl" $ do - program <- liftIO programPath + program <- liftIO $ fromOsPath <$> programPath (cmd, params) <- liftIO $ toBatchCommand (program, [Param "remotedaemon", Param "--foreground"]) let p = proc cmd (toCommand params) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 563e038e78..f9ff82dadb 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -68,7 +68,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta ifM (not <$> liftAnnex (inRepo checkIndexFast)) ( do debug ["corrupt index file found at startup; removing and restaging"] - liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile + liftAnnex $ inRepo $ removeWhenExistsWith removeFile . indexFile {- Normally the startup scan avoids re-staging files, - but with the index deleted, everything needs to be - restaged. -} @@ -82,7 +82,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta - will be automatically regenerated. -} unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do debug ["corrupt annex/index file found at startup; removing"] - liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex + liftAnnex $ liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexIndex {- Fix up ssh remotes set up by past versions of the assistant. -} liftIO $ fixUpSshRemotes @@ -154,13 +154,13 @@ dailyCheck urlrenderer = do batchmaker <- liftIO getBatchCommandMaker -- Find old unstaged symlinks, and add them to git. - (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False ["."] g + (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False [literalOsPath "."] g now <- liftIO getPOSIXTime forM_ unstaged $ \file -> do - ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file + ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file case ms of Just s | toonew (statusChangeTime s) now -> noop - | isSymbolicLink s -> addsymlink (fromRawFilePath file) ms + | isSymbolicLink s -> addsymlink file ms _ -> noop liftIO $ void cleanup @@ -182,7 +182,7 @@ dailyCheck urlrenderer = do {- Run git-annex unused once per day. This is run as a separate - process to stay out of the annex monad and so it can run as a - batch job. -} - program <- liftIO programPath + program <- fromOsPath <$> liftIO programPath let (program', params') = batchmaker (program, [Param "unused"]) void $ liftIO $ boolSystem program' params' {- Invalidate unused keys cache, and queue transfers of all unused @@ -202,7 +202,7 @@ dailyCheck urlrenderer = do void $ addAlert $ sanityCheckFixAlert msg addsymlink file s = do Watcher.runHandler Watcher.onAddSymlink file s - insanity $ "found unstaged symlink: " ++ file + insanity $ "found unstaged symlink: " ++ fromOsPath file hourlyCheck :: Assistant () hourlyCheck = do @@ -222,14 +222,14 @@ hourlyCheck = do -} checkLogSize :: Int -> Assistant () checkLogSize n = do - f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile - logs <- liftIO $ listLogs f - totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs + f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile + logs <- liftIO $ listLogs (fromOsPath f) + totalsize <- liftIO $ sum <$> mapM (getFileSize . toOsPath) logs when (totalsize > 2 * oneMegabyte) $ do debug ["Rotated logs due to size:", show totalsize] - liftIO $ openLog f >>= handleToFd >>= redirLog + liftIO $ openLog (fromOsPath f) >>= handleToFd >>= redirLog when (n < maxLogs + 1) $ do - df <- liftIO $ getDiskFree $ takeDirectory f + df <- liftIO $ getDiskFree $ fromOsPath $ takeDirectory f case df of Just free | free < fromIntegral totalsize -> @@ -270,5 +270,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit checkRepoExists :: Assistant () checkRepoExists = do g <- liftAnnex gitRepo - liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $ + liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $ terminateSelf diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index bff9263fb6..0b52e8121f 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -38,26 +38,26 @@ transferWatcherThread = namedThread "TransferWatcher" $ do , modifyHook = modifyhook , errHook = errhook } - void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id + void $ liftIO $ watchDir dir (const False) True hooks id debug ["watching for transfers"] -type Handler = FilePath -> Assistant () +type Handler t = t -> Assistant () {- Runs an action handler. - - Exceptions are ignored, otherwise a whole thread could be crashed. -} -runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () +runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant () runHandler handler file _filestatus = either (liftIO . print) (const noop) =<< tryIO <~> handler file {- Called when there's an error with inotify. -} -onErr :: Handler +onErr :: Handler String onErr = giveup {- Called when a new transfer information file is written. -} -onAdd :: Handler -onAdd file = case parseTransferFile (toRawFilePath file) of +onAdd :: Handler OsPath +onAdd file = case parseTransferFile file of Nothing -> noop Just t -> go t =<< liftAnnex (checkTransfer t) where @@ -72,10 +72,10 @@ onAdd file = case parseTransferFile (toRawFilePath file) of - - The only thing that should change in the transfer info is the - bytesComplete, so that's the only thing updated in the DaemonStatus. -} -onModify :: Handler -onModify file = case parseTransferFile (toRawFilePath file) of +onModify :: Handler OsPath +onModify file = case parseTransferFile file of Nothing -> noop - Just t -> go t =<< liftIO (readTransferInfoFile Nothing (toRawFilePath file)) + Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) where go _ Nothing = noop go t (Just newinfo) = alterTransferInfo t $ @@ -87,8 +87,8 @@ watchesTransferSize :: Bool watchesTransferSize = modifyTracked {- Called when a transfer information file is removed. -} -onDel :: Handler -onDel file = case parseTransferFile (toRawFilePath file) of +onDel :: Handler OsPath +onDel file = case parseTransferFile file of Nothing -> noop Just t -> do debug [ "transfer finishing:", show t] diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs index 5960a70c32..b474b6d420 100644 --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -46,7 +46,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do , modifyHook = changed , delDirHook = changed } - let dir = fromRawFilePath (parentDir (toRawFilePath flagfile)) + let dir = parentDir flagfile let depth = length (splitPath dir) + 1 let nosubdirs f = length (splitPath f) == depth void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) @@ -57,7 +57,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do void $ swapMVar mvar Started return r -changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant () +changedFile :: UrlRenderer -> MVar WatcherState -> OsPath -> OsPath -> Maybe FileStatus -> Assistant () changedFile urlrenderer mvar flagfile file _status | flagfile /= file = noop | otherwise = do diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 37ac9b876e..1e38195cfe 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -42,6 +42,7 @@ import Git.FilePath import Config.GitConfig import Utility.ThreadScheduler import Logs.Location +import qualified Utility.OsString as OS import qualified Database.Keys #ifndef mingw32_HOST_OS import qualified Utility.Lsof as Lsof @@ -94,16 +95,16 @@ runWatcher = do delhook <- hook onDel addsymlinkhook <- hook onAddSymlink deldirhook <- hook onDelDir - errhook <- hook onErr + errhook <- asIO2 onErr let hooks = mkWatchHooks { addHook = addhook , delHook = delhook , addSymlinkHook = addsymlinkhook , delDirHook = deldirhook - , errHook = errhook + , errHook = Just errhook } scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig - h <- liftIO $ watchDir "." ignored scanevents hooks startup + h <- liftIO $ watchDir (literalOsPath ".") ignored scanevents hooks startup debug [ "watching", "."] {- Let the DirWatcher thread run until signalled to pause it, @@ -138,9 +139,8 @@ startupScan scanner = do top <- liftAnnex $ fromRepo Git.repoPath (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top] forM_ fs $ \f -> do - let f' = fromRawFilePath f - liftAnnex $ onDel' f' - maybe noop recordChange =<< madeChange f' RmChange + liftAnnex $ onDel' f + maybe noop recordChange =<< madeChange f RmChange void $ liftIO cleanup liftAnnex $ showAction "started" @@ -157,30 +157,31 @@ startupScan scanner = do {- Hardcoded ignores, passed to the DirWatcher so it can avoid looking - at the entire .git directory. Does not include .gitignores. -} -ignored :: FilePath -> Bool +ignored :: OsPath -> Bool ignored = ig . takeFileName where - ig ".git" = True - ig ".gitignore" = True - ig ".gitattributes" = True + ig f + | f == literalOsPath ".git" = True + | f == literalOsPath ".gitignore" = True + | f == literalOsPath ".gitattributes" = True #ifdef darwin_HOST_OS - ig ".DS_Store" = True + | f == literlosPath ".DS_Store" = True #endif - ig _ = False + | otherwise = False -unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change) -unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file)) +unlessIgnored :: OsPath -> Assistant (Maybe Change) -> Assistant (Maybe Change) +unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file) ( noChange , a ) -type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change) +type Handler = OsPath -> Maybe FileStatus -> Assistant (Maybe Change) {- Runs an action handler, and if there was a change, adds it to the ChangeChan. - - Exceptions are ignored, otherwise a whole watcher thread could be crashed. -} -runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () +runHandler :: Handler -> OsPath -> Maybe FileStatus -> Assistant () runHandler handler file filestatus = void $ do r <- tryIO <~> handler (normalize file) filestatus case r of @@ -189,7 +190,7 @@ runHandler handler file filestatus = void $ do Right (Just change) -> recordChange change where normalize f - | "./" `isPrefixOf` file = drop 2 f + | literalOsPath "./" `OS.isPrefixOf` file = OS.drop 2 f | otherwise = f shouldRestage :: DaemonStatus -> Bool @@ -201,34 +202,34 @@ onAddFile symlinkssupported f fs = where addassociatedfile key file = Database.Keys.addAssociatedFile key - =<< inRepo (toTopFilePath (toRawFilePath file)) + =<< inRepo (toTopFilePath file) samefilestatus key file status = do cache <- Database.Keys.getInodeCaches key curr <- withTSDelta $ \delta -> - liftIO $ toInodeCache delta (toRawFilePath file) status + liftIO $ toInodeCache delta file status case (cache, curr) of (_, Just c) -> elemInodeCaches c cache ([], Nothing) -> return True _ -> return False contentchanged oldkey file = do Database.Keys.removeAssociatedFile oldkey - =<< inRepo (toTopFilePath (toRawFilePath file)) + =<< inRepo (toTopFilePath file) unlessM (inAnnex oldkey) $ logStatus NoLiveUpdate oldkey InfoMissing addlink file key = do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) - liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file) + liftAnnex $ stagePointerFile file mode =<< hashPointerFile key madeChange file $ LinkChange (Just key) onAddFile' - :: (Key -> FilePath -> Annex ()) - -> (Key -> FilePath -> Annex ()) - -> (FilePath -> Key -> Assistant (Maybe Change)) - -> (Key -> FilePath -> FileStatus -> Annex Bool) + :: (Key -> OsPath -> Annex ()) + -> (Key -> OsPath -> Annex ()) + -> (OsPath -> Key -> Assistant (Maybe Change)) + -> (Key -> OsPath -> FileStatus -> Annex Bool) -> Bool -> Handler onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do - v <- liftAnnex $ catKeyFile (toRawFilePath file) + v <- liftAnnex $ catKeyFile file case (v, fs) of (Just key, Just filestatus) -> ifM (liftAnnex $ samefilestatus key file filestatus) @@ -242,13 +243,13 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo , noChange ) , guardSymlinkStandin (Just key) $ do - debug ["changed", file] + debug ["changed", fromOsPath file] liftAnnex $ contentchanged key file pendingAddChange file ) _ -> unlessIgnored file $ guardSymlinkStandin Nothing $ do - debug ["add", file] + debug ["add", fromOsPath file] pendingAddChange file where {- On a filesystem without symlinks, we'll get changes for regular @@ -258,8 +259,7 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo guardSymlinkStandin mk a | symlinkssupported = a | otherwise = do - linktarget <- liftAnnex $ getAnnexLinkTarget $ - toRawFilePath file + linktarget <- liftAnnex $ getAnnexLinkTarget file case linktarget of Nothing -> a Just lt -> do @@ -275,21 +275,20 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo -} onAddSymlink :: Handler onAddSymlink file filestatus = unlessIgnored file $ do - linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file') - kv <- liftAnnex (lookupKey file') + linktarget <- liftIO $ catchMaybeIO $ + R.readSymbolicLink (fromOsPath file) + kv <- liftAnnex (lookupKey file) onAddSymlink' linktarget kv file filestatus - where - file' = toRawFilePath file onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler onAddSymlink' linktarget mk file filestatus = go mk where go (Just key) = do - link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key + link <- liftAnnex $ fromOsPath <$> calcRepo (gitAnnexLink file key) if linktarget == Just link then ensurestaged (Just link) =<< getDaemonStatus else do - liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $ + liftAnnex $ replaceWorkTreeFile file $ makeAnnexLink link addLink file link (Just key) -- other symlink, not git-annex @@ -315,33 +314,32 @@ onAddSymlink' linktarget mk file filestatus = go mk ensurestaged Nothing _ = noChange {- For speed, tries to reuse the existing blob for symlink target. -} -addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change) +addLink :: OsPath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change) addLink file link mk = do - debug ["add symlink", file] + debug ["add symlink", fromOsPath file] liftAnnex $ do - v <- catObjectDetails $ Ref $ encodeBS $ ':':file + v <- catObjectDetails $ Ref $ encodeBS $ ':':fromOsPath file case v of Just (currlink, sha, _type) | L.fromStrict link == currlink -> - stageSymlink (toRawFilePath file) sha - _ -> stageSymlink (toRawFilePath file) - =<< hashSymlink link + stageSymlink file sha + _ -> stageSymlink file =<< hashSymlink link madeChange file $ LinkChange mk onDel :: Handler onDel file _ = do - debug ["file deleted", file] + debug ["file deleted", fromOsPath file] liftAnnex $ onDel' file madeChange file RmChange -onDel' :: FilePath -> Annex () +onDel' :: OsPath -> Annex () onDel' file = do - topfile <- inRepo (toTopFilePath (toRawFilePath file)) + topfile <- inRepo (toTopFilePath file) withkey $ flip Database.Keys.removeAssociatedFile topfile Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.unstageFile (toRawFilePath file)) + inRepo (Git.UpdateIndex.unstageFile file) where - withkey a = maybe noop a =<< catKeyFile (toRawFilePath file) + withkey a = maybe noop a =<< catKeyFile file {- A directory has been deleted, or moved, so tell git to remove anything - that was inside it from its cache. Since it could reappear at any time, @@ -351,23 +349,21 @@ onDel' file = do - pairing up renamed files when the directory was renamed. -} onDelDir :: Handler onDelDir dir _ = do - debug ["directory deleted", dir] - (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [toRawFilePath dir] - let fs' = map fromRawFilePath fs + debug ["directory deleted", fromOsPath dir] + (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [dir] - liftAnnex $ mapM_ onDel' fs' + liftAnnex $ mapM_ onDel' fs -- Get the events queued up as fast as possible, so the -- committer sees them all in one block. now <- liftIO getCurrentTime - recordChanges $ map (\f -> Change now f RmChange) fs' + recordChanges $ map (\f -> Change now f RmChange) fs void $ liftIO clean noChange {- Called when there's an error with inotify or kqueue. -} -onErr :: Handler +onErr :: String -> Maybe FileStatus -> Assistant () onErr msg _ = do liftAnnex $ warning (UnquotedString msg) void $ addAlert $ warningAlert "watcher" msg - noChange diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index ad7cd13d47..9a65e5bf8c 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -62,7 +62,7 @@ webAppThread -> Maybe (IO Url) -> Maybe HostName -> Maybe PortNumber - -> Maybe (Url -> FilePath -> IO ()) + -> Maybe (Url -> OsPath -> IO ()) -> NamedThread webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do listenhost' <- if isJust listenhost @@ -89,15 +89,13 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost , return app ) runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex - then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do + then withTmpFile (literalOsPath "webapp.html") $ \tmpfile h -> do hClose h - go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing + go tlssettings addr webapp tmpfile Nothing else do htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile - go tlssettings addr webapp - (fromRawFilePath htmlshim) - (Just urlfile) + go tlssettings addr webapp htmlshim (Just urlfile) where -- The webapp thread does not wait for the startupSanityCheckThread -- to finish, so that the user interface remains responsive while @@ -105,8 +103,8 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost thread = namedThreadUnchecked "WebApp" getreldir | noannex = return Nothing - | otherwise = Just <$> - (relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath)) + | otherwise = Just . fromOsPath <$> + (relHome =<< absPath =<< getAnnex' (fromRepo repoPath)) go tlssettings addr webapp htmlshim urlfile = do let url = myUrl tlssettings webapp addr maybe noop (`writeFileProtected` url) urlfile @@ -131,6 +129,8 @@ getTlsSettings = do cert <- fromRepo gitAnnexWebCertificate privkey <- fromRepo gitAnnexWebPrivKey ifM (liftIO $ allM doesFileExist [cert, privkey]) - ( return $ Just $ TLS.tlsSettings cert privkey + ( return $ Just $ TLS.tlsSettings + (fromOsPath cert) + (fromOsPath privkey) , return Nothing ) diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 9f97764445..af9b06b3f0 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -174,7 +174,7 @@ genTransfer t info = case transferRemote info of AssociatedFile Nothing -> noop AssociatedFile (Just af) -> void $ addAlert $ makeAlertFiller True $ - transferFileAlert direction True (fromRawFilePath af) + transferFileAlert direction True (fromOsPath af) unless isdownload $ handleDrops ("object uploaded to " ++ show remote) diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs index a08810ba54..b8494ad7a7 100644 --- a/Assistant/Types/Changes.hs +++ b/Assistant/Types/Changes.hs @@ -9,10 +9,10 @@ module Assistant.Types.Changes where +import Common import Types.KeySource import Types.Key import Utility.TList -import Utility.FileSystemEncoding import Annex.Ingest import Control.Concurrent.STM @@ -34,12 +34,12 @@ newChangePool = atomically newTList data Change = Change { changeTime :: UTCTime - , _changeFile :: FilePath + , _changeFile :: OsPath , changeInfo :: ChangeInfo } | PendingAddChange { changeTime ::UTCTime - , _changeFile :: FilePath + , _changeFile :: OsPath } | InProcessAddChange { changeTime ::UTCTime @@ -55,10 +55,10 @@ changeInfoKey (AddKeyChange k) = Just k changeInfoKey (LinkChange (Just k)) = Just k changeInfoKey _ = Nothing -changeFile :: Change -> FilePath +changeFile :: Change -> OsPath changeFile (Change _ f _) = f changeFile (PendingAddChange _ f) = f -changeFile (InProcessAddChange _ ld) = fromRawFilePath $ keyFilename $ keySource ld +changeFile (InProcessAddChange _ ld) = keyFilename $ keySource ld isPendingAddChange :: Change -> Bool isPendingAddChange (PendingAddChange {}) = True diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs index d63a00ca93..4afc0d7047 100644 --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -34,7 +34,7 @@ describeUnusedWhenBig = describeUnused' True - than the remaining free disk space, or more than 1/10th the total - disk space being unused keys all suggest a problem. -} describeUnused' :: Bool -> Assistant (Maybe TenseText) -describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog "" +describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog (literalOsPath "") where go m = do let num = M.size m @@ -64,13 +64,13 @@ describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog "" sumkeysize s k = s + fromMaybe 0 (fromKey keySize k) - forpath a = inRepo $ liftIO . a . fromRawFilePath . Git.repoPath + forpath a = inRepo $ liftIO . a . fromOsPath . Git.repoPath {- With a duration, expires all unused files that are older. - With Nothing, expires *all* unused files. -} expireUnused :: Maybe Duration -> Assistant () expireUnused duration = do - m <- liftAnnex $ readUnusedLog "" + m <- liftAnnex $ readUnusedLog (literalOsPath "") now <- liftIO getPOSIXTime let oldkeys = M.keys $ M.filter (tooold now) m forM_ oldkeys $ \k -> do diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 3d448c4998..df91bb976d 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Assistant.Upgrade where @@ -42,10 +43,10 @@ import qualified Annex.Url as Url hiding (download) import Utility.Tuple import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F +import qualified Utility.OsString as OS import Data.Either import qualified Data.Map as M -import qualified System.FilePath.ByteString as P {- Upgrade without interaction in the webapp. -} unattendedUpgrade :: Assistant () @@ -89,12 +90,12 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol hook <- asIO1 $ distributionDownloadComplete d dest cleanup modifyDaemonStatus_ $ \s -> s { transferHook = M.insert k hook (transferHook s) } - maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t) + maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t) =<< liftAnnex (remoteFromUUID webUUID) startTransfer t k = mkKey $ const $ distributionKey d u = distributionUrl d - f = takeFileName u ++ " (for upgrade)" + f = takeFileName (toOsPath u) <> literalOsPath " (for upgrade)" t = Transfer { transferDirection = Download , transferUUID = webUUID @@ -110,7 +111,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol - - Verifies the content of the downloaded key. -} -distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant () +distributionDownloadComplete :: GitAnnexDistribution -> OsPath -> Assistant () -> Transfer -> Assistant () distributionDownloadComplete d dest cleanup t | transferDirection t == Download = do debug ["finished downloading git-annex distribution"] @@ -120,11 +121,11 @@ distributionDownloadComplete d dest cleanup t where k = mkKey $ const $ distributionKey d fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case - Nothing -> return $ Just (fromRawFilePath f) + Nothing -> return $ Just f Just b -> case Types.Backend.verifyKeyContent b of - Nothing -> return $ Just (fromRawFilePath f) + Nothing -> return $ Just f Just verifier -> ifM (verifier k f) - ( return $ Just (fromRawFilePath f) + ( return $ Just f , return Nothing ) go f = do @@ -142,7 +143,7 @@ distributionDownloadComplete d dest cleanup t - and unpack the new distribution next to it (in a versioned directory). - Then update the programFile to point to the new version. -} -upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant () +upgradeToDistribution :: OsPath -> Assistant () -> OsPath -> Assistant () upgradeToDistribution newdir cleanup distributionfile = do liftIO $ createDirectoryIfMissing True newdir (program, deleteold) <- unpack @@ -156,92 +157,92 @@ upgradeToDistribution newdir cleanup distributionfile = do postUpgrade url where changeprogram program = liftIO $ do - unlessM (boolSystem program [Param "version"]) $ + unlessM (boolSystem (fromOsPath program) [Param "version"]) $ giveup "New git-annex program failed to run! Not using." pf <- programFile - liftIO $ writeFile pf program + liftIO $ writeFile (fromOsPath pf) (fromOsPath program) #ifdef darwin_HOST_OS {- OS X uses a dmg, so mount it, and copy the contents into place. -} unpack = liftIO $ do olddir <- oldVersionLocation - withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) "git-annex.upgrade" $ \tmpdir -> do + withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do void $ boolSystem "hdiutil" [ Param "attach", File distributionfile - , Param "-mountpoint", File tmpdir + , Param "-mountpoint", File (fromOsPath tmpdir) ] void $ boolSystem "cp" [ Param "-R" - , File $ tmpdir installBase "Contents" + , File $ fromOsPath $ tmpdir toOsPath installBase literalOsPath "Contents" , File $ newdir ] void $ boolSystem "hdiutil" [ Param "eject" - , File tmpdir + , File (fromOsPath tmpdir) ] sanitycheck newdir let deleteold = do - deleteFromManifest $ olddir "Contents" "MacOS" + deleteFromManifest $ toOsPath olddir literalOsPath "Contents" literalOsPath "MacOS" makeorigsymlink olddir - return (newdir "Contents" "MacOS" "git-annex", deleteold) + return (newdir literalOsPath "Contents" literalOsPath "MacOS" literalOsPath "git-annex", deleteold) #else {- Linux uses a tarball (so could other POSIX systems), so - untar it (into a temp directory) and move the directory - into place. -} unpack = liftIO $ do olddir <- oldVersionLocation - withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) (toOsPath $ toRawFilePath "git-annex.upgrade") $ \tmpdir -> do - let tarball = tmpdir "tar" + withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do + let tarball = tmpdir literalOsPath "tar" -- Cannot rely on filename extension, and this also -- avoids problems if tar doesn't support transparent -- decompression. void $ boolSystem "sh" [ Param "-c" - , Param $ "zcat < " ++ shellEscape distributionfile ++ - " > " ++ shellEscape tarball + , Param $ "zcat < " ++ shellEscape (fromOsPath distributionfile) ++ + " > " ++ shellEscape (fromOsPath tarball) ] tarok <- boolSystem "tar" [ Param "xf" - , Param tarball - , Param "--directory", File tmpdir + , Param (fromOsPath tarball) + , Param "--directory", File (fromOsPath tmpdir) ] unless tarok $ - giveup $ "failed to untar " ++ distributionfile - sanitycheck $ tmpdir installBase - installby R.rename newdir (tmpdir installBase) + giveup $ "failed to untar " ++ fromOsPath distributionfile + sanitycheck $ tmpdir toOsPath installBase + installby R.rename newdir (tmpdir toOsPath installBase) let deleteold = do deleteFromManifest olddir makeorigsymlink olddir - return (newdir "git-annex", deleteold) + return (newdir literalOsPath "git-annex", deleteold) installby a dstdir srcdir = - mapM_ (\x -> a x (toRawFilePath dstdir P. P.takeFileName x)) - =<< dirContents (toRawFilePath srcdir) + mapM_ (\x -> a (fromOsPath x) (fromOsPath (dstdir takeFileName x))) + =<< dirContents srcdir #endif sanitycheck dir = unlessM (doesDirectoryExist dir) $ - giveup $ "did not find " ++ dir ++ " in " ++ distributionfile + giveup $ "did not find " ++ fromOsPath dir ++ " in " ++ fromOsPath distributionfile makeorigsymlink olddir = do - let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) installBase - removeWhenExistsWith R.removeLink (toRawFilePath origdir) - R.createSymbolicLink (toRawFilePath newdir) (toRawFilePath origdir) + let origdir = parentDir olddir toOsPath installBase + removeWhenExistsWith removeFile origdir + R.createSymbolicLink (fromOsPath newdir) (fromOsPath origdir) {- Finds where the old version was installed. -} -oldVersionLocation :: IO FilePath +oldVersionLocation :: IO OsPath oldVersionLocation = readProgramFile >>= \case Nothing -> giveup "Cannot find old distribution bundle; not upgrading." Just pf -> do - let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf + let pdir = parentDir pf #ifdef darwin_HOST_OS let dirs = splitDirectories pdir {- It will probably be deep inside a git-annex.app directory. -} - let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of + let olddir = case findIndex (literalOsPath "git-annex.app" `OS.isPrefixOf`) dirs of Nothing -> pdir Just i -> joinPath (take (i + 1) dirs) #else let olddir = pdir #endif - when (null olddir) $ - giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" + when (OS.null olddir) $ + giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ fromOsPath pdir ++ ")" return olddir {- Finds a place to install the new version. @@ -251,15 +252,15 @@ oldVersionLocation = readProgramFile >>= \case - - The directory is created. If it already exists, returns Nothing. -} -newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath) +newVersionLocation :: GitAnnexDistribution -> OsPath -> IO (Maybe OsPath) newVersionLocation d olddir = trymkdir newloc $ do home <- myHomeDir - trymkdir (home s) $ + trymkdir (toOsPath home s) $ return Nothing where - s = installBase ++ "." ++ distributionVersion d - topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir + s = toOsPath $ installBase ++ "." ++ distributionVersion d + topdir = parentDir olddir newloc = topdir s trymkdir dir fallback = (createDirectory dir >> return (Just dir)) @@ -277,24 +278,25 @@ installBase = "git-annex." ++ #endif #endif -deleteFromManifest :: FilePath -> IO () +deleteFromManifest :: OsPath -> IO () deleteFromManifest dir = do - fs <- map (dir ) . lines <$> catchDefaultIO "" (readFile manifest) - mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs - removeWhenExistsWith R.removeLink (toRawFilePath manifest) - removeEmptyRecursive (toRawFilePath dir) + fs <- map (\f -> dir toOsPath f) . lines + <$> catchDefaultIO "" (readFile (fromOsPath manifest)) + mapM_ (removeWhenExistsWith removeFile) fs + removeWhenExistsWith removeFile manifest + removeEmptyRecursive dir where - manifest = dir "git-annex.MANIFEST" + manifest = dir literalOsPath "git-annex.MANIFEST" -removeEmptyRecursive :: RawFilePath -> IO () +removeEmptyRecursive :: OsPath -> IO () removeEmptyRecursive dir = do mapM_ removeEmptyRecursive =<< dirContents dir - void $ tryIO $ removeDirectory (fromRawFilePath dir) + void $ tryIO $ removeDirectory dir {- This is a file that the UpgradeWatcher can watch for modifications to - detect when git-annex has been upgraded. -} -upgradeFlagFile :: IO FilePath +upgradeFlagFile :: IO OsPath upgradeFlagFile = programPath {- Sanity check to see if an upgrade is complete and the program is ready @@ -309,13 +311,13 @@ upgradeSanityCheck = ifM usingDistribution program <- programPath untilM (doesFileExist program <&&> nowriter program) $ threadDelaySeconds (Seconds 60) - boolSystem program [Param "version"] + boolSystem (fromOsPath program) [Param "version"] ) where nowriter f = null . filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly]) . map snd3 - <$> Lsof.query [f] + <$> Lsof.query [fromOsPath f] usingDistribution :: IO Bool usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV" @@ -324,14 +326,14 @@ downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution) downloadDistributionInfo = do uo <- liftAnnex Url.getUrlOptions gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig - liftIO $ withTmpDir (toOsPath (toRawFilePath "git-annex.tmp")) $ \tmpdir -> do - let infof = tmpdir "info" - let sigf = infof ++ ".sig" + liftIO $ withTmpDir (literalOsPath "git-annex.tmp") $ \tmpdir -> do + let infof = tmpdir literalOsPath "info" + let sigf = infof <> literalOsPath ".sig" ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo <&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo) <&&> verifyDistributionSig gpgcmd sigf) ( parseInfoFile . map decodeBS . fileLines' - <$> F.readFile' (toOsPath (toRawFilePath infof)) + <$> F.readFile' infof , return Nothing ) @@ -360,20 +362,20 @@ upgradeSupported = False - The gpg keyring used to verify the signature is located in - trustedkeys.gpg, next to the git-annex program. -} -verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool +verifyDistributionSig :: GpgCmd -> OsPath -> IO Bool verifyDistributionSig gpgcmd sig = readProgramFile >>= \case Just p | isAbsolute p -> - withUmask 0o0077 $ withTmpDir (toOsPath (toRawFilePath "git-annex-gpg.tmp")) $ \gpgtmp -> do - let trustedkeys = takeDirectory p "trustedkeys.gpg" + withUmask 0o0077 $ withTmpDir (literalOsPath "git-annex-gpg.tmp") $ \gpgtmp -> do + let trustedkeys = takeDirectory p literalOsPath "trustedkeys.gpg" boolGpgCmd gpgcmd [ Param "--no-default-keyring" , Param "--no-auto-check-trustdb" , Param "--no-options" , Param "--homedir" - , File gpgtmp + , File (fromOsPath gpgtmp) , Param "--keyring" - , File trustedkeys + , File (fromOsPath trustedkeys) , Param "--verify" - , File sig + , File (fromOsPath sig) ] _ -> return False diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 31b5b19d14..ebc6c165b1 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -78,7 +78,7 @@ deleteCurrentRepository = dangerPage $ do sanityVerifierAForm $ SanityVerifier magicphrase case result of FormSuccess _ -> liftH $ do - dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath + dir <- liftAnnex $ fromRepo Git.repoPath liftIO $ removeAutoStartFile dir {- Disable syncing to this repository, and all @@ -89,9 +89,8 @@ deleteCurrentRepository = dangerPage $ do rs <- syncRemotes <$> getDaemonStatus mapM_ (\r -> changeSyncable (Just r) False) rs - liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir) - liftIO $ removeDirectoryRecursive . fromRawFilePath - =<< absPath (toRawFilePath dir) + liftAnnex $ prepareRemoveAnnexDir dir + liftIO $ removeDirectoryRecursive =<< absPath dir redirect ShutdownConfirmedR _ -> $(widgetFile "configurators/delete/currentrepository") diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 65da2d588e..4103f6bccb 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -121,7 +121,7 @@ setRepoConfig uuid mremote oldc newc = do Just t | T.null t -> noop | otherwise -> liftAnnex $ do - let dir = takeBaseName $ T.unpack t + let dir = fromOsPath $ takeBaseName $ toOsPath $ T.unpack t m <- remoteConfigMap case M.lookup uuid m of Nothing -> noop @@ -246,8 +246,8 @@ checkAssociatedDirectory cfg (Just r) = do case repoGroup cfg of RepoGroupStandard gr -> case associatedDirectory repoconfig gr of Just d -> do - top <- fromRawFilePath <$> fromRepo Git.repoPath - createWorkTreeDirectory (toRawFilePath (top d)) + top <- fromRepo Git.repoPath + createWorkTreeDirectory (top toOsPath d) Nothing -> noop _ -> noop diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 0b7c60a092..0d6b6f1eb3 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -81,24 +81,24 @@ checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text)) checkRepositoryPath p = do home <- myHomeDir let basepath = expandTilde home $ T.unpack p - path <- fromRawFilePath <$> absPath (toRawFilePath basepath) - let parent = fromRawFilePath $ parentDir (toRawFilePath path) + path <- absPath basepath + let parent = parentDir 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.") + [ (return $ path == literalOsPath "/", "Enter the full path to use for the repository.") + , (return $ all isSpace (fromOsPath basepath :: FilePath), "A blank path? Seems unlikely.") , (doesFileExist path, "A file already exists with that name.") - , (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.") + , (return $ fromOsPath path == home, "Sorry, using git-annex for your whole home directory is not currently supported.") , (not <$> doesDirectoryExist parent, "Parent directory does not exist.") , (not <$> canWrite path, "Cannot write a repository there.") ] return $ case headMaybe problems of - Nothing -> Right $ Just $ T.pack basepath + Nothing -> Right $ Just $ T.pack $ fromOsPath basepath Just prob -> Left prob where runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing ) - expandTilde home ('~':'/':path) = home path - expandTilde _ path = path + expandTilde home ('~':'/':path) = toOsPath home toOsPath path + expandTilde _ path = toOsPath path {- On first run, if run in the home directory, default to putting it in - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise. @@ -110,12 +110,12 @@ checkRepositoryPath p = do - the user probably wants to put it there. Unless that directory - contains a git-annex file, in which case the user has probably - browsed to a directory with git-annex and run it from there. -} -defaultRepositoryPath :: Bool -> IO FilePath +defaultRepositoryPath :: Bool -> IO OsPath defaultRepositoryPath firstrun = do #ifndef mingw32_HOST_OS home <- myHomeDir currdir <- liftIO getCurrentDirectory - if home == currdir && firstrun + if toOsPath home == currdir && firstrun then inhome else ifM (legit currdir <&&> canWrite currdir) ( return currdir @@ -130,29 +130,29 @@ defaultRepositoryPath firstrun = do where inhome = ifM osAndroid ( do - home <- myHomeDir - let storageshared = home "storage" "shared" + home <- toOsPath <$> myHomeDir + let storageshared = home literalOsPath "storage" literalOsPath "shared" ifM (doesDirectoryExist storageshared) ( relHome $ storageshared gitAnnexAssistantDefaultDir - , return $ "~" gitAnnexAssistantDefaultDir + , return $ literalOsPath "~" gitAnnexAssistantDefaultDir ) , do - desktop <- userDesktopDir + desktop <- toOsPath <$> userDesktopDir ifM (doesDirectoryExist desktop <&&> canWrite desktop) ( relHome $ desktop gitAnnexAssistantDefaultDir - , return $ "~" gitAnnexAssistantDefaultDir + , return $ literalOsPath "~" gitAnnexAssistantDefaultDir ) ) #ifndef mingw32_HOST_OS -- Avoid using eg, standalone build's git-annex.linux/ directory -- when run from there. - legit d = not <$> doesFileExist (d "git-annex") + legit d = not <$> doesFileExist (d literalOsPath "git-annex") #endif -newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath +newRepositoryForm :: OsPath -> Hamlet.Html -> MkMForm RepositoryPath newRepositoryForm defpath msg = do (pathRes, pathView) <- mreq (repositoryPathField True) (bfs "") - (Just $ T.pack $ addTrailingPathSeparator defpath) + (Just $ T.pack $ fromOsPath $ addTrailingPathSeparator defpath) let (err, errmsg) = case pathRes of FormMissing -> (False, "") FormFailure l -> (True, concatMap T.unpack l) @@ -174,17 +174,17 @@ postFirstRepositoryR = page "Getting started" (Just Configuration) $ do ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path case res of FormSuccess (RepositoryPath p) -> liftH $ - startFullAssistant (T.unpack p) ClientGroup Nothing + startFullAssistant (toOsPath $ T.unpack p) ClientGroup Nothing _ -> $(widgetFile "configurators/newrepository/first") getAndroidCameraRepositoryR :: Handler () getAndroidCameraRepositoryR = do home <- liftIO myHomeDir - let dcim = home "storage" "dcim" + let dcim = toOsPath home literalOsPath "storage" literalOsPath "dcim" startFullAssistant dcim SourceGroup $ Just addignore where addignore = do - liftIO $ unlessM (doesFileExist ".gitignore") $ + liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $ writeFile ".gitignore" ".thumbnails" void $ inRepo $ Git.Command.runBool [Param "add", File ".gitignore"] @@ -195,20 +195,21 @@ getNewRepositoryR :: Handler Html getNewRepositoryR = postNewRepositoryR postNewRepositoryR :: Handler Html postNewRepositoryR = page "Add another repository" (Just Configuration) $ do - home <- liftIO myHomeDir + home <- toOsPath <$> liftIO myHomeDir ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home case res of FormSuccess (RepositoryPath p) -> do - let path = T.unpack p + let path = toOsPath (T.unpack p) isnew <- liftIO $ makeRepo path False u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup) liftIO $ addAutoStartFile path liftIO $ startAssistant path - askcombine u path + askcombine u (fromOsPath path) _ -> $(widgetFile "configurators/newrepository") where askcombine newrepouuid newrepopath = do - newrepo <- liftIO $ relHome newrepopath + newrepo' <- liftIO $ relHome (toOsPath newrepopath) + let newrepo = fromOsPath newrepo' :: FilePath mainrepo <- fromJust . relDir <$> liftH getYesod $(widgetFile "configurators/newrepository/combine") @@ -222,17 +223,18 @@ immediateSyncRemote r = do getCombineRepositoryR :: FilePath -> UUID -> Handler Html getCombineRepositoryR newrepopath newrepouuid = do - liftAssistant . immediateSyncRemote =<< combineRepos newrepopath remotename + liftAssistant . immediateSyncRemote + =<< combineRepos (toOsPath newrepopath) remotename redirect $ EditRepositoryR $ RepoUUID newrepouuid where - remotename = takeFileName newrepopath + remotename = fromOsPath $ takeFileName $ toOsPath newrepopath selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive <$> pure Nothing <*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing <*> areq textField (bfs "Use this directory on the drive:") - (Just $ T.pack gitAnnexAssistantDefaultDir) + (Just $ T.pack $ fromOsPath gitAnnexAssistantDefaultDir) where pairs = zip (map describe drives) (map mountPoint drives) describe drive = case diskFree drive of @@ -246,9 +248,9 @@ selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive ] onlywritable = [whamlet|This list only includes drives you can write to.|] -removableDriveRepository :: RemovableDrive -> FilePath +removableDriveRepository :: RemovableDrive -> OsPath removableDriveRepository drive = - T.unpack (mountPoint drive) T.unpack (driveRepoPath drive) + toOsPath (T.unpack (mountPoint drive)) toOsPath (T.unpack (driveRepoPath drive)) {- Adding a removable drive. -} getAddDriveR :: Handler Html @@ -257,7 +259,7 @@ postAddDriveR :: Handler Html postAddDriveR = page "Add a removable drive" (Just Configuration) $ do removabledrives <- liftIO driveList writabledrives <- liftIO $ - filterM (canWrite . T.unpack . mountPoint) removabledrives + filterM (canWrite . toOsPath . T.unpack . mountPoint) removabledrives ((res, form), enctype) <- liftH $ runFormPostNoToken $ selectDriveForm (sort writabledrives) case res of @@ -277,7 +279,7 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir) mu <- liftIO $ probeUUID dir case mu of Nothing -> maybe askcombine isknownuuid - =<< liftAnnex (probeGCryptRemoteUUID dir) + =<< liftAnnex (probeGCryptRemoteUUID $ fromOsPath dir) Just driveuuid -> isknownuuid driveuuid , newrepo ) @@ -317,19 +319,19 @@ getFinishAddDriveR drive = go where go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do r <- liftAnnex $ addRemote $ - makeGCryptRemote remotename dir keyid + makeGCryptRemote remotename (fromOsPath dir) keyid return (Types.Remote.uuid r, r) - go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted makeunencrypted $ do - mu <- liftAnnex $ probeGCryptRemoteUUID dir + go NoRepoKey = checkGCryptRepoEncryption (fromOsPath dir) makeunencrypted makeunencrypted $ do + mu <- liftAnnex $ probeGCryptRemoteUUID (fromOsPath dir) case mu of Just u -> enableexistinggcryptremote u Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported." enableexistinggcryptremote u = do - remotename' <- liftAnnex $ getGCryptRemoteName u dir + remotename' <- liftAnnex $ getGCryptRemoteName u (fromOsPath dir) makewith $ const $ do r <- liftAnnex $ addRemote $ enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList - [(Proposed "gitrepo", Proposed dir)] + [(Proposed "gitrepo", Proposed (fromOsPath dir))] return (u, r) {- Making a new unencrypted repo, or combining with an existing one. -} makeunencrypted = makewith $ \isnew -> (,) @@ -347,21 +349,19 @@ getFinishAddDriveR drive = go liftAnnex $ defaultStandardGroup u TransferGroup liftAssistant $ immediateSyncRemote r redirect $ EditNewRepositoryR u - mountpoint = T.unpack (mountPoint drive) + mountpoint = toOsPath $ T.unpack (mountPoint drive) dir = removableDriveRepository drive - remotename = takeFileName mountpoint + remotename = fromOsPath $ takeFileName mountpoint {- Each repository is made a remote of the other. - Next call syncRemote to get them in sync. -} -combineRepos :: FilePath -> String -> Handler Remote +combineRepos :: OsPath -> String -> Handler Remote combineRepos dir name = liftAnnex $ do hostname <- fromMaybe "host" <$> liftIO getHostname - mylocation <- fromRepo Git.repoLocation - mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile - (toRawFilePath dir) - (toRawFilePath mylocation) - liftIO $ inDir dir $ void $ makeGitRemote hostname mypath - addRemote $ makeGitRemote name dir + mylocation <- fromRepo Git.repoPath + mypath <- liftIO $ relPathDirToFile dir mylocation + liftIO $ inDir dir $ void $ makeGitRemote hostname (fromOsPath mypath) + addRemote $ makeGitRemote name (fromOsPath dir) getEnableDirectoryR :: UUID -> Handler Html getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do @@ -396,12 +396,12 @@ genRemovableDrive :: FilePath -> IO RemovableDrive genRemovableDrive dir = RemovableDrive <$> getDiskFree dir <*> pure (T.pack dir) - <*> pure (T.pack gitAnnexAssistantDefaultDir) + <*> pure (T.pack $ fromOsPath gitAnnexAssistantDefaultDir) {- Bootstraps from first run mode to a fully running assistant in a - repository, by running the postFirstRun callback, which returns the - url to the new webapp. -} -startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler () +startFullAssistant :: OsPath -> StandardGroup -> Maybe (Annex ())-> Handler () startFullAssistant path repogroup setup = do webapp <- getYesod url <- liftIO $ do @@ -417,17 +417,17 @@ startFullAssistant path repogroup setup = do - - The directory may be in the process of being created; if so - the parent directory is checked instead. -} -canWrite :: FilePath -> IO Bool +canWrite :: OsPath -> IO Bool canWrite dir = do tocheck <- ifM (doesDirectoryExist dir) ( return dir - , return $ fromRawFilePath $ parentDir $ toRawFilePath dir + , return $ parentDir dir ) - catchBoolIO $ R.fileAccess (toRawFilePath tocheck) False True False + catchBoolIO $ R.fileAccess (fromOsPath tocheck) False True False {- Gets the UUID of the git repo at a location, which may not exist, or - not be a git-annex repo. -} -probeUUID :: FilePath -> IO (Maybe UUID) +probeUUID :: OsPath -> IO (Maybe UUID) probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do u <- getUUID return $ if u == NoUUID then Nothing else Just u diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index ceff21a3bf..a9ed6c0be1 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -72,7 +72,7 @@ getPrepareWormholePairR pairingwith = do enableTor :: Handler () enableTor = do - gitannex <- liftIO programPath + gitannex <- fromOsPath <$> liftIO programPath (transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing if ok -- Reload remotedameon so it's serving the tor hidden @@ -173,7 +173,7 @@ getFinishLocalPairR = postFinishLocalPairR postFinishLocalPairR :: PairMsg -> Handler Html #ifdef WITH_PAIRING postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do - repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo + repodir <- liftH $ repoPath <$> liftAnnex gitRepo liftIO $ setup repodir startLocalPairing PairAck (cleanup repodir) alert uuid "" secret where diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs index 14b3267b1c..a21da3306c 100644 --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -23,7 +23,6 @@ import Types.Distribution import Assistant.Upgrade import qualified Data.Text as T -import qualified System.FilePath.ByteString as P data PrefsForm = PrefsForm { diskReserve :: Text @@ -89,7 +88,7 @@ storePrefs p = do unsetConfig (annexConfig "numcopies") -- deprecated setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p) unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do - here <- fromRawFilePath <$> fromRepo Git.repoPath + here <- fromRepo Git.repoPath liftIO $ if autoStart p then addAutoStartFile here else removeAutoStartFile here @@ -110,5 +109,4 @@ postPreferencesR = page "Preferences" (Just Configuration) $ do inAutoStartFile :: Annex Bool inAutoStartFile = do here <- liftIO . absPath =<< fromRepo Git.repoPath - any (`P.equalFilePath` here) . map toRawFilePath - <$> liftIO readAutoStartFile + any (`equalFilePath` here) <$> liftIO readAutoStartFile diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 4edfee9fca..e56f434805 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -76,7 +76,7 @@ mkSshData s = SshData , sshDirectory = fromMaybe "" $ inputDirectory s , sshRepoName = genSshRepoName (T.unpack $ fromJust $ inputHostname s) - (maybe "" T.unpack $ inputDirectory s) + (toOsPath (maybe "" T.unpack $ inputDirectory s)) , sshPort = inputPort s , needsPubKey = False , sshCapabilities = [] -- untested @@ -101,7 +101,7 @@ sshInputAForm hostnamefield d = normalize <$> gen <*> aopt check_username (bfs "User name") (Just $ inputUsername d) <*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod d) <*> aopt passwordField (bfs "Password") Nothing - <*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory d) + <*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack $ fromOsPath gitAnnexAssistantDefaultDir) $ inputDirectory d) <*> areq intField (bfs "Port") (Just $ inputPort d) authmethods :: [(Text, AuthMethod)] @@ -389,13 +389,13 @@ sshAuthTranscript sshinput opts sshhost cmd input = case inputAuthMethod sshinpu v <- getCachedCred login liftIO $ case v of Nothing -> go [passwordprompts 0] Nothing - Just pass -> withTmpFile (toOsPath "ssh") $ \passfile h -> do + Just pass -> withTmpFile (literalOsPath "ssh") $ \passfile h -> do hClose h - writeFileProtected (fromOsPath passfile) pass + writeFileProtected passfile pass environ <- getEnvironment let environ' = addEntries - [ ("SSH_ASKPASS", program) - , (sshAskPassEnv, fromRawFilePath $ fromOsPath passfile) + [ ("SSH_ASKPASS", fromOsPath program) + , (sshAskPassEnv, fromOsPath passfile) , ("DISPLAY", ":0") ] environ go [passwordprompts 1] (Just environ') @@ -531,7 +531,7 @@ prepSsh' needsinit origsshdata sshdata keypair a ] , if needsinit then Just (wrapCommand "git annex init") else Nothing , if needsPubKey origsshdata - then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair + then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) (toOsPath remotedir) . sshPubKey <$> keypair else Nothing ] rsynconly = onlyCapability origsshdata RsyncCapable @@ -602,7 +602,7 @@ postAddRsyncNetR = do |] go sshinput = do let reponame = genSshRepoName "rsync.net" - (maybe "" T.unpack $ inputDirectory sshinput) + (toOsPath (maybe "" T.unpack $ inputDirectory sshinput)) prepRsyncNet sshinput reponame $ \sshdata -> inpage $ checkExistingGCrypt sshdata $ do diff --git a/Assistant/WebApp/Configurators/Unused.hs b/Assistant/WebApp/Configurators/Unused.hs index 11f60e3127..55b1e565ae 100644 --- a/Assistant/WebApp/Configurators/Unused.hs +++ b/Assistant/WebApp/Configurators/Unused.hs @@ -51,7 +51,7 @@ postConfigUnusedR = page "Unused files" (Just Configuration) $ do redirect ConfigurationR _ -> do munuseddesc <- liftAssistant describeUnused - ts <- liftAnnex $ dateUnusedLog "" + ts <- liftAnnex $ dateUnusedLog (literalOsPath "") mlastchecked <- case ts of Nothing -> pure Nothing Just t -> Just <$> liftIO (durationSince t) diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs index 5d60731bfe..0f0a76584e 100644 --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -73,6 +73,6 @@ getRestartThreadR name = do getLogR :: Handler Html getLogR = page "Logs" Nothing $ do logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile - logs <- liftIO $ listLogs (fromRawFilePath logfile) + logs <- liftIO $ listLogs (fromOsPath logfile) logcontent <- liftIO $ concat <$> mapM readFile logs $(widgetFile "control/log") diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 5bbcee3c92..4fbba263b0 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -45,7 +45,7 @@ transfersDisplay = do transferPaused info || isNothing (startedTime info) desc transfer info = case associatedFile info of AssociatedFile Nothing -> serializeKey $ transferKey transfer - AssociatedFile (Just af) -> fromRawFilePath af + AssociatedFile (Just af) -> fromOsPath af {- Simplifies a list of transfers, avoiding display of redundant - equivalent transfers. -} @@ -118,7 +118,7 @@ getFileBrowserR = whenM openFileBrowser redirectBack - blocking the response to the browser on it. -} openFileBrowser :: Handler Bool openFileBrowser = do - path <- fromRawFilePath + path <- fromOsPath <$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath)) #ifdef darwin_HOST_OS let cmd = "open" diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs index 63c4f7cb98..a6dcc03853 100644 --- a/Assistant/WebApp/Documentation.hs +++ b/Assistant/WebApp/Documentation.hs @@ -16,10 +16,10 @@ import BuildFlags {- The full license info may be included in a file on disk that can - be read in and displayed. -} -licenseFile :: IO (Maybe FilePath) +licenseFile :: IO (Maybe OsPath) licenseFile = do base <- standaloneAppBase - return $ ( "LICENSE") <$> base + return $ ( literalOsPath "LICENSE") <$> base getAboutR :: Handler Html getAboutR = page "About git-annex" (Just About) $ do @@ -34,7 +34,7 @@ getLicenseR = do Just f -> customPage (Just About) $ do -- no sidebar, just pages of legalese.. setTitle "License" - license <- liftIO $ readFile f + license <- liftIO $ readFile (fromOsPath f) $(widgetFile "documentation/license") getRepoGroupR :: Handler Html diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs index c13d93ffdc..4b45cc9541 100644 --- a/Assistant/WebApp/OtherRepos.hs +++ b/Assistant/WebApp/OtherRepos.hs @@ -15,7 +15,6 @@ import Assistant.WebApp.Page 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 @@ -25,15 +24,16 @@ getRepositorySwitcherR = page "Switch repository" Nothing $ do listOtherRepos :: IO [(String, String)] listOtherRepos = do dirs <- readAutoStartFile - pwd <- R.getCurrentDirectory + pwd <- getCurrentDirectory gooddirs <- filterM isrepo $ - filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs + filter (\d -> not $ d `dirContains` pwd) dirs names <- mapM relHome gooddirs - return $ sort $ zip names gooddirs + return $ sort $ zip (map fromOsPath names) (map fromOsPath gooddirs) where - isrepo d = doesDirectoryExist (d ".git") + isrepo d = doesDirectoryExist (d literalOsPath ".git") getSwitchToRepositoryR :: FilePath -> Handler Html getSwitchToRepositoryR repo = do - liftIO $ addAutoStartFile repo -- make this the new default repo - redirect =<< liftIO (newAssistantUrl repo) + let repo' = toOsPath repo + liftIO $ addAutoStartFile repo' -- make this the new default repo + redirect =<< liftIO (newAssistantUrl repo') diff --git a/Backend.hs b/Backend.hs index 216b59fb4a..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 (toRawFilePath file) <> " (" <> + warning $ "skipping " <> QuotedPath file <> " (" <> UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")" return Nothing @@ -78,7 +78,7 @@ unknownBackendVarietyMessage v = {- 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 :: RawFilePath -> Annex Backend +chooseBackend :: OsPath -> Annex Backend chooseBackend f = Annex.getRead Annex.forcebackend >>= go where go Nothing = do diff --git a/Backend/External.hs b/Backend/External.hs index 53416c7e4b..23977d1ce7 100644 --- a/Backend/External.hs +++ b/Backend/External.hs @@ -96,7 +96,7 @@ genKeyExternal ebname hasext ks meterupdate = withExternalState ebname hasext $ \st -> handleRequest st req notavail go where - req = GENKEY (fromRawFilePath (contentLocation ks)) + req = GENKEY (fromOsPath (contentLocation ks)) notavail = giveup $ "Cannot generate a key, since " ++ externalBackendProgram ebname ++ " is not available." go (GENKEY_SUCCESS pk) = Just $ Result <$> fromProtoKey pk hasext ks @@ -107,12 +107,12 @@ genKeyExternal ebname hasext ks meterupdate = return $ GetNextMessage go go _ = Nothing -verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> RawFilePath -> Annex Bool +verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> OsPath -> Annex Bool verifyKeyContentExternal ebname hasext meterupdate k f = withExternalState ebname hasext $ \st -> handleRequest st req notavail go where - req = VERIFYKEYCONTENT (toProtoKey k) (fromRawFilePath f) + req = VERIFYKEYCONTENT (toProtoKey k) (fromOsPath 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/GitRemoteAnnex.hs b/Backend/GitRemoteAnnex.hs index 2eaba4a4d6..02b60244a5 100644 --- a/Backend/GitRemoteAnnex.hs +++ b/Backend/GitRemoteAnnex.hs @@ -75,7 +75,7 @@ sameCheckSum key s = s == expected expected = reverse $ takeWhile (/= '-') $ reverse $ decodeBS $ S.fromShort $ fromKey keyName key -genGitBundleKey :: UUID -> RawFilePath -> MeterUpdate -> Annex Key +genGitBundleKey :: UUID -> OsPath -> MeterUpdate -> Annex Key genGitBundleKey remoteuuid file meterupdate = do filesize <- liftIO $ getFileSize file s <- Hash.hashFile hash file meterupdate diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 80cd8e64d8..652bd796d7 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -127,7 +127,7 @@ keyValueE hash source meterupdate = keyValue hash source meterupdate >>= addE source (const $ hashKeyVariety hash (HasExt True)) -checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> RawFilePath -> Annex Bool +checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> OsPath -> Annex Bool checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do showAction (UnquotedString descChecksum) issame key @@ -187,7 +187,7 @@ trivialMigrate' oldkey newbackend afile maxextlen maxexts AssociatedFile Nothing -> Nothing AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d { keyName = S.toShort $ keyHash oldkey - <> selectExtension maxextlen maxexts file + <> selectExtension maxextlen maxexts (fromOsPath file) , keyVariety = newvariety } {- Upgrade to fix bad previous migration that created a @@ -205,9 +205,9 @@ trivialMigrate' oldkey newbackend afile maxextlen maxexts oldvariety = fromKey keyVariety oldkey newvariety = backendVariety newbackend -hashFile :: Hash -> RawFilePath -> MeterUpdate -> Annex String +hashFile :: Hash -> OsPath -> MeterUpdate -> Annex String hashFile hash file meterupdate = - liftIO $ withMeteredFile (fromRawFilePath file) meterupdate $ \b -> do + liftIO $ withMeteredFile file meterupdate $ \b -> do let h = (fst $ hasher hash) b -- Force full evaluation of hash so whole file is read -- before returning. diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs index 244ded29e5..69da541452 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -49,7 +49,7 @@ addE source sethasext k = do let ext = selectExtension (annexMaxExtensionLength c) (annexMaxExtensions c) - (keyFilename source) + (fromOsPath (keyFilename source)) return $ alterKey k $ \d -> d { keyName = keyName d <> S.toShort ext , keyVariety = sethasext (keyVariety d) diff --git a/Backend/VURL/Utilities.hs b/Backend/VURL/Utilities.hs index 37dcb9eea6..82e5939e7c 100644 --- a/Backend/VURL/Utilities.hs +++ b/Backend/VURL/Utilities.hs @@ -43,7 +43,7 @@ migrateFromVURLToURL oldkey newbackend _af _ | otherwise = return Nothing -- The Backend must use a cryptographically secure hash. -generateEquivilantKey :: Backend -> RawFilePath -> Annex (Maybe Key) +generateEquivilantKey :: Backend -> OsPath -> Annex (Maybe Key) generateEquivilantKey b f = case genKey b of Just genkey -> do diff --git a/Backend/WORM.hs b/Backend/WORM.hs index 2e2df45004..1eb95d28b0 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -42,9 +42,9 @@ backend = Backend keyValue :: KeySource -> MeterUpdate -> Annex Key keyValue source _ = do let f = contentLocation source - stat <- liftIO $ R.getFileStatus f + stat <- liftIO $ R.getFileStatus (fromOsPath f) sz <- liftIO $ getFileSize' f stat - relf <- fromRawFilePath . getTopFilePath + relf <- fromOsPath . getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) return $ mkKey $ \k -> k { keyName = genKeyName relf diff --git a/Build/Configure.hs b/Build/Configure.hs index cce9488bae..2c848ce965 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -11,6 +11,7 @@ import Utility.SafeCommand import Utility.Env.Basic import qualified Git.Version import Utility.SystemDirectory +import Utility.OsPath import Control.Monad import Control.Applicative @@ -91,11 +92,11 @@ getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$> setup :: IO () setup = do - createDirectoryIfMissing True tmpDir + createDirectoryIfMissing True (toOsPath tmpDir) writeFile testFile "test file contents" cleanup :: IO () -cleanup = removeDirectoryRecursive tmpDir +cleanup = removeDirectoryRecursive (toOsPath tmpDir) run :: [TestCase] -> IO () run ts = do diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs index 00af543551..b69fd82854 100644 --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -6,17 +6,14 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Build.DesktopFile where -import Utility.Exception +import Common import Utility.FreeDesktop -import Utility.Path -import Utility.Monad -import Utility.SystemDirectory -import Utility.FileSystemEncoding import Config.Files import Utility.OSX import Assistant.Install.AutoStart @@ -25,8 +22,6 @@ import Assistant.Install.Menu import System.Environment #ifndef mingw32_HOST_OS import System.Posix.User -import Data.Maybe -import Control.Applicative import Prelude #endif @@ -42,10 +37,10 @@ systemwideInstall = isroot <||> (not <$> userdirset) systemwideInstall = return False #endif -inDestDir :: FilePath -> IO FilePath +inDestDir :: OsPath -> IO OsPath inDestDir f = do destdir <- catchDefaultIO "" (getEnv "DESTDIR") - return $ destdir ++ "/" ++ f + return $ toOsPath destdir <> literalOsPath "/" <> f writeFDODesktop :: FilePath -> IO () writeFDODesktop command = do @@ -54,7 +49,7 @@ writeFDODesktop command = do datadir <- if systemwide then return systemDataDir else userDataDir menufile <- inDestDir (desktopMenuFilePath "git-annex" datadir) icondir <- inDestDir (iconDir datadir) - installMenu command menufile "doc" icondir + installMenu command menufile (literalOsPath "doc") icondir configdir <- if systemwide then return systemConfigDir else userConfigDir installAutoStart command @@ -78,8 +73,8 @@ install command = do ( return () , do programfile <- inDestDir =<< programFile - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath programfile))) - writeFile programfile command + createDirectoryIfMissing True (parentDir programfile) + writeFile (fromOsPath programfile) command ) installUser :: FilePath -> IO () diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs index 434b6c31bd..fad73c4c76 100644 --- a/Build/LinuxMkLibs.hs +++ b/Build/LinuxMkLibs.hs @@ -26,11 +26,12 @@ import Utility.Path.AbsRel import Utility.FileMode import Utility.CopyFile import Utility.FileSystemEncoding +import Utility.SystemDirectory mklibs :: FilePath -> a -> IO Bool mklibs top _installedbins = do - fs <- dirContentsRecursive top - exes <- filterM checkExe fs + fs <- dirContentsRecursive (toRawFilePath top) + exes <- filterM checkExe (map fromRawFilePath fs) libs <- runLdd exes glibclibs <- glibcLibs diff --git a/Build/Standalone.hs b/Build/Standalone.hs index 367527430a..36a4d5a002 100644 --- a/Build/Standalone.hs +++ b/Build/Standalone.hs @@ -25,6 +25,7 @@ import Utility.Path.AbsRel import Utility.Directory import Utility.Env import Utility.FileSystemEncoding +import Utility.SystemDirectory import Build.BundledPrograms #ifdef darwin_HOST_OS import System.IO @@ -71,14 +72,15 @@ installGitLibs topdir = do -- install git-core programs; these are run by the git command createDirectoryIfMissing True gitcoredestdir execpath <- getgitpath "exec-path" - cfs <- dirContents execpath + cfs <- dirContents (toRawFilePath execpath) forM_ cfs $ \f -> do + let f' = fromRawFilePath f destf <- ((gitcoredestdir ) . fromRawFilePath) <$> relPathDirToFile (toRawFilePath execpath) - (toRawFilePath f) + f createDirectoryIfMissing True (takeDirectory destf) - issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f + issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f' if issymlink then do -- many git-core files may symlink to eg @@ -91,20 +93,20 @@ installGitLibs topdir = do -- Other git-core files symlink to a file -- beside them in the directory. Those -- links can be copied as-is. - linktarget <- readSymbolicLink f + linktarget <- readSymbolicLink f' if takeFileName linktarget == linktarget - then cp f destf + then cp f' destf else do let linktarget' = progDir topdir takeFileName linktarget unlessM (doesFileExist linktarget') $ do createDirectoryIfMissing True (takeDirectory linktarget') - L.readFile f >>= L.writeFile linktarget' + L.readFile f' >>= L.writeFile linktarget' removeWhenExistsWith removeLink destf rellinktarget <- relPathDirToFile (toRawFilePath (takeDirectory destf)) (toRawFilePath linktarget') createSymbolicLink (fromRawFilePath rellinktarget) destf - else cp f destf + else cp f' destf -- install git's template files -- git does not have an option to get the path of these, @@ -112,14 +114,14 @@ installGitLibs topdir = do -- next to the --man-path, in eg /usr/share/git-core manpath <- getgitpath "man-path" let templatepath = manpath ".." "git-core" "templates" - tfs <- dirContents templatepath + tfs <- dirContents (toRawFilePath templatepath) forM_ tfs $ \f -> do destf <- ((templatedestdir ) . fromRawFilePath) <$> relPathDirToFile (toRawFilePath templatepath) - (toRawFilePath f) + f createDirectoryIfMissing True (takeDirectory destf) - cp f destf + cp (fromRawFilePath f) destf where gitcoredestdir = topdir "git-core" templatedestdir = topdir "templates" diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index 5458612d4c..f20972fa8f 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -8,9 +8,9 @@ import Utility.Path import Utility.Monad import Utility.SafeCommand import Utility.SystemDirectory +import Utility.OsPath import System.IO -import System.FilePath type ConfigKey = String data ConfigValue = @@ -105,8 +105,11 @@ findCmdPath k command = do ) where find d = - let f = d command - in ifM (doesFileExist f) ( return (Just f), return Nothing ) + let f = toOsPath d toOsPath command + in ifM (doesFileExist f) + ( return (Just (fromOsPath f)) + , return Nothing + ) quiet :: String -> String quiet s = s ++ " >/dev/null 2>&1" diff --git a/Build/Version.hs b/Build/Version.hs index e3b905919d..3552814116 100644 --- a/Build/Version.hs +++ b/Build/Version.hs @@ -73,4 +73,4 @@ writeVersion ver = catchMaybeIO (F.readFile' f) >>= \case , "" ] footer = [] - f = toOsPath "Build/Version" + f = literalOsPath "Build/Version" diff --git a/CmdLine.hs b/CmdLine.hs index f432452e43..ebf0b3b1a1 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module CmdLine ( dispatch, usage, @@ -29,6 +31,7 @@ import Annex.Action import Annex.Environment import Command import Types.Messages +import qualified Utility.OsString as OS {- Parses input arguments, finds a matching Command, and runs it. -} dispatch :: Bool -> Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () @@ -159,17 +162,18 @@ findAddonCommand Nothing = return Nothing findAddonCommand (Just subcommandname) = searchPath c >>= \case Nothing -> return Nothing - Just p -> return (Just (mkAddonCommand p subcommandname)) + Just p -> return (Just (mkAddonCommand (fromOsPath p) subcommandname)) where c = "git-annex-" ++ subcommandname findAllAddonCommands :: IO [Command] findAllAddonCommands = filter isaddoncommand - . map (\p -> mkAddonCommand p (deprefix p)) - <$> searchPathContents ("git-annex-" `isPrefixOf`) + . map go + <$> searchPathContents (literalOsPath "git-annex-" `OS.isPrefixOf`) where - deprefix = replace "git-annex-" "" . takeFileName + go p = mkAddonCommand (fromOsPath p) (deprefix p) + deprefix = replace "git-annex-" "" . fromOsPath . takeFileName isaddoncommand c -- git-annex-shell | cmdname c == "shell" = False diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index 2a7924ab2b..3f69022d34 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -154,12 +154,12 @@ batchCommandStart a = a >>= \case -- to handle them. -- -- File matching options are checked, and non-matching files skipped. -batchFiles :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex () +batchFiles :: BatchFormat -> ((SeekInput, OsPath) -> CommandStart) -> Annex () batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> case v of Right f -> a (si, f) Left _k -> return Nothing -batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key RawFilePath) -> CommandStart) -> Annex () +batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key OsPath) -> CommandStart) -> Annex () batchFilesKeys fmt a = do matcher <- getMatcher go $ \si v -> case v of @@ -177,7 +177,7 @@ batchFilesKeys fmt a = do -- CmdLine.Seek uses git ls-files. BatchFormat _ (BatchKeys False) -> Right . Right - <$$> liftIO . relPathCwdToFile . toRawFilePath + <$$> liftIO . relPathCwdToFile . toOsPath BatchFormat _ (BatchKeys True) -> \i -> pure $ case deserializeKey i of Just k -> Right (Left k) diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 964b6da44e..251947ef5d 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -136,7 +136,7 @@ builtin cmd dir params = do "Restricted login shell for git-annex only SSH access" where mkrepo = do - r <- Git.Construct.repoAbsPath (toRawFilePath dir) + r <- Git.Construct.repoAbsPath (toOsPath dir) >>= Git.Construct.fromAbsPath let r' = r { repoPathSpecifiedExplicitly = True } Git.Config.read r' diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs index 8c623c7263..b104b412f2 100644 --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -48,9 +48,9 @@ checkDirectory mdir = do v <- getEnv "GIT_ANNEX_SHELL_DIRECTORY" case (v, mdir) of (Nothing, _) -> noop - (Just d, Nothing) -> req d Nothing + (Just d, Nothing) -> req (toOsPath d) Nothing (Just d, Just dir) - | d `equalFilePath` dir -> noop + | toOsPath d `equalFilePath` toOsPath dir -> noop | otherwise -> do home <- myHomeDir d' <- canondir home d @@ -61,19 +61,21 @@ checkDirectory mdir = do where req d mdir' = giveup $ unwords [ "Only allowed to access" - , d - , maybe "and could not determine directory from command line" ("not " ++) mdir' + , fromOsPath d + , maybe "and could not determine directory from command line" + (("not " ++) . fromOsPath) + mdir' ] {- A directory may start with ~/ or in some cases, even /~/, - or could just be relative to home, or of course could - be absolute. -} canondir home d - | "~/" `isPrefixOf` d = return d - | "/~/" `isPrefixOf` d = return $ drop 1 d - | otherwise = relHome $ fromRawFilePath $ absPathFrom - (toRawFilePath home) - (toRawFilePath d) + | "~/" `isPrefixOf` d = return $ toOsPath d + | "/~/" `isPrefixOf` d = return $ toOsPath $ drop 1 d + | otherwise = relHome $ absPathFrom + (toOsPath home) + (toOsPath 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/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs index 91bdc0b263..79d6befd5b 100644 --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -66,7 +66,6 @@ import Data.Char import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.Map.Strict as M -import qualified System.FilePath.ByteString as P import qualified Data.Set as S run :: [String] -> IO () @@ -146,13 +145,14 @@ list st rmt forpush = do else downloadManifestOrFail rmt l <- forM (inManifest manifest) $ \k -> do b <- downloadGitBundle rmt k - heads <- inRepo $ Git.Bundle.listHeads b + let b' = fromOsPath b + heads <- inRepo $ Git.Bundle.listHeads b' -- Get all the objects from the bundle. This is done here -- so that the tracking refs can be updated with what is -- listed, and so what when a full repush is done, all -- objects are available to be pushed. when forpush $ - inRepo $ Git.Bundle.unbundle b + inRepo $ Git.Bundle.unbundle b' -- The bundle may contain tracking refs, or regular refs, -- make sure we're operating on regular refs. return $ map (\(s, r) -> (fromTrackingRef rmt r, s)) heads @@ -202,7 +202,8 @@ fetch' :: State -> Remote -> Annex () fetch' st rmt = do manifest <- maybe (downloadManifestOrFail rmt) pure (manifestCache st) forM_ (inManifest manifest) $ \k -> - downloadGitBundle rmt k >>= inRepo . Git.Bundle.unbundle + downloadGitBundle rmt k + >>= inRepo . Git.Bundle.unbundle . fromOsPath -- Newline indicates end of fetch. liftIO $ do putStrLn "" @@ -496,10 +497,9 @@ resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String) resolveSpecialRemoteWebUrl url | "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl = Url.withUrlOptionsPromptingCreds $ \uo -> - withTmpFile (toOsPath "git-remote-annex") $ \tmp h -> do + withTmpFile (literalOsPath "git-remote-annex") $ \tmp h -> do liftIO $ hClose h - let tmp' = fromRawFilePath $ fromOsPath tmp - Url.download' nullMeterUpdate Nothing url tmp' uo >>= \case + Url.download' nullMeterUpdate Nothing url tmp uo >>= \case Left err -> giveup $ url ++ " " ++ err Right () -> liftIO $ fmap decodeBS @@ -728,9 +728,9 @@ downloadManifest rmt = get mkmain >>= maybe (get mkbak) (pure . Just) -- it needs to re-download it fresh every time, and the object -- file should not be stored locally. gettotmp dl = withOtherTmp $ \othertmp -> - withTmpFileIn (toOsPath othertmp) (toOsPath "GITMANIFEST") $ \tmp tmph -> do + withTmpFileIn othertmp (literalOsPath "GITMANIFEST") $ \tmp tmph -> do liftIO $ hClose tmph - _ <- dl (fromRawFilePath (fromOsPath tmp)) + _ <- dl tmp b <- liftIO (F.readFile' tmp) case parseManifest b of Right m -> Just <$> verifyManifest rmt m @@ -778,7 +778,7 @@ uploadManifest rmt manifest = do dropKey' rmt mk put mk - put mk = withTmpFile (toOsPath "GITMANIFEST") $ \tmp tmph -> do + put mk = withTmpFile (literalOsPath "GITMANIFEST") $ \tmp tmph -> do liftIO $ B8.hPut tmph (formatManifest manifest) liftIO $ hClose tmph -- Uploading needs the key to be in the annex objects @@ -789,13 +789,13 @@ uploadManifest rmt manifest = do -- keys, which it is not. objfile <- calcRepo (gitAnnexLocation mk) modifyContentDir objfile $ - linkOrCopy mk (fromOsPath tmp) objfile Nothing >>= \case + linkOrCopy mk tmp objfile Nothing >>= \case -- Important to set the right perms even -- though the object is only present -- briefly, since sending objects may rely -- on or even copy file perms. Just _ -> do - liftIO $ R.setFileMode objfile + liftIO $ R.setFileMode (fromOsPath objfile) =<< defaultFileMode freezeContent objfile Nothing -> uploadfailed @@ -843,9 +843,11 @@ parseManifest b = - interrupted before updating the manifest on the remote, or when a race - causes the uploaded manigest to be overwritten. -} -lastPushedManifestFile :: UUID -> Git.Repo -> RawFilePath -lastPushedManifestFile u r = gitAnnexDir r P. "git-remote-annex" - P. fromUUID u P. "manifest" +lastPushedManifestFile :: UUID -> Git.Repo -> OsPath +lastPushedManifestFile u r = gitAnnexDir r + literalOsPath "git-remote-annex" + fromUUID u + literalOsPath "manifest" {- Call before uploading anything. The returned manifest has added - to it any bundle keys that were in the lastPushedManifestFile @@ -861,7 +863,7 @@ startPush' rmt manifest = do f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt)) oldmanifest <- liftIO $ fromRight mempty . parseManifest - <$> F.readFile' (toOsPath f) + <$> F.readFile' f `catchNonAsync` (const (pure mempty)) let oldmanifest' = mkManifest [] $ S.fromList (inManifest oldmanifest) @@ -911,7 +913,7 @@ verifyManifest rmt manifest = -- and so more things pulled from it, etc. -- 3. Git bundle objects are not usually transferred between repositories -- except special remotes (although the user can if they want to). -downloadGitBundle :: Remote -> Key -> Annex FilePath +downloadGitBundle :: Remote -> Key -> Annex OsPath downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case Nothing -> dlwith $ download rmt k (AssociatedFile Nothing) stdRetry noNotification @@ -919,7 +921,7 @@ downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case anyM getexport locs where dlwith a = ifM a - ( decodeBS <$> calcRepo (gitAnnexLocation k) + ( calcRepo (gitAnnexLocation k) , giveup $ "Failed to download " ++ serializeKey k ) @@ -927,7 +929,7 @@ downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case getexport' loc = getViaTmp rsp vc k (AssociatedFile Nothing) Nothing $ \tmp -> do v <- Remote.retrieveExport (Remote.exportActions rmt) - k loc (decodeBS tmp) nullMeterUpdate + k loc tmp nullMeterUpdate return (True, v) rsp = Remote.retrievalSecurityPolicy rmt vc = Remote.RemoteVerify rmt @@ -952,7 +954,7 @@ checkPresentGitBundle rmt k = uploadGitObject :: Remote -> Key -> Annex () uploadGitObject rmt k = getKeyExportLocations rmt k >>= \case Just (loc:_) -> do - objfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation k) + objfile <- calcRepo (gitAnnexLocation k) Remote.storeExport (Remote.exportActions rmt) objfile k loc nullMeterUpdate _ -> unlessM (upload rmt k (AssociatedFile Nothing) retry noNotification) $ @@ -977,15 +979,14 @@ generateGitBundle -> Manifest -> Annex (Key, Annex ()) generateGitBundle rmt bs manifest = - withTmpFile (toOsPath "GITBUNDLE") $ \tmp tmph -> do - let tmp' = fromOsPath tmp + withTmpFile (literalOsPath "GITBUNDLE") $ \tmp tmph -> do liftIO $ hClose tmph - inRepo $ Git.Bundle.create (fromRawFilePath tmp') bs + inRepo $ Git.Bundle.create (fromOsPath tmp) bs bundlekey <- genGitBundleKey (Remote.uuid rmt) - tmp' nullMeterUpdate + tmp nullMeterUpdate if (bundlekey `notElem` inManifest manifest) then do - unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp') $ + unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp) $ giveup "Unable to push" return (bundlekey, uploadaction bundlekey) else return (bundlekey, noop) @@ -1025,7 +1026,7 @@ getKeyExportLocations rmt k = do keyExportLocations :: Remote -> Key -> GitConfig -> UUID -> Maybe [ExportLocation] keyExportLocations rmt k cfg uuid | exportTree (Remote.config rmt) || importTree (Remote.config rmt) = - Just $ map (\p -> mkExportLocation (".git" P. p)) $ + Just $ map (\p -> mkExportLocation (literalOsPath ".git" p)) $ concatMap (`annexLocationsBare` k) cfgs | otherwise = Nothing where @@ -1094,7 +1095,7 @@ getRepo = getEnv "GIT_WORK_TREE" >>= \case Nothing -> fixup <$> Git.CurrentRepo.get where fixup r@(Repo { location = loc@(Local { worktree = Just _ }) }) = - r { location = loc { worktree = Just (P.takeDirectory (gitdir loc)) } } + r { location = loc { worktree = Just (takeDirectory (gitdir loc)) } } fixup r = r -- Records what the git-annex branch was at the beginning of this command. @@ -1127,11 +1128,11 @@ startAnnexBranch = ifM (null <$> Annex.Branch.siblingBranches) -- journal writes to a temporary directory, so that all writes -- to the git-annex branch by the action will be discarded. specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a -specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do +specialRemoteFromUrl sab a = withTmpDir (literalOsPath "journal") $ \tmpdir -> do Annex.overrideGitConfig $ \c -> c { annexAlwaysCommit = False } Annex.BranchState.changeState $ \st -> - st { alternateJournal = Just (toRawFilePath tmpdir) } + st { alternateJournal = Just tmpdir } a `finally` cleanupInitialization sab tmpdir -- If the git-annex branch did not exist when this command started, @@ -1165,16 +1166,15 @@ specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do -- involve checking out an adjusted branch. But git clone wants to do its -- own checkout. So no initialization is done then, and the git bundle -- objects are deleted. -cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex () +cleanupInitialization :: StartAnnexBranch -> OsPath -> Annex () cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do - liftIO $ mapM_ R.removeLink - =<< dirContents (toRawFilePath alternatejournaldir) + liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir case sab of AnnexBranchExistedAlready _ -> noop AnnexBranchCreatedEmpty r -> whenM ((r ==) <$> Annex.Branch.getBranch) $ do indexfile <- fromRepo gitAnnexIndex - liftIO $ removeWhenExistsWith R.removeLink indexfile + liftIO $ removeWhenExistsWith removeFile indexfile -- When cloning failed and this is being -- run as an exception is thrown, HEAD will -- not be set to a valid value, which will @@ -1202,7 +1202,7 @@ cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do forM_ ks $ \k -> case fromKey keyVariety k of GitBundleKey -> lockContentForRemoval k noop removeAnnex _ -> noop - void $ liftIO $ tryIO $ removeDirectory (decodeBS annexobjectdir) + void $ liftIO $ tryIO $ removeDirectory annexobjectdir notcrippledfilesystem = not <$> probeCrippledFileSystem diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index a25c6b083b..c012811ac3 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -48,6 +48,7 @@ import qualified Database.Keys import qualified Utility.RawFilePath as R import Utility.Tuple import Utility.HumanTime +import qualified Utility.OsString as OS import Control.Concurrent.Async import Control.Concurrent.STM @@ -55,11 +56,9 @@ import System.Posix.Types import Data.IORef import Data.Time.Clock.POSIX import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID) -import qualified System.FilePath.ByteString as P -import qualified Data.ByteString as S data AnnexedFileSeeker = AnnexedFileSeeker - { startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart + { startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart , checkContentPresent :: Maybe Bool , usesLocationLog :: Bool } @@ -82,7 +81,7 @@ withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.ge getfiles c [] = return (reverse c, pure True) getfiles c (p:ps) = do os <- seekOptions ww - (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] + (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toOsPath p] r <- case fs of [f] -> do propagateLsFilesError cleanup @@ -96,18 +95,18 @@ withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.ge return (r, pure True) withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop -withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesNotInGit (CheckGitIgnore ci) ww a l = do force <- Annex.getRead Annex.force let include_ignored = force || not ci seekFiltered (const (pure True)) a $ seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l -withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek +withPathContents :: ((OsPath, OsPath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do matcher <- Limit.getMatcher checktimelimit <- mkCheckTimeLimit - go matcher checktimelimit params [] + go matcher checktimelimit (map toOsPath params) [] where go _ _ [] [] = return () go matcher checktimelimit (p:ps) [] = @@ -121,14 +120,12 @@ withPathContents a params = do -- fail if the path that the user provided is a broken symlink, -- the same as it fails if the path that the user provided does not -- exist. - get p = ifM (isDirectory <$> R.getFileStatus p') + get p = ifM (isDirectory <$> R.getFileStatus (fromOsPath p)) ( map (\f -> - (f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f)) - <$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p' - , return [(p', P.takeFileName p')] + (f, makeRelative (takeDirectory (dropTrailingPathSeparator p)) f)) + <$> dirContentsRecursiveSkipping (literalOsPath ".git" `OS.isSuffixOf`) False p + , return [(p, takeFileName p)] ) - where - p' = toRawFilePath p checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo { contentFile = f @@ -150,24 +147,24 @@ withPairs a params = sequence_ $ pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesToBeCommitted ww a l = seekFiltered (const (pure True)) a $ seekHelper id ww (const LsFiles.stagedNotDeleted) l {- unlocked pointer files that are staged, and whose content has not been - modified-} -withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withUnmodifiedUnlockedPointers ww a l = seekFiltered (isUnmodifiedUnlocked . snd) a $ seekHelper id ww (const LsFiles.typeChangedStaged) l -isUnmodifiedUnlocked :: RawFilePath -> Annex Bool +isUnmodifiedUnlocked :: OsPath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case Nothing -> return False Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k {- Finds files that may be modified. -} -withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesMaybeModified ww a params = seekFiltered (const (pure True)) a $ seekHelper id ww LsFiles.modified params @@ -320,7 +317,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do forM_ ts $ \(t, i) -> keyaction Nothing (SeekInput [], transferKey t, mkActionItem (t, i)) -seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex () +seekFiltered :: ((SeekInput, OsPath) -> Annex Bool) -> ((SeekInput, OsPath) -> CommandSeek) -> Annex ([(SeekInput, OsPath)], IO Bool) -> Annex () seekFiltered prefilter a listfs = do matcher <- Limit.getMatcher checktimelimit <- mkCheckTimeLimit @@ -351,7 +348,7 @@ checkMatcherWhen mi c i a -- because of the way data is streamed through git cat-file. -- -- It can also precache location logs using the same efficient streaming. -seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (RawFilePath, Git.Sha, FileMode))], IO Bool) -> Annex () +seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (OsPath, Git.Sha, FileMode))], IO Bool) -> Annex () seekFilteredKeys seeker listfs = do g <- Annex.gitRepo mi <- MatcherInfo @@ -465,7 +462,7 @@ seekFilteredKeys seeker listfs = do -- Check if files exist, because a deleted file will still be -- listed by ls-tree, but should not be processed. - exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) + exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath p)) mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case Just ((si, f), Just (sha, size, _type)) @@ -485,18 +482,18 @@ seekFilteredKeys seeker listfs = do null <$> Annex.Branch.getUnmergedRefs | otherwise = pure False -seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool) +seekHelper :: (a -> OsPath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [OsPath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool) seekHelper c ww a (WorkTreeItems l) = do os <- seekOptions ww v <- liftIO $ newIORef [] r <- inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l) - (runSegmentPaths' mk c (\fs -> go v os fs g) . map toRawFilePath) + (runSegmentPaths' mk c (\fs -> go v os fs g) . map toOsPath) return (r, cleanupall v) where - mk (Just i) f = (SeekInput [fromRawFilePath i], f) + mk (Just i) f = (SeekInput [fromOsPath i], f) -- This is not accurate, but it only happens when there are a -- great many input WorkTreeItems. - mk Nothing f = (SeekInput [fromRawFilePath (c f)], f) + mk Nothing f = (SeekInput [fromOsPath (c f)], f) go v os fs g = do (ls, cleanup) <- a os fs g @@ -561,7 +558,7 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of currbranch <- getCurrentBranch stopattop <- prepviasymlink ps' <- flip filterM ps $ \p -> do - let p' = toRawFilePath p + let p' = toOsPath p relf <- liftIO $ relPathCwdToFile p' ifM (not <$> (exists p' <||> hidden currbranch relf)) ( prob action FileNotFound p' "not found" @@ -574,13 +571,13 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of then return NoWorkTreeItems else return (WorkTreeItems ps') - exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) + exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath p) prepviasymlink = do repotopst <- inRepo $ maybe (pure Nothing) - (catchMaybeIO . R.getSymbolicLinkStatus) + (catchMaybeIO . R.getSymbolicLinkStatus . fromOsPath) . Git.repoWorkTree return $ \st -> case repotopst of Nothing -> False @@ -589,7 +586,7 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of viasymlink _ Nothing = return False viasymlink stopattop (Just p) = do - st <- liftIO $ R.getSymbolicLinkStatus p + st <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath p if stopattop st then return False else if isSymbolicLink st @@ -602,12 +599,12 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of | otherwise = return False prob action errorid p msg = do - toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromRawFilePath p]) + toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromOsPath p]) Annex.incError return False -notSymlink :: RawFilePath -> IO Bool -notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f +notSymlink :: OsPath -> IO Bool +notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f) {- Returns an action that, when there's a time limit, can be used - to check it before processing a file. The first action is run when diff --git a/Command.hs b/Command.hs index 6dc20a2cc6..1b683b2994 100644 --- a/Command.hs +++ b/Command.hs @@ -144,8 +144,7 @@ noDaemonRunning :: Command -> Command noDaemonRunning = addCheck NoDaemonRunning $ whenM (isJust <$> daemonpid) $ giveup "You cannot run this command while git-annex watch or git-annex assistant is running." where - daemonpid = liftIO . checkDaemon . fromRawFilePath - =<< fromRepo gitAnnexPidFile + daemonpid = liftIO . checkDaemon =<< 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 index ef5853126f..aca25f02dd 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -31,7 +31,6 @@ import Utility.InodeCache import Annex.InodeSentinal import Annex.CheckIgnore import qualified Utility.RawFilePath as R -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (fileSize, isSymbolicLink, isRegularFile, modificationTime, fileID, deviceID, fileMode, ownerExecuteMode, intersectFileModes) @@ -140,23 +139,23 @@ seek' o = do dr = dryRunOption o {- Pass file off to git-add. -} -startSmall :: Bool -> DryRun -> SeekInput -> RawFilePath -> CommandStart +startSmall :: Bool -> DryRun -> SeekInput -> OsPath -> CommandStart startSmall isdotfile dr si file = - liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case + liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file) >>= \case Just s -> starting "add" (ActionItemTreeFile file) si $ addSmall isdotfile dr file s Nothing -> stop -addSmall :: Bool -> DryRun -> RawFilePath -> FileStatus -> CommandPerform +addSmall :: Bool -> DryRun -> OsPath -> FileStatus -> CommandPerform addSmall isdotfile dr file s = do showNote $ (if isdotfile then "dotfile" else "non-large file") <> "; adding content to git repository" skipWhenDryRun dr $ next $ addFile Small file s -startSmallOverridden :: DryRun -> SeekInput -> RawFilePath -> CommandStart +startSmallOverridden :: DryRun -> SeekInput -> OsPath -> CommandStart startSmallOverridden dr si file = - liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case + liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file) >>= \case Just s -> starting "add" (ActionItemTreeFile file) si $ do showNote "adding content to git repository" skipWhenDryRun dr $ next $ addFile Small file s @@ -164,22 +163,23 @@ startSmallOverridden dr si file = data SmallOrLarge = Small | Large -addFile :: SmallOrLarge -> RawFilePath -> FileStatus -> Annex Bool +addFile :: SmallOrLarge -> OsPath -> FileStatus -> Annex Bool addFile smallorlarge file s = do + let file' = fromOsPath file sha <- if isSymbolicLink s - then hashBlob =<< liftIO (R.readSymbolicLink file) + then hashBlob =<< liftIO (R.readSymbolicLink file') else if isRegularFile s then hashFile file else do qp <- coreQuotePath <$> Annex.getGitConfig - giveup $ decodeBS $ quote qp $ - file <> " is not a regular file" + giveup $ decodeBS $ quote qp file + <> " is not a regular file" let treetype = if isSymbolicLink s then TreeSymlink else if intersectFileModes ownerExecuteMode (fileMode s) /= 0 then TreeExecutable else TreeFile - s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file + s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file' if maybe True (changed s) s' then do warning $ QuotedPath file <> " changed while it was being added" @@ -206,9 +206,9 @@ addFile smallorlarge file s = do isRegularFile a /= isRegularFile b || isSymbolicLink a /= isSymbolicLink b -start :: DryRun -> SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart +start :: DryRun -> SeekInput -> OsPath -> AddUnlockedMatcher -> CommandStart start dr si file addunlockedmatcher = - liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case + liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file) >>= \case Nothing -> stop Just s | not (isRegularFile s) && not (isSymbolicLink s) -> stop @@ -231,11 +231,11 @@ start dr si file addunlockedmatcher = starting "add" (ActionItemTreeFile file) si $ addingExistingLink file key $ skipWhenDryRun dr $ withOtherTmp $ \tmp -> do - let tmpf = tmp P. P.takeFileName file + let tmpf = tmp takeFileName file liftIO $ moveFile file tmpf - ifM (isSymbolicLink <$> liftIO (R.getSymbolicLinkStatus tmpf)) + ifM (isSymbolicLink <$> liftIO (R.getSymbolicLinkStatus $ fromOsPath tmpf)) ( do - liftIO $ R.removeLink tmpf + liftIO $ removeFile tmpf addSymlink file key Nothing next $ cleanup key =<< inAnnex key , do @@ -249,7 +249,7 @@ start dr si file addunlockedmatcher = Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) next $ addFile Large file s -perform :: RawFilePath -> AddUnlockedMatcher -> CommandPerform +perform :: OsPath -> AddUnlockedMatcher -> CommandPerform perform file addunlockedmatcher = withOtherTmp $ \tmpdir -> do lockingfile <- not <$> addUnlocked addunlockedmatcher (MatchingFile (FileInfo file file Nothing)) @@ -259,7 +259,7 @@ perform file addunlockedmatcher = withOtherTmp $ \tmpdir -> do , hardlinkFileTmpDir = Just tmpdir , checkWritePerms = True } - ld <- lockDown cfg (fromRawFilePath file) + ld <- lockDown cfg file let sizer = keySource <$> ld v <- metered Nothing sizer Nothing $ \_meter meterupdate -> ingestAdd meterupdate ld diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 243297c1c6..e883d72aac 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -27,7 +27,7 @@ start :: UnusedMaps -> Int -> CommandStart start = startUnused go (other "bad") (other "tmp") where go n key = do - let file = "unused." <> keyFile key + let file = literalOsPath "unused." <> keyFile key starting "addunused" (ActionItemTreeFile file) (SeekInput [show n]) $ diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index d464dbd048..87a1ae629f 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -177,14 +177,14 @@ checkUrl addunlockedmatcher r o si u = do warning (UnquotedString (show e)) next $ return False go deffile (Right (UrlContents sz mf)) = do - f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf + f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o . fromOsPath) mf let f' = adjustFile o (fromMaybe f (fileOption (downloadOptions o))) void $ commandAction $ startRemote addunlockedmatcher r o si f' u sz go deffile (Right (UrlMulti l)) = case fileOption (downloadOptions o) of Nothing -> forM_ l $ \(u', sz, f) -> do - f' <- sanitizeOrPreserveFilePath o f - let f'' = adjustFile o (deffile f') + f' <- sanitizeOrPreserveFilePath o (fromOsPath f) + let f'' = adjustFile o (fromOsPath (toOsPath deffile toOsPath f')) void $ commandAction $ startRemote addunlockedmatcher r o si f'' u' sz Just f -> case l of [] -> noop @@ -200,14 +200,14 @@ checkUrl addunlockedmatcher r o si u = do startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart startRemote addunlockedmatcher r o si file uri sz = do pathmax <- liftIO $ fileNameLengthLimit "." - let file' = P.joinPath $ map (truncateFilePath pathmax) $ + let file' = toOsPath $ P.joinPath $ map (truncateFilePath pathmax) $ P.splitDirectories (toRawFilePath file) startingAddUrl si uri o $ do showNote $ UnquotedString $ "from " ++ Remote.name r showDestinationFile file' performRemote addunlockedmatcher r o uri file' sz -performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform +performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> OsPath -> Maybe Integer -> CommandPerform performRemote addunlockedmatcher r o uri file sz = lookupKey file >>= \case Just k -> adduri k Nothing -> geturi @@ -219,7 +219,7 @@ performRemote addunlockedmatcher r o uri file sz = lookupKey file >>= \case 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 -> RawFilePath -> Maybe Integer -> Annex (Maybe Key) +downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> OsPath -> Maybe Integer -> Annex (Maybe Key) downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do let urlkey = Backend.URL.fromUrl uri sz (verifiableOption o) createWorkTreeDirectory (parentDir file) @@ -265,12 +265,12 @@ startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURIPortab f <- sanitizeOrPreserveFilePath o sf if preserveFilenameOption (downloadOptions o) then pure f - else ifM (liftIO $ doesFileExist f <||> doesDirectoryExist f) + else ifM (liftIO $ doesFileExist (toOsPath f) <||> doesDirectoryExist (toOsPath f)) ( pure $ url2file url (pathdepthOption o) pathmax , pure f ) _ -> pure $ url2file url (pathdepthOption o) pathmax - performWeb addunlockedmatcher o urlstring (toRawFilePath file) urlinfo + performWeb addunlockedmatcher o urlstring (toOsPath file) urlinfo sanitizeOrPreserveFilePath :: AddUrlOptions -> FilePath -> Annex FilePath sanitizeOrPreserveFilePath o f @@ -294,12 +294,12 @@ checkPreserveFileNameSecurity f = do qp <- coreQuotePath <$> Annex.getGitConfig giveup $ decodeBS $ quote qp $ "--preserve-filename was used, but the filename (" - <> QuotedPath (toRawFilePath f) + <> QuotedPath (toOsPath f) <> ") has a security problem (" <> d <> "), not adding." -performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> RawFilePath -> Url.UrlInfo -> CommandPerform +performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> OsPath -> Url.UrlInfo -> CommandPerform performWeb addunlockedmatcher o url file urlinfo = lookupKey file >>= \case Just k -> addurl k Nothing -> geturl @@ -314,7 +314,7 @@ performWeb addunlockedmatcher o url file urlinfo = lookupKey file >>= \case {- 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 -> RawFilePath -> UUID -> (Key -> Annex (Maybe (Bool, Bool, URLString))) -> Key -> CommandPerform +addUrlChecked :: AddUrlOptions -> URLString -> OsPath -> UUID -> (Key -> Annex (Maybe (Bool, Bool, URLString))) -> Key -> CommandPerform addUrlChecked o url file u checkexistssize key = ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key)) ( do @@ -340,14 +340,14 @@ addUrlChecked o url file u checkexistssize key = - 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 -> RawFilePath -> Annex (Maybe Key) +addUrlFile :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> OsPath -> Annex (Maybe Key) addUrlFile addunlockedmatcher o url urlinfo file = ifM (Annex.getRead Annex.fast <||> pure (relaxedOption o)) ( nodownloadWeb addunlockedmatcher o url urlinfo file , downloadWeb addunlockedmatcher o url urlinfo file ) -downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key) +downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> OsPath -> Annex (Maybe Key) downloadWeb addunlockedmatcher o url urlinfo file = go =<< downloadWith' downloader urlkey webUUID url file where @@ -366,25 +366,25 @@ downloadWeb addunlockedmatcher o url urlinfo file = -- so it's only used when the file contains embedded media. tryyoutubedl tmp backend = youtubeDlFileNameHtmlOnly url >>= \case Right mediafile -> do - liftIO $ liftIO $ removeWhenExistsWith R.removeLink tmp - let f = youtubeDlDestFile o file (toRawFilePath mediafile) + liftIO $ liftIO $ removeWhenExistsWith removeFile tmp + let f = youtubeDlDestFile o file mediafile lookupKey f >>= \case Just k -> alreadyannexed f k Nothing -> dl f Left err -> checkRaw (Just err) o (pure Nothing) (normalfinish tmp backend) where dl dest = withTmpWorkDir mediakey $ \workdir -> do - let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) + let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeFile) dlcmd <- youtubeDlCommand showNote ("using " <> UnquotedString dlcmd) Transfer.notifyTransfer Transfer.Download url $ Transfer.download' webUUID mediakey (AssociatedFile Nothing) Nothing Transfer.noRetry $ \p -> do showDestinationFile dest - youtubeDl url (fromRawFilePath workdir) p >>= \case + youtubeDl url workdir p >>= \case Right (Just mediafile) -> do cleanuptmp checkCanAdd o dest $ \canadd -> do - addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile)) + addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile) return $ Just mediakey Left msg -> do cleanuptmp @@ -445,10 +445,10 @@ startingAddUrl si url o p = starting "addurl" ai si $ do ai = OnlyActionOn urlkey (ActionItemOther (Just (UnquotedString url))) urlkey = Backend.URL.fromUrl url Nothing (verifiableOption (downloadOptions o)) -showDestinationFile :: RawFilePath -> Annex () +showDestinationFile :: OsPath -> Annex () showDestinationFile file = do showNote ("to " <> QuotedPath file) - maybeShowJSON $ JSONChunk [("file", fromRawFilePath file)] + maybeShowJSON $ JSONChunk [("file", file)] {- The Key should be a dummy key, based on the URL, which is used - for this download, before we can examine the file and find its real key. @@ -459,7 +459,7 @@ showDestinationFile file = do - Downloads the url, sets up the worktree file, and returns the - real key. -} -downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe Key) +downloadWith :: CanAddFile -> AddUnlockedMatcher -> (OsPath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> OsPath -> Annex (Maybe Key) downloadWith canadd addunlockedmatcher downloader dummykey u url file = go =<< downloadWith' downloader dummykey u url file where @@ -468,7 +468,7 @@ downloadWith canadd addunlockedmatcher downloader dummykey u url file = {- Like downloadWith, but leaves the dummy key content in - the returned location. -} -downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe (RawFilePath, Backend)) +downloadWith' :: (OsPath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> OsPath -> Annex (Maybe (OsPath, Backend)) downloadWith' downloader dummykey u url file = checkDiskSpaceToGet dummykey Nothing Nothing $ do backend <- chooseBackend file @@ -477,14 +477,14 @@ downloadWith' downloader dummykey u url file = ok <- Transfer.notifyTransfer Transfer.Download url $ \_w -> Transfer.runTransfer t (Just backend) afile Nothing Transfer.stdRetry $ \p -> do createAnnexDirectory (parentDir tmp) - downloader (fromRawFilePath tmp) p + downloader tmp p if ok then return (Just (tmp, backend)) else return Nothing where afile = AssociatedFile (Just file) -finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> Backend -> UUID -> URLString -> RawFilePath -> Annex Key +finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> OsPath -> Backend -> UUID -> URLString -> OsPath -> Annex Key finishDownloadWith canadd addunlockedmatcher tmp backend u url file = do let source = KeySource { keyFilename = file @@ -502,14 +502,14 @@ addSizeUrlKey urlinfo key = alterKey key $ \d -> d } {- Adds worktree file to the repository. -} -addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> RawFilePath -> Key -> Maybe RawFilePath -> Annex () +addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> OsPath -> Key -> Maybe OsPath -> Annex () addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of Nothing -> go Just tmp -> do - s <- liftIO $ R.getSymbolicLinkStatus tmp + s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath tmp) -- Move to final location for large file check. pruneTmpWorkDirBefore tmp $ \_ -> do - createWorkTreeDirectory (P.takeDirectory file) + createWorkTreeDirectory (takeDirectory file) liftIO $ moveFile tmp file largematcher <- largeFilesMatcher large <- checkFileMatcher NoLiveUpdate largematcher file @@ -531,15 +531,15 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of ( do when (isJust mtmp) $ logStatus NoLiveUpdate key InfoPresent - , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)) mtmp + , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeFile)) mtmp ) -nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key) +nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> OsPath -> Annex (Maybe Key) nodownloadWeb addunlockedmatcher o url urlinfo file | Url.urlExists urlinfo = if rawOption o then nomedia else youtubeDlFileName url >>= \case - Right mediafile -> usemedia (toRawFilePath mediafile) + Right mediafile -> usemedia mediafile Left err -> checkRaw (Just err) o (pure Nothing) nomedia | otherwise = do warning $ UnquotedString $ "unable to access url: " ++ url @@ -554,12 +554,12 @@ nodownloadWeb addunlockedmatcher o url urlinfo file let mediakey = Backend.URL.fromUrl mediaurl Nothing (verifiableOption o) nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest -youtubeDlDestFile :: DownloadOptions -> RawFilePath -> RawFilePath -> RawFilePath +youtubeDlDestFile :: DownloadOptions -> OsPath -> OsPath -> OsPath youtubeDlDestFile o destfile mediafile | isJust (fileOption o) = destfile - | otherwise = P.takeFileName mediafile + | otherwise = takeFileName mediafile -nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key) +nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> OsPath -> Annex (Maybe Key) nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do showDestinationFile file createWorkTreeDirectory (parentDir file) @@ -601,8 +601,8 @@ adjustFile o = addprefix . addsuffix data CanAddFile = CanAddFile -checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) -checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file)) +checkCanAdd :: DownloadOptions -> OsPath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) +checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath file))) ( do warning $ QuotedPath file <> " already exists; not overwriting" return Nothing diff --git a/Command/Assist.hs b/Command/Assist.hs index bcdac9ae67..6e25fb3457 100644 --- a/Command/Assist.hs +++ b/Command/Assist.hs @@ -28,7 +28,8 @@ myseek o = do Command.Sync.prepMerge Command.Add.seek Command.Add.AddOptions - { Command.Add.addThese = Command.Sync.contentOfOption o + { Command.Add.addThese = map fromOsPath $ + Command.Sync.contentOfOption o , Command.Add.batchOption = NoBatch , Command.Add.updateOnly = False , Command.Add.largeFilesOverride = Nothing diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 444b37ca5c..159453e35a 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -79,11 +79,11 @@ autoStart o = do dirs <- liftIO readAutoStartFile when (null dirs) $ do f <- autoStartFile - giveup $ "Nothing listed in " ++ f - program <- programPath + giveup $ "Nothing listed in " ++ fromOsPath f + program <- fromOsPath <$> programPath haveionice <- pure BuildInfo.ionice <&&> inSearchPath "ionice" pids <- forM dirs $ \d -> do - putStrLn $ "git-annex autostart in " ++ d + putStrLn $ "git-annex autostart in " ++ fromOsPath d mpid <- catchMaybeIO $ go haveionice program d if foregroundDaemonOption (daemonOptions o) then return mpid @@ -128,9 +128,9 @@ autoStart o = do autoStop :: IO () autoStop = do dirs <- liftIO readAutoStartFile - program <- programPath + program <- fromOsPath <$> programPath forM_ dirs $ \d -> do - putStrLn $ "git-annex autostop in " ++ d + putStrLn $ "git-annex autostop in " ++ fromOsPath d tryIO (setCurrentDirectory d) >>= \case Right () -> ifM (boolSystem program [Param "assistant", Param "--stop"]) ( putStrLn "ok" diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs index 44aa69b59d..ebe796fa5b 100644 --- a/Command/CalcKey.hs +++ b/Command/CalcKey.hs @@ -32,4 +32,4 @@ run _ _ file = tryNonAsync (genKey ks nullMeterUpdate =<< defaultBackend) >>= \c Left _err -> return False where ks = KeySource file' file' Nothing - file' = toRawFilePath file + file' = toOsPath file diff --git a/Command/Config.hs b/Command/Config.hs index c61b443c3e..e138162cd7 100644 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -152,7 +152,7 @@ seek (ShowOrigin ck@(ConfigKey name) forfile) = commandAction $ | decodeBS name `elem` annexAttrs = case forfile of Just file -> do - v <- checkAttr (decodeBS name) (toRawFilePath file) + v <- checkAttr (decodeBS name) (toOsPath file) if null v then cont else showval "gitattributes" v diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs index ea2845899a..7b367b7abe 100644 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -9,7 +9,6 @@ module Command.ContentLocation where import Command import Annex.Content -import qualified Utility.RawFilePath as R import qualified Data.ByteString.Char8 as B8 @@ -23,10 +22,13 @@ cmd = noCommit $ noMessages $ run :: () -> SeekInput -> String -> Annex Bool run _ _ p = do let k = fromMaybe (giveup "bad key") $ deserializeKey p - maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True) + maybe (return False) emit =<< inAnnex' (pure True) Nothing check k where - check f = ifM (liftIO (R.doesPathExist f)) + check f = ifM (liftIO (doesFileExist f)) ( return (Just f) , return Nothing ) + emit f = liftIO $ do + B8.putStrLn $ fromOsPath f + return True diff --git a/Command/Copy.hs b/Command/Copy.hs index f23626c4b2..dce01ddefe 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -77,7 +77,7 @@ seek' o fto = startConcurrency (Command.Move.stages fto) $ do {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or - sending non-preferred content. -} -start :: CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: CopyOptions -> FromToHereOptions -> SeekInput -> OsPath -> Key -> CommandStart start o fto si file key = do ru <- case fto of FromOrToRemote (ToRemote dest) -> getru dest @@ -90,7 +90,7 @@ start o fto si file key = do where getru dest = Just . Remote.uuid <$> getParsed dest -start' :: LiveUpdate -> CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start' :: LiveUpdate -> CopyOptions -> FromToHereOptions -> SeekInput -> OsPath -> Key -> CommandStart start' lu o fto si file key = stopUnless shouldCopy $ Command.Move.start lu fto Command.Move.RemoveNever si file key where diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index 4c398026dc..bfcc917ec7 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -119,7 +119,7 @@ fixupReq req@(Req {}) opts = maybe (return r) go (parseLinkTargetOrPointer =<< v) _ -> maybe (return r) go =<< liftIO (isPointerFile f) where - f = toRawFilePath (getfile r) + f = toOsPath (getfile r) go k = do when (getOption opts) $ unlessM (inAnnex k) $ @@ -132,7 +132,7 @@ fixupReq req@(Req {}) opts = si = SeekInput [] af = AssociatedFile (Just f) repoint k = withObjectLoc k $ - pure . setfile r . fromRawFilePath + pure . setfile r . fromOsPath externalDiffer :: String -> [String] -> Differ externalDiffer c ps = \req -> boolSystem c (map Param ps ++ serializeReq req ) diff --git a/Command/Drop.hs b/Command/Drop.hs index 819d61dcc7..94720a6ae4 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -76,7 +76,7 @@ seek o = startConcurrency commandStages $ do where ww = WarnUnmatchLsFiles "drop" -start :: DropOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: DropOptions -> Maybe Remote -> SeekInput -> OsPath -> Key -> CommandStart start o from si file key = start' o from key afile ai si where afile = AssociatedFile (Just file) diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 45663bafcd..6733b42235 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -17,7 +17,6 @@ import qualified Git import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Annex.NumCopies import Annex.Content -import qualified Utility.RawFilePath as R cmd :: Command cmd = withAnnexOptions [jobsOption, jsonOptions] $ @@ -77,8 +76,8 @@ perform from numcopies mincopies key = case from of pcc = Command.Drop.PreferredContentChecked False ud = Command.Drop.DroppingUnused True -performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform +performOther :: (Key -> Git.Repo -> OsPath) -> Key -> CommandPerform performOther filespec key = do f <- fromRepo $ filespec key - pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith R.removeLink) + pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith removeFile) next $ return True diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs index f80c4c06fd..03293d2af4 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -57,7 +57,7 @@ start _os = do Nothing -> giveup "Need user-id parameter." Just userid -> go userid else starting "enable-tor" ai si $ do - gitannex <- liftIO programPath + gitannex <- fromOsPath <$> liftIO programPath let ps = [Param (cmdname cmd), Param (show curruserid)] sucommand <- liftIO $ mkSuCommand gitannex ps cleanenv <- liftIO $ cleanStandaloneEnvironment @@ -145,6 +145,6 @@ checkHiddenService = bracket setup cleanup go haslistener sockfile = catchBoolIO $ do soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol - S.connect soc (S.SockAddrUnix sockfile) + S.connect soc (S.SockAddrUnix $ fromOsPath sockfile) S.close soc return True diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index 439472a47e..1caa4224db 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -39,7 +39,7 @@ optParser :: Parser ExamineOptions optParser = ExamineOptions <$> optional parseFormatOption <*> (fmap (DeferredParse . tobackend) <$> migrateopt) - <*> (AssociatedFile <$> fileopt) + <*> (AssociatedFile . fmap stringToOsPath <$> fileopt) where fileopt = optional $ strOption ( long "filename" <> metavar paramFile @@ -59,8 +59,8 @@ run o _ input = do let objectpointer = formatPointer k isterminal <- liftIO $ checkIsTerminal stdout showFormatted isterminal (format o) (serializeKey' k) $ - [ ("objectpath", fromRawFilePath objectpath) - , ("objectpointer", fromRawFilePath objectpointer) + [ ("objectpath", fromOsPath objectpath) + , ("objectpointer", decodeBS objectpointer) ] ++ formatVars k af return True where @@ -71,7 +71,7 @@ run o _ input = do ik = fromMaybe (giveup "bad key") (deserializeKey' ikb) af = if B.null ifb' then associatedFile o - else AssociatedFile (Just ifb') + else AssociatedFile (Just (toOsPath ifb')) getkey = case migrateToBackend o of Nothing -> pure ik diff --git a/Command/Export.hs b/Command/Export.hs index a8bdfab5ab..b4acaac401 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -78,8 +78,8 @@ optParser _ = ExportOptions -- To handle renames which swap files, the exported file is first renamed -- to a stable temporary name based on the key. exportTempName :: Key -> ExportLocation -exportTempName ek = mkExportLocation $ toRawFilePath $ - ".git-annex-tmp-content-" ++ serializeKey ek +exportTempName ek = mkExportLocation $ + literalOsPath ".git-annex-tmp-content-" <> toOsPath (serializeKey'' ek) seek :: ExportOptions -> CommandSeek seek o = startConcurrency commandStages $ do @@ -312,12 +312,11 @@ performExport r srcrs db ek af contentsha loc allfilledvar = do sent <- tryNonAsync $ if not (isGitShaKey ek) then tryrenameannexobject $ sendannexobject -- Sending a non-annexed file. - else withTmpFile (toOsPath "export") $ \tmp h -> do + else withTmpFile (literalOsPath "export") $ \tmp h -> do b <- catObject contentsha liftIO $ L.hPut h b liftIO $ hClose h - Remote.action $ - storer (fromRawFilePath (fromOsPath tmp)) ek loc nullMeterUpdate + Remote.action $ storer tmp ek loc nullMeterUpdate let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False)) case sent of Right True -> next $ cleanupExport r db ek loc True diff --git a/Command/FilterBranch.hs b/Command/FilterBranch.hs index 6c565c5d29..6f79d47ad6 100644 --- a/Command/FilterBranch.hs +++ b/Command/FilterBranch.hs @@ -27,13 +27,11 @@ import Git.Env import Git.UpdateIndex import qualified Git.LsTree as LsTree import qualified Git.Branch as Git -import Utility.RawFilePath import qualified Data.Map as M import qualified Data.Set as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder -import qualified System.FilePath.ByteString as P cmd :: Command cmd = noMessages $ withAnnexOptions [annexedMatchingOptions] $ @@ -120,10 +118,10 @@ mkUUIDMatcher' sameasmap l = \u -> seek :: FilterBranchOptions -> CommandSeek seek o = withOtherTmp $ \tmpdir -> do - let tmpindex = tmpdir P. "index" + let tmpindex = tmpdir literalOsPath "index" gc <- Annex.getGitConfig tmpindexrepo <- Annex.inRepo $ \r -> - addGitEnv r indexEnv (fromRawFilePath tmpindex) + addGitEnv r indexEnv (fromOsPath tmpindex) withUpdateIndex tmpindexrepo $ \h -> do keyinfomatcher <- mkUUIDMatcher (keyInformation o) repoconfigmatcher <- mkUUIDMatcher (repoConfig o) @@ -186,7 +184,7 @@ seek o = withOtherTmp $ \tmpdir -> do -- Commit the temporary index, and output the result. t <- liftIO $ Git.writeTree tmpindexrepo - liftIO $ removeWhenExistsWith removeLink tmpindex + liftIO $ removeWhenExistsWith removeFile tmpindex cmode <- annexCommitMode <$> Annex.getGitConfig cmessage <- Annex.Branch.commitMessage c <- inRepo $ Git.commitTree cmode [cmessage] [] t diff --git a/Command/FilterProcess.hs b/Command/FilterProcess.hs index ff20dd7268..023d165d29 100644 --- a/Command/FilterProcess.hs +++ b/Command/FilterProcess.hs @@ -36,7 +36,7 @@ seek _ = liftIO longRunningFilterProcessHandshake >>= \case go Nothing -> return () -smudge :: FilePath -> Annex () +smudge :: OsPath -> Annex () smudge file = do {- The whole git file content is necessarily buffered in memory, - because we have to consume everything git is sending before @@ -49,7 +49,7 @@ smudge file = do - See Command.Smudge.smudge for details of how this works. -} liftIO $ respondFilterRequest b -clean :: FilePath -> Annex () +clean :: OsPath -> Annex () clean file = do {- We have to consume everything git is sending before we can - respond to it. But it can be an arbitrarily large file, @@ -82,7 +82,7 @@ clean file = do -- read from the file. It may be less expensive to incrementally -- hash the content provided by git, but Backend does not currently -- have an interface to do so. - Command.Smudge.clean' (toRawFilePath file) + Command.Smudge.clean' file (parseLinkTargetOrPointer' b) passthrough discardreststdin diff --git a/Command/Find.hs b/Command/Find.hs index 3a1fabe5e2..2bd7debc64 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -88,9 +88,9 @@ contentPresentUnlessLimited s = do else Just True } -start :: FindOptions -> IsTerminal -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: FindOptions -> IsTerminal -> SeekInput -> OsPath -> Key -> CommandStart start o isterminal _ file key = startingCustomOutput key $ do - showFormatted isterminal (formatOption o) file + showFormatted isterminal (formatOption o) (fromOsPath file) (formatVars key (AssociatedFile (Just file))) next $ return True @@ -113,14 +113,14 @@ showFormatted (IsTerminal isterminal) format unformatted vars = formatVars :: Key -> AssociatedFile -> [(String, String)] formatVars key (AssociatedFile af) = - (maybe id (\f l -> (("file", fromRawFilePath f) : l)) af) + (maybe id (\f l -> (("file", fromOsPath f) : l)) af) [ ("key", serializeKey key) , ("backend", decodeBS $ formatKeyVariety $ fromKey keyVariety key) , ("bytesize", size show) , ("humansize", size $ roughSize storageUnits True) , ("keyname", decodeBS $ S.fromShort $ fromKey keyName key) - , ("hashdirlower", fromRawFilePath $ hashDirLower def key) - , ("hashdirmixed", fromRawFilePath $ hashDirMixed def key) + , ("hashdirlower", fromOsPath $ hashDirLower def key) + , ("hashdirmixed", fromOsPath $ hashDirMixed def key) , ("mtime", whenavail show $ fromKey keyMtime key) ] where 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/Get.hs b/Command/Get.hs index f9a48733af..880aa03198 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -55,7 +55,7 @@ seek o = startConcurrency transferStages $ do where ww = WarnUnmatchLsFiles "get" -start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: GetOptions -> Maybe Remote -> SeekInput -> OsPath -> Key -> CommandStart start o from si file key = do lu <- prepareLiveUpdate Nothing key AddingKey start' lu (expensivecheck lu) from key afile ai si diff --git a/Command/Import.hs b/Command/Import.hs index c35055927e..7375b807df 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -129,7 +129,7 @@ seek :: ImportOptions -> CommandSeek seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do repopath <- liftIO . absPath =<< fromRepo Git.repoPath inrepops <- liftIO $ filter (dirContains repopath) - <$> mapM (absPath . toRawFilePath) (importFiles o) + <$> mapM (absPath . toOsPath) (importFiles o) unless (null inrepops) $ do qp <- coreQuotePath <$> Annex.getGitConfig giveup $ decodeBS $ quote qp $ @@ -145,7 +145,7 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do giveup "That remote does not support imports." subdir <- maybe (pure Nothing) - (Just <$$> inRepo . toTopFilePath . toRawFilePath) + (Just <$$> inRepo . toTopFilePath . toOsPath) (importToSubDir o) addunlockedmatcher <- addUnlockedMatcher seekRemote r (importToBranch o) subdir (importContent o) @@ -153,9 +153,9 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do addunlockedmatcher (messageOption o) -startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (RawFilePath, RawFilePath) -> CommandStart +startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (OsPath, OsPath) -> CommandStart startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = - ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus srcfile) + ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus (fromOsPath srcfile)) ( starting "import" ai si pickaction , stop ) @@ -167,7 +167,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = showNote $ UnquotedString $ "duplicate of " ++ serializeKey k verifyExisting k destfile ( do - liftIO $ R.removeLink srcfile + liftIO $ removeFile srcfile next $ return True , do warning "Could not verify that the content is still present in the annex; not removing from the import location." @@ -183,26 +183,26 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = warning $ "not importing " <> QuotedPath destfile <> " which is .gitignored (use --no-check-gitignore to override)" stop else do - existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile) + existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath destfile)) case existing of Nothing -> importfilechecked ld k Just s | isDirectory s -> notoverwriting "(is a directory)" | isSymbolicLink s -> ifM (Annex.getRead Annex.force) ( do - liftIO $ removeWhenExistsWith R.removeLink destfile + liftIO $ removeWhenExistsWith removeFile destfile importfilechecked ld k , notoverwriting "(is a symlink)" ) | otherwise -> ifM (Annex.getRead Annex.force) ( do - liftIO $ removeWhenExistsWith R.removeLink destfile + liftIO $ removeWhenExistsWith removeFile 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 $ R.getSymbolicLinkStatus destdir) + existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath destdir)) case existing of Nothing -> cont Just s @@ -217,10 +217,8 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = createWorkTreeDirectory (parentDir destfile) unwind <- liftIO $ if mode == Duplicate || mode == SkipDuplicates then do - void $ copyFileExternal CopyAllMetaData - (fromRawFilePath srcfile) - (fromRawFilePath destfile) - return $ removeWhenExistsWith R.removeLink destfile + void $ copyFileExternal CopyAllMetaData srcfile destfile + return $ removeWhenExistsWith removeFile destfile else do moveFile srcfile destfile return $ moveFile destfile srcfile @@ -241,7 +239,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = -- 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.) - s <- liftIO $ R.getSymbolicLinkStatus destfile + s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath destfile) newcache <- withTSDelta $ \d -> liftIO $ toInodeCache d destfile s let unchanged = case (newcache, inodeCache (keySource ld)) of (_, Nothing) -> True @@ -287,7 +285,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = -- the file gets copied into the repository. , checkWritePerms = False } - v <- lockDown cfg (fromRawFilePath srcfile) + v <- lockDown cfg srcfile case v of Just ld -> do backend <- chooseBackend destfile @@ -314,7 +312,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = showNote (s <> "; skipping") next (return True) -verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform +verifyExisting :: Key -> OsPath -> (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 index 8adeb9a487..df1537fb65 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -24,7 +24,6 @@ import Data.Time.LocalTime import Control.Concurrent.STM import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import qualified System.FilePath.ByteString as P import qualified Data.ByteString as B import Command @@ -158,7 +157,7 @@ getFeed o url st = | scrapeOption o = scrape | otherwise = get - get = withTmpFile (toOsPath "feed") $ \tmpf h -> do + get = withTmpFile (literalOsPath "feed") $ \tmpf h -> do let tmpf' = fromRawFilePath $ fromOsPath tmpf liftIO $ hClose h ifM (downloadFeed url tmpf') @@ -270,7 +269,7 @@ downloadFeed :: URLString -> FilePath -> Annex Bool downloadFeed url f | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" | otherwise = Url.withUrlOptions $ - Url.download nullMeterUpdate Nothing url f + Url.download nullMeterUpdate Nothing url (toOsPath f) startDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> CommandStart startDownload addunlockedmatcher opts cache cv todownload = case location todownload of @@ -315,15 +314,15 @@ startDownload addunlockedmatcher opts cache cv todownload = case location todown ifM (useYoutubeDl (downloadOptions opts) <&&> youtubeDlSupported linkurl) ( startUrlDownload cv todownload linkurl $ withTmpWorkDir mediakey $ \workdir -> do - dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate + dl <- youtubeDl linkurl workdir nullMeterUpdate case dl of Right (Just mediafile) -> do - let ext = case takeExtension mediafile of + let ext = case fromOsPath (takeExtension mediafile) of [] -> ".m" s -> s runDownload todownload linkurl ext cache cv $ \f -> checkCanAdd (downloadOptions opts) f $ \canadd -> do - addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile)) + addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile) return (Just [mediakey]) -- youtube-dl didn't support it, so -- download it as if the link were @@ -352,16 +351,16 @@ startDownload addunlockedmatcher opts cache cv todownload = case location todown ) downloadEnclosure :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> URLString -> CommandPerform -downloadEnclosure addunlockedmatcher opts cache cv todownload url = - runDownload todownload url (takeWhile (/= '?') $ takeExtension url) cache cv $ \f -> do - let f' = fromRawFilePath f +downloadEnclosure addunlockedmatcher opts cache cv todownload url = + let extension = takeWhile (/= '?') $ fromOsPath $ takeExtension $ toOsPath url + in runDownload todownload url extension cache cv $ \f -> do r <- checkClaimingUrl (downloadOptions opts) url if Remote.uuid r == webUUID || rawOption (downloadOptions opts) then checkRaw (Just url) (downloadOptions opts) (pure Nothing) $ do let dlopts = (downloadOptions opts) -- force using the filename -- chosen here - { fileOption = Just f' + { fileOption = Just (fromOsPath f) -- don't use youtube-dl , rawOption = True } @@ -385,7 +384,7 @@ downloadEnclosure addunlockedmatcher opts cache cv todownload url = downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz Right (UrlMulti l) -> do kl <- forM l $ \(url', sz, subf) -> - let dest = f P. toRawFilePath (sanitizeFilePath subf) + let dest = f toOsPath (sanitizeFilePath (fromOsPath subf)) in downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' dest sz return $ Just $ if all isJust kl then catMaybes kl @@ -397,7 +396,7 @@ runDownload -> String -> Cache -> TMVar Bool - -> (RawFilePath -> Annex (Maybe [Key])) + -> (OsPath -> Annex (Maybe [Key])) -> CommandPerform runDownload todownload url extension cache cv getter = do dest <- makeunique (1 :: Integer) $ @@ -406,7 +405,7 @@ runDownload todownload url extension cache cv getter = do Nothing -> do recordsuccess next $ return True - Just f -> getter (toRawFilePath f) >>= \case + Just f -> getter f >>= \case Just ks -- Download problem. | null ks -> do @@ -440,7 +439,7 @@ runDownload todownload url extension cache cv getter = do - to be re-downloaded. -} makeunique n file = ifM alreadyexists ( ifM forced - ( lookupKey (toRawFilePath f) >>= \case + ( lookupKey f >>= \case Just k -> checksameurl k Nothing -> tryanother , tryanother @@ -449,12 +448,12 @@ runDownload todownload url extension cache cv getter = do ) where f = if n < 2 - then file + then toOsPath file else - let (d, base) = splitFileName file - in d show n ++ "_" ++ base + let (d, base) = splitFileName (toOsPath file) + in d toOsPath (show n ++ "_") <> base tryanother = makeunique (n + 1) file - alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f)) + alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (fromOsPath f)) checksameurl k = ifM (elem url . map fst . map getDownloader <$> getUrls k) ( return Nothing , tryanother @@ -609,10 +608,10 @@ feedProblem url message = ifM (checkFeedBroken url) - least 23 hours. -} checkFeedBroken :: URLString -> Annex Bool checkFeedBroken url = checkFeedBroken' url =<< feedState url -checkFeedBroken' :: URLString -> RawFilePath -> Annex Bool +checkFeedBroken' :: URLString -> OsPath -> Annex Bool checkFeedBroken' url f = do prev <- maybe Nothing readish - <$> liftIO (catchMaybeIO $ readFile (fromRawFilePath f)) + <$> liftIO (catchMaybeIO $ readFile (fromOsPath f)) now <- liftIO getCurrentTime case prev of Nothing -> do @@ -628,10 +627,9 @@ checkFeedBroken' url f = do clearFeedProblem :: URLString -> Annex () clearFeedProblem url = - void $ liftIO . tryIO . removeFile . fromRawFilePath - =<< feedState url + void $ liftIO . tryIO . removeFile =<< feedState url -feedState :: URLString -> Annex RawFilePath +feedState :: URLString -> Annex OsPath feedState url = fromRepo $ gitAnnexFeedState $ fromUrl url Nothing False {- The feed library parses the feed to Text, and does not use the 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/Mirror.hs b/Command/Mirror.hs index 7f5be7ae54..8116dcf0ce 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -57,7 +57,7 @@ seek o = startConcurrency stages $ , usesLocationLog = True } -start :: MirrorOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: MirrorOptions -> SeekInput -> OsPath -> Key -> CommandStart start o si file k = startKey o afile (si, k, ai) where afile = AssociatedFile (Just file) diff --git a/Command/Move.hs b/Command/Move.hs index 89c5556b78..120cb4f598 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -94,7 +94,7 @@ stages ToHere = transferStages stages (FromRemoteToRemote _ _) = transferStages stages (FromAnywhereToRemote _) = transferStages -start :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> SeekInput -> OsPath -> Key -> CommandStart start lu fromto removewhen si f k = start' lu fromto removewhen afile si k ai where afile = AssociatedFile (Just f) 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/P2P.hs b/Command/P2P.hs index 14f6d24fa4..c26b30374d 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -25,7 +25,6 @@ import Utility.Tmp.Dir import Utility.FileMode import Utility.ThreadScheduler import Utility.SafeOutput -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F import qualified Utility.MagicWormhole as Wormhole @@ -220,12 +219,12 @@ wormholePairing remotename ouraddrs ui = do -- files. Permissions of received files may allow others -- to read them. So, set up a temp directory that only -- we can read. - withTmpDir (toOsPath "pair") $ \tmp -> do - liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $ + withTmpDir (literalOsPath "pair") $ \tmp -> do + liftIO $ void $ tryIO $ modifyFileMode tmp $ removeModes otherGroupModes - let sendf = tmp "send" - let recvf = tmp "recv" - liftIO $ writeFileProtected (toRawFilePath sendf) $ + let sendf = tmp literalOsPath "send" + let recvf = tmp literalOsPath "recv" + liftIO $ writeFileProtected sendf $ serializePairData ourpairdata observer <- liftIO Wormhole.mkCodeObserver @@ -235,18 +234,18 @@ wormholePairing remotename ouraddrs ui = do -- the same channels that other wormhole users use. let appid = Wormhole.appId "git-annex.branchable.com/p2p-setup" (sendres, recvres) <- liftIO $ - Wormhole.sendFile sendf observer appid + Wormhole.sendFile (fromOsPath sendf) observer appid `concurrently` - Wormhole.receiveFile recvf producer appid - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath sendf) + Wormhole.receiveFile (fromOsPath recvf) producer appid + liftIO $ removeWhenExistsWith removeFile sendf if sendres /= True then return SendFailed else if recvres /= True then return ReceiveFailed else do r <- liftIO $ tryIO $ - map decodeBS . fileLines' <$> F.readFile' - (toOsPath (toRawFilePath recvf)) + map decodeBS . fileLines' + <$> F.readFile' recvf case r of Left _e -> return ReceiveFailed Right ls -> maybe diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index ac72c7053d..029307ed10 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -267,7 +267,7 @@ getAuthEnv = do findRepos :: Options -> IO [Git.Repo] findRepos o = do files <- concat - <$> mapM (dirContents . toRawFilePath) (directoryOption o) + <$> mapM (dirContents . toOsPath) (directoryOption o) map Git.Construct.newFrom . catMaybes <$> mapM Git.Construct.checkForRepo files diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs index 3ad80d8321..fd1c6b035d 100644 --- a/Command/PostReceive.hs +++ b/Command/PostReceive.hs @@ -9,6 +9,7 @@ module Command.PostReceive where +import Common import Command import qualified Annex import Annex.UpdateInstead @@ -107,12 +108,11 @@ fixPostReceiveHookEnv :: Annex () fixPostReceiveHookEnv = do g <- Annex.gitRepo case location g of - Local { gitdir = ".", worktree = Just "." } -> + l@(Local {}) | gitdir l == literalOsPath "." && worktree l == Just (literalOsPath ".") -> Annex.adjustGitRepo $ \g' -> pure $ g' { location = case location g' of loc@(Local {}) -> loc - { worktree = Just ".." } + { worktree = Just (literalOsPath "..") } loc -> loc } _ -> noop - 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/Command/ReKey.hs b/Command/ReKey.hs index a7a547b719..3f02f2ab60 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -44,7 +44,7 @@ optParser desc = ReKeyOptions -- Split on the last space, since a FilePath can contain whitespace, -- but a Key very rarely does. -batchParser :: String -> Annex (Either String (RawFilePath, Key)) +batchParser :: String -> Annex (Either String (OsPath, Key)) batchParser s = case separate (== ' ') (reverse s) of (rk, rf) | null rk || null rf -> return $ Left "Expected: \"file key\"" @@ -52,7 +52,7 @@ batchParser s = case separate (== ' ') (reverse s) of Nothing -> return $ Left "bad key" Just k -> do let f = reverse rf - f' <- liftIO $ relPathCwdToFile (toRawFilePath f) + f' <- liftIO $ relPathCwdToFile (toOsPath f) return $ Right (f', k) seek :: ReKeyOptions -> CommandSeek @@ -65,9 +65,9 @@ seek o = case batchOption o of (reKeyThese o) where parsekey (file, skey) = - (toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey)) + (toOsPath file, fromMaybe (giveup "bad key") (deserializeKey skey)) -start :: SeekInput -> (RawFilePath, Key) -> CommandStart +start :: SeekInput -> (OsPath, Key) -> CommandStart start si (file, newkey) = lookupKey file >>= \case Just k -> go k Nothing -> stop @@ -79,7 +79,7 @@ start si (file, newkey) = lookupKey file >>= \case ai = ActionItemTreeFile file -perform :: RawFilePath -> Key -> Key -> CommandPerform +perform :: OsPath -> Key -> Key -> CommandPerform perform file oldkey newkey = do ifM (inAnnex oldkey) ( unlessM (linkKey file oldkey newkey) $ @@ -93,7 +93,7 @@ perform file oldkey newkey = do {- Make a hard link to the old key content (when supported), - to avoid wasting disk space. -} -linkKey :: RawFilePath -> Key -> Key -> Annex Bool +linkKey :: OsPath -> Key -> Key -> Annex Bool linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) ( linkKey' DefaultVerify oldkey newkey , do @@ -101,7 +101,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) - it's hard linked to the old key, that link must be broken. -} oldobj <- calcRepo (gitAnnexLocation oldkey) v <- tryNonAsync $ do - st <- liftIO $ R.getFileStatus file + st <- liftIO $ R.getFileStatus (fromOsPath file) when (linkCount st > 1) $ do freezeContent oldobj replaceWorkTreeFile file $ \tmp -> do @@ -132,7 +132,7 @@ linkKey' v oldkey newkey = oldobj <- calcRepo (gitAnnexLocation oldkey) isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing -cleanup :: RawFilePath -> Key -> (MigrationRecord -> Annex ()) -> CommandCleanup +cleanup :: OsPath -> Key -> (MigrationRecord -> Annex ()) -> CommandCleanup cleanup file newkey a = do newkeyrec <- ifM (isJust <$> isAnnexLink file) ( do @@ -141,7 +141,8 @@ cleanup file newkey a = do stageSymlink file sha return (MigrationRecord sha) , do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus (fromOsPath file) liftIO $ whenM (isJust <$> isPointerFile file) $ writePointerFile file newkey mode sha <- hashPointerFile newkey diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index efcac6fd50..b1cd926236 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -39,4 +39,4 @@ start (_, key) = fieldTransfer Download key $ \_p -> do go tmp = unVerified $ do opts <- filterRsyncSafeOptions . maybe [] words <$> getField "RsyncOptions" - liftIO $ rsyncServerReceive (map Param opts) (fromRawFilePath tmp) + liftIO $ rsyncServerReceive (map Param opts) (fromOsPath tmp) diff --git a/Command/Reinject.hs b/Command/Reinject.hs index dbd96a9fdb..7ea45623fb 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -57,26 +57,26 @@ startSrcDest :: (SeekInput, (String, String)) -> CommandStart startSrcDest (si, (src, dest)) | src == dest = stop | otherwise = starting "reinject" ai si $ notAnnexed src' $ - lookupKey (toRawFilePath dest) >>= \case + lookupKey (toOsPath dest) >>= \case Just key -> ifM (verifyKeyContent key src') ( perform src' key , do qp <- coreQuotePath <$> Annex.getGitConfig giveup $ decodeBS $ quote qp $ QuotedPath src' <> " does not have expected content of " - <> QuotedPath (toRawFilePath dest) + <> QuotedPath (toOsPath dest) ) Nothing -> do qp <- coreQuotePath <$> Annex.getGitConfig giveup $ decodeBS $ quote qp $ QuotedPath src' <> " is not an annexed file" where - src' = toRawFilePath src + src' = toOsPath src ai = ActionItemOther (Just (QuotedPath src')) startGuessKeys :: FilePath -> CommandStart startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $ - case fileKey (toRawFilePath (takeFileName src)) of + case fileKey (takeFileName src') of Just key -> ifM (verifyKeyContent key src') ( perform src' key , do @@ -88,7 +88,7 @@ startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $ warning "Not named like an object file; skipping" next $ return True where - src' = toRawFilePath src + src' = toOsPath src ai = ActionItemOther (Just (QuotedPath src')) si = SeekInput [src] @@ -102,12 +102,12 @@ startKnown src = starting "reinject" ai si $ notAnnexed src' $ do next $ return True ) where - src' = toRawFilePath src + src' = toOsPath src ks = KeySource src' src' Nothing ai = ActionItemOther (Just (QuotedPath src')) si = SeekInput [src] -notAnnexed :: RawFilePath -> CommandPerform -> CommandPerform +notAnnexed :: OsPath -> CommandPerform -> CommandPerform notAnnexed src a = ifM (fromRepo Git.repoIsLocalBare) ( a @@ -120,7 +120,7 @@ notAnnexed src a = Nothing -> a ) -perform :: RawFilePath -> Key -> CommandPerform +perform :: OsPath -> Key -> CommandPerform perform src key = do maybeAddJSONField "key" (serializeKey key) ifM move diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs index 03f5eaaf3d..8c3226d05e 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -29,7 +29,7 @@ run o | foregroundDaemonOption o = liftIO runInteractive | otherwise = do #ifndef mingw32_HOST_OS - git_annex <- liftIO programPath + git_annex <- fromOsPath <$> liftIO programPath ps <- gitAnnexDaemonizeParams let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive diff --git a/Command/Repair.hs b/Command/Repair.hs index c85c77d299..5e7a6dfdc6 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -14,7 +14,6 @@ import qualified Annex.Branch import qualified Git.Ref import Git.Types import Annex.Version -import qualified Utility.RawFilePath as R cmd :: Command cmd = noCommit $ dontCheck repoExists $ @@ -76,7 +75,7 @@ repairAnnexBranch modifiedbranches Annex.Branch.forceCommit "committing index after git repository repair" liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index" nukeindex = do - inRepo $ removeWhenExistsWith R.removeLink . gitAnnexIndex + inRepo $ removeWhenExistsWith removeFile . 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/ResolveMerge.hs b/Command/ResolveMerge.hs index 2d003547b2..4ba9cc8c89 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -16,8 +16,6 @@ import qualified Git.Branch import Annex.AutoMerge import qualified Utility.FileIO as F -import qualified System.FilePath.ByteString as P - cmd :: Command cmd = command "resolvemerge" SectionPlumbing "resolve merge conflicts" @@ -30,7 +28,7 @@ start :: CommandStart start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do us <- fromMaybe nobranch <$> inRepo Git.Branch.current d <- fromRepo Git.localGitDir - let merge_head = toOsPath $ d P. "MERGE_HEAD" + let merge_head = d literalOsPath "MERGE_HEAD" them <- fromMaybe (giveup nomergehead) . extractSha <$> liftIO (F.readFile' merge_head) ifM (resolveMerge (Just us) them False) @@ -41,4 +39,4 @@ start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do ) where nobranch = giveup "No branch is currently checked out." - nomergehead = giveup "No SHA found in .git/merge_head" + nomergehead = giveup "No SHA found in .git/MERGE_HEAD" diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index d7a2b396fd..17c734c5b2 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -32,29 +32,28 @@ seek :: RmUrlOptions -> CommandSeek seek o = case batchOption o of Batch fmt -> batchOnly Nothing (rmThese o) $ batchInput fmt batchParser (batchCommandAction . start) - NoBatch -> withPairs (commandAction . start) (rmThese o) + NoBatch -> withPairs (commandAction . start . conv) (rmThese o) + where + conv (si, (f, u)) = (si, (toOsPath f, u)) --- Split on the last space, since a FilePath can contain whitespace, +-- Split on the last space, since a OsPath can contain whitespace, -- but a url should not. -batchParser :: String -> Annex (Either String (FilePath, URLString)) +batchParser :: String -> Annex (Either String (OsPath, URLString)) batchParser s = case separate (== ' ') (reverse s) of (ru, rf) | null ru || null rf -> return $ Left "Expected: \"file url\"" | otherwise -> do - let f = reverse rf - f' <- liftIO $ fromRawFilePath - <$> relPathCwdToFile (toRawFilePath f) + let f = toOsPath (reverse rf) + f' <- liftIO $ relPathCwdToFile f return $ Right (f', reverse ru) -start :: (SeekInput, (FilePath, URLString)) -> CommandStart -start (si, (file, url)) = lookupKeyStaged file' >>= \case +start :: (SeekInput, (OsPath, URLString)) -> CommandStart +start (si, (file, url)) = lookupKeyStaged file >>= \case Nothing -> stop Just key -> do - let ai = mkActionItem (key, AssociatedFile (Just file')) + let ai = mkActionItem (key, AssociatedFile (Just file)) starting "rmurl" ai si $ next $ cleanup url key - where - file' = toRawFilePath file cleanup :: String -> Key -> CommandCleanup cleanup url key = do diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 4d92656ffb..12f3382a19 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -33,7 +33,9 @@ start (_, key) = do ifM (inAnnex key) ( fieldTransfer Upload key $ \_p -> sendAnnex key Nothing rollback $ \f _sz -> - liftIO $ rsyncServerSend (map Param opts) f + liftIO $ rsyncServerSend + (map Param opts) + (fromOsPath f) , do warning "requested key is not present" liftIO exitFailure diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 820ab4af58..b7db0200df 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -25,13 +25,13 @@ start ps@(keyname:file:[]) = starting "setkey" ai si $ where ai = ActionItemOther (Just (QuotedPath file')) si = SeekInput ps - file' = toRawFilePath file + file' = toOsPath file start _ = giveup "specify a key and a content file" keyOpt :: String -> Key keyOpt = fromMaybe (giveup "bad key") . deserializeKey -perform :: RawFilePath -> Key -> CommandPerform +perform :: OsPath -> 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 diff --git a/Command/Sim.hs b/Command/Sim.hs index 26398772fd..36357c4398 100644 --- a/Command/Sim.hs +++ b/Command/Sim.hs @@ -61,13 +61,13 @@ startsim simfile = startsim' simfile >>= cleanup startsim' :: Maybe FilePath -> Annex (SimState SimRepo) startsim' simfile = do - simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir + simdir <- fromRepo gitAnnexSimDir whenM (liftIO $ doesDirectoryExist simdir) $ giveup "A sim was previously started. Use `git-annex sim end` to stop it before starting a new one." showLongNote $ UnquotedString "Sim started." rng <- liftIO $ fst . random <$> getStdGen - let st = emptySimState rng simdir + let st = emptySimState rng (fromOsPath simdir) case simfile of Nothing -> startup simdir st [] Just f -> liftIO (readFile f) >>= \c -> @@ -77,7 +77,7 @@ startsim' simfile = do where startup simdir st cs = do repobyname <- mkGetExistingRepoByName - createAnnexDirectory (toRawFilePath simdir) + createAnnexDirectory simdir let st' = recordSeed st cs go st' repobyname cs @@ -88,7 +88,7 @@ startsim' simfile = do endsim :: CommandSeek endsim = do - simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir + simdir <- fromRepo gitAnnexSimDir whenM (liftIO $ doesDirectoryExist simdir) $ do liftIO $ removeDirectoryRecursive simdir showLongNote $ UnquotedString "Sim ended." diff --git a/Command/Smudge.hs b/Command/Smudge.hs index 89f637dd52..355dd7a647 100644 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -44,7 +44,7 @@ cmd = noCommit $ noMessages $ paramFile (seek <$$> optParser) data SmudgeOptions = UpdateOption | SmudgeOptions - { smudgeFile :: FilePath + { smudgeFile :: OsPath , cleanOption :: Bool } @@ -52,14 +52,14 @@ optParser :: CmdParamsDesc -> Parser SmudgeOptions optParser desc = smudgeoptions <|> updateoption where smudgeoptions = SmudgeOptions - <$> argument str ( metavar desc ) + <$> (stringToOsPath <$> argument str ( metavar desc )) <*> switch ( long "clean" <> help "clean filter" ) updateoption = flag' UpdateOption ( long "update" <> help "populate annexed worktree files" ) seek :: SmudgeOptions -> CommandSeek seek (SmudgeOptions f False) = commandAction (smudge f) -seek (SmudgeOptions f True) = commandAction (clean (toRawFilePath f)) +seek (SmudgeOptions f True) = commandAction (clean f) seek UpdateOption = commandAction update -- Smudge filter is fed git file content, and if it's a pointer to an @@ -73,7 +73,7 @@ seek UpdateOption = commandAction update -- * To support annex.thin -- * Because git currently buffers the whole object received from the -- smudge filter in memory, which is a problem with large files. -smudge :: FilePath -> CommandStart +smudge :: OsPath -> CommandStart smudge file = do b <- liftIO $ L.hGetContents stdin smudge' file b @@ -81,18 +81,18 @@ smudge file = do stop -- Handles everything except the IO of the file content. -smudge' :: FilePath -> L.ByteString -> Annex () +smudge' :: OsPath -> L.ByteString -> Annex () smudge' file b = case parseLinkTargetOrPointerLazy b of Nothing -> noop Just k -> do - topfile <- inRepo (toTopFilePath (toRawFilePath file)) + topfile <- inRepo (toTopFilePath file) Database.Keys.addAssociatedFile k topfile void $ smudgeLog k topfile -- 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 :: RawFilePath -> CommandStart +clean :: OsPath -> CommandStart clean file = do Annex.BranchState.disableUpdate -- optimisation b <- liftIO $ L.hGetContents stdin @@ -116,7 +116,7 @@ clean file = do -- Handles everything except the IO of the file content. clean' - :: RawFilePath + :: OsPath -> Either InvalidAppendedPointerFile (Maybe Key) -- ^ If the content provided by git is an annex pointer, -- this is the key it points to. @@ -188,7 +188,7 @@ clean' file mk passthrough discardreststdin emitpointer = emitpointer =<< postingest =<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage) - =<< lockDown cfg (fromRawFilePath file) + =<< lockDown cfg file postingest (Just k, _) = do logStatus NoLiveUpdate k InfoPresent @@ -203,7 +203,7 @@ clean' file mk passthrough discardreststdin emitpointer = -- git diff can run the clean filter on files outside the -- repository; can't annex those -fileOutsideRepo :: RawFilePath -> Annex Bool +fileOutsideRepo :: OsPath -> Annex Bool fileOutsideRepo file = do repopath <- liftIO . absPath =<< fromRepo Git.repoPath filepath <- liftIO $ absPath file @@ -232,7 +232,7 @@ inSmudgeCleanFilter = bracket setup cleanup . const -- in the index, and has the same content, leave it in git. -- This handles cases such as renaming a file followed by git add, -- which the user naturally expects to behave the same as git mv. -shouldAnnex :: RawFilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool +shouldAnnex :: OsPath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool shouldAnnex file indexmeta moldkey = do ifM (annexGitAddToAnnex <$> Annex.getGitConfig) ( checkunchanged $ checkmatcher checkwasannexed @@ -299,7 +299,7 @@ shouldAnnex file indexmeta moldkey = do -- This also handles the case where a copy of a pointer file is made, -- then git-annex gets the content, and later git add is run on -- the pointer copy. It will then be populated with the content. -getMoveRaceRecovery :: Key -> RawFilePath -> Annex () +getMoveRaceRecovery :: Key -> OsPath -> Annex () getMoveRaceRecovery k file = void $ tryNonAsync $ whenM (inAnnex k) $ do obj <- calcRepo (gitAnnexLocation k) diff --git a/Command/Status.hs b/Command/Status.hs index d6b2358f66..4ad00501a7 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -66,6 +66,6 @@ displayStatus s = do absf <- fromRepo $ fromTopFilePath (statusFile s) f <- liftIO $ relPathCwdToFile absf qp <- coreQuotePath <$> Annex.getGitConfig - unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromRawFilePath f)]) $ + unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromOsPath f)]) $ liftIO $ B8.putStrLn $ quote qp $ UnquotedString (c : " ") <> QuotedPath f diff --git a/Command/Sync.hs b/Command/Sync.hs index 5b2fa3c380..7b74f83b71 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -110,7 +110,7 @@ data SyncOptions = SyncOptions , pushOption :: Bool , contentOption :: Maybe Bool , noContentOption :: Maybe Bool - , contentOfOption :: [FilePath] + , contentOfOption :: [OsPath] , cleanupOption :: Bool , keyOptions :: Maybe KeyOptions , resolveMergeOverride :: Bool @@ -201,7 +201,7 @@ optParser mode desc = SyncOptions <> short 'g' <> help "do not transfer annexed file contents" ))) - <*> many (strOption + <*> many (stringToOsPath <$> strOption ( long "content-of" <> short 'C' <> help "transfer contents of annexed files in a given location" @@ -248,7 +248,7 @@ instance DeferredParseClass SyncOptions where <*> pure (pushOption v) <*> pure (contentOption v) <*> pure (noContentOption v) - <*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v)) + <*> liftIO (mapM absPath (contentOfOption v)) <*> pure (cleanupOption v) <*> pure (keyOptions v) <*> pure (resolveMergeOverride v) @@ -340,7 +340,7 @@ seek' o = startConcurrency transferStages $ do - of the repo. This also means that sync always acts on all files in the - repository, not just on a subdirectory. -} prepMerge :: Annex () -prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath +prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath mergeConfig :: Bool -> Annex [Git.Merge.MergeConfig] mergeConfig mergeunrelated = do @@ -681,7 +681,7 @@ pushRemote o remote (Just branch, _) = do Nothing -> return True Just wt -> ifM needemulation ( gitAnnexChildProcess "post-receive" [] - (\cp -> cp { cwd = Just (fromRawFilePath wt) }) + (\cp -> cp { cwd = Just (fromOsPath wt) }) (\_ _ _ pid -> waitForProcess pid >>= return . \case ExitSuccess -> True _ -> False @@ -820,11 +820,13 @@ seekSyncContent o rs currbranch = do ) _ -> case currbranch of (Just origbranch, Just adj) | adjustmentHidesFiles adj -> do - l <- workTreeItems' (AllowHidden True) ww (contentOfOption o) + l <- workTreeItems' (AllowHidden True) ww + (map fromOsPath (contentOfOption o)) seekincludinghidden origbranch mvar l (const noop) pure Nothing _ -> do - l <- workTreeItems ww (contentOfOption o) + l <- workTreeItems ww + (map fromOsPath (contentOfOption o)) seekworktree mvar l (const noop) pure Nothing waitForAllRunningCommandActions @@ -1013,7 +1015,7 @@ seekExportContent' o rs (mcurrbranch, madj) mtree <- inRepo $ Git.Ref.tree b let addsubdir = case snd (splitRemoteAnnexTrackingBranchSubdir b) of Just subdir -> \cb -> Git.Ref $ - Git.fromRef' cb <> ":" <> getTopFilePath subdir + Git.fromRef' cb <> ":" <> fromOsPath (getTopFilePath subdir) Nothing -> id mcurrtree <- maybe (pure Nothing) (inRepo . Git.Ref.tree . addsubdir) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index eb643d7aad..b35ee6ecb2 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -87,8 +87,7 @@ start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemo showAction "generating test keys" NE.fromList <$> mapM randKey (keySizes basesz fast) - fs -> NE.fromList - <$> mapM (getReadonlyKey r . toRawFilePath) fs + fs -> NE.fromList <$> mapM (getReadonlyKey r . toOsPath) fs let r' = if null (testReadonlyFile o) then r else r { Remote.readonly = True } @@ -256,15 +255,15 @@ test runannex mkr mkk = get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ \r k -> do - tmp <- toOsPath <$> prepTmp k + tmp <- prepTmp k liftIO $ F.writeFile' tmp mempty lockContentForRemoval k noop removeAnnex get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 33%" $ \r k -> do - loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) - tmp <- toOsPath <$> prepTmp k - partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do + loc <- Annex.calcRepo (gitAnnexLocation k) + tmp <- prepTmp k + partial <- liftIO $ bracket (F.openBinaryFile loc ReadMode) hClose $ \h -> do sz <- hFileSize h L.hGet h $ fromInteger $ sz `div` 3 liftIO $ F.writeFile tmp partial @@ -272,8 +271,8 @@ test runannex mkr mkk = get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from end" $ \r k -> do - loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) - tmp <- fromRawFilePath <$> prepTmp k + loc <- Annex.calcRepo (gitAnnexLocation k) + tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k noop removeAnnex get r k @@ -303,7 +302,7 @@ test runannex mkr mkk = loc <- Annex.calcRepo (gitAnnexLocation k) verifier k loc get r k = logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate @@ -342,8 +341,8 @@ testExportTree runannex mkr mkk1 mkk2 = -- renames are not tested because remotes do not need to support them ] where - testexportdirectory = "testremote-export" - testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory "location")) + testexportdirectory = literalOsPath "testremote-export" + testexportlocation = mkExportLocation (testexportdirectory literalOsPath "location") check desc a = testCase desc $ do let a' = mkr >>= \case Just r -> do @@ -354,17 +353,17 @@ testExportTree runannex mkr mkk1 mkk2 = Nothing -> return True runannex a' @? "failed" storeexport ea k = do - loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) + loc <- Annex.calcRepo (gitAnnexLocation k) Remote.storeExport ea loc k testexportlocation nullMeterUpdate - retrieveexport ea k = withTmpFile (toOsPath "exported") $ \tmp h -> do + retrieveexport ea k = withTmpFile (literalOsPath "exported") $ \tmp h -> do liftIO $ hClose h - tryNonAsync (Remote.retrieveExport ea k testexportlocation (fromRawFilePath (fromOsPath tmp)) nullMeterUpdate) >>= \case + tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case Left _ -> return False - Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (fromOsPath tmp) + Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k tmp checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation removeexport ea k = Remote.removeExport ea k testexportlocation removeexportdirectory ea = case Remote.removeExportDirectory ea of - Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory)) + Just a -> a (mkExportDirectory testexportdirectory) Nothing -> noop testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree] @@ -377,14 +376,14 @@ testUnavailable runannex mkr mkk = Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate (RemoteVerify r)) >>= \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 -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> unVerified $ isRight - <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) + <$> tryNonAsync (a k (AssociatedFile Nothing) dest) ] where check checkval desc a = testCase desc $ @@ -430,24 +429,24 @@ keySizes base fast = filter want | otherwise = sz > 0 randKey :: Int -> Annex Key -randKey sz = withTmpFile (toOsPath "randkey") $ \f h -> do +randKey sz = withTmpFile (literalOsPath "randkey") $ \f h -> do gen <- liftIO (newGenIO :: IO SystemRandom) case genBytes sz gen of Left e -> giveup $ "failed to generate random key: " ++ show e Right (rand, _) -> liftIO $ B.hPut h rand liftIO $ hClose h let ks = KeySource - { keyFilename = fromOsPath f - , contentLocation = fromOsPath f + { keyFilename = f + , contentLocation = f , inodeCache = Nothing } 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 (AssociatedFile Nothing) (fromOsPath f) + _ <- moveAnnex k (AssociatedFile Nothing) f return k -getReadonlyKey :: Remote -> RawFilePath -> Annex Key +getReadonlyKey :: Remote -> OsPath -> Annex Key getReadonlyKey r f = do qp <- coreQuotePath <$> Annex.getGitConfig lookupKey f >>= \case diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index ee985ddf9a..9732e7d656 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -30,7 +30,7 @@ optParser :: CmdParamsDesc -> Parser TransferKeyOptions optParser desc = TransferKeyOptions <$> cmdParams desc <*> parseFromToOptions - <*> (AssociatedFile <$> optional (strOption + <*> (AssociatedFile . fmap stringToOsPath <$> optional (strOption ( long "file" <> metavar paramFile <> help "the associated file" ))) @@ -64,7 +64,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key af remote = go Upload af $ download' (uuid remote) key af Nothing stdRetry $ \p -> logStatusAfter NoLiveUpdate key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t -> - tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case + tryNonAsync (Remote.retrieveKeyFile remote key af t p vc) >>= \case Right v -> return (True, v) Left e -> do warning (UnquotedString (show e)) diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index db22b64897..f06a687c71 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -51,7 +51,7 @@ start = do | otherwise = notifyTransfer direction af $ download' (Remote.uuid remote) key af Nothing stdRetry $ \p -> logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case + r <- tryNonAsync (Remote.retrieveKeyFile remote key af t p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) return (False, UnVerified) @@ -128,10 +128,10 @@ instance TCSerialized Direction where deserialize _ = Nothing instance TCSerialized AssociatedFile where - serialize (AssociatedFile (Just f)) = fromRawFilePath f + serialize (AssociatedFile (Just f)) = fromOsPath f serialize (AssociatedFile Nothing) = "" deserialize "" = Just (AssociatedFile Nothing) - deserialize f = Just (AssociatedFile (Just (toRawFilePath f))) + deserialize f = Just (AssociatedFile (Just (toOsPath f))) instance TCSerialized RemoteName where serialize n = n diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs index 79568bf4af..f84f783597 100644 --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -56,7 +56,7 @@ start = do -- and for retrying, and updating location log, -- and stall canceling. let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do - Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) + Remote.verifiedAction (Remote.retrieveKeyFile remote key af t p (RemoteVerify remote)) in download' (Remote.uuid remote) key af Nothing noRetry go noNotification runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote = @@ -73,7 +73,7 @@ start = do notifyTransfer Download file $ download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case + r <- tryNonAsync (Remote.retrieveKeyFile remote key file t p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) return (False, UnVerified) diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 8eeae06d28..31ae53c6ff 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -39,12 +39,12 @@ seeker fast = AnnexedFileSeeker , usesLocationLog = False } -start :: Bool -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: Bool -> SeekInput -> OsPath -> Key -> CommandStart start fast si file key = starting "unannex" (mkActionItem (key, file)) si $ perform fast file key -perform :: Bool -> RawFilePath -> Key -> CommandPerform +perform :: Bool -> OsPath -> Key -> CommandPerform perform fast file key = do Annex.Queue.addCommand [] "rm" [ Param "--cached" @@ -52,7 +52,7 @@ perform fast file key = do , Param "--quiet" , Param "--" ] - [fromRawFilePath file] + [fromOsPath file] isAnnexLink file >>= \case -- If the file is locked, it needs to be replaced with -- the content from the annex. Note that it's possible @@ -73,9 +73,9 @@ perform fast file key = do maybe noop Database.Keys.removeInodeCache =<< withTSDelta (liftIO . genInodeCache file) -cleanup :: Bool -> RawFilePath -> Key -> CommandCleanup +cleanup :: Bool -> OsPath -> Key -> CommandCleanup cleanup fast file key = do - liftIO $ removeFile (fromRawFilePath file) + liftIO $ removeFile file src <- calcRepo (gitAnnexLocation key) ifM (pure fast <||> Annex.getRead Annex.fast) ( do @@ -83,7 +83,7 @@ cleanup fast file key = do -- already have other hard links pointing at it. This -- avoids unannexing (and uninit) ending up hard -- linking files together, which would be surprising. - s <- liftIO $ R.getFileStatus src + s <- liftIO $ R.getFileStatus (fromOsPath src) if linkCount s > 1 then copyfrom src else hardlinkfrom src @@ -91,13 +91,14 @@ cleanup fast file key = do ) where copyfrom src = - thawContent file `after` liftIO - (copyFileExternal CopyAllMetaData - (fromRawFilePath src) - (fromRawFilePath file)) + thawContent file `after` + liftIO (copyFileExternal CopyAllMetaData src file) hardlinkfrom src = -- creating a hard link could fall; fall back to copying - ifM (liftIO $ catchBoolIO $ R.createLink src file >> return True) + ifM (liftIO $ tryhardlink src file) ( return True , copyfrom src ) + tryhardlink src dest = catchBoolIO $ do + R.createLink (fromOsPath src) (fromOsPath dest) + return True diff --git a/Command/Undo.hs b/Command/Undo.hs index 000cc1c313..289d4c35d2 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -18,7 +18,6 @@ import qualified Annex import qualified Git.LsFiles as LsFiles import qualified Git.Command as Git import qualified Git.Branch -import qualified Utility.RawFilePath as R cmd :: Command cmd = notBareRepo $ withAnnexOptions [jsonOptions] $ @@ -30,7 +29,7 @@ seek :: CmdParams -> CommandSeek seek ps = do -- Safety first; avoid any undo that would touch files that are not -- in the index. - (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toRawFilePath ps) + (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toOsPath ps) unless (null fs) $ do qp <- coreQuotePath <$> Annex.getGitConfig giveup $ decodeBS $ quote qp $ @@ -48,19 +47,20 @@ seek ps = do start :: FilePath -> CommandStart start p = starting "undo" ai si $ - perform p + perform p' where - ai = ActionItemOther (Just (QuotedPath (toRawFilePath p))) + p' = toOsPath p + ai = ActionItemOther (Just (QuotedPath p')) si = SeekInput [p] -perform :: FilePath -> CommandPerform +perform :: OsPath -> CommandPerform perform p = do g <- gitRepo -- Get the reversed diff that needs to be applied to undo. (diff, cleanup) <- inRepo $ - diffLog [Param "-R", Param "--", Param p] - top <- inRepo $ toTopFilePath $ toRawFilePath p + diffLog [Param "-R", Param "--", Param (fromOsPath p)] + top <- inRepo $ toTopFilePath p let diff' = filter (`isDiffOf` top) diff liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff') @@ -73,10 +73,10 @@ perform p = do forM_ removals $ \di -> do f <- mkrel di - liftIO $ removeWhenExistsWith R.removeLink f + liftIO $ removeWhenExistsWith removeFile f forM_ adds $ \di -> do - f <- fromRawFilePath <$> mkrel di + f <- fromOsPath <$> mkrel di inRepo $ Git.run [Param "checkout", Param "--", File f] next $ liftIO cleanup diff --git a/Command/Uninit.hs b/Command/Uninit.hs index d883467787..0c95774c14 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -73,7 +73,7 @@ checkCanUninit recordok = when (b == Just Annex.Branch.name) $ giveup $ "cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out" top <- fromRepo Git.repoPath - currdir <- liftIO R.getCurrentDirectory + currdir <- liftIO getCurrentDirectory whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" @@ -87,14 +87,14 @@ checkCanUninit recordok = {- git annex symlinks that are not checked into git could be left by an - interrupted add. -} -startCheckIncomplete :: Annex () -> RawFilePath -> Key -> CommandStart +startCheckIncomplete :: Annex () -> OsPath -> Key -> CommandStart startCheckIncomplete recordnotok file key = starting "uninit check" (mkActionItem (file, key)) (SeekInput []) $ do recordnotok giveup $ unlines err where err = - [ fromRawFilePath file ++ " points to annexed content, but is not checked into git." + [ fromOsPath file ++ " points to annexed content, but is not checked into git." , "Perhaps this was left behind by an interrupted git annex add?" , "Not continuing with uninit; either delete or git annex add the file and retry." ] @@ -109,11 +109,11 @@ removeAnnexDir recordok = do prepareRemoveAnnexDir annexdir if null leftovers then do - liftIO $ removeDirectoryRecursive (fromRawFilePath annexdir) + liftIO $ removeDirectoryRecursive annexdir next recordok else giveup $ unlines [ "Not fully uninitialized" - , "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir + , "Some annexed data is still left in " ++ fromOsPath annexobjectdir , "This may include deleted files, or old versions of modified files." , "" , "If you don't care about preserving the data, just delete the" @@ -134,12 +134,12 @@ removeAnnexDir recordok = do - - Also closes sqlite databases that might be in the directory, - to avoid later failure to write any cached changes to them. -} -prepareRemoveAnnexDir :: RawFilePath -> Annex () +prepareRemoveAnnexDir :: OsPath -> Annex () prepareRemoveAnnexDir annexdir = do Database.Keys.closeDb liftIO $ prepareRemoveAnnexDir' annexdir -prepareRemoveAnnexDir' :: RawFilePath -> IO () +prepareRemoveAnnexDir' :: OsPath -> IO () prepareRemoveAnnexDir' annexdir = emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir) >>= mapM_ (void . tryIO . allowWrite) @@ -159,7 +159,7 @@ removeUnannexed = go [] , go (k:c) ks ) enoughlinks f = catchBoolIO $ do - s <- R.getFileStatus f + s <- R.getFileStatus (fromOsPath f) return $ linkCount s > 1 completeUnitialize :: CommandStart diff --git a/Command/Unlock.hs b/Command/Unlock.hs index e0f7ccb29a..ac8520f0f4 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -40,7 +40,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) ( starting "unlock" ai si $ perform file key , stop @@ -48,9 +48,9 @@ start si file key = ifM (isJust <$> isAnnexLink file) where ai = mkActionItem (key, AssociatedFile (Just file)) -perform :: RawFilePath -> Key -> CommandPerform +perform :: OsPath -> Key -> CommandPerform perform dest key = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest + destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath dest) destic <- replaceWorkTreeFile dest $ \tmp -> do ifM (inAnnex key) ( do @@ -64,7 +64,7 @@ perform dest key = do withTSDelta (liftIO . genInodeCache tmp) next $ cleanup dest destic key destmode -cleanup :: RawFilePath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup +cleanup :: OsPath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup cleanup dest destic key destmode = do stagePointerFile dest destmode =<< hashPointerFile key maybe noop (restagePointerFile (Restage True) dest) destic diff --git a/Command/Unused.hs b/Command/Unused.hs index 85913a5782..22edacdc35 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -119,7 +119,7 @@ check fileprefix msg a c = do maybeAddJSONField ((if null fileprefix then "unused" else fileprefix) ++ "-list") (M.fromList $ map (\(n, k) -> (T.pack (show n), serializeKey k)) unusedlist) - updateUnusedLog (toRawFilePath fileprefix) (M.fromList unusedlist) + updateUnusedLog (toOsPath fileprefix) (M.fromList unusedlist) return $ c + length l number :: Int -> [a] -> [(Int, a)] @@ -194,7 +194,7 @@ excludeReferenced refspec ks = runbloomfilter withKeysReferencedM ks {- Given an initial value, accumulates the value over each key - referenced by files in the working tree. -} -withKeysReferenced :: v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v +withKeysReferenced :: v -> (Key -> OsPath -> v -> Annex v) -> Annex v withKeysReferenced initial = withKeysReferenced' Nothing initial {- Runs an action on each referenced key in the working tree. -} @@ -204,10 +204,10 @@ withKeysReferencedM a = withKeysReferenced' Nothing () calla calla k _ _ = a k {- Folds an action over keys and files referenced in a particular directory. -} -withKeysFilesReferencedIn :: FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v +withKeysFilesReferencedIn :: OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v withKeysFilesReferencedIn = withKeysReferenced' . Just -withKeysReferenced' :: Maybe FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v +withKeysReferenced' :: Maybe OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v withKeysReferenced' mdir initial a = do (files, clean) <- getfiles r <- go initial files @@ -221,7 +221,7 @@ withKeysReferenced' mdir initial a = do top <- fromRepo Git.repoPath inRepo $ LsFiles.allFiles [] [top] ) - Just dir -> inRepo $ LsFiles.inRepo [] [toRawFilePath dir] + Just dir -> inRepo $ LsFiles.inRepo [] [dir] go v [] = return v go v (f:fs) = do mk <- lookupKey f @@ -308,9 +308,9 @@ data UnusedMaps = UnusedMaps withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CmdParams -> CommandSeek withUnusedMaps a params = do - unused <- readUnusedMap "" - unusedbad <- readUnusedMap "bad" - unusedtmp <- readUnusedMap "tmp" + unused <- readUnusedMap (literalOsPath "") + unusedbad <- readUnusedMap (literalOsPath "bad") + unusedtmp <- readUnusedMap (literalOsPath "tmp") let m = unused `M.union` unusedbad `M.union` unusedtmp let unusedmaps = UnusedMaps unused unusedbad unusedtmp commandActions $ map (a unusedmaps) $ concatMap (unusedSpec m) params diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 426177ec69..4679c598e5 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -34,7 +34,6 @@ import Types.NumCopies import Remote import Git.Types (fromConfigKey, fromConfigValue) import Utility.DataUnits -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F cmd :: Command @@ -47,30 +46,35 @@ seek = withNothing (commandAction start) 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 (fromOsPath f) $ genCfg cfg descs + vicfg cfg f stop -vicfg :: Cfg -> FilePath -> Annex () +vicfg :: Cfg -> OsPath -> Annex () vicfg curcfg f = do vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR" - -- Allow EDITOR to be processed by the shell, so it can contain options. - unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ + unlessM (liftIO $ boolSystem "sh" (shparams vi)) $ giveup $ vi ++ " exited nonzero; aborting" r <- liftIO $ parseCfg (defCfg curcfg) . map decodeBS . fileLines' - <$> F.readFile' (toOsPath (toRawFilePath f)) - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + <$> F.readFile' f + liftIO $ removeWhenExistsWith removeFile f case r of Left s -> do - liftIO $ writeFile f s + liftIO $ writeFile (fromOsPath f) s vicfg curcfg f Right newcfg -> setCfg curcfg newcfg + where + -- Allow EDITOR to be processed by the shell, + -- so it can contain options. + shparams editor = + [ Param "-c" + , Param $ unwords [editor, shellEscape (fromOsPath f)] + ] data Cfg = Cfg { cfgTrustMap :: M.Map UUID (Down TrustLevel) diff --git a/Command/View.hs b/Command/View.hs index c510d3671b..9873d91b1d 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -24,8 +24,6 @@ import Logs.View import Types.AdjustedBranch import Annex.AdjustedBranch.Name -import qualified System.FilePath.ByteString as P - cmd :: Command cmd = notBareRepo $ command "view" SectionMetaData "enter a view branch" @@ -120,13 +118,12 @@ checkoutViewBranch view madj mkbranch = do forM_ l (removeemptydir top) liftIO $ void cleanup unlessM (liftIO $ doesDirectoryExist here) $ do - showLongNote $ UnquotedString $ cwdmissing (fromRawFilePath top) + showLongNote $ UnquotedString $ cwdmissing (fromOsPath top) return ok where removeemptydir top d = do p <- inRepo $ toTopFilePath d - liftIO $ tryIO $ removeDirectory $ - fromRawFilePath $ (top P. getTopFilePath p) + liftIO $ tryIO $ removeDirectory $ top 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 index 2958784eb7..02e5735d3b 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -86,15 +86,15 @@ start' allowauto o = do listenPort' <- if isJust (listenPort o) then pure (listenPort o) else annexPort <$> Annex.getGitConfig - ifM (checkpid <&&> checkshim (fromRawFilePath f)) + ifM (checkpid <&&> checkshim f) ( if isJust (listenAddress o) || isJust (listenPort o) then giveup "The assistant is already running, so --listen and --port cannot be used." else do - url <- liftIO . readFile . fromRawFilePath + url <- liftIO . readFile . fromOsPath =<< fromRepo gitAnnexUrlFile liftIO $ if isJust listenAddress' then putStrLn url - else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing + else liftIO $ openBrowser browser f url Nothing Nothing , do startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $ \origout origerr url htmlshim -> @@ -104,11 +104,11 @@ start' allowauto o = do ) checkpid = do pidfile <- fromRepo gitAnnexPidFile - liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile) + liftIO $ isJust <$> checkDaemon pidfile checkshim f = liftIO $ doesFileExist f notinitialized = do g <- Annex.gitRepo - liftIO $ cannotStartIn (Git.repoLocation g) "repository has not been initialized by git-annex" + liftIO $ cannotStartIn (Git.repoPath g) "repository has not been initialized by git-annex" liftIO $ firstRun o {- If HOME is a git repo, even if it's initialized for git-annex, @@ -117,7 +117,7 @@ notHome :: Annex Bool notHome = do g <- Annex.gitRepo d <- liftIO $ absPath (Git.repoPath g) - h <- liftIO $ absPath . toRawFilePath =<< myHomeDir + h <- liftIO $ absPath . toOsPath =<< myHomeDir return (d /= h) {- When run without a repo, start the first available listed repository in @@ -136,14 +136,15 @@ startNoRepo o = go =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile) go ds Right state -> void $ Annex.eval state $ do whenM (fromRepo Git.repoIsLocalBare) $ - giveup $ d ++ " is a bare git repository, cannot run the webapp in it" + giveup $ fromOsPath d ++ " is a bare git repository, cannot run the webapp in it" r <- callCommandAction $ start' False o quiesce False return r -cannotStartIn :: FilePath -> String -> IO () -cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason +cannotStartIn :: OsPath -> String -> IO () +cannotStartIn d reason = warningIO $ + "unable to start webapp in repository " ++ fromOsPath d ++ ": " ++ reason {- Run the webapp without a repository, which prompts the user, makes one, - changes to it, starts the regular assistant, and redirects the @@ -203,12 +204,12 @@ firstRun o = do (Just $ sendurlback v) sendurlback v _origout _origerr url _htmlshim = putMVar v url -openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () +openBrowser :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO () openBrowser mcmd htmlshim realurl outh errh = do - htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim) + htmlshim' <- absPath htmlshim openBrowser' mcmd htmlshim' realurl outh errh -openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () +openBrowser' :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO () openBrowser' mcmd htmlshim realurl outh errh = ifM osAndroid {- Android does not support file:// urls well, but neither @@ -220,7 +221,7 @@ openBrowser' mcmd htmlshim realurl outh errh = where runbrowser url = do let p = case mcmd of - Just c -> proc c [url] + Just c -> proc (fromOsPath c) [url] Nothing -> #ifndef mingw32_HOST_OS browserProc url @@ -228,8 +229,8 @@ openBrowser' mcmd htmlshim realurl outh errh = {- Windows hack to avoid using the full path, - which might contain spaces that cause problems - for browserProc. -} - (browserProc (takeFileName htmlshim)) - { cwd = Just (takeDirectory htmlshim) } + (browserProc (fromOsPath (takeFileName htmlshim))) + { cwd = Just (fromOsPath (takeDirectory htmlshim)) } #endif hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url hFlush stdout @@ -245,8 +246,8 @@ openBrowser' mcmd htmlshim realurl outh errh = hPutStrLn (fromMaybe stderr errh) "failed to start web browser" {- web.browser is a generic git config setting for a web browser program -} -webBrowser :: Git.Repo -> Maybe FilePath +webBrowser :: Git.Repo -> Maybe OsPath webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser" -fileUrl :: FilePath -> String -fileUrl file = "file://" ++ file +fileUrl :: OsPath -> String +fileUrl file = "file://" ++ fromOsPath file diff --git a/Command/WhereUsed.hs b/Command/WhereUsed.hs index 2119c02a66..bfe49d1a73 100644 --- a/Command/WhereUsed.hs +++ b/Command/WhereUsed.hs @@ -124,7 +124,7 @@ findHistorical key = do display key (descBranchFilePath (BranchFilePath r tf)) return True -searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Annex Bool) -> Annex Bool +searchLog :: Key -> [CommandParam] -> (S.ByteString -> [OsPath] -> Annex Bool) -> Annex Bool searchLog key ps a = do (output, cleanup) <- Annex.inRepo $ Git.Command.pipeNullSplit ps' found <- case output of @@ -154,7 +154,7 @@ searchLog key ps a = do -- so a regexp is used. Since annex pointer files -- may contain a newline followed by perhaps something -- else, that is also matched. - , Param ("-G" ++ escapeRegexp (fromRawFilePath (keyFile key)) ++ "($|\n)") + , Param ("-G" ++ escapeRegexp (fromOsPath (keyFile key)) ++ "($|\n)") -- Skip commits where the file was deleted, -- only find those where it was added or modified. , Param "--diff-filter=ACMRTUX" diff --git a/Command/Whereis.hs b/Command/Whereis.hs index b91c44bb1c..919d96b322 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -67,7 +67,7 @@ seek o = do where ww = WarnUnmatchLsFiles "whereis" -start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> OsPath -> Key -> CommandStart start o remotemap si file key = startKeys o remotemap (si, key, mkActionItem (key, afile)) where diff --git a/Common.hs b/Common.hs index 71681275f9..fe322fa1c4 100644 --- a/Common.hs +++ b/Common.hs @@ -10,7 +10,6 @@ import Data.List as X hiding (head, tail, init, last) import Data.Monoid as X import Data.Default as X -import System.FilePath as X import System.IO as X hiding (FilePath) import System.Exit as X import System.PosixCompat.Files as X (FileStatus) diff --git a/Config.hs b/Config.hs index 15dce780d0..892c49d4a5 100644 --- a/Config.hs +++ b/Config.hs @@ -94,7 +94,7 @@ setCrippledFileSystem :: Bool -> Annex () setCrippledFileSystem b = setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) -pidLockFile :: Annex (Maybe RawFilePath) +pidLockFile :: Annex (Maybe OsPath) #ifndef mingw32_HOST_OS pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) ( Just <$> Annex.fromRepo gitAnnexPidLockFile @@ -111,4 +111,4 @@ splitRemoteAnnexTrackingBranchSubdir tb = (branch, subdir) branch = Git.Ref b subdir = if S.null p then Nothing - else Just (asTopFilePath p) + else Just (asTopFilePath (toOsPath p)) diff --git a/Config/Files.hs b/Config/Files.hs index 83e4eda085..14450fcc72 100644 --- a/Config/Files.hs +++ b/Config/Files.hs @@ -5,32 +5,31 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Config.Files where +import Common import Utility.FreeDesktop -import Utility.Exception - -import System.FilePath {- ~/.config/git-annex/file -} -userConfigFile :: FilePath -> IO FilePath +userConfigFile :: OsPath -> IO OsPath userConfigFile file = do dir <- userConfigDir - return $ dir "git-annex" file + return $ dir literalOsPath "git-annex" file -autoStartFile :: IO FilePath -autoStartFile = userConfigFile "autostart" +autoStartFile :: IO OsPath +autoStartFile = userConfigFile (literalOsPath "autostart") {- The path to git-annex is written here; which is useful when something - has installed it to some awful non-PATH location. -} -programFile :: IO FilePath -programFile = userConfigFile "program" +programFile :: IO OsPath +programFile = userConfigFile (literalOsPath "program") {- A .noannex file in a git repository prevents git-annex from - initializing that repository. The content of the file is returned. -} -noAnnexFileContent :: Maybe FilePath -> IO (Maybe String) +noAnnexFileContent :: Maybe OsPath -> IO (Maybe String) noAnnexFileContent repoworktree = case repoworktree of Nothing -> return Nothing - Just wt -> catchMaybeIO (readFile (wt ".noannex")) + Just wt -> catchMaybeIO (readFile (fromOsPath (wt literalOsPath ".noannex"))) diff --git a/Config/Files/AutoStart.hs b/Config/Files/AutoStart.hs index 8b20644901..7307e46d5c 100644 --- a/Config/Files/AutoStart.hs +++ b/Config/Files/AutoStart.hs @@ -14,38 +14,36 @@ import Config.Files import Utility.Tmp {- Returns anything listed in the autostart file (which may not exist). -} -readAutoStartFile :: IO [FilePath] +readAutoStartFile :: IO [OsPath] readAutoStartFile = do f <- autoStartFile - filter valid . nub . map dropTrailingPathSeparator . lines - <$> catchDefaultIO "" (readFile f) + filter valid . nub . map (dropTrailingPathSeparator . toOsPath) . lines + <$> catchDefaultIO "" (readFile (fromOsPath f)) where -- Ignore any relative paths; some old buggy versions added eg "." valid = isAbsolute -modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO () +modifyAutoStartFile :: ([OsPath] -> [OsPath]) -> 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 . fromRawFilePath . fromOsPath) - (toOsPath (toRawFilePath f)) - (unlines dirs') + createDirectoryIfMissing True (parentDir f) + viaTmp (writeFile . fromRawFilePath . fromOsPath) f + (unlines (map fromOsPath 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 :: OsPath -> IO () addAutoStartFile path = do - path' <- fromRawFilePath <$> absPath (toRawFilePath path) + path' <- absPath path modifyAutoStartFile $ (:) path' {- Removes a directory from the autostart file. -} -removeAutoStartFile :: FilePath -> IO () +removeAutoStartFile :: OsPath -> IO () removeAutoStartFile path = do - path' <- fromRawFilePath <$> absPath (toRawFilePath path) + path' <- absPath path modifyAutoStartFile $ filter (not . equalFilePath path') diff --git a/Config/Smudge.hs b/Config/Smudge.hs index aa89990c0a..c17eaa1bca 100644 --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -20,7 +20,6 @@ import Annex.Version import qualified Utility.FileIO as F import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P configureSmudgeFilter :: Annex () configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do @@ -47,11 +46,11 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do gfs <- readattr gf gittop <- Git.localGitDir <$> gitRepo liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do - createDirectoryUnder [gittop] (P.takeDirectory lf) - F.writeFile' (toOsPath lf) $ + createDirectoryUnder [gittop] (takeDirectory lf) + F.writeFile' lf $ linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr)) where - readattr = liftIO . catchDefaultIO mempty . F.readFile' . toOsPath + readattr = liftIO . catchDefaultIO mempty . F.readFile' configureSmudgeFilterProcess :: Annex () configureSmudgeFilterProcess = @@ -70,8 +69,8 @@ deconfigureSmudgeFilter :: Annex () deconfigureSmudgeFilter = do lf <- Annex.fromRepo Git.attributesLocal ls <- liftIO $ catchDefaultIO [] $ - map decodeBS . fileLines' <$> F.readFile' (toOsPath lf) - liftIO $ writeFile (fromRawFilePath lf) $ unlines $ + map decodeBS . fileLines' <$> F.readFile' lf + liftIO $ writeFile (fromOsPath lf) $ unlines $ filter (\l -> l `notElem` stdattr && not (null l)) ls unsetConfig (ConfigKey "filter.annex.smudge") unsetConfig (ConfigKey "filter.annex.clean") diff --git a/Creds.hs b/Creds.hs index 3bbf6f7b28..4e197d7001 100644 --- a/Creds.hs +++ b/Creds.hs @@ -36,18 +36,16 @@ import Types.ProposedAccepted import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher) import Utility.Env (getEnv) import Utility.Base64 -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Char8 as S8 import qualified Data.Map as M -import qualified System.FilePath.ByteString as P {- A CredPair can be stored in a file, or in the environment, or - in a remote's configuration. -} data CredPairStorage = CredPairStorage - { credPairFile :: FilePath + { credPairFile :: OsPath , credPairEnvironment :: (String, String) , credPairRemoteField :: RemoteConfigField } @@ -196,21 +194,21 @@ existsCacheCredPair storage = {- Stores the creds in a file inside gitAnnexCredsDir that only the user - can read. -} -writeCreds :: Creds -> FilePath -> Annex () +writeCreds :: Creds -> OsPath -> Annex () writeCreds creds file = do d <- fromRepo gitAnnexCredsDir createAnnexDirectory d - liftIO $ writeFileProtected (d P. toRawFilePath file) creds + liftIO $ writeFileProtected (d file) creds -readCreds :: FilePath -> Annex (Maybe Creds) +readCreds :: OsPath -> Annex (Maybe Creds) readCreds f = do - f' <- toOsPath . toRawFilePath <$> credsFile f + f' <- credsFile f liftIO $ catchMaybeIO $ decodeBS . S8.unlines . fileLines' <$> F.readFile' f' -credsFile :: FilePath -> Annex FilePath +credsFile :: OsPath -> Annex OsPath credsFile basefile = do - d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir + d <- fromRepo gitAnnexCredsDir return $ d basefile encodeCredPair :: CredPair -> Creds @@ -221,10 +219,10 @@ decodeCredPair creds = case lines creds of l:p:[] -> Just (l, p) _ -> Nothing -removeCreds :: FilePath -> Annex () +removeCreds :: OsPath -> Annex () removeCreds file = do d <- fromRepo gitAnnexCredsDir - liftIO $ removeWhenExistsWith R.removeLink (d P. toRawFilePath file) + liftIO $ removeWhenExistsWith removeFile (d file) includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do diff --git a/Crypto.hs b/Crypto.hs index b28814f0ea..b9a09a19ba 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -211,7 +211,7 @@ encrypt gpgcmd c cipher feeder reader = case cipher of Cipher{} -> let passphrase = cipherPassphrase cipher in case statelessOpenPGPCommand c of - Just sopcmd -> withTmpDir (toOsPath "sop") $ \d -> + Just sopcmd -> withTmpDir (literalOsPath "sop") $ \d -> SOP.encryptSymmetric sopcmd passphrase (SOP.EmptyDirectory d) (statelessOpenPGPProfile c) @@ -233,7 +233,7 @@ decrypt cmd c cipher feeder reader = case cipher of Cipher{} -> let passphrase = cipherPassphrase cipher in case statelessOpenPGPCommand c of - Just sopcmd -> withTmpDir (toOsPath "sop") $ \d -> + Just sopcmd -> withTmpDir (literalOsPath "sop") $ \d -> SOP.decryptSymmetric sopcmd passphrase (SOP.EmptyDirectory d) feeder reader diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs index 552236df95..d2296dc33c 100644 --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -26,13 +26,12 @@ import qualified Data.ByteString.Short as S (toShort) 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 "." (toOsPath "benchmark") $ \tmpdir -> do - db <- benchDb (toRawFilePath tmpdir) n +benchmarkDbs mode n = withTmpDirIn (literalOsPath ".") (literalOsPath "benchmark") $ \tmpdir -> do + db <- benchDb tmpdir n liftIO $ runMode mode [ bgroup "keys database" [ getAssociatedFilesHitBench db @@ -93,7 +92,7 @@ keyN n = mkKey $ \k -> k } fileN :: Integer -> TopFilePath -fileN n = asTopFilePath (toRawFilePath ("file" ++ show n)) +fileN n = asTopFilePath (toOsPath ("file" ++ show n)) keyMiss :: Key keyMiss = keyN 0 -- 0 is never stored @@ -103,7 +102,7 @@ fileMiss = fileN 0 -- 0 is never stored data BenchDb = BenchDb H.DbQueue Integer (MVar Integer) -benchDb :: RawFilePath -> Integer -> Annex BenchDb +benchDb :: OsPath -> Integer -> Annex BenchDb benchDb tmpdir num = do liftIO $ putStrLn $ "setting up database with " ++ show num ++ " items" initDb db SQL.createTables @@ -115,6 +114,6 @@ benchDb tmpdir num = do mv <- liftIO $ newMVar 1 return (BenchDb h num mv) where - db = tmpdir P. toRawFilePath (show num "db") + db = tmpdir toOsPath (show num) literalOsPath "db" #endif /* WITH_BENCHMARK */ diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs index 3a399f7765..c531f915ea 100644 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -47,11 +47,9 @@ import Git.FilePath 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 #if MIN_VERSION_persistent_sqlite(2,13,3) import Database.RawFilePath @@ -98,15 +96,15 @@ AnnexBranch openDb :: Annex ContentIdentifierHandle openDb = do dbdir <- calcRepo' gitAnnexContentIdentifierDbDir - let db = dbdir P. "db" - isnew <- liftIO $ not <$> R.doesPathExist db + let db = dbdir literalOsPath "db" + isnew <- liftIO $ not <$> doesDirectoryExist db if isnew then initDb db $ void $ runMigrationSilent migrateContentIdentifier -- Migrate from old versions of database, which had buggy -- and suboptimal uniqueness constraints. #if MIN_VERSION_persistent_sqlite(2,13,3) - else liftIO $ runSqlite' db $ void $ + else liftIO $ runSqlite' (fromOsPath db) $ void $ runMigrationSilent migrateContentIdentifier #else else liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $ diff --git a/Database/Export.hs b/Database/Export.hs index 6de86c7925..0ed6c126bb 100644 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -58,11 +58,9 @@ import Git.Types 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 @@ -98,8 +96,8 @@ ExportTreeCurrent openDb :: UUID -> Annex ExportHandle openDb u = do dbdir <- calcRepo' (gitAnnexExportDbDir u) - let db = dbdir P. "db" - unlessM (liftIO $ R.doesPathExist db) $ do + let db = dbdir literalOsPath "db" + unlessM (liftIO $ doesDirectoryExist db) $ do initDb db $ void $ runMigrationSilent migrateExport h <- liftIO $ H.openDbQueue db "exported" @@ -136,26 +134,27 @@ addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () addExportedLocation h k el = queueDb h $ do void $ insertUniqueFast $ Exported k ef let edirs = map - (\ed -> ExportedDirectory (SByteString (fromExportDirectory ed)) ef) + (\ed -> ExportedDirectory (SByteString (fromOsPath (fromExportDirectory ed))) ef) (exportDirectories el) putMany edirs where - ef = SByteString (fromExportLocation el) + ef = SByteString (fromOsPath (fromExportLocation el)) removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () removeExportedLocation h k el = queueDb h $ do deleteWhere [ExportedKey ==. k, ExportedFile ==. ef] - let subdirs = map (SByteString . fromExportDirectory) + let subdirs = map + (SByteString . fromOsPath . fromExportDirectory) (exportDirectories el) deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs] where - ef = SByteString (fromExportLocation el) + ef = SByteString (fromOsPath (fromExportLocation el)) {- Note that this does not see recently queued changes. -} getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportedKey ==. k] [] - return $ map (mkExportLocation . (\(SByteString f) -> f) . exportedFile . entityVal) l + return $ map (mkExportLocation . (\(SByteString f) -> toOsPath f) . exportedFile . entityVal) l {- Note that this does not see recently queued changes. -} isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool @@ -163,13 +162,13 @@ isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do l <- selectList [ExportedDirectorySubdir ==. ed] [] return $ null l where - ed = SByteString $ fromExportDirectory d + ed = SByteString $ fromOsPath $ fromExportDirectory d {- Get locations in the export that might contain a key. -} getExportTree :: ExportHandle -> Key -> IO [ExportLocation] getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportTreeKey ==. k] [] - return $ map (mkExportLocation . (\(SByteString f) -> f) . exportTreeFile . entityVal) l + return $ map (mkExportLocation . (\(SByteString f) -> toOsPath f) . exportTreeFile . entityVal) l {- Get keys that might be currently exported to a location. - @@ -180,19 +179,19 @@ getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do map (exportTreeKey . entityVal) <$> selectList [ExportTreeFile ==. ef] [] where - ef = SByteString (fromExportLocation el) + ef = SByteString (fromOsPath (fromExportLocation el)) addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $ void $ insertUniqueFast $ ExportTree k ef where - ef = SByteString (fromExportLocation loc) + ef = SByteString (fromOsPath (fromExportLocation loc)) removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO () removeExportTree h k loc = queueDb h $ deleteWhere [ExportTreeKey ==. k, ExportTreeFile ==. ef] where - ef = SByteString (fromExportLocation loc) + ef = SByteString (fromOsPath (fromExportLocation loc)) -- An action that is passed the old and new values that were exported, -- and updates state. diff --git a/Database/Fsck.hs b/Database/Fsck.hs index 2ff4eb6bb5..496903e0e4 100644 --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -33,12 +33,10 @@ import Annex.Locations 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 @@ -66,14 +64,14 @@ newPass u = do go = do removedb =<< calcRepo' (gitAnnexFsckDbDir u) removedb =<< calcRepo' (gitAnnexFsckDbDirOld u) - removedb = liftIO . void . tryIO . removeDirectoryRecursive . fromRawFilePath + removedb = liftIO . void . tryIO . removeDirectoryRecursive {- Opens the database, creating it if it doesn't exist yet. -} openDb :: UUID -> Annex FsckHandle openDb u = do dbdir <- calcRepo' (gitAnnexFsckDbDir u) - let db = dbdir P. "db" - unlessM (liftIO $ R.doesPathExist db) $ do + let db = dbdir literalOsPath "db" + unlessM (liftIO $ doesDirectoryExist db) $ do initDb db $ void $ runMigrationSilent migrateFsck lockFileCached =<< calcRepo' (gitAnnexFsckDbLock u) diff --git a/Database/Handle.hs b/Database/Handle.hs index 23e7df2d33..ff358f7588 100644 --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -23,6 +23,7 @@ import Utility.FileSystemEncoding import Utility.Debug import Utility.DebugLocks import Utility.InodeCache +import Utility.OsPath import Database.Persist.Sqlite import qualified Database.Sqlite as Sqlite @@ -41,14 +42,14 @@ import System.IO {- A DbHandle is a reference to a worker thread that communicates with - the database. It has a MVar which Jobs are submitted to. - There is also an MVar which it will fill when there is a fatal error-} -data DbHandle = DbHandle RawFilePath (Async ()) (MVar Job) (MVar String) +data DbHandle = DbHandle OsPath (Async ()) (MVar Job) (MVar String) {- Name of a table that should exist once the database is initialized. -} type TableName = String {- Opens the database, but does not perform any migrations. Only use - once the database is known to exist and have the right tables. -} -openDb :: RawFilePath -> TableName -> IO DbHandle +openDb :: OsPath -> TableName -> IO DbHandle openDb db tablename = do jobs <- newEmptyMVar errvar <- newEmptyMVar @@ -135,7 +136,7 @@ data Job | ChangeJob (SqlPersistM ()) | CloseJob -workerThread :: RawFilePath -> TableName -> MVar Job -> MVar String -> IO () +workerThread :: OsPath -> TableName -> MVar Job -> MVar String -> IO () workerThread db tablename jobs errvar = newconn where newconn = do @@ -174,7 +175,7 @@ workerThread db tablename jobs errvar = newconn - retrying only if the database shows signs of being modified by another - process at least once each 30 seconds. -} -runSqliteRobustly :: TableName -> RawFilePath -> (SqlPersistM a) -> IO a +runSqliteRobustly :: TableName -> OsPath -> (SqlPersistM a) -> IO a runSqliteRobustly tablename db a = do conn <- opensettle maxretries emptyDatabaseInodeCache go conn maxretries emptyDatabaseInodeCache @@ -194,9 +195,9 @@ runSqliteRobustly tablename db a = do opensettle retries ic = do #if MIN_VERSION_persistent_sqlite(2,13,3) - conn <- Sqlite.open' db + conn <- Sqlite.open' (fromOsPath db) #else - conn <- Sqlite.open (T.pack (fromRawFilePath db)) + conn <- Sqlite.open (T.pack (fromOsPath db)) #endif settle conn retries ic @@ -237,7 +238,7 @@ withSqlConnRobustly , BaseBackend backend ~ SqlBackend , BackendCompatible SqlBackend backend ) - => RawFilePath + => OsPath -> (LogFunc -> IO backend) -> (backend -> m a) -> m a @@ -260,7 +261,7 @@ closeRobustly , BaseBackend backend ~ SqlBackend , BackendCompatible SqlBackend backend ) - => RawFilePath + => OsPath -> backend -> IO () closeRobustly db conn = go maxretries emptyDatabaseInodeCache @@ -294,7 +295,7 @@ retryHelper => String -> err -> Int - -> RawFilePath + -> OsPath -> Int -> DatabaseInodeCache -> (Int -> DatabaseInodeCache -> IO a) @@ -309,9 +310,9 @@ retryHelper action err maxretries db retries ic a = do else giveup (databaseAccessStalledMsg action db err) else a retries' ic -databaseAccessStalledMsg :: Show err => String -> RawFilePath -> err -> String +databaseAccessStalledMsg :: Show err => String -> OsPath -> err -> String databaseAccessStalledMsg action db err = - "Repeatedly unable to " ++ action ++ " sqlite database " ++ fromRawFilePath db + "Repeatedly unable to " ++ action ++ " sqlite database " ++ fromOsPath db ++ ": " ++ show err ++ ". " ++ "Perhaps another git-annex process is suspended and is " ++ "keeping this database locked?" @@ -321,10 +322,10 @@ data DatabaseInodeCache = DatabaseInodeCache (Maybe InodeCache) (Maybe InodeCach emptyDatabaseInodeCache :: DatabaseInodeCache emptyDatabaseInodeCache = DatabaseInodeCache Nothing Nothing -getDatabaseInodeCache :: RawFilePath -> IO DatabaseInodeCache +getDatabaseInodeCache :: OsPath -> IO DatabaseInodeCache getDatabaseInodeCache db = DatabaseInodeCache <$> genInodeCache db noTSDelta - <*> genInodeCache (db <> "-wal") noTSDelta + <*> genInodeCache (db <> literalOsPath "-wal") noTSDelta isDatabaseModified :: DatabaseInodeCache -> DatabaseInodeCache -> Bool isDatabaseModified (DatabaseInodeCache a1 b1) (DatabaseInodeCache a2 b2) = diff --git a/Database/ImportFeed.hs b/Database/ImportFeed.hs index ad18a15530..2d1611c73c 100644 --- a/Database/ImportFeed.hs +++ b/Database/ImportFeed.hs @@ -40,11 +40,9 @@ import Logs.MetaData import Types.MetaData import Annex.MetaData.StandardFields import Annex.LockFile -import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH -import qualified System.FilePath.ByteString as P import qualified Data.ByteString as B import qualified Data.Set as S @@ -75,8 +73,8 @@ AnnexBranch openDb :: Annex ImportFeedDbHandle openDb = do dbdir <- calcRepo' gitAnnexImportFeedDbDir - let db = dbdir P. "db" - isnew <- liftIO $ not <$> R.doesPathExist db + let db = dbdir literalOsPath "db" + isnew <- liftIO $ not <$> doesDirectoryExist db when isnew $ initDb db $ void $ runMigrationSilent migrateImportFeed diff --git a/Database/Init.hs b/Database/Init.hs index 6f7ba09faf..7a07beabde 100644 --- a/Database/Init.hs +++ b/Database/Init.hs @@ -20,7 +20,6 @@ import Database.RawFilePath import Database.Persist.Sqlite 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. @@ -30,26 +29,26 @@ import qualified System.FilePath.ByteString as P - file causes Sqlite to always use the same permissions for additional - files it writes later on -} -initDb :: P.RawFilePath -> SqlPersistM () -> Annex () +initDb :: OsPath -> SqlPersistM () -> Annex () initDb db migration = do - let dbdir = P.takeDirectory db - let tmpdbdir = dbdir <> ".tmp" - let tmpdb = tmpdbdir P. "db" - let tmpdb' = T.pack (fromRawFilePath tmpdb) + let dbdir = takeDirectory db + let tmpdbdir = dbdir <> literalOsPath ".tmp" + let tmpdb = tmpdbdir literalOsPath "db" + let tmpdb' = fromOsPath tmpdb createAnnexDirectory tmpdbdir #if MIN_VERSION_persistent_sqlite(2,13,3) - liftIO $ runSqliteInfo' tmpdb (enableWAL tmpdb') migration + liftIO $ runSqliteInfo' tmpdb' (enableWAL tmpdb') migration #else liftIO $ runSqliteInfo (enableWAL tmpdb') migration #endif setAnnexDirPerm tmpdbdir -- Work around sqlite bug that prevents it from honoring -- less restrictive umasks. - liftIO $ R.setFileMode tmpdb =<< defaultFileMode + liftIO $ R.setFileMode tmpdb' =<< defaultFileMode setAnnexFilePerm tmpdb liftIO $ do - void $ tryIO $ removeDirectoryRecursive (fromRawFilePath dbdir) - R.rename tmpdbdir dbdir + void $ tryIO $ removeDirectoryRecursive dbdir + R.rename (fromOsPath tmpdbdir) (fromOsPath dbdir) {- Make sure that the database uses WAL mode, to prevent readers - from blocking writers, and prevent a writer from blocking readers. @@ -59,6 +58,6 @@ initDb db migration = do - - Note that once WAL mode is enabled, it will persist whenever the - database is opened. -} -enableWAL :: T.Text -> SqliteConnectionInfo +enableWAL :: RawFilePath -> SqliteConnectionInfo enableWAL db = over walEnabled (const True) $ - mkSqliteConnectionInfo db + mkSqliteConnectionInfo (T.pack (fromRawFilePath db)) diff --git a/Database/Keys.hs b/Database/Keys.hs index 9704b6ff4c..686be30e13 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -54,11 +54,10 @@ import Git.Branch (writeTreeQuiet, update') import qualified Git.Ref import Config import Config.Smudge -import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 -import qualified System.FilePath.ByteString as P import Control.Concurrent.Async {- Runs an action that reads from the database. @@ -129,8 +128,8 @@ openDb forwrite _ = do lck <- calcRepo' gitAnnexKeysDbLock catchPermissionDenied permerr $ withExclusiveLock lck $ do dbdir <- calcRepo' gitAnnexKeysDbDir - let db = dbdir P. "db" - dbexists <- liftIO $ R.doesPathExist db + let db = dbdir literalOsPath "db" + dbexists <- liftIO $ doesDirectoryExist db case dbexists of True -> open db False False -> do @@ -182,7 +181,7 @@ emptyWhenBare a = ifM isBareRepo ) {- Include a known associated file along with any recorded in the database. -} -getAssociatedFilesIncluding :: AssociatedFile -> Key -> Annex [RawFilePath] +getAssociatedFilesIncluding :: AssociatedFile -> Key -> Annex [OsPath] getAssociatedFilesIncluding afile k = emptyWhenBare $ do g <- Annex.gitRepo l <- map (`fromTopFilePath` g) <$> getAssociatedFiles k @@ -201,7 +200,7 @@ removeAssociatedFile k = runWriterIO AssociatedTable . SQL.removeAssociatedFile k {- Stats the files, and stores their InodeCaches. -} -storeInodeCaches :: Key -> [RawFilePath] -> Annex () +storeInodeCaches :: Key -> [OsPath] -> Annex () storeInodeCaches k fs = withTSDelta $ \d -> addInodeCaches k . catMaybes =<< liftIO (mapM (\f -> genInodeCache f d) fs) @@ -265,7 +264,7 @@ reconcileStaged dbisnew qh = ifM isBareRepo ( return mempty , do gitindex <- inRepo currentIndexFile - indexcache <- fromRawFilePath <$> calcRepo' gitAnnexKeysDbIndexCache + indexcache <- fromOsPath <$> calcRepo' gitAnnexKeysDbIndexCache withTSDelta (liftIO . genInodeCache gitindex) >>= \case Just cur -> readindexcache indexcache >>= \case Nothing -> go cur indexcache =<< getindextree @@ -356,8 +355,9 @@ reconcileStaged dbisnew qh = ifM isBareRepo -- be a pointer file. And a pointer file that is replaced with -- a non-pointer file will match this. This is only a -- prefilter so that's ok. - , Param $ "-G" ++ fromRawFilePath (toInternalGitPath $ - P.pathSeparator `S.cons` objectDir) + , Param $ "-G" ++ + fromOsPath (toInternalGitPath $ + pathSeparator `OS.cons` objectDir) -- Disable rename detection. , Param "--no-renames" -- Avoid other complications. @@ -371,6 +371,7 @@ reconcileStaged dbisnew qh = ifM isBareRepo procdiff mdfeeder (info:file:rest) conflicted | ":" `S.isPrefixOf` info = case S8.words info of (_colonsrcmode:dstmode:srcsha:dstsha:status:[]) -> do + let file' = asTopFilePath (toOsPath file) let conflicted' = status == "U" -- avoid removing associated file when -- there is a merge conflict @@ -378,17 +379,15 @@ reconcileStaged dbisnew qh = ifM isBareRepo send mdfeeder (Ref srcsha) $ \case Just oldkey -> do liftIO $ SQL.removeAssociatedFile oldkey - (asTopFilePath file) - (SQL.WriteHandle qh) + file' (SQL.WriteHandle qh) return True Nothing -> return False send mdfeeder (Ref dstsha) $ \case Just key -> do liftIO $ addassociatedfile key - (asTopFilePath file) - (SQL.WriteHandle qh) + file' (SQL.WriteHandle qh) when (dstmode /= fmtTreeItemType TreeSymlink) $ - reconcilepointerfile (asTopFilePath file) key + reconcilepointerfile file' key return True Nothing -> return False procdiff mdfeeder rest @@ -403,11 +402,11 @@ reconcileStaged dbisnew qh = ifM isBareRepo procmergeconflictdiff mdfeeder (info:file:rest) conflicted | ":" `S.isPrefixOf` info = case S8.words info of (_colonmode:_mode:sha:_sha:status:[]) -> do + let file' = asTopFilePath (toOsPath file) send mdfeeder (Ref sha) $ \case Just key -> do liftIO $ SQL.addAssociatedFile key - (asTopFilePath file) - (SQL.WriteHandle qh) + file' (SQL.WriteHandle qh) return True Nothing -> return False let conflicted' = status == "U" diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs index 6b36cd09d5..dd37e2e6b1 100644 --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -22,6 +22,7 @@ import Database.Utility import qualified Database.Queue as H import Utility.InodeCache import Git.FilePath +import Utility.OsPath import Database.Persist.Sql hiding (Key) import Database.Persist.TH @@ -84,7 +85,7 @@ addAssociatedFile k f = queueDb $ (Associated k af) [AssociatedFile =. af, AssociatedKey =. k] where - af = SByteString (getTopFilePath f) + af = SByteString (fromOsPath (getTopFilePath f)) -- Faster than addAssociatedFile, but only safe to use when the file -- was not associated with a different key before, as it does not delete @@ -93,14 +94,14 @@ newAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO () newAssociatedFile k f = queueDb $ insert_ $ Associated k af where - af = SByteString (getTopFilePath f) + af = SByteString (fromOsPath (getTopFilePath f)) {- Note that the files returned were once associated with the key, but - some of them may not be any longer. -} getAssociatedFiles :: Key -> ReadHandle -> IO [TopFilePath] getAssociatedFiles k = readDb $ do l <- selectList [AssociatedKey ==. k] [] - return $ map (asTopFilePath . (\(SByteString f) -> f) . associatedFile . entityVal) l + return $ map (asTopFilePath . toOsPath . (\(SByteString f) -> f) . associatedFile . entityVal) l {- Gets any keys that are on record as having a particular associated file. - (Should be one or none.) -} @@ -109,13 +110,13 @@ getAssociatedKey f = readDb $ do l <- selectList [AssociatedFile ==. af] [] return $ map (associatedKey . entityVal) l where - af = SByteString (getTopFilePath f) + af = SByteString (fromOsPath (getTopFilePath f)) removeAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO () removeAssociatedFile k f = queueDb $ deleteWhere [AssociatedKey ==. k, AssociatedFile ==. af] where - af = SByteString (getTopFilePath f) + af = SByteString (fromOsPath (getTopFilePath f)) addInodeCaches :: Key -> [InodeCache] -> WriteHandle -> IO () addInodeCaches k is = queueDb $ diff --git a/Database/Queue.hs b/Database/Queue.hs index 8e941fa66c..0f3f5233ba 100644 --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -19,9 +19,9 @@ module Database.Queue ( ) where import Utility.Monad -import Utility.RawFilePath import Utility.DebugLocks import Utility.Exception +import Utility.OsPath import Database.Handle import Database.Persist.Sqlite @@ -39,7 +39,7 @@ data DbQueue = DQ DbHandle (MVar Queue) {- 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 :: RawFilePath -> TableName -> IO DbQueue +openDbQueue :: OsPath -> TableName -> IO DbQueue openDbQueue db tablename = DQ <$> openDb db tablename <*> (newMVar =<< emptyQueue) diff --git a/Database/RepoSize.hs b/Database/RepoSize.hs index 0118e88a7b..93c6b1d5ba 100644 --- a/Database/RepoSize.hs +++ b/Database/RepoSize.hs @@ -42,11 +42,9 @@ import Database.Utility import Database.Types import Annex.LockFile import Git.Types -import qualified Utility.RawFilePath as R import Database.Persist.Sql hiding (Key) import Database.Persist.TH -import qualified System.FilePath.ByteString as P import qualified Data.Map.Strict as M import qualified Data.Set as S import Control.Exception @@ -107,8 +105,8 @@ getRepoSizeHandle = Annex.getState Annex.reposizehandle >>= \case openDb :: Annex RepoSizeHandle openDb = lockDbWhile permerr $ do dbdir <- calcRepo' gitAnnexRepoSizeDbDir - let db = dbdir P. "db" - unlessM (liftIO $ R.doesPathExist db) $ do + let db = dbdir literalOsPath "db" + unlessM (liftIO $ doesDirectoryExist db) $ do initDb db $ void $ runMigrationSilent migrateRepoSizes h <- liftIO $ H.openDb db "repo_sizes" diff --git a/Git.hs b/Git.hs index d8a9de2256..32d37b1987 100644 --- a/Git.hs +++ b/Git.hs @@ -38,15 +38,14 @@ module Git ( 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 +import qualified Utility.OsString as OS #ifndef mingw32_HOST_OS import Utility.FileMode #endif @@ -56,37 +55,37 @@ repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url repoDescribe Repo { location = UnparseableUrl url } = url -repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir -repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir -repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir +repoDescribe Repo { location = Local { worktree = Just dir } } = fromOsPath dir +repoDescribe Repo { location = Local { gitdir = dir } } = fromOsPath dir +repoDescribe Repo { location = LocalUnknown dir } = fromOsPath dir repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url repoLocation Repo { location = UnparseableUrl url } = url -repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir -repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir -repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir +repoLocation Repo { location = Local { worktree = Just dir } } = fromOsPath dir +repoLocation Repo { location = Local { gitdir = dir } } = fromOsPath dir +repoLocation Repo { location = LocalUnknown dir } = fromOsPath dir repoLocation Repo { location = Unknown } = giveup "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - it's the gitdir, and for URL repositories, is the path on the remote - host. -} -repoPath :: Repo -> RawFilePath -repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u +repoPath :: Repo -> OsPath +repoPath Repo { location = Url u } = toOsPath $ unEscapeString $ uriPath u repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = giveup "unknown repoPath" repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath" -repoWorkTree :: Repo -> Maybe RawFilePath +repoWorkTree :: Repo -> Maybe OsPath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} -localGitDir :: Repo -> RawFilePath +localGitDir :: Repo -> OsPath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = giveup "unknown localGitDir" @@ -137,26 +136,27 @@ assertLocal repo action | otherwise = action {- Path to a repository's gitattributes file. -} -attributes :: Repo -> RawFilePath +attributes :: Repo -> OsPath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = repoPath repo P. ".gitattributes" + | otherwise = repoPath repo literalOsPath ".gitattributes" -attributesLocal :: Repo -> RawFilePath -attributesLocal repo = localGitDir repo P. "info" P. "attributes" +attributesLocal :: Repo -> OsPath +attributesLocal repo = localGitDir repo literalOsPath "info" literalOsPath "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} -hookPath :: String -> Repo -> IO (Maybe FilePath) +hookPath :: String -> Repo -> IO (Maybe OsPath) hookPath script repo = do - let hook = fromRawFilePath (localGitDir repo) "hooks" script + let hook = localGitDir repo literalOsPath "hooks" toOsPath script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where #if mingw32_HOST_OS isexecutable f = doesFileExist f #else - isexecutable f = isExecutable . fileMode <$> getSymbolicLinkStatus f + isexecutable f = isExecutable . fileMode + <$> getSymbolicLinkStatus (fromOsPath f) #endif {- Makes the path to a local Repo be relative to the cwd. -} @@ -165,10 +165,12 @@ relPath = adjustPath torel where torel p = do p' <- relPathCwdToFile p - return $ if B.null p' then "." else p' + return $ if OS.null p' + then literalOsPath "." + else p' {- Adjusts the path to a local Repo using the provided function. -} -adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo +adjustPath :: (OsPath -> IO OsPath) -> 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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 89df87404d..877186a1ae 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -99,11 +99,11 @@ catFileMetaDataStop :: CatFileMetaDataHandle -> IO () catFileMetaDataStop = CoProcess.stop . checkFileProcess {- Reads a file from a specified branch. -} -catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString +catFile :: CatFileHandle -> Branch -> OsPath -> IO L.ByteString catFile h branch file = catObject h $ Git.Ref.branchFileRef branch file -catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: CatFileHandle -> Branch -> OsPath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Git.Ref.branchFileRef branch file diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index f93c9075cf..5c3248ff9d 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -11,12 +11,11 @@ import Common 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], RawFilePath) +type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], OsPath) type Attr = String @@ -24,7 +23,7 @@ type Attr = String - and returns a handle. -} checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle checkAttrStart attrs repo = do - currdir <- R.getCurrentDirectory + currdir <- getCurrentDirectory h <- gitCoProcessStart True params repo return (h, attrs, currdir) where @@ -38,14 +37,14 @@ checkAttrStart attrs repo = do checkAttrStop :: CheckAttrHandle -> IO () checkAttrStop (h, _, _) = CoProcess.stop h -checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String +checkAttr :: CheckAttrHandle -> Attr -> OsPath -> IO String checkAttr h want file = checkAttrs h [want] file >>= return . \case (v:_) -> v [] -> "" {- Gets attributes of a file. When an attribute is not specified, - returns "" for it. -} -checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String] +checkAttrs :: CheckAttrHandle -> [Attr] -> OsPath -> IO [String] checkAttrs (h, attrs, currdir) want file = do l <- CoProcess.query h send (receive "") return (getvals l want) @@ -54,9 +53,9 @@ checkAttrs (h, attrs, currdir) want file = do getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of ["unspecified"] -> "" : getvals l xs [v] -> v : getvals l xs - _ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file + _ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromOsPath file - send to = B.hPutStr to $ file' `B.snoc` 0 + send to = B.hPutStr to $ (fromOsPath 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 index 46a5b25cf3..78811e1ef0 100644 --- a/Git/CheckIgnore.hs +++ b/Git/CheckIgnore.hs @@ -52,11 +52,11 @@ checkIgnoreStop :: CheckIgnoreHandle -> IO () checkIgnoreStop = void . tryIO . CoProcess.stop {- Returns True if a file is ignored. -} -checkIgnored :: CheckIgnoreHandle -> RawFilePath -> IO Bool +checkIgnored :: CheckIgnoreHandle -> OsPath -> IO Bool checkIgnored h file = CoProcess.query h send (receive "") where send to = do - B.hPutStr to $ file `B.snoc` 0 + B.hPutStr to $ fromOsPath file `B.snoc` 0 hFlush to receive c from = do s <- hGetSomeString from 1024 @@ -68,4 +68,4 @@ checkIgnored h file = CoProcess.query h send (receive "") parse s = case segment (== '\0') s of (_source:_line:pattern:_pathname:_eol:[]) -> Just $ not $ null pattern _ -> Nothing - eofError = ioError $ mkIOError userErrorType "git cat-file EOF" Nothing Nothing + eofError = ioError $ mkIOError userErrorType "git check-ignore EOF" Nothing Nothing diff --git a/Git/Command.hs b/Git/Command.hs index 894f6ae689..b3c25dcee1 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -24,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) = where setdir | gitEnvOverridesGitDir r = [] - | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] + | otherwise = [Param $ "--git-dir=" ++ fromOsPath (gitdir l)] settree = case worktree l of Nothing -> [] - Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] + Just t -> [Param $ "--work-tree=" ++ fromOsPath t] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} @@ -123,9 +123,12 @@ pipeNullSplit params repo = do - convenience. -} pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool) -pipeNullSplit' params repo = do +pipeNullSplit' = pipeNullSplit'' id + +pipeNullSplit'' :: (S.ByteString -> t) -> [CommandParam] -> Repo -> IO ([t], IO Bool) +pipeNullSplit'' f params repo = do (s, cleanup) <- pipeNullSplit params repo - return (map L.toStrict s, cleanup) + return (map (f . L.toStrict) s, cleanup) pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString] pipeNullSplitStrict params repo = do diff --git a/Git/Config.hs b/Git/Config.hs index b6fd77b249..4e72b73be6 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -14,7 +14,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.List.NonEmpty as NE import Data.Char -import qualified System.FilePath.ByteString as P import Control.Concurrent.Async import Common @@ -76,7 +75,7 @@ read' repo = go repo params = addparams ++ explicitrepoparams ++ ["config", "--null", "--list"] p = (proc "git" params) - { cwd = Just (fromRawFilePath d) + { cwd = Just (fromOsPath d) , env = gitEnv repo , std_out = CreatePipe } @@ -99,7 +98,7 @@ read' repo = go repo global :: IO (Maybe Repo) global = do home <- myHomeDir - ifM (doesFileExist $ home ".gitconfig") + ifM (doesFileExist $ toOsPath home literalOsPath ".gitconfig") ( Just <$> withCreateProcess p go , return Nothing ) @@ -153,22 +152,22 @@ store' k v repo = repo -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) = case isBare r of - Just True -> ifM (doesDirectoryExist (fromRawFilePath dotgit)) + Just True -> ifM (doesDirectoryExist dotgit) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) Just False -> mknonbare {- core.bare not in config, probably because safe.directory - did not allow reading the config -} - Nothing -> ifM (Git.Construct.isBareRepo (fromRawFilePath d)) + Nothing -> ifM (Git.Construct.isBareRepo d) ( mkbare , mknonbare ) where - dotgit = d P. ".git" + dotgit = d literalOsPath ".git" -- git treats eg ~/foo as a bare git repository located in -- ~/foo/.git if ~/foo/.git/config has core.bare=true - mkbare = ifM (doesDirectoryExist (fromRawFilePath dotgit)) + mkbare = ifM (doesDirectoryExist dotgit) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) @@ -184,7 +183,7 @@ updateLocation' r l@(Local {}) = do Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} top <- absPath (gitdir l) - let p = absPathFrom top d + let p = absPathFrom top (toOsPath d) return $ l { worktree = Just p } Just NoConfigValue -> return l return $ r { location = l' } @@ -337,7 +336,7 @@ checkRepoConfigInaccessible r -- Cannot use gitCommandLine here because specifying --git-dir -- will bypass the git security check. let p = (proc "git" ["config", "--local", "--list"]) - { cwd = Just (fromRawFilePath (repoPath r)) + { cwd = Just (fromOsPath (repoPath r)) , env = gitEnv r } (out, ok) <- processTranscript' p Nothing diff --git a/Git/Construct.hs b/Git/Construct.hs index 76261cabf2..229af82aff 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -41,14 +41,12 @@ import qualified Git.Url as Url import Utility.UserInfo import Utility.Url.Parse import qualified Utility.RawFilePath as R - -import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P +import qualified Utility.OsString as OS {- Finds the git repository used for the cwd, which may be in a parent - directory. -} fromCwd :: IO (Maybe Repo) -fromCwd = R.getCurrentDirectory >>= seekUp +fromCwd = R.getCurrentDirectory >>= seekUp . toOsPath where seekUp dir = do r <- checkForRepo dir @@ -59,31 +57,32 @@ fromCwd = R.getCurrentDirectory >>= seekUp Just loc -> pure $ Just $ newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -} -fromPath :: RawFilePath -> IO Repo +fromPath :: OsPath -> IO Repo fromPath dir -- When dir == "foo/.git", git looks for "foo/.git/.git", -- and failing that, uses "foo" as the repository. - | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = - ifM (doesDirectoryExist $ fromRawFilePath dir ".git") + | (pathSeparator `OS.cons` dotgit) `OS.isSuffixOf` canondir = + ifM (doesDirectoryExist $ dir dotgit) ( ret dir - , ret (P.takeDirectory canondir) + , ret (takeDirectory canondir) ) - | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir)) + | otherwise = ifM (doesDirectoryExist 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 <> dotgit) else ret dir ) where + dotgit = literalOsPath ".git" ret = pure . newFrom . LocalUnknown - canondir = P.dropTrailingPathSeparator dir + canondir = dropTrailingPathSeparator dir {- Local Repo constructor, requires an absolute path to the repo be - specified. -} -fromAbsPath :: RawFilePath -> IO Repo +fromAbsPath :: OsPath -> IO Repo fromAbsPath dir | absoluteGitPath dir = fromPath dir | otherwise = @@ -107,7 +106,7 @@ fromUrl url fromUrl' :: String -> IO Repo fromUrl' url | "file://" `isPrefixOf` url = case parseURIPortable url of - Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u + Just u -> fromAbsPath $ toOsPath $ unEscapeString $ uriPath u Nothing -> pure $ newFrom $ UnparseableUrl url | otherwise = case parseURIPortable url of Just u -> pure $ newFrom $ Url u @@ -129,7 +128,7 @@ localToUrl reference r [ s , "//" , auth - , fromRawFilePath (repoPath r) + , fromOsPath (repoPath r) ] in r { location = Url $ fromJust $ parseURIPortable absurl } _ -> r @@ -176,43 +175,43 @@ fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo P. toRawFilePath dir' + fromPath $ repoPath repo 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 :: RawFilePath -> IO RawFilePath +repoAbsPath :: OsPath -> IO OsPath repoAbsPath d = do - d' <- expandTilde (fromRawFilePath d) + d' <- expandTilde (fromOsPath d) h <- myHomeDir - return $ toRawFilePath $ h d' + return $ toOsPath h d' -expandTilde :: FilePath -> IO FilePath +expandTilde :: FilePath -> IO OsPath #ifdef mingw32_HOST_OS -expandTilde = return +expandTilde = return . toOsPath #else expandTilde p = expandt True p -- If unable to expand a tilde, eg due to a user not existing, -- use the path as given. - `catchNonAsync` (const (return p)) + `catchNonAsync` (const (return (toOsPath p))) where - expandt _ [] = return "" + expandt _ [] = return $ literalOsPath "" expandt _ ('/':cs) = do v <- expandt True cs - return ('/':v) + return $ literalOsPath "/" <> v expandt True ('~':'/':cs) = do h <- myHomeDir - return $ h cs - expandt True "~" = myHomeDir + return $ toOsPath h toOsPath cs + expandt True "~" = toOsPath <$> myHomeDir expandt True ('~':cs) = do let (name, rest) = findname "" cs u <- getUserEntryForName name - return $ homeDirectory u rest + return $ toOsPath (homeDirectory u) toOsPath rest expandt _ (c:cs) = do v <- expandt False cs - return (c:v) + return $ toOsPath [c] <> v findname n [] = (n, "") findname n (c:cs) | c == '/' = (n, cs) @@ -221,11 +220,11 @@ expandTilde p = expandt True p {- Checks if a git repository exists in a directory. Does not find - git repositories in parent directories. -} -checkForRepo :: RawFilePath -> IO (Maybe RepoLocation) +checkForRepo :: OsPath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ check (checkGitDirFile dir) $ - check (checkdir (isBareRepo dir')) $ + check (checkdir (isBareRepo dir)) $ return Nothing where check test cont = maybe cont (return . Just) =<< test @@ -234,23 +233,22 @@ checkForRepo dir = , return Nothing ) isRepo = checkdir $ - doesFileExist (dir' ".git" "config") + doesFileExist (dir literalOsPath ".git" literalOsPath "config") <||> -- A git-worktree lacks .git/config, but has .git/gitdir. -- (Normally the .git is a file, not a symlink, but it can -- be converted to a symlink and git will still work; -- this handles that case.) - doesFileExist (dir' ".git" "gitdir") - dir' = fromRawFilePath dir + doesFileExist (dir literalOsPath ".git" literalOsPath "gitdir") -isBareRepo :: FilePath -> IO Bool -isBareRepo dir = doesFileExist (dir "config") - <&&> doesDirectoryExist (dir "objects") +isBareRepo :: OsPath -> IO Bool +isBareRepo dir = doesFileExist (dir literalOsPath "config") + <&&> doesDirectoryExist (dir literalOsPath "objects") -- Check for a .git file. -checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation) +checkGitDirFile :: OsPath -> IO (Maybe RepoLocation) checkGitDirFile dir = adjustGitDirFile' $ Local - { gitdir = dir P. ".git" + { gitdir = dir literalOsPath ".git" , worktree = Just dir } @@ -264,15 +262,13 @@ adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) adjustGitDirFile' loc@(Local {}) = do let gd = gitdir loc - c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd)) + c <- firstLine <$> catchDefaultIO "" (readFile (fromOsPath gd)) if gitdirprefix `isPrefixOf` c then do - top <- fromRawFilePath . P.takeDirectory <$> absPath gd + top <- takeDirectory <$> absPath gd return $ Just $ loc - { gitdir = absPathFrom - (toRawFilePath top) - (toRawFilePath - (drop (length gitdirprefix) c)) + { gitdir = absPathFrom top $ + toOsPath $ drop (length gitdirprefix) c } else return Nothing where diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 747caaac9e..41c3d6f996 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -16,10 +16,8 @@ import Git.Construct 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. - @@ -42,16 +40,16 @@ import qualified System.FilePath.ByteString as P get :: IO Repo get = do gd <- getpathenv "GIT_DIR" - r <- configure gd =<< fromCwd + r <- configure (fmap toOsPath gd) =<< fromCwd prefix <- getpathenv "GIT_PREFIX" wt <- maybe (worktree (location r)) Just <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> relPath r Just d -> do - curr <- R.getCurrentDirectory + curr <- getCurrentDirectory unless (d `dirContains` curr) $ - setCurrentDirectory (fromRawFilePath d) + setCurrentDirectory d relPath $ addworktree wt r where getpathenv s = do @@ -66,15 +64,15 @@ get = do getpathenv s >>= \case Nothing -> return Nothing Just d - | d == "." -> return (Just d) + | d == "." -> return (Just (toOsPath d)) | otherwise -> Just - <$> absPath (prefix P. d) - getpathenvprefix s _ = getpathenv s + <$> absPath (toOsPath prefix toOsPath d) + getpathenvprefix s _ = fmap toOsPath <$> getpathenv s configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d - curr <- R.getCurrentDirectory + curr <- getCurrentDirectory loc <- adjustGitDirFile $ Local { gitdir = absd , worktree = Just curr diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs index 102658922b..ed6c7f8768 100644 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -18,7 +18,6 @@ module Git.DiffTree ( parseDiffRaw, ) 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 @@ -31,6 +30,7 @@ import Git.FilePath import Git.DiffTreeItem import qualified Git.Quote import qualified Git.Ref +import qualified Utility.OsString as OS import Utility.Attoparsec {- Checks if the DiffTreeItem modifies a file with a given name @@ -38,7 +38,7 @@ import Utility.Attoparsec isDiffOf :: DiffTreeItem -> TopFilePath -> Bool isDiffOf diff f = let f' = getTopFilePath f - in if B.null f' + in if OS.null f' then True -- top of repo contains all else f' `dirContains` getTopFilePath (file diff) @@ -133,6 +133,6 @@ parserDiffRaw f = DiffTreeItem <*> (maybe (fail "bad dstsha") return . extractSha =<< nextword) <* A8.char ' ' <*> A.takeByteString - <*> pure (asTopFilePath $ fromInternalGitPath $ Git.Quote.unquote f) + <*> pure (asTopFilePath $ fromInternalGitPath $ toOsPath $ Git.Quote.unquote f) where nextword = A8.takeTill (== ' ') diff --git a/Git/Env.hs b/Git/Env.hs index fb0377f85d..6bf773f9d0 100644 --- a/Git/Env.hs +++ b/Git/Env.hs @@ -30,9 +30,9 @@ addGitEnv g var val = adjustGitEnv g (addEntry var val) - and a copy of the rest of the system environment. -} propGitEnv :: Repo -> IO [(String, String)] propGitEnv g = do - g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g)) + g' <- addGitEnv g "GIT_DIR" (fromOsPath (localGitDir g)) g'' <- maybe (pure g') - (addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath) + (addGitEnv g' "GIT_WORK_TREE" . fromOsPath) (repoWorkTree g) return $ fromMaybe [] (gitEnv g'') diff --git a/Git/FilePath.hs b/Git/FilePath.hs index b27c0c7059..b184264ab0 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -32,13 +32,11 @@ import Common import Git import Git.Quote -import qualified System.FilePath.ByteString as P -import qualified System.FilePath.Posix.ByteString import GHC.Generics import Control.DeepSeq -{- A RawFilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } +{- A path relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: OsPath } deriving (Show, Eq, Ord, Generic) instance NFData TopFilePath @@ -53,16 +51,16 @@ descBranchFilePath (BranchFilePath b f) = UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f) {- Path to a TopFilePath, within the provided git repo. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath -fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) +fromTopFilePath :: TopFilePath -> Git.Repo -> OsPath +fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} -toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath +toTopFilePath :: OsPath -> Git.Repo -> IO TopFilePath toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file {- The input RawFilePath must already be relative to the top of the git - repository -} -asTopFilePath :: RawFilePath -> TopFilePath +asTopFilePath :: OsPath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing @@ -72,25 +70,24 @@ asTopFilePath file = TopFilePath file - despite Windows using '\'. - -} -type InternalGitPath = RawFilePath +type InternalGitPath = OsPath -toInternalGitPath :: RawFilePath -> InternalGitPath +toInternalGitPath :: OsPath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else -toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS +toInternalGitPath = toOsPath . encodeBS . replace "\\" "/" . decodeBS . fromOsPath #endif -fromInternalGitPath :: InternalGitPath -> RawFilePath +fromInternalGitPath :: InternalGitPath -> OsPath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else -fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS +fromInternalGitPath = toOsPath . encodeBS . replace "/" "\\" . decodeBS . fromOsPath #endif {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute, - so try posix paths. -} -absoluteGitPath :: RawFilePath -> Bool -absoluteGitPath p = P.isAbsolute p || - System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p) +absoluteGitPath :: OsPath -> Bool +absoluteGitPath p = isAbsolute p || isAbsolute (toInternalGitPath p) diff --git a/Git/FilterProcess.hs b/Git/FilterProcess.hs index 7e04e46118..678f11f837 100644 --- a/Git/FilterProcess.hs +++ b/Git/FilterProcess.hs @@ -130,7 +130,7 @@ longRunningFilterProcessHandshake = -- Delay capability is not implemented, so filter it out. filtercapabilities = filter (`elem` [Capability "smudge", Capability "clean"]) -data FilterRequest = Smudge FilePath | Clean FilePath +data FilterRequest = Smudge OsPath | Clean OsPath deriving (Show, Eq) {- Waits for the next FilterRequest to be received. Does not read @@ -143,8 +143,8 @@ getFilterRequest = do let cs = mapMaybe decodeConfigValue ps case (extractConfigValue cs "command", extractConfigValue cs "pathname") of (Just command, Just pathname) - | command == "smudge" -> return $ Just $ Smudge pathname - | command == "clean" -> return $ Just $ Clean pathname + | command == "smudge" -> return $ Just $ Smudge $ toOsPath pathname + | command == "clean" -> return $ Just $ Clean $ toOsPath pathname | otherwise -> return Nothing _ -> return Nothing diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 35031f20ae..69b5b586b6 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -5,7 +5,6 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Git.HashObject where @@ -15,14 +14,14 @@ import Git import Git.Sha import Git.Command import Git.Types -import qualified Utility.CoProcess as CoProcess import Utility.Tmp +import qualified Utility.CoProcess as CoProcess +import qualified Utility.OsString as OS import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder -import Data.Char data HashObjectHandle = HashObjectHandle CoProcess.CoProcessHandle Repo [CommandParam] @@ -41,7 +40,7 @@ hashObjectStop :: HashObjectHandle -> IO () hashObjectStop (HashObjectHandle h _ _) = CoProcess.stop h {- Injects a file into git, returning the Sha of the object. -} -hashFile :: HashObjectHandle -> RawFilePath -> IO Sha +hashFile :: HashObjectHandle -> OsPath -> IO Sha hashFile hdl@(HashObjectHandle h _ _) file = do -- git hash-object chdirs to the top of the repository on -- start, so if the filename is relative, it will @@ -49,24 +48,24 @@ hashFile hdl@(HashObjectHandle h _ _) file = do -- So, make the filename absolute, which will work now -- and also if git's behavior later changes. file' <- absPath file - if newline `S.elem` file' || carriagereturn `S.elem` file + if newline `OS.elem` file' || carriagereturn `OS.elem` file then hashFile' hdl file - else CoProcess.query h (send file') receive + else CoProcess.query h (send (fromOsPath file')) receive where send file' to = S8.hPutStrLn to file' receive from = getSha "hash-object" $ S8.hGetLine from - newline = fromIntegral (ord '\n') + newline = unsafeFromChar '\n' -- git strips carriage return from the end of a line, out of some -- misplaced desire to support windows, so also use the newline -- fallback for those. - carriagereturn = fromIntegral (ord '\r') + carriagereturn = unsafeFromChar '\r' {- Runs git hash-object once per call, rather than using a running - one, so is slower. But, is able to handle newlines in the filepath, - which --stdin-paths cannot. -} -hashFile' :: HashObjectHandle -> RawFilePath -> IO Sha +hashFile' :: HashObjectHandle -> OsPath -> IO Sha hashFile' (HashObjectHandle _ repo ps) file = getSha "hash-object" $ - pipeReadStrict (ps ++ [File (fromRawFilePath file)]) repo + pipeReadStrict (ps ++ [File (fromOsPath file)]) repo class HashableBlob t where hashableBlobToHandle :: Handle -> t -> IO () @@ -83,10 +82,10 @@ instance HashableBlob Builder where {- Injects a blob into git. Unfortunately, the current git-hash-object - interface does not allow batch hashing without using temp files. -} hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha -hashBlob h b = withTmpFile (toOsPath "hash") $ \tmp tmph -> do +hashBlob h b = withTmpFile (literalOsPath "hash") $ \tmp tmph -> do hashableBlobToHandle tmph b hClose tmph - hashFile h (fromOsPath tmp) + hashFile h tmp {- Injects some content into git, returning its Sha. - diff --git a/Git/Hook.hs b/Git/Hook.hs index c2e5a8125e..e5a67bda7d 100644 --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -21,10 +21,8 @@ import qualified Utility.RawFilePath as R import System.PosixCompat.Files (fileMode) #endif -import qualified System.FilePath.ByteString as P - data Hook = Hook - { hookName :: RawFilePath + { hookName :: OsPath , hookScript :: String , hookOldScripts :: [String] } @@ -33,8 +31,8 @@ data Hook = Hook instance Eq Hook where a == b = hookName a == hookName b -hookFile :: Hook -> Repo -> RawFilePath -hookFile h r = localGitDir r P. "hooks" P. hookName h +hookFile :: Hook -> Repo -> OsPath +hookFile h r = localGitDir r literalOsPath "hooks" hookName h {- Writes a hook. Returns False if the hook already exists with a different - content. Upgrades old scripts. @@ -50,7 +48,7 @@ hookFile h r = localGitDir r P. "hooks" P. hookName h - is run with a bundled bash, so should start with #!/bin/sh -} hookWrite :: Hook -> Repo -> IO Bool -hookWrite h r = ifM (doesFileExist (fromRawFilePath f)) +hookWrite h r = ifM (doesFileExist f) ( expectedContent h r >>= \case UnexpectedContent -> return False ExpectedContent -> return True @@ -65,7 +63,7 @@ hookWrite h r = ifM (doesFileExist (fromRawFilePath f)) -- Hook scripts on Windows could use CRLF endings, but -- they typically use unix newlines, which does work there -- and makes the repository more portable. - viaTmp F.writeFile' (toOsPath f) (encodeBS (hookScript h)) + viaTmp F.writeFile' f (encodeBS (hookScript h)) void $ tryIO $ modifyFileMode f (addModes executeModes) return True @@ -81,7 +79,7 @@ hookUnWrite h r = ifM (doesFileExist f) , return True ) where - f = fromRawFilePath $ hookFile h r + f = hookFile h r data ExpectedContent = UnexpectedContent | ExpectedContent | OldExpectedContent @@ -91,7 +89,7 @@ expectedContent h r = do -- and so a hook file that has CRLF will be treated the same as one -- that has LF. That is intentional, since users may have a reason -- to prefer one or the other. - content <- readFile $ fromRawFilePath $ hookFile h r + content <- readFile $ fromOsPath $ hookFile h r return $ if content == hookScript h then ExpectedContent else if any (content ==) (hookOldScripts h) @@ -103,13 +101,13 @@ hookExists h r = do let f = hookFile h r catchBoolIO $ #ifndef mingw32_HOST_OS - isExecutable . fileMode <$> R.getFileStatus f + isExecutable . fileMode <$> R.getFileStatus (fromOsPath f) #else - doesFileExist (fromRawFilePath f) + doesFileExist f #endif runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a runHook runner h ps r = do - let f = fromRawFilePath $ hookFile h r + let f = hookFile h r (c, cps) <- findShellCommand f runner c (cps ++ ps) diff --git a/Git/Index.hs b/Git/Index.hs index b55fc04b99..de4ceaf3dc 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -14,8 +14,6 @@ import Git import Utility.Env import Utility.Env.Set -import qualified System.FilePath.ByteString as P - indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -30,8 +28,8 @@ indexEnv = "GIT_INDEX_FILE" - - So, an absolute path is the only safe option for this to return. -} -indexEnvVal :: RawFilePath -> IO String -indexEnvVal p = fromRawFilePath <$> absPath p +indexEnvVal :: OsPath -> IO OsPath +indexEnvVal p = absPath p {- Forces git to use the specified index file. - @@ -40,11 +38,11 @@ indexEnvVal p = fromRawFilePath <$> absPath p - - Warning: Not thread safe. -} -override :: RawFilePath -> Repo -> IO (IO ()) +override :: OsPath -> Repo -> IO (IO ()) override index _r = do res <- getEnv var val <- indexEnvVal index - setEnv var val True + setEnv var (fromOsPath val) True return $ reset res where var = "GIT_INDEX_FILE" @@ -52,13 +50,13 @@ override index _r = do reset _ = unsetEnv var {- The normal index file. Does not check GIT_INDEX_FILE. -} -indexFile :: Repo -> RawFilePath -indexFile r = localGitDir r P. "index" +indexFile :: Repo -> OsPath +indexFile r = localGitDir r literalOsPath "index" {- The index file git will currently use, checking GIT_INDEX_FILE. -} -currentIndexFile :: Repo -> IO RawFilePath -currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv +currentIndexFile :: Repo -> IO OsPath +currentIndexFile r = maybe (indexFile r) toOsPath <$> getEnv indexEnv {- Git locks the index by creating this file. -} -indexFileLock :: RawFilePath -> RawFilePath -indexFileLock f = f <> ".lock" +indexFileLock :: OsPath -> OsPath +indexFileLock f = f <> literalOsPath ".lock" diff --git a/Git/LockFile.hs b/Git/LockFile.hs index fa92df046e..70d8e5bb54 100644 --- a/Git/LockFile.hs +++ b/Git/LockFile.hs @@ -21,9 +21,9 @@ import System.Win32.File #endif #ifndef mingw32_HOST_OS -data LockHandle = LockHandle FilePath Fd +data LockHandle = LockHandle OsPath Fd #else -data LockHandle = LockHandle FilePath HANDLE +data LockHandle = LockHandle OsPath HANDLE #endif {- Uses the same exclusive locking that git does. @@ -33,14 +33,14 @@ data LockHandle = LockHandle FilePath HANDLE - a dangling lock can be left if a process is terminated at the wrong - time. -} -openLock :: FilePath -> IO LockHandle +openLock :: OsPath -> IO LockHandle openLock lck = openLock' lck `catchNonAsync` lckerr where lckerr e = do -- Same error message displayed by git. whenM (doesFileExist lck) $ hPutStrLn stderr $ unlines - [ "fatal: Unable to create '" ++ lck ++ "': " ++ show e + [ "fatal: Unable to create '" ++ fromOsPath lck ++ "': " ++ show e , "" , "If no other git process is currently running, this probably means a" , "git process crashed in this repository earlier. Make sure no other git" @@ -48,11 +48,11 @@ openLock lck = openLock' lck `catchNonAsync` lckerr ] throwM e -openLock' :: FilePath -> IO LockHandle +openLock' :: OsPath -> IO LockHandle openLock' lck = do #ifndef mingw32_HOST_OS -- On unix, git simply uses O_EXCL - h <- openFdWithMode (toRawFilePath lck) ReadWrite (Just 0O666) + h <- openFdWithMode (fromOsPath lck) ReadWrite (Just 0O666) (defaultFileFlags { exclusive = True }) setFdOption h CloseOnExec True #else @@ -65,7 +65,7 @@ openLock' lck = do -- So, all that's needed is a way to open the file, that fails -- if the file already exists. Using CreateFile with CREATE_NEW -- accomplishes that. - h <- createFile lck gENERIC_WRITE fILE_SHARE_NONE Nothing + h <- createFile (fromOsPath lck) gENERIC_WRITE fILE_SHARE_NONE Nothing cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing #endif return (LockHandle lck h) diff --git a/Git/Log.hs b/Git/Log.hs index a3246d5102..1d6e719bb4 100644 --- a/Git/Log.hs +++ b/Git/Log.hs @@ -19,7 +19,7 @@ import Data.Time.Clock.POSIX data LoggedFileChange t = LoggedFileChange { changetime :: POSIXTime , changed :: t - , changedfile :: FilePath + , changedfile :: OsPath , oldref :: Ref , newref :: Ref } @@ -34,7 +34,7 @@ getGitLog -> Maybe Ref -> [FilePath] -> [CommandParam] - -> (Sha -> FilePath -> Maybe t) + -> (Sha -> OsPath -> Maybe t) -> Repo -> IO ([LoggedFileChange t], IO Bool) getGitLog ref stopref fs os selector repo = do @@ -75,7 +75,7 @@ commitinfoFormat = "%H %ct" -- -- The commitinfo is not included before all changelines, so -- keep track of the most recently seen commitinfo. -parseGitRawLog :: (Ref -> FilePath -> Maybe t) -> [String] -> [LoggedFileChange t] +parseGitRawLog :: (Ref -> OsPath -> Maybe t) -> [String] -> [LoggedFileChange t] parseGitRawLog selector = parse (deleteSha, epoch) where epoch = toEnum 0 :: POSIXTime @@ -91,11 +91,12 @@ parseGitRawLog selector = parse (deleteSha, epoch) _ -> (oldcommitsha, oldts, cl') mrc = do (old, new) <- parseRawChangeLine cl - v <- selector commitsha c2 + let c2' = toOsPath c2 + v <- selector commitsha c2' return $ LoggedFileChange { changetime = ts , changed = v - , changedfile = c2 + , changedfile = c2' , oldref = old , newref = new } diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 08c98b7fda..d26e758748 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -39,14 +39,13 @@ import Git.Sha import Utility.InodeCache import Utility.TimeStamp import Utility.Attoparsec -import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS 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. - @@ -78,20 +77,22 @@ opParam ErrorUnmatch = Param "--error-unmatch" {- Lists files that are checked into git's index at the specified paths. - With no paths, all files are listed. -} -inRepo :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) inRepo = inRepo' [Param "--cached"] -inRepo' :: [CommandParam] -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo' ps os l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo +inRepo' :: [CommandParam] -> [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) +inRepo' ps os l repo = guardSafeForLsFiles repo $ do + (fs, cleanup) <- pipeNullSplit' params repo + return (map toOsPath fs, cleanup) where params = Param "ls-files" : Param "-z" : map opParam os ++ ps ++ - (Param "--" : map (File . fromRawFilePath) l) + (Param "--" : map (File . fromOsPath) l) {- Lists the same files inRepo does, but with sha and mode. -} -inRepoDetails :: [Options] -> [RawFilePath] -> Repo -> IO ([(RawFilePath, Sha, FileMode)], IO Bool) +inRepoDetails :: [Options] -> [OsPath] -> Repo -> IO ([(OsPath, Sha, FileMode)], IO Bool) inRepoDetails = stagedDetails' parser . map opParam where parser s = case parseStagedDetails s of @@ -102,17 +103,17 @@ inRepoDetails = stagedDetails' parser . map opParam {- Files that are checked into the index or have been committed to a - branch. -} -inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepoOrBranch :: Branch -> [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) inRepoOrBranch b = inRepo' [ Param "--cached" , Param ("--with-tree=" ++ fromRef b) ] {- Scans for files at the specified locations that are not checked into git. -} -notInRepo :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo :: [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) notInRepo = notInRepo' [] -notInRepo' :: [CommandParam] -> [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo' :: [CommandParam] -> [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) notInRepo' ps os include_ignored = inRepo' (Param "--others" : ps ++ exclude) os where @@ -122,41 +123,42 @@ notInRepo' ps os include_ignored = {- Scans for files at the specified locations that are not checked into - git. Empty directories are included in the result. -} -notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] {- Finds all files in the specified locations, whether checked into git or - not. -} -allFiles :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +allFiles :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) allFiles = inRepo' [Param "--cached", Param "--others"] {- Returns a list of files in the specified locations that have been - deleted. -} -deleted :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +deleted :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) deleted = inRepo' [Param "--deleted"] {- Returns a list of files in the specified locations that have been - modified. -} -modified :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modified :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) modified = inRepo' [Param "--modified"] {- Returns a list of all files that are staged for commit. -} -staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +staged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool) staged = staged' [] {- Returns a list of the files, staged for commit, that are being added, - moved, or changed (but not deleted), from the specified locations. -} -stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +stagedNotDeleted :: [OsPath] -> Repo -> IO ([OsPath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -staged' ps l repo = guardSafeForLsFiles repo $ - pipeNullSplit' (prefix ++ ps ++ suffix) repo +staged' :: [CommandParam] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) +staged' ps l repo = guardSafeForLsFiles repo $ do + (fs, cleanup) <- pipeNullSplit' (prefix ++ ps ++ suffix) repo + return (map toOsPath fs, cleanup) where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] - suffix = Param "--" : map (File . fromRawFilePath) l + suffix = Param "--" : map (File . fromOsPath) l -type StagedDetails = (RawFilePath, Sha, FileMode, StageNum) +type StagedDetails = (OsPath, Sha, FileMode, StageNum) type StageNum = Int @@ -174,16 +176,16 @@ mergeConflictHeadStageNum = 2 - Note that, during a conflict, a file will appear in the list - more than once with different stage numbers. -} -stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails :: [OsPath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails = stagedDetails' parseStagedDetails [] -stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [RawFilePath] -> Repo -> IO ([t], IO Bool) +stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [OsPath] -> Repo -> IO ([t], IO Bool) stagedDetails' parser ps l repo = guardSafeForLsFiles repo $ do (ls, cleanup) <- pipeNullSplit' params repo return (mapMaybe parser ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ - Param "--" : map (File . fromRawFilePath) l + Param "--" : map (File . fromOsPath) l parseStagedDetails :: S.ByteString -> Maybe StagedDetails parseStagedDetails = eitherToMaybe . A.parseOnly parser @@ -196,28 +198,28 @@ parseStagedDetails = eitherToMaybe . A.parseOnly parser stagenum <- A8.decimal void $ A8.char '\t' file <- A.takeByteString - return (file, sha, mode, stagenum) + return (toOsPath file, sha, mode, stagenum) nextword = A8.takeTill (== ' ') {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} -typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +typeChangedStaged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool) typeChangedStaged = typeChanged' [Param "--cached"] {- Returns a list of the files in the specified locations whose type has - changed. Files only staged for commit will not be included. -} -typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +typeChanged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool) typeChanged = typeChanged' [] -typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +typeChanged' :: [CommandParam] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool) typeChanged' ps l repo = guardSafeForLsFiles repo $ do (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 (repoPath repo) - currdir <- R.getCurrentDirectory - return (map (\f -> relPathDirToFileAbs currdir $ top P. f) fs, cleanup) + currdir <- getCurrentDirectory + return (map (\f -> relPathDirToFileAbs currdir $ top toOsPath f) fs, cleanup) where prefix = [ Param "diff" @@ -225,7 +227,7 @@ typeChanged' ps l repo = guardSafeForLsFiles repo $ do , Param "--diff-filter=T" , Param "-z" ] - suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l) + suffix = Param "--" : (if null l then [File "."] else map (File . fromOsPath) l) {- A item in conflict has two possible values. - Either can be Nothing, when that side deleted the file. -} @@ -235,10 +237,10 @@ data Conflicting v = Conflicting } deriving (Show) data Unmerged = Unmerged - { unmergedFile :: RawFilePath + { unmergedFile :: OsPath , unmergedTreeItemType :: Conflicting TreeItemType , unmergedSha :: Conflicting Sha - , unmergedSiblingFile :: Maybe RawFilePath + , unmergedSiblingFile :: Maybe OsPath -- ^ Normally this is Nothing, because a -- merge conflict is represented as a single file with two -- stages. However, git resolvers sometimes choose to stage @@ -257,7 +259,7 @@ data Unmerged = Unmerged - 3 = them - If line 2 or 3 is omitted, that side removed the file. -} -unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) +unmerged :: [OsPath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup) @@ -267,11 +269,11 @@ unmerged l repo = guardSafeForLsFiles repo $ do Param "--unmerged" : Param "-z" : Param "--" : - map (File . fromRawFilePath) l + map (File . fromOsPath) l data InternalUnmerged = InternalUnmerged { isus :: Bool - , ifile :: RawFilePath + , ifile :: OsPath , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha } deriving (Show) @@ -287,7 +289,7 @@ parseUnmerged s else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) sha <- extractSha (encodeBS rawsha) - return $ InternalUnmerged (stage == 2) (toRawFilePath file) + return $ InternalUnmerged (stage == 2) (toOsPath file) (Just treeitemtype) (Just sha) _ -> Nothing where @@ -321,7 +323,7 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest -- foo~ are unmerged sibling files of foo -- Some versions or resolvers of git stage the sibling files, -- other versions or resolvers do not. - issibfile x y = (ifile x <> "~") `S.isPrefixOf` ifile y + issibfile x y = (ifile x <> literalOsPath "~") `OS.isPrefixOf` ifile y && isus x || isus y && not (isus x && isus y) @@ -330,7 +332,7 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest - Note that this uses a --debug option whose output could change at some - point in the future. If the output is not as expected, will use Nothing. -} -inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool) +inodeCaches :: [OsPath] -> Repo -> IO ([(OsPath, Maybe InodeCache)], IO Bool) inodeCaches locs repo = guardSafeForLsFiles repo $ do (ls, cleanup) <- pipeNullSplit params repo return (parse Nothing (map decodeBL ls), cleanup) @@ -341,16 +343,16 @@ inodeCaches locs repo = guardSafeForLsFiles repo $ do Param "-z" : Param "--debug" : Param "--" : - map (File . fromRawFilePath) locs + map (File . fromOsPath) locs parse Nothing (f:ls) = parse (Just f) ls parse (Just f) (s:[]) = let i = parsedebug s - in (f, i) : [] + in (toOsPath f, i) : [] parse (Just f) (s:ls) = let (d, f') = splitdebug s i = parsedebug d - in (f, i) : parse (Just f') ls + in (toOsPath f, i) : parse (Just f') ls parse _ _ = [] -- First 5 lines are --debug output, remainder is the next filename. diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 9129d18fc4..5399416707 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -137,7 +137,8 @@ parserLsTree long = case long of -- sha <*> (Ref <$> A8.takeTill A8.isSpace) - fileparser = asTopFilePath . Git.Quote.unquote <$> A.takeByteString + fileparser = asTopFilePath . toOsPath . Git.Quote.unquote + <$> A.takeByteString sizeparser = fmap Just A8.decimal @@ -152,4 +153,6 @@ formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' '))) [ encodeBS (showOct (mode ti) "") , typeobj ti , fromRef' (sha ti) - ] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti))) + ] + <> (S.cons (fromIntegral (ord '\t')) + (fromOsPath (getTopFilePath (file ti)))) diff --git a/Git/Objects.hs b/Git/Objects.hs index b66b0b5e19..4d2a2e907b 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -12,38 +12,47 @@ module Git.Objects where import Common import Git import Git.Sha +import qualified Utility.OsString as OS import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P +objectsDir :: Repo -> OsPath +objectsDir r = localGitDir r literalOsPath "objects" -objectsDir :: Repo -> RawFilePath -objectsDir r = localGitDir r P. "objects" +packDir :: Repo -> OsPath +packDir r = objectsDir r literalOsPath "pack" -packDir :: Repo -> RawFilePath -packDir r = objectsDir r P. "pack" +packIdxFile :: OsPath -> OsPath +packIdxFile = flip replaceExtension (literalOsPath "idx") -packIdxFile :: RawFilePath -> RawFilePath -packIdxFile = flip P.replaceExtension "idx" - -listPackFiles :: Repo -> IO [RawFilePath] -listPackFiles r = filter (".pack" `B.isSuffixOf`) +listPackFiles :: Repo -> IO [OsPath] +listPackFiles r = filter (literalOsPath ".pack" `OS.isSuffixOf`) <$> catchDefaultIO [] (dirContents $ packDir r) listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $ - mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories . decodeBS) - <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (objectsDir r)) + mapMaybe conv <$> emptyWhenDoesNotExist + (dirContentsRecursiveSkipping ispackdir True (objectsDir r)) + where + conv :: OsPath -> Maybe Sha + conv = extractSha + . fromOsPath + . OS.concat + . reverse + . take 2 + . reverse + . splitDirectories + ispackdir f = f == literalOsPath "pack" -looseObjectFile :: Repo -> Sha -> RawFilePath -looseObjectFile r sha = objectsDir r P. prefix P. rest +looseObjectFile :: Repo -> Sha -> OsPath +looseObjectFile r sha = objectsDir r toOsPath prefix toOsPath rest where (prefix, rest) = B.splitAt 2 (fromRef' sha) listAlternates :: Repo -> IO [FilePath] listAlternates r = catchDefaultIO [] $ - lines <$> readFile (fromRawFilePath alternatesfile) + lines <$> readFile (fromOsPath alternatesfile) where - alternatesfile = objectsDir r P. "info" P. "alternates" + alternatesfile = objectsDir r literalOsPath "info" literalOsPath "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 index 156ed8c95a..d4a3f5f901 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -53,11 +53,11 @@ data Action m - those will be run before the FlushAction is. -} | FlushAction { getFlushActionRunner :: FlushActionRunner m - , getFlushActionFiles :: [RawFilePath] + , getFlushActionFiles :: [OsPath] } {- The String must be unique for each flush action. -} -data FlushActionRunner m = FlushActionRunner String (Repo -> [RawFilePath] -> m ()) +data FlushActionRunner m = FlushActionRunner String (Repo -> [OsPath] -> m ()) instance Eq (FlushActionRunner m) where FlushActionRunner s1 _ == FlushActionRunner s2 _ = s1 == s2 @@ -140,7 +140,7 @@ addCommand commonparams subcommand params files q repo = {- Adds an flush action to the queue. This can co-exist with anything else - that gets added to the queue, and when the queue is eventually flushed, - it will be run after the other things in the queue. -} -addFlushAction :: MonadIO m => FlushActionRunner m -> [RawFilePath] -> Queue m -> Repo -> m (Queue m) +addFlushAction :: MonadIO m => FlushActionRunner m -> [OsPath] -> Queue m -> Repo -> m (Queue m) addFlushAction runner files q repo = updateQueue action (const False) (length files) q repo where diff --git a/Git/Quote.hs b/Git/Quote.hs index 2ca442ecb6..24b616de4e 100644 --- a/Git/Quote.hs +++ b/Git/Quote.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} module Git.Quote ( unquote, @@ -71,17 +72,23 @@ instance Quoteable RawFilePath where noquote = id +#ifdef WITH_OSPATH +instance Quoteable OsPath where + quote qp f = quote qp (fromOsPath f :: RawFilePath) + noquote = fromOsPath +#endif + -- Allows building up a string that contains paths, which will get quoted. -- With OverloadedStrings, strings are passed through without quoting. -- Eg: QuotedPath f <> ": not found" data StringContainingQuotedPath = UnquotedString String | UnquotedByteString S.ByteString - | QuotedPath RawFilePath + | QuotedPath OsPath | StringContainingQuotedPath :+: StringContainingQuotedPath deriving (Show, Eq) -quotedPaths :: [RawFilePath] -> StringContainingQuotedPath +quotedPaths :: [OsPath] -> StringContainingQuotedPath quotedPaths [] = mempty quotedPaths (p:ps) = QuotedPath p <> if null ps then mempty @@ -90,12 +97,12 @@ quotedPaths (p:ps) = QuotedPath p <> if null ps instance Quoteable StringContainingQuotedPath where quote _ (UnquotedString s) = safeOutput (encodeBS s) quote _ (UnquotedByteString s) = safeOutput s - quote qp (QuotedPath p) = quote qp p + quote qp (QuotedPath p) = quote qp (fromOsPath p :: RawFilePath) quote qp (a :+: b) = quote qp a <> quote qp b noquote (UnquotedString s) = encodeBS s noquote (UnquotedByteString s) = s - noquote (QuotedPath p) = p + noquote (QuotedPath p) = fromOsPath p noquote (a :+: b) = noquote a <> noquote b instance IsString StringContainingQuotedPath where diff --git a/Git/Ref.hs b/Git/Ref.hs index c6b2027280..6721b34051 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -20,17 +20,16 @@ import qualified Utility.FileIO as F import Data.Char (chr, ord) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 -import qualified System.FilePath.ByteString as P headRef :: Ref headRef = Ref "HEAD" -headFile :: Repo -> RawFilePath -headFile r = localGitDir r P. "HEAD" +headFile :: Repo -> OsPath +headFile r = localGitDir r literalOsPath "HEAD" setHeadRef :: Ref -> Repo -> IO () setHeadRef ref r = - F.writeFile' (toOsPath (headFile r)) ("ref: " <> fromRef' ref) + F.writeFile' (headFile r) ("ref: " <> fromRef' ref) {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String @@ -70,7 +69,7 @@ branchRef = underBase "refs/heads" - - If the input file is located outside the repository, returns Nothing. -} -fileRef :: RawFilePath -> Repo -> IO (Maybe Ref) +fileRef :: OsPath -> Repo -> IO (Maybe Ref) fileRef f repo = do -- The filename could be absolute, or contain eg "../repo/file", -- neither of which work in a ref, so convert it to a minimal @@ -80,12 +79,13 @@ fileRef f repo = do -- Prefixing the file with ./ makes this work even when in a -- subdirectory of a repo. Eg, ./foo in directory bar refers -- to bar/foo, not to foo in the top of the repository. - then Just $ Ref $ ":./" <> toInternalGitPath f' + then Just $ Ref $ ":./" <> fromOsPath (toInternalGitPath f') else Nothing {- A Ref that can be used to refer to a file in a particular branch. -} -branchFileRef :: Branch -> RawFilePath -> Ref -branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f +branchFileRef :: Branch -> OsPath -> Ref +branchFileRef branch f = Ref $ fromOsPath $ + toOsPath (fromRef' branch) <> literalOsPath ":" <> toInternalGitPath f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref @@ -96,7 +96,7 @@ dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d - - If the file path is located outside the repository, returns Nothing. -} -fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref) +fileFromRef :: Ref -> OsPath -> Repo -> IO (Maybe Ref) fileFromRef r f repo = fileRef f repo >>= return . \case Just (Ref fr) -> Just (Ref (fromRef' r <> fr)) Nothing -> Nothing @@ -113,8 +113,8 @@ exists ref = runBool {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} -file :: Ref -> Repo -> FilePath -file ref repo = fromRawFilePath (localGitDir repo) fromRef ref +file :: Ref -> Repo -> OsPath +file ref repo = localGitDir repo toOsPath (fromRef' ref) {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} diff --git a/Git/Repair.hs b/Git/Repair.hs index ed46161cfe..2f1c31fe71 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -43,13 +43,11 @@ import Utility.Directory.Create import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F import qualified Data.Set as S import qualified Data.ByteString as B 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. -} @@ -59,7 +57,7 @@ cleanCorruptObjects fsckresults r = do mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeBad =<< listLooseObjectShas r where - removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s) + removeLoose s = removeWhenExistsWith removeFile $ looseObjectFile r s removeBad s = do void $ tryIO $ allowRead $ looseObjectFile r s whenM (isMissing s r) $ @@ -80,8 +78,8 @@ explodePacks :: Repo -> IO Bool explodePacks r = go =<< listPackFiles r where go [] = return False - go packs = withTmpDir (toOsPath "packs") $ \tmpdir -> do - r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir + go packs = withTmpDir (literalOsPath "packs") $ \tmpdir -> do + r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" (fromOsPath tmpdir) putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do -- Just in case permissions are messed up. @@ -89,19 +87,16 @@ explodePacks r = go =<< listPackFiles r -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> - L.hPut h =<< F.readFile (toOsPath packfile) - objs <- emptyWhenDoesNotExist (dirContentsRecursive (toRawFilePath tmpdir)) + L.hPut h =<< F.readFile packfile + objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir) forM_ objs $ \objfile -> do - f <- relPathDirToFile - (toRawFilePath tmpdir) - objfile - let dest = objectsDir r P. f - createDirectoryIfMissing True - (fromRawFilePath (parentDir dest)) + f <- relPathDirToFile tmpdir objfile + let dest = objectsDir r f + createDirectoryIfMissing True (parentDir dest) moveFile objfile dest forM_ packs $ \packfile -> do - removeWhenExistsWith R.removeLink packfile - removeWhenExistsWith R.removeLink (packIdxFile packfile) + removeWhenExistsWith removeFile packfile + removeWhenExistsWith removeFile (packIdxFile packfile) return True {- Try to retrieve a set of missing objects, from the remotes of a @@ -114,12 +109,12 @@ explodePacks r = go =<< listPackFiles r retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults retrieveMissingObjects missing referencerepo r | not (foundBroken missing) = return missing - | otherwise = withTmpDir (toOsPath "tmprepo") $ \tmpdir -> do - unlessM (boolSystem "git" [Param "init", File tmpdir]) $ - giveup $ "failed to create temp repository in " ++ tmpdir - tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) - let repoconfig r' = toOsPath (localGitDir r' P. "config") - whenM (doesFileExist (fromRawFilePath (fromOsPath (repoconfig r)))) $ + | otherwise = withTmpDir (literalOsPath "tmprepo") $ \tmpdir -> do + unlessM (boolSystem "git" [Param "init", File (fromOsPath tmpdir)]) $ + giveup $ "failed to create temp repository in " ++ fromOsPath tmpdir + tmpr <- Config.read =<< Construct.fromPath tmpdir + let repoconfig r' = localGitDir r' literalOsPath "config" + whenM (doesFileExist (repoconfig r)) $ F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr) rs <- Construct.fromRemotes r stillmissing <- pullremotes tmpr rs fetchrefstags missing @@ -181,8 +176,8 @@ retrieveMissingObjects missing referencerepo r copyObjects :: Repo -> Repo -> IO Bool copyObjects srcr destr = rsync [ Param "-qr" - , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr - , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr + , File $ fromOsPath $ addTrailingPathSeparator $ objectsDir srcr + , File $ fromOsPath $ addTrailingPathSeparator $ objectsDir destr ] {- To deal with missing objects that cannot be recovered, resets any @@ -249,38 +244,35 @@ badBranches missing r = filterM isbad =<< getAllRefs r - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = getAllRefs' (localGitDir r P. "refs") +getAllRefs r = getAllRefs' (localGitDir r literalOsPath "refs") -getAllRefs' :: RawFilePath -> IO [Ref] +getAllRefs' :: OsPath -> IO [Ref] getAllRefs' refdir = do - let topsegs = length (P.splitPath refdir) - 1 - let toref = Ref . toInternalGitPath . encodeBS + let topsegs = length (splitPath refdir) - 1 + let toref = Ref . fromOsPath . toInternalGitPath . joinPath . drop topsegs . splitPath - . decodeBS map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir) explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile r = do let f = packedRefsFile r - let f' = toRawFilePath f whenM (doesFileExist f) $ do rs <- mapMaybe parsePacked . map decodeBS . fileLines' - <$> catchDefaultIO "" (safeReadFile f') + <$> catchDefaultIO "" (safeReadFile f) forM_ rs makeref - removeWhenExistsWith R.removeLink f' + removeWhenExistsWith removeFile f where makeref (sha, ref) = do let gitd = localGitDir r - let dest = gitd P. fromRef' ref - let dest' = fromRawFilePath dest + let dest = gitd toOsPath (fromRef' ref) createDirectoryUnder [gitd] (parentDir dest) - unlessM (doesFileExist dest') $ - writeFile dest' (fromRef sha) + unlessM (doesFileExist dest) $ + writeFile (fromOsPath dest) (fromRef sha) -packedRefsFile :: Repo -> FilePath -packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" +packedRefsFile :: Repo -> OsPath +packedRefsFile r = localGitDir r literalOsPath "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of @@ -292,7 +284,8 @@ parsePacked l = case words l of {- 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 = removeWhenExistsWith R.removeLink $ localGitDir r P. fromRef' b +nukeBranchRef b r = removeWhenExistsWith removeFile $ + localGitDir r toOsPath (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. @@ -411,7 +404,7 @@ checkIndexFast r = do length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool -missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) "index") +missingIndex r = not <$> doesFileExist (localGitDir r literalOsPath "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) @@ -430,11 +423,11 @@ rewriteIndex r | otherwise = do (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do - removeWhenExistsWith R.removeLink (indexFile r) + removeWhenExistsWith removeFile (indexFile r) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map (\(file,_, _, _) -> fromRawFilePath file) bad + return $ map (\(file,_, _, _) -> fromOsPath file) bad where reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing @@ -478,13 +471,13 @@ displayList items header preRepair :: Repo -> IO () preRepair g = do unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do - removeWhenExistsWith R.removeLink headfile - writeFile (fromRawFilePath headfile) "ref: refs/heads/master" + removeWhenExistsWith removeFile headfile + writeFile (fromOsPath headfile) "ref: refs/heads/master" explodePackedRefsFile g unless (repoIsLocalBare g) $ void $ tryIO $ allowWrite $ indexFile g where - headfile = localGitDir g P. "HEAD" + headfile = localGitDir g literalOsPath "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha (encodeBS s)) @@ -611,7 +604,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do else successfulfinish modifiedbranches corruptedindex = do - removeWhenExistsWith R.removeLink (indexFile g) + removeWhenExistsWith removeFile (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. fsckresult' <- findBroken False False g @@ -655,7 +648,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do successfulRepair :: (Bool, [Branch]) -> Bool successfulRepair = fst -safeReadFile :: RawFilePath -> IO B.ByteString +safeReadFile :: OsPath -> IO B.ByteString safeReadFile f = do allowRead f - F.readFile' (toOsPath f) + F.readFile' f diff --git a/Git/Status.hs b/Git/Status.hs index 8e50a69fc4..db777a2465 100644 --- a/Git/Status.hs +++ b/Git/Status.hs @@ -57,13 +57,13 @@ parseStatusZ = go [] in go (v : c) xs' _ -> go c xs - cparse 'M' f _ = (Just (Modified (asTopFilePath (toRawFilePath f))), Nothing) - cparse 'A' f _ = (Just (Added (asTopFilePath (toRawFilePath f))), Nothing) - cparse 'D' f _ = (Just (Deleted (asTopFilePath (toRawFilePath f))), Nothing) - cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toRawFilePath f))), Nothing) - cparse '?' f _ = (Just (Untracked (asTopFilePath (toRawFilePath f))), Nothing) + cparse 'M' f _ = (Just (Modified (asTopFilePath (toOsPath f))), Nothing) + cparse 'A' f _ = (Just (Added (asTopFilePath (toOsPath f))), Nothing) + cparse 'D' f _ = (Just (Deleted (asTopFilePath (toOsPath f))), Nothing) + cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toOsPath f))), Nothing) + cparse '?' f _ = (Just (Untracked (asTopFilePath (toOsPath f))), Nothing) cparse 'R' f (oldf:xs) = - (Just (Renamed (asTopFilePath (toRawFilePath oldf)) (asTopFilePath (toRawFilePath f))), Just xs) + (Just (Renamed (asTopFilePath (toOsPath oldf)) (asTopFilePath (toOsPath f))), Just xs) cparse _ _ _ = (Nothing, Nothing) getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool) diff --git a/Git/Tree.hs b/Git/Tree.hs index af2a132aa4..33a4b3cda0 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -137,7 +137,7 @@ mkTreeOutput fm ot s f = concat , " " , fromRef s , "\t" - , takeFileName (fromRawFilePath (getTopFilePath f)) + , fromOsPath (takeFileName (getTopFilePath f)) , "\NUL" ] @@ -178,7 +178,7 @@ treeItemsToTree = go M.empty Just (NewSubTree d l) -> go (addsubtree idir m (NewSubTree d (c:l))) is _ -> - go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is + go (addsubtree idir m (NewSubTree (asTopFilePath (toOsPath idir)) [c])) is where p = gitPath i idir = P.takeDirectory p @@ -191,7 +191,7 @@ treeItemsToTree = go M.empty Just (NewSubTree d' l) -> let l' = filter (\ti -> gitPath ti /= d) l in addsubtree parent m' (NewSubTree d' (t:l')) - _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) + _ -> addsubtree parent m' (NewSubTree (asTopFilePath (toOsPath parent)) [t]) | otherwise = M.insert d t m where parent = P.takeDirectory d @@ -362,7 +362,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs subdirs = P.splitDirectories $ gitPath graftloc - graftdirs = map (asTopFilePath . toInternalGitPath) $ + graftdirs = map (asTopFilePath . toInternalGitPath . toOsPath) $ pathPrefixes subdirs {- Assumes the list is ordered, with tree objects coming right before their @@ -401,7 +401,7 @@ instance GitPath FilePath where gitPath = toRawFilePath instance GitPath TopFilePath where - gitPath = getTopFilePath + gitPath = fromOsPath . getTopFilePath instance GitPath TreeItem where gitPath (TreeItem f _ _) = gitPath f diff --git a/Git/Types.hs b/Git/Types.hs index b28380bc46..a32d07d4f7 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -6,9 +6,14 @@ -} {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE CPP #-} module Git.Types where +import Utility.SafeCommand +import Utility.FileSystemEncoding +import Utility.OsPath + import Network.URI import Data.String import Data.Default @@ -16,8 +21,6 @@ import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.List.NonEmpty as NE import System.Posix.Types -import Utility.SafeCommand -import Utility.FileSystemEncoding import qualified Data.Semigroup as Sem import Prelude @@ -32,8 +35,8 @@ import Prelude - else known about it. -} data RepoLocation - = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } - | LocalUnknown RawFilePath + = Local { gitdir :: OsPath, worktree :: Maybe OsPath } + | LocalUnknown OsPath | Url URI | UnparseableUrl String | Unknown @@ -105,6 +108,11 @@ 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/Git/UnionMerge.hs b/Git/UnionMerge.hs index a6bc469f66..bf171ae60e 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -76,14 +76,14 @@ doMerge hashhandle ch differ repo streamer = do void $ cleanup where go [] = noop - go (info:file:rest) = mergeFile info file hashhandle ch >>= + go (info:file:rest) = mergeFile info (toOsPath file) hashhandle ch >>= maybe (go rest) (\l -> streamer l >> go rest) go (_:[]) = giveup $ "parse error " ++ show differ {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the - diff. -} -mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) +mergeFile :: S.ByteString -> OsPath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) mergeFile info file hashhandle h = case S8.words info of [_colonmode, _bmode, asha, bsha, _status] -> case filter (`notElem` nullShas) [Ref asha, Ref bsha] of diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index f56bc86cbc..257fcd7763 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -81,6 +81,7 @@ lsTree (Ref x) repo streamer = do void $ cleanup where params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x] + lsSubTree :: Ref -> FilePath -> Repo -> Streamer lsSubTree (Ref x) p repo streamer = do (s, cleanup) <- pipeNullSplit params repo @@ -97,15 +98,15 @@ updateIndexLine sha treeitemtype file = L.fromStrict $ <> " blob " <> fromRef' sha <> "\t" - <> indexPath file + <> fromOsPath (indexPath file) -stageFile :: Sha -> TreeItemType -> RawFilePath -> Repo -> IO Streamer +stageFile :: Sha -> TreeItemType -> OsPath -> Repo -> IO Streamer stageFile sha treeitemtype file repo = do p <- toTopFilePath file repo return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} -unstageFile :: RawFilePath -> Repo -> IO Streamer +unstageFile :: OsPath -> Repo -> IO Streamer unstageFile file repo = do p <- toTopFilePath file repo return $ unstageFile' p @@ -115,10 +116,10 @@ unstageFile' p = pureStreamer $ L.fromStrict $ "0 " <> fromRef' deleteSha <> "\t" - <> indexPath p + <> fromOsPath (indexPath p) {- A streamer that adds a symlink to the index. -} -stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer +stageSymlink :: OsPath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha @@ -141,7 +142,7 @@ indexPath = toInternalGitPath . getTopFilePath - update-index. Sending Nothing will wait for update-index to finish - updating the index. -} -refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m () +refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe OsPath -> IO ()) -> m ()) -> m () refreshIndex repo feeder = bracket (liftIO $ createProcess p) (liftIO . cleanupProcess) @@ -163,7 +164,7 @@ refreshIndex repo feeder = bracket hClose h forceSuccessProcess p pid feeder $ \case - Just f -> S.hPut h (S.snoc f 0) + Just f -> S.hPut h (S.snoc (fromOsPath f) 0) Nothing -> closer liftIO $ closer go _ = error "internal" diff --git a/Key.hs b/Key.hs index b19aee8040..611bffcd72 100644 --- a/Key.hs +++ b/Key.hs @@ -18,6 +18,7 @@ module Key ( keyParser, serializeKey, serializeKey', + serializeKey'', deserializeKey, deserializeKey', nonChunkKey, @@ -31,7 +32,7 @@ module Key ( import qualified Data.Text as T import qualified Data.ByteString as S -import qualified Data.ByteString.Short as S (toShort, fromShort) +import Data.ByteString.Short (ShortByteString, toShort, fromShort) import qualified Data.Attoparsec.ByteString as A import Common @@ -63,7 +64,10 @@ serializeKey :: Key -> String serializeKey = decodeBS . serializeKey' serializeKey' :: Key -> S.ByteString -serializeKey' = S.fromShort . keySerialization +serializeKey' = fromShort . keySerialization + +serializeKey'' :: Key -> ShortByteString +serializeKey'' = keySerialization deserializeKey :: String -> Maybe Key deserializeKey = deserializeKey' . encodeBS @@ -73,7 +77,7 @@ deserializeKey' = eitherToMaybe . A.parseOnly keyParser instance Arbitrary KeyData where arbitrary = Key - <$> (S.toShort . encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")) + <$> (toShort . encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")) <*> (parseKeyVariety . encodeBS <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND <*> ((abs <$>) <$> arbitrary) -- size cannot be negative <*> ((abs . fromInteger <$>) <$> arbitrary) -- mtime cannot be negative @@ -82,7 +86,7 @@ instance Arbitrary KeyData where instance Arbitrary AssociatedFile where arbitrary = AssociatedFile - . fmap (toRawFilePath . fromTestableFilePath) + . fmap (toOsPath . fromTestableFilePath) <$> arbitrary instance Arbitrary Key where diff --git a/Limit.hs b/Limit.hs index 2c7ce3c22e..4bdd7f6e1b 100644 --- a/Limit.hs +++ b/Limit.hs @@ -48,7 +48,6 @@ import Control.Monad.Writer import Data.Time.Clock.POSIX import qualified Data.Set as S import qualified Data.Map as M -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (accessTime, isSymbolicLink) {- Some limits can look at the current status of files on @@ -140,11 +139,12 @@ matchGlobFile :: String -> MatchInfo -> Annex Bool matchGlobFile glob = go where cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized - go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) + go (MatchingFile fi) = pure $ matchGlob cglob (fromOsPath (matchFile fi)) go (MatchingInfo p) = pure $ case providedFilePath p of - Just f -> matchGlob cglob (fromRawFilePath f) + Just f -> matchGlob cglob (fromOsPath f) Nothing -> False - go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p) + go (MatchingUserInfo p) = matchGlob cglob . fromOsPath + <$> getUserInfo (userProvidedFilePath p) {- Add a limit to skip files when there is no other file using the same - content, with a name matching the glob. -} @@ -188,23 +188,22 @@ matchSameContentGlob glob mi = checkKey (go mi) mi Just f -> check k f Nothing -> return False go (MatchingUserInfo p) k = - check k . toRawFilePath - =<< getUserInfo (userProvidedFilePath p) + check k =<< getUserInfo (userProvidedFilePath p) cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized - matchesglob f = matchGlob cglob (fromRawFilePath f) + matchesglob f = matchGlob cglob (fromOsPath f) #ifdef mingw32_HOST_OS - || matchGlob cglob (fromRawFilePath (toInternalGitPath f)) + || matchGlob cglob (fromOsPath (toInternalGitPath f)) #endif check k skipf = do -- Find other files with the same content, with filenames -- matching the glob. g <- Annex.gitRepo - fs <- filter (/= P.normalise skipf) + fs <- filter (/= normalise skipf) . filter matchesglob - . map (\f -> P.normalise (fromTopFilePath f g)) + . map (\f -> normalise (fromTopFilePath f g)) <$> Database.Keys.getAssociatedFiles k -- Some associated files in the keys database may no longer -- correspond to files in the repository. This is checked @@ -219,7 +218,7 @@ addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMime addMagicLimit :: String - -> (Magic -> FilePath -> Annex (Maybe String)) + -> (Magic -> OsPath -> Annex (Maybe String)) -> (ProvidedInfo -> Maybe String) -> (UserProvidedInfo -> UserInfo String) -> String @@ -228,20 +227,19 @@ addMagicLimit limitname querymagic selectprovidedinfo selectuserprovidedinfo glo magic <- liftIO initMagicMime addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob where - querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case + querymagic' magic f = liftIO (isPointerFile f) >>= \case -- Avoid getting magic of a pointer file, which would -- wrongly be detected as text. Just _ -> return Nothing -- When the file is an annex symlink, get magic of the -- object file. - Nothing -> isAnnexLink (toRawFilePath f) >>= \case - Just k -> withObjectLoc k $ - querymagic magic . fromRawFilePath + Nothing -> isAnnexLink f >>= \case + Just k -> withObjectLoc k (querymagic magic) Nothing -> querymagic magic f matchMagic :: String - -> (Magic -> FilePath -> Annex (Maybe String)) + -> (Magic -> OsPath -> Annex (Maybe String)) -> (ProvidedInfo -> Maybe String) -> (UserProvidedInfo -> UserInfo String) -> Maybe Magic @@ -261,7 +259,7 @@ matchMagic limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just cglob = compileGlob glob CaseSensitive (GlobFilePath False) -- memoized go (MatchingFile fi) = catchBoolIO $ maybe False (matchGlob cglob) - <$> querymagic magic (fromRawFilePath (contentFile fi)) + <$> querymagic magic (contentFile fi) go (MatchingInfo p) = maybe (usecontent (providedKey p)) (pure . matchGlob cglob) @@ -269,8 +267,7 @@ matchMagic limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p) usecontent (Just k) = withObjectLoc k $ \obj -> catchBoolIO $ - maybe False (matchGlob cglob) - <$> querymagic magic (fromRawFilePath obj) + maybe False (matchGlob cglob) <$> querymagic magic obj usecontent Nothing = pure False matchMagic limitname _ _ _ Nothing _ = Left $ "unable to load magic database; \""++limitname++"\" cannot be used" @@ -305,7 +302,7 @@ matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do islocked <- isPointerFile f >>= \case Just _key -> return False Nothing -> isSymbolicLink - <$> R.getSymbolicLinkStatus f + <$> R.getSymbolicLinkStatus (fromOsPath f) return (islocked == wantlocked) matchLockStatus wantlocked (MatchingInfo p) = pure $ case providedLinkType p of @@ -388,7 +385,7 @@ limitPresent u = MatchFiles } {- Limit to content that is in a directory, anywhere in the repository tree -} -limitInDir :: FilePath -> String -> MatchFiles Annex +limitInDir :: OsPath -> String -> MatchFiles Annex limitInDir dir desc = MatchFiles { matchAction = const $ const go , matchNeedsFileName = True @@ -400,8 +397,8 @@ limitInDir dir desc = MatchFiles , matchDesc = matchDescSimple desc } where - go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi - go (MatchingInfo p) = maybe (pure False) (checkf . fromRawFilePath) (providedFilePath p) + go (MatchingFile fi) = checkf $ matchFile fi + go (MatchingInfo p) = maybe (pure False) checkf (providedFilePath p) go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p) checkf = return . elem dir . splitPath . takeDirectory @@ -867,7 +864,7 @@ addAccessedWithin duration = do where check now k = inAnnexCheck k $ \f -> liftIO $ catchDefaultIO False $ do - s <- R.getSymbolicLinkStatus f + s <- R.getSymbolicLinkStatus (fromOsPath f) let accessed = realToFrac (accessTime s) let delta = now - accessed return $ delta <= secs diff --git a/Logs.hs b/Logs.hs index 52968ca575..e8652ebd04 100644 --- a/Logs.hs +++ b/Logs.hs @@ -11,9 +11,7 @@ module Logs where import Annex.Common import Annex.DirHashes - -import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P +import qualified Utility.OsString as OS {- There are several varieties of log file formats. -} data LogVariety @@ -28,7 +26,7 @@ data LogVariety {- Converts a path from the git-annex branch into one of the varieties - of logs used by git-annex, if it's a known path. -} -getLogVariety :: GitConfig -> RawFilePath -> Maybe LogVariety +getLogVariety :: GitConfig -> OsPath -> Maybe LogVariety getLogVariety config f | f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog | f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog @@ -63,7 +61,7 @@ logFilesToCache :: Int logFilesToCache = 2 {- All the log files that might contain information about a key. -} -keyLogFiles :: GitConfig -> Key -> [RawFilePath] +keyLogFiles :: GitConfig -> Key -> [OsPath] keyLogFiles config k = [ locationLogFile config k , urlLogFile config k @@ -76,11 +74,11 @@ keyLogFiles config k = ] ++ oldurlLogs config k {- All uuid-based logs stored in the top of the git-annex branch. -} -topLevelUUIDBasedLogs :: [RawFilePath] +topLevelUUIDBasedLogs :: [OsPath] topLevelUUIDBasedLogs = topLevelNewUUIDBasedLogs ++ topLevelOldUUIDBasedLogs {- All the old-format uuid-based logs stored in the top of the git-annex branch. -} -topLevelOldUUIDBasedLogs :: [RawFilePath] +topLevelOldUUIDBasedLogs :: [OsPath] topLevelOldUUIDBasedLogs = [ uuidLog , remoteLog @@ -95,7 +93,7 @@ topLevelOldUUIDBasedLogs = ] {- All the new-format uuid-based logs stored in the top of the git-annex branch. -} -topLevelNewUUIDBasedLogs :: [RawFilePath] +topLevelNewUUIDBasedLogs :: [OsPath] topLevelNewUUIDBasedLogs = [ exportLog , proxyLog @@ -104,7 +102,7 @@ topLevelNewUUIDBasedLogs = ] {- Other top-level logs. -} -otherTopLevelLogs :: [RawFilePath] +otherTopLevelLogs :: [OsPath] otherTopLevelLogs = [ numcopiesLog , mincopiesLog @@ -112,188 +110,188 @@ otherTopLevelLogs = , groupPreferredContentLog ] -uuidLog :: RawFilePath -uuidLog = "uuid.log" +uuidLog :: OsPath +uuidLog = literalOsPath "uuid.log" -numcopiesLog :: RawFilePath -numcopiesLog = "numcopies.log" +numcopiesLog :: OsPath +numcopiesLog = literalOsPath "numcopies.log" -mincopiesLog :: RawFilePath -mincopiesLog = "mincopies.log" +mincopiesLog :: OsPath +mincopiesLog = literalOsPath "mincopies.log" -configLog :: RawFilePath -configLog = "config.log" +configLog :: OsPath +configLog = literalOsPath "config.log" -remoteLog :: RawFilePath -remoteLog = "remote.log" +remoteLog :: OsPath +remoteLog = literalOsPath "remote.log" -trustLog :: RawFilePath -trustLog = "trust.log" +trustLog :: OsPath +trustLog = literalOsPath "trust.log" -groupLog :: RawFilePath -groupLog = "group.log" +groupLog :: OsPath +groupLog = literalOsPath "group.log" -preferredContentLog :: RawFilePath -preferredContentLog = "preferred-content.log" +preferredContentLog :: OsPath +preferredContentLog = literalOsPath "preferred-content.log" -requiredContentLog :: RawFilePath -requiredContentLog = "required-content.log" +requiredContentLog :: OsPath +requiredContentLog = literalOsPath "required-content.log" -groupPreferredContentLog :: RawFilePath -groupPreferredContentLog = "group-preferred-content.log" +groupPreferredContentLog :: OsPath +groupPreferredContentLog = literalOsPath "group-preferred-content.log" -scheduleLog :: RawFilePath -scheduleLog = "schedule.log" +scheduleLog :: OsPath +scheduleLog = literalOsPath "schedule.log" -activityLog :: RawFilePath -activityLog = "activity.log" +activityLog :: OsPath +activityLog = literalOsPath "activity.log" -differenceLog :: RawFilePath -differenceLog = "difference.log" +differenceLog :: OsPath +differenceLog = literalOsPath "difference.log" -multicastLog :: RawFilePath -multicastLog = "multicast.log" +multicastLog :: OsPath +multicastLog = literalOsPath "multicast.log" -exportLog :: RawFilePath -exportLog = "export.log" +exportLog :: OsPath +exportLog = literalOsPath "export.log" -proxyLog :: RawFilePath -proxyLog = "proxy.log" +proxyLog :: OsPath +proxyLog = literalOsPath "proxy.log" -clusterLog :: RawFilePath -clusterLog = "cluster.log" +clusterLog :: OsPath +clusterLog = literalOsPath "cluster.log" -maxSizeLog :: RawFilePath -maxSizeLog = "maxsize.log" +maxSizeLog :: OsPath +maxSizeLog = literalOsPath "maxsize.log" {- This is not a log file, it's where exported treeishes get grafted into - the git-annex branch. -} -exportTreeGraftPoint :: RawFilePath -exportTreeGraftPoint = "export.tree" +exportTreeGraftPoint :: OsPath +exportTreeGraftPoint = literalOsPath "export.tree" {- This is not a log file, it's where migration treeishes get grafted into - the git-annex branch. -} -migrationTreeGraftPoint :: RawFilePath -migrationTreeGraftPoint = "migrate.tree" +migrationTreeGraftPoint :: OsPath +migrationTreeGraftPoint = literalOsPath "migrate.tree" {- The pathname of the location log file for a given key. -} -locationLogFile :: GitConfig -> Key -> RawFilePath +locationLogFile :: GitConfig -> Key -> OsPath locationLogFile config key = - branchHashDir config key P. keyFile key <> locationLogExt + branchHashDir config key keyFile key <> locationLogExt -locationLogExt :: S.ByteString -locationLogExt = ".log" +locationLogExt :: OsPath +locationLogExt = literalOsPath ".log" {- The filename of the url log for a given key. -} -urlLogFile :: GitConfig -> Key -> RawFilePath +urlLogFile :: GitConfig -> Key -> OsPath urlLogFile config key = - branchHashDir config key P. keyFile key <> urlLogExt + branchHashDir config key keyFile key <> urlLogExt {- Old versions stored the urls elsewhere. -} -oldurlLogs :: GitConfig -> Key -> [RawFilePath] +oldurlLogs :: GitConfig -> Key -> [OsPath] oldurlLogs config key = - [ "remote/web" P. hdir P. serializeKey' key <> ".log" - , "remote/web" P. hdir P. keyFile key <> ".log" + [ literalOsPath "remote/web" hdir toOsPath (serializeKey'' key) <> literalOsPath ".log" + , literalOsPath "remote/web" hdir keyFile key <> literalOsPath ".log" ] where hdir = branchHashDir config key -urlLogExt :: S.ByteString -urlLogExt = ".log.web" +urlLogExt :: OsPath +urlLogExt = literalOsPath ".log.web" {- Does not work on oldurllogs. -} -isUrlLog :: RawFilePath -> Bool -isUrlLog file = urlLogExt `S.isSuffixOf` file +isUrlLog :: OsPath -> Bool +isUrlLog file = urlLogExt `OS.isSuffixOf` file {- The filename of the remote state log for a given key. -} -remoteStateLogFile :: GitConfig -> Key -> RawFilePath +remoteStateLogFile :: GitConfig -> Key -> OsPath remoteStateLogFile config key = - (branchHashDir config key P. keyFile key) + (branchHashDir config key keyFile key) <> remoteStateLogExt -remoteStateLogExt :: S.ByteString -remoteStateLogExt = ".log.rmt" +remoteStateLogExt :: OsPath +remoteStateLogExt = literalOsPath ".log.rmt" -isRemoteStateLog :: RawFilePath -> Bool -isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path +isRemoteStateLog :: OsPath -> Bool +isRemoteStateLog path = remoteStateLogExt `OS.isSuffixOf` path {- The filename of the chunk log for a given key. -} -chunkLogFile :: GitConfig -> Key -> RawFilePath +chunkLogFile :: GitConfig -> Key -> OsPath chunkLogFile config key = - (branchHashDir config key P. keyFile key) + (branchHashDir config key keyFile key) <> chunkLogExt -chunkLogExt :: S.ByteString -chunkLogExt = ".log.cnk" +chunkLogExt :: OsPath +chunkLogExt = literalOsPath ".log.cnk" {- The filename of the equivalent keys log for a given key. -} -equivilantKeysLogFile :: GitConfig -> Key -> RawFilePath +equivilantKeysLogFile :: GitConfig -> Key -> OsPath equivilantKeysLogFile config key = - (branchHashDir config key P. keyFile key) + (branchHashDir config key keyFile key) <> equivilantKeyLogExt -equivilantKeyLogExt :: S.ByteString -equivilantKeyLogExt = ".log.ek" +equivilantKeyLogExt :: OsPath +equivilantKeyLogExt = literalOsPath ".log.ek" -isEquivilantKeyLog :: RawFilePath -> Bool -isEquivilantKeyLog path = equivilantKeyLogExt `S.isSuffixOf` path +isEquivilantKeyLog :: OsPath -> Bool +isEquivilantKeyLog path = equivilantKeyLogExt `OS.isSuffixOf` path {- The filename of the metadata log for a given key. -} -metaDataLogFile :: GitConfig -> Key -> RawFilePath +metaDataLogFile :: GitConfig -> Key -> OsPath metaDataLogFile config key = - (branchHashDir config key P. keyFile key) + (branchHashDir config key keyFile key) <> metaDataLogExt -metaDataLogExt :: S.ByteString -metaDataLogExt = ".log.met" +metaDataLogExt :: OsPath +metaDataLogExt = literalOsPath ".log.met" -isMetaDataLog :: RawFilePath -> Bool -isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path +isMetaDataLog :: OsPath -> Bool +isMetaDataLog path = metaDataLogExt `OS.isSuffixOf` path {- The filename of the remote metadata log for a given key. -} -remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath +remoteMetaDataLogFile :: GitConfig -> Key -> OsPath remoteMetaDataLogFile config key = - (branchHashDir config key P. keyFile key) + (branchHashDir config key keyFile key) <> remoteMetaDataLogExt -remoteMetaDataLogExt :: S.ByteString -remoteMetaDataLogExt = ".log.rmet" +remoteMetaDataLogExt :: OsPath +remoteMetaDataLogExt = literalOsPath ".log.rmet" -isRemoteMetaDataLog :: RawFilePath -> Bool -isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path +isRemoteMetaDataLog :: OsPath -> Bool +isRemoteMetaDataLog path = remoteMetaDataLogExt `OS.isSuffixOf` path {- The filename of the remote content identifier log for a given key. -} -remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath +remoteContentIdentifierLogFile :: GitConfig -> Key -> OsPath remoteContentIdentifierLogFile config key = - (branchHashDir config key P. keyFile key) + (branchHashDir config key keyFile key) <> remoteContentIdentifierExt -remoteContentIdentifierExt :: S.ByteString -remoteContentIdentifierExt = ".log.cid" +remoteContentIdentifierExt :: OsPath +remoteContentIdentifierExt = literalOsPath ".log.cid" -isRemoteContentIdentifierLog :: RawFilePath -> Bool -isRemoteContentIdentifierLog path = remoteContentIdentifierExt `S.isSuffixOf` path +isRemoteContentIdentifierLog :: OsPath -> Bool +isRemoteContentIdentifierLog path = remoteContentIdentifierExt `OS.isSuffixOf` path {- From an extension and a log filename, get the key that it's a log for. -} -extLogFileKey :: S.ByteString -> RawFilePath -> Maybe Key +extLogFileKey :: OsPath -> OsPath -> Maybe Key extLogFileKey expectedext path | ext == expectedext = fileKey base | otherwise = Nothing where - file = P.takeFileName path - (base, ext) = S.splitAt (S.length file - extlen) file - extlen = S.length expectedext + file = takeFileName path + (base, ext) = OS.splitAt (OS.length file - extlen) file + extlen = OS.length expectedext {- Converts a url log file into a key. - (Does not work on oldurlLogs.) -} -urlLogFileKey :: RawFilePath -> Maybe Key +urlLogFileKey :: OsPath -> Maybe Key urlLogFileKey = extLogFileKey urlLogExt {- Converts a pathname into a key if it's a location log. -} -locationLogFileKey :: GitConfig -> RawFilePath -> Maybe Key +locationLogFileKey :: GitConfig -> OsPath -> Maybe Key locationLogFileKey config path - | length (splitDirectories (fromRawFilePath path)) /= locationLogFileDepth config = Nothing - | otherwise = extLogFileKey ".log" path + | length (splitDirectories path) /= locationLogFileDepth config = Nothing + | otherwise = extLogFileKey (literalOsPath ".log") path {- Depth of location log files within the git-annex branch. - diff --git a/Logs/Export.hs b/Logs/Export.hs index a3cf823d53..169708f1e8 100644 --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -130,7 +130,7 @@ getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem] getExportExcluded u = do logf <- fromRepo $ gitAnnexExportExcludeLog u liftIO $ catchDefaultIO [] $ exportExcludedParser - <$> F.readFile (toOsPath logf) + <$> F.readFile logf where exportExcludedParser :: L.ByteString -> [Git.Tree.TreeItem] diff --git a/Logs/File.hs b/Logs/File.hs index 93aef17f97..ed95627883 100644 --- a/Logs/File.hs +++ b/Logs/File.hs @@ -34,16 +34,16 @@ import qualified Data.ByteString.Lazy.Char8 as L8 -- | 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 :: RawFilePath -> String -> Annex () -writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (toOsPath f) c +writeLogFile :: OsPath -> String -> Annex () +writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c where writelog tmp c' = do - liftIO $ writeFile (fromRawFilePath (fromOsPath tmp)) c' - setAnnexFilePerm (fromOsPath tmp) + liftIO $ writeFile (fromOsPath tmp) c' + setAnnexFilePerm tmp -- | Runs the action with a handle connected to a temp file. -- The temp file replaces the log file once the action succeeds. -withLogHandle :: RawFilePath -> (Handle -> Annex a) -> Annex a +withLogHandle :: OsPath -> (Handle -> Annex a) -> Annex a withLogHandle f a = do createAnnexDirectory (parentDir f) replaceGitAnnexDirFile f $ \tmp -> @@ -51,16 +51,16 @@ withLogHandle f a = do where setup tmp = do setAnnexFilePerm tmp - liftIO $ F.openFile (toOsPath tmp) WriteMode + liftIO $ F.openFile tmp WriteMode cleanup h = liftIO $ hClose h -- | Appends a line to a log file, first locking it to prevent -- concurrent writers. -appendLogFile :: RawFilePath -> RawFilePath -> L.ByteString -> Annex () +appendLogFile :: OsPath -> OsPath -> L.ByteString -> Annex () appendLogFile f lck c = createDirWhenNeeded f $ withExclusiveLock lck $ do - liftIO $ F.withFile (toOsPath f) AppendMode $ + liftIO $ F.withFile f AppendMode $ \h -> L8.hPutStrLn h c setAnnexFilePerm f @@ -72,25 +72,24 @@ appendLogFile f lck c = -- -- The file is locked to prevent concurrent writers, and it is written -- atomically. -modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex () +modifyLogFile :: OsPath -> OsPath -> ([L.ByteString] -> [L.ByteString]) -> Annex () modifyLogFile f lck modf = withExclusiveLock lck $ do ls <- liftIO $ fromMaybe [] - <$> tryWhenExists (fileLines <$> F.readFile f') + <$> tryWhenExists (fileLines <$> F.readFile f) let ls' = modf ls when (ls' /= ls) $ createDirWhenNeeded f $ - viaTmp writelog f' (L8.unlines ls') + viaTmp writelog f (L8.unlines ls') where - f' = toOsPath f writelog lf b = do liftIO $ F.writeFile lf b - setAnnexFilePerm (fromOsPath lf) + setAnnexFilePerm lf -- | Checks the content of a log file to see if any line matches. -checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool +checkLogFile :: OsPath -> OsPath -> (L.ByteString -> Bool) -> Annex Bool checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go where - setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode + setup = liftIO $ tryWhenExists $ F.openFile f ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = return False @@ -99,15 +98,15 @@ checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go return r -- | Folds a function over lines of a log file to calculate a value. -calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t +calcLogFile :: OsPath -> OsPath -> t -> (L.ByteString -> t -> t) -> Annex t calcLogFile f lck start update = withSharedLock lck $ calcLogFileUnsafe f start update -- | Unsafe version that does not do locking. -calcLogFileUnsafe :: RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t +calcLogFileUnsafe :: OsPath -> t -> (L.ByteString -> t -> t) -> Annex t calcLogFileUnsafe f start update = bracket setup cleanup go where - setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode + setup = liftIO $ tryWhenExists $ F.openFile f ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = return start @@ -129,19 +128,19 @@ calcLogFileUnsafe f start update = bracket setup cleanup go -- -- Locking is used to prevent writes to to the log file while this -- is running. -streamLogFile :: RawFilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex () +streamLogFile :: OsPath -> OsPath -> Annex () -> (String -> Annex ()) -> Annex () streamLogFile f lck finalizer processor = withExclusiveLock lck $ do streamLogFileUnsafe f finalizer processor - liftIO $ F.writeFile' (toOsPath f) mempty + liftIO $ F.writeFile' f mempty setAnnexFilePerm f -- Unsafe version that does not do locking, and does not empty the file -- at the end. -streamLogFileUnsafe :: RawFilePath -> Annex () -> (String -> Annex ()) -> Annex () +streamLogFileUnsafe :: OsPath -> Annex () -> (String -> Annex ()) -> Annex () streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go where - setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode + setup = liftIO $ tryWhenExists $ F.openFile f ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = finalizer @@ -150,7 +149,7 @@ streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go liftIO $ hClose h finalizer -createDirWhenNeeded :: RawFilePath -> Annex () -> Annex () +createDirWhenNeeded :: OsPath -> 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 index 017941d370..b938491092 100644 --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -15,7 +15,6 @@ import Annex.Common import Git.Fsck import Git.Types import Logs.File -import qualified Utility.RawFilePath as R import qualified Data.Set as S @@ -25,7 +24,7 @@ writeFsckResults u fsckresults = do case serializeFsckResults fsckresults of Just s -> store s logfile Nothing -> liftIO $ - removeWhenExistsWith R.removeLink logfile + removeWhenExistsWith removeFile logfile where store s logfile = writeLogFile logfile s @@ -46,7 +45,7 @@ readFsckResults :: UUID -> Annex FsckResults readFsckResults u = do logfile <- fromRepo $ gitAnnexFsckResultsLog u liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $ - deserializeFsckResults <$> readFile (fromRawFilePath logfile) + deserializeFsckResults <$> readFile (fromOsPath logfile) deserializeFsckResults :: String -> FsckResults deserializeFsckResults = deserialize . lines @@ -58,6 +57,6 @@ deserializeFsckResults = deserialize . lines in if S.null s then FsckFailed else FsckFoundMissing s t clearFsckResults :: UUID -> Annex () -clearFsckResults = liftIO . removeWhenExistsWith R.removeLink +clearFsckResults = liftIO . removeWhenExistsWith removeFile <=< fromRepo . gitAnnexFsckResultsLog diff --git a/Logs/Location.hs b/Logs/Location.hs index 608020899a..2adcddd2e3 100644 --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -124,7 +124,7 @@ parseLoggedLocationsWithoutClusters l = map (toUUID . fromLogInfo . info) (filterPresent (parseLog l)) -getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] +getLoggedLocations :: (OsPath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do config <- Annex.getGitConfig locs <- map (toUUID . fromLogInfo) <$> getter (locationLogFile config key) @@ -301,8 +301,8 @@ overLocationLogsJournal v branchsha keyaction mclusters = changedlocs _ _ _ Nothing = pure (S.empty, S.empty) overLocationLogsHelper - :: ((RawFilePath -> Maybe Key) -> (Annex (FileContents Key b) -> Annex v) -> Annex a) - -> ((Maybe L.ByteString -> [UUID]) -> Key -> RawFilePath -> Maybe (L.ByteString, Maybe b) -> Annex u) + :: ((OsPath -> Maybe Key) -> (Annex (FileContents Key b) -> Annex v) -> Annex a) + -> ((Maybe L.ByteString -> [UUID]) -> Key -> OsPath -> Maybe (L.ByteString, Maybe b) -> Annex u) -> Bool -> v -> (Annex (FileContents Key b) -> Annex v -> Annex v) diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs index 746b72dfbd..b5650e0904 100644 --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -59,7 +59,7 @@ import qualified Data.ByteString.Lazy as L getCurrentMetaData :: Key -> Annex MetaData getCurrentMetaData = getCurrentMetaData' metaDataLogFile -getCurrentMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> Annex MetaData +getCurrentMetaData' :: (GitConfig -> Key -> OsPath) -> Key -> Annex MetaData getCurrentMetaData' getlogfile k = do config <- Annex.getGitConfig parseCurrentMetaData <$> Annex.Branch.get (getlogfile config k) @@ -101,7 +101,7 @@ getCurrentRemoteMetaData (RemoteStateHandle u) k = extractRemoteMetaData u <$> addMetaData :: Key -> MetaData -> Annex () addMetaData = addMetaData' (Annex.Branch.RegardingUUID []) metaDataLogFile -addMetaData' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex () +addMetaData' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> OsPath) -> Key -> MetaData -> Annex () addMetaData' ru getlogfile k metadata = addMetaDataClocked' ru getlogfile k metadata =<< currentVectorClock @@ -112,7 +112,7 @@ addMetaData' ru getlogfile k metadata = addMetaDataClocked :: Key -> MetaData -> CandidateVectorClock -> Annex () addMetaDataClocked = addMetaDataClocked' (Annex.Branch.RegardingUUID []) metaDataLogFile -addMetaDataClocked' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> CandidateVectorClock -> Annex () +addMetaDataClocked' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> OsPath) -> Key -> MetaData -> CandidateVectorClock -> Annex () addMetaDataClocked' ru getlogfile k d@(MetaData m) c | d == emptyMetaData = noop | otherwise = do @@ -160,5 +160,5 @@ copyMetaData oldkey newkey (const $ buildLog l) return True -readLog :: RawFilePath -> Annex (Log MetaData) +readLog :: OsPath -> Annex (Log MetaData) readLog = parseLog <$$> Annex.Branch.get diff --git a/Logs/Migrate.hs b/Logs/Migrate.hs index 63ace2f92e..07f7b39fa0 100644 --- a/Logs/Migrate.hs +++ b/Logs/Migrate.hs @@ -56,11 +56,10 @@ import Git.Log import Logs.File import Logs import Annex.CatFile +import qualified Utility.OsString as OS -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Control.Concurrent.STM -import System.FilePath.ByteString as P -- | What to use to record a migration. This should be the same Sha that is -- used to as the content of the annexed file in the HEAD branch. @@ -95,7 +94,7 @@ commitMigration = do n <- readTVar nv let !n' = succ n writeTVar nv n' - return (asTopFilePath (encodeBS (show n'))) + return (asTopFilePath (toOsPath (show n'))) let rec h r = liftIO $ sendMkTree h (fromTreeItemType TreeFile) BlobObject @@ -110,8 +109,8 @@ commitMigration = do n <- liftIO $ atomically $ readTVar nv when (n > 0) $ do treesha <- liftIO $ flip recordTree g $ Tree - [ RecordedSubTree (asTopFilePath "old") oldt [] - , RecordedSubTree (asTopFilePath "new") newt [] + [ RecordedSubTree (asTopFilePath (literalOsPath "old")) oldt [] + , RecordedSubTree (asTopFilePath (literalOsPath "new")) newt [] ] commitsha <- Annex.Branch.rememberTreeish treesha (asTopFilePath migrationTreeGraftPoint) @@ -129,7 +128,7 @@ streamNewDistributedMigrations incremental a = do (stoppoint, toskip) <- getPerformedMigrations (l, cleanup) <- inRepo $ getGitLog branchsha (if incremental then stoppoint else Nothing) - [fromRawFilePath migrationTreeGraftPoint] + [fromOsPath migrationTreeGraftPoint] -- Need to follow because migrate.tree is grafted in -- and then deleted, and normally git log stops when a file -- gets deleted. @@ -142,7 +141,7 @@ streamNewDistributedMigrations incremental a = do go toskip c | newref c `elem` nullShas = return () | changed c `elem` toskip = return () - | not ("/new/" `B.isInfixOf` newfile) = return () + | not (literalOsPath "/new/" `OS.isInfixOf` newfile) = return () | otherwise = catKey (newref c) >>= \case Nothing -> return () @@ -150,10 +149,10 @@ streamNewDistributedMigrations incremental a = do Nothing -> return () Just oldkey -> a oldkey newkey where - newfile = toRawFilePath (changedfile c) + newfile = changedfile c oldfile = migrationTreeGraftPoint - P. "old" - P. P.takeBaseName (fromInternalGitPath newfile) + literalOsPath "old" + takeBaseName (fromInternalGitPath newfile) oldfileref = branchFileRef (changed c) oldfile getPerformedMigrations :: Annex (Maybe Sha, [Sha]) diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs index e86347d375..0a19756f75 100644 --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -32,7 +32,7 @@ requiredContentSet u expr = do setLog requiredContentLog u expr Annex.changeState $ \st -> st { Annex.requiredcontentmap = Nothing } -setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex () +setLog :: OsPath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do c <- currentVectorClock Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) logfile $ diff --git a/Logs/Presence.hs b/Logs/Presence.hs index 810ce6462d..f459df9110 100644 --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -32,11 +32,11 @@ import Git.Types (RefDate) import qualified Data.ByteString.Lazy as L {- Adds to the log, removing any LogLines that are obsoleted. -} -addLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () +addLog :: Annex.Branch.RegardingUUID -> OsPath -> LogStatus -> LogInfo -> Annex () addLog ru file logstatus loginfo = addLog' ru file logstatus loginfo =<< currentVectorClock -addLog' :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> CandidateVectorClock -> Annex () +addLog' :: Annex.Branch.RegardingUUID -> OsPath -> LogStatus -> LogInfo -> CandidateVectorClock -> Annex () addLog' ru file logstatus loginfo c = Annex.Branch.changeOrAppend ru file $ \b -> let old = parseLog b @@ -53,7 +53,7 @@ addLog' ru file logstatus loginfo c = - When the log was changed, the onchange action is run (with the journal - still locked to prevent any concurrent changes) and True is returned. -} -maybeAddLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () -> Annex Bool +maybeAddLog :: Annex.Branch.RegardingUUID -> OsPath -> LogStatus -> LogInfo -> Annex () -> Annex Bool maybeAddLog ru file logstatus loginfo onchange = do c <- currentVectorClock let f = \b -> @@ -72,15 +72,15 @@ genLine logstatus loginfo c old = LogLine c' logstatus loginfo {- Reads a log file. - Note that the LogLines returned may be in any order. -} -readLog :: RawFilePath -> Annex [LogLine] +readLog :: OsPath -> Annex [LogLine] readLog = parseLog <$$> Annex.Branch.get {- Reads a log and returns only the info that is still present. -} -presentLogInfo :: RawFilePath -> Annex [LogInfo] +presentLogInfo :: OsPath -> Annex [LogInfo] presentLogInfo file = map info . filterPresent <$> readLog file {- Reads a log and returns only the info that is no longer present. -} -notPresentLogInfo :: RawFilePath -> Annex [LogInfo] +notPresentLogInfo :: OsPath -> Annex [LogInfo] notPresentLogInfo file = map info . filterNotPresent <$> readLog file {- Reads a historical version of a log and returns the info that was in @@ -88,7 +88,7 @@ notPresentLogInfo file = map info . filterNotPresent <$> readLog file - - The date is formatted as shown in gitrevisions man page. -} -historicalLogInfo :: RefDate -> RawFilePath -> Annex [LogInfo] +historicalLogInfo :: RefDate -> OsPath -> Annex [LogInfo] historicalLogInfo refdate file = parseLogInfo <$> Annex.Branch.getHistorical refdate file diff --git a/Logs/Restage.hs b/Logs/Restage.hs index dc9a35940c..3e3c439598 100644 --- a/Logs/Restage.hs +++ b/Logs/Restage.hs @@ -18,7 +18,6 @@ import qualified Utility.FileIO as F import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import qualified Utility.RawFilePath as R -- | Log a file whose pointer needs to be restaged in git. -- The content of the file may not be a pointer, if it is populated with @@ -52,13 +51,13 @@ streamRestageLog finalizer processor = do lckf <- fromRepo gitAnnexRestageLock withExclusiveLock lckf $ liftIO $ - whenM (R.doesPathExist logf) $ - ifM (R.doesPathExist oldf) + whenM (doesPathExist logf) $ + ifM (doesPathExist oldf) ( do - h <- F.openFile (toOsPath oldf) AppendMode - hPutStr h =<< readFile (fromRawFilePath logf) + h <- F.openFile oldf AppendMode + hPutStr h =<< readFile (fromOsPath logf) hClose h - liftIO $ removeWhenExistsWith R.removeLink logf + liftIO $ removeWhenExistsWith removeFile logf , moveFile logf oldf ) @@ -67,7 +66,7 @@ streamRestageLog finalizer processor = do Just (f, ic) -> processor f ic Nothing -> noop - liftIO $ removeWhenExistsWith R.removeLink oldf + liftIO $ removeWhenExistsWith removeFile oldf -- | Calculate over both the current restage log, and also over the old -- one if it had started to be processed but did not get finished due @@ -86,11 +85,12 @@ calcRestageLog start update = do Nothing -> v formatRestageLog :: TopFilePath -> InodeCache -> S.ByteString -formatRestageLog f ic = encodeBS (showInodeCache ic) <> ":" <> getTopFilePath f +formatRestageLog f ic = + encodeBS (showInodeCache ic) <> ":" <> fromOsPath (getTopFilePath f) parseRestageLog :: String -> Maybe (TopFilePath, InodeCache) parseRestageLog l = let (ics, f) = separate (== ':') l in do ic <- readInodeCache ics - return (asTopFilePath (toRawFilePath f), ic) + return (asTopFilePath (toOsPath f), ic) diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs index 7abcf14da8..6727fdd316 100644 --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -63,7 +63,7 @@ scheduleChange u a = scheduleSet u . S.toList . a =<< scheduleGet u getLastRunTimes :: Annex (M.Map ScheduledActivity LocalTime) getLastRunTimes = do - f <- fromRawFilePath <$> fromRepo gitAnnexScheduleState + f <- fromOsPath <$> fromRepo gitAnnexScheduleState liftIO $ fromMaybe M.empty <$> catchDefaultIO Nothing (readish <$> readFile f) diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs index 2018e73ee7..f46fbe5e28 100644 --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -27,13 +27,13 @@ import Annex.VectorClock import qualified Data.Set as S -readLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Log v) +readLog :: (Ord v, SingleValueSerializable v) => OsPath -> Annex (Log v) readLog = parseLog <$$> Annex.Branch.get -getLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Maybe v) +getLog :: (Ord v, SingleValueSerializable v) => OsPath -> Annex (Maybe v) getLog = newestValue <$$> readLog -setLog :: (Ord v, SingleValueSerializable v) => Annex.Branch.RegardingUUID -> RawFilePath -> v -> Annex () +setLog :: (Ord v, SingleValueSerializable v) => Annex.Branch.RegardingUUID -> OsPath -> v -> Annex () setLog ru f v = do c <- currentVectorClock Annex.Branch.change ru f $ \old -> diff --git a/Logs/Smudge.hs b/Logs/Smudge.hs index 5a667ec826..57493bdbdf 100644 --- a/Logs/Smudge.hs +++ b/Logs/Smudge.hs @@ -21,7 +21,7 @@ smudgeLog k f = do logf <- fromRepo gitAnnexSmudgeLog lckf <- fromRepo gitAnnexSmudgeLock appendLogFile logf lckf $ L.fromStrict $ - serializeKey' k <> " " <> getTopFilePath f + serializeKey' k <> " " <> fromOsPath (getTopFilePath f) -- | Streams all smudged files, and then empties the log at the end. -- @@ -43,4 +43,4 @@ streamSmudged a = do let (ks, f) = separate (== ' ') l in do k <- deserializeKey ks - return (k, asTopFilePath (toRawFilePath f)) + return (k, asTopFilePath (toOsPath f)) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 6ddd9350b2..85a5f7b824 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -21,8 +21,8 @@ import Utility.PID import Annex.LockPool import Utility.TimeStamp import Logs.File -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F +import qualified Utility.OsString as OS #ifndef mingw32_HOST_OS import Annex.Perms #endif @@ -30,9 +30,6 @@ import Annex.Perms import Data.Time.Clock import Data.Time.Clock.POSIX import Control.Concurrent.STM -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified System.FilePath.ByteString as P describeTransfer :: Git.Quote.QuotePath -> Transfer -> TransferInfo -> String describeTransfer qp t info = unwords @@ -62,20 +59,21 @@ percentComplete t info = - appropriate permissions, which should be run after locking the transfer - lock file, but before using the callback, and a TVar that can be used to - read the number of bytes processed so far. -} -mkProgressUpdater :: Transfer -> TransferInfo -> RawFilePath -> Annex (MeterUpdate, Annex (), TVar (Maybe BytesProcessed)) +mkProgressUpdater :: Transfer -> TransferInfo -> OsPath -> Annex (MeterUpdate, Annex (), TVar (Maybe BytesProcessed)) mkProgressUpdater t info tfile = do - let createtfile = void $ tryNonAsync $ writeTransferInfoFile info tfile + let createtfile = void $ tryNonAsync $ + writeTransferInfoFile info tfile tvar <- liftIO $ newTVarIO Nothing loggedtvar <- liftIO $ newTVarIO 0 - return (liftIO . updater (fromRawFilePath tfile) tvar loggedtvar, createtfile, tvar) + return (liftIO . updater tvar loggedtvar, createtfile, tvar) where - updater tfile' tvar loggedtvar new = do + updater tvar loggedtvar new = do old <- atomically $ swapTVar tvar (Just new) let oldbytes = maybe 0 fromBytesProcessed old let newbytes = fromBytesProcessed new when (newbytes - oldbytes >= mindelta) $ do let info' = info { bytesComplete = Just newbytes } - _ <- tryIO $ updateTransferInfoFile info' tfile' + _ <- tryIO $ updateTransferInfoFile info' tfile atomically $ writeTVar loggedtvar newbytes {- The minimum change in bytesComplete that is worth @@ -109,9 +107,9 @@ checkTransfer :: Transfer -> Annex (Maybe TransferInfo) checkTransfer t = debugLocks $ do (tfile, lck, moldlck) <- fromRepo $ transferFileAndLockFile t let deletestale = do - void $ tryIO $ R.removeLink tfile - void $ tryIO $ R.removeLink lck - maybe noop (void . tryIO . R.removeLink) moldlck + void $ tryIO $ removeFile tfile + void $ tryIO $ removeFile lck + maybe noop (void . tryIO . removeFile) moldlck #ifndef mingw32_HOST_OS v <- getLockStatus lck v' <- case (moldlck, v) of @@ -198,7 +196,7 @@ clearFailedTransfers u = do removeFailedTransfer :: Transfer -> Annex () removeFailedTransfer t = do f <- fromRepo $ failedTransferFile t - liftIO $ void $ tryIO $ R.removeLink f + liftIO $ void $ tryIO $ removeFile f recordFailedTransfer :: Transfer -> TransferInfo -> Annex () recordFailedTransfer t info = do @@ -225,46 +223,47 @@ recordFailedTransfer t info = do - At some point in the future, when old git-annex processes are no longer - a concern, this complication can be removed. -} -transferFileAndLockFile :: Transfer -> Git.Repo -> (RawFilePath, RawFilePath, Maybe RawFilePath) +transferFileAndLockFile :: Transfer -> Git.Repo -> (OsPath, OsPath, Maybe OsPath) transferFileAndLockFile (Transfer direction u kd) r = case direction of Upload -> (transferfile, uuidlockfile, Nothing) Download -> (transferfile, nouuidlockfile, Just uuidlockfile) where td = transferDir direction r - fu = B8.filter (/= '/') (fromUUID u) + fu = OS.filter (/= unsafeFromChar '/') (fromUUID u) kf = keyFile (mkKey (const kd)) - lckkf = "lck." <> kf - transferfile = td P. fu P. kf - uuidlockfile = td P. fu P. lckkf - nouuidlockfile = td P. "lck" P. lckkf + lckkf = literalOsPath "lck." <> kf + transferfile = td fu kf + uuidlockfile = td fu lckkf + nouuidlockfile = td literalOsPath "lck" lckkf {- The transfer information file to use to record a failed Transfer -} -failedTransferFile :: Transfer -> Git.Repo -> RawFilePath +failedTransferFile :: Transfer -> Git.Repo -> OsPath failedTransferFile (Transfer direction u kd) r = failedTransferDir u direction r - P. keyFile (mkKey (const kd)) + keyFile (mkKey (const kd)) {- Parses a transfer information filename to a Transfer. -} -parseTransferFile :: RawFilePath -> Maybe Transfer +parseTransferFile :: OsPath -> Maybe Transfer parseTransferFile file - | "lck." `B.isPrefixOf` P.takeFileName file = Nothing + | literalOsPath "lck." `OS.isPrefixOf` takeFileName file = Nothing | otherwise = case drop (length bits - 3) bits of [direction, u, key] -> Transfer - <$> parseDirection direction + <$> parseDirection (fromOsPath direction) <*> pure (toUUID u) <*> fmap (fromKey id) (fileKey key) _ -> Nothing where - bits = P.splitDirectories file + bits = splitDirectories file -writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex () +writeTransferInfoFile :: TransferInfo -> OsPath -> Annex () writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info -- The file keeps whatever permissions it has, so should be used only -- after it's been created with the right perms by writeTransferInfoFile. -updateTransferInfoFile :: TransferInfo -> FilePath -> IO () -updateTransferInfoFile info tfile = writeFile tfile $ writeTransferInfo info +updateTransferInfoFile :: TransferInfo -> OsPath -> IO () +updateTransferInfoFile info tfile = + writeFile (fromOsPath tfile) $ writeTransferInfo info {- File format is a header line containing the startedTime and any - bytesComplete value. Followed by a newline and the associatedFile. @@ -283,12 +282,12 @@ writeTransferInfo info = unlines #endif -- comes last; arbitrary content , let AssociatedFile afile = associatedFile info - in maybe "" fromRawFilePath afile + in maybe "" fromOsPath afile ] -readTransferInfoFile :: Maybe PID -> RawFilePath -> IO (Maybe TransferInfo) +readTransferInfoFile :: Maybe PID -> OsPath -> IO (Maybe TransferInfo) readTransferInfoFile mpid tfile = catchDefaultIO Nothing $ - readTransferInfo mpid . decodeBS <$> F.readFile' (toOsPath tfile) + readTransferInfo mpid . decodeBS <$> F.readFile' tfile readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo readTransferInfo mpid s = TransferInfo @@ -301,15 +300,18 @@ readTransferInfo mpid s = TransferInfo <*> pure Nothing <*> pure Nothing <*> bytes - <*> pure (AssociatedFile (if null filename then Nothing else Just (toRawFilePath filename))) + <*> pure af <*> pure False where + af = AssociatedFile $ + if null filename + then Nothing + else Just (toOsPath filename) #ifdef mingw32_HOST_OS (firstliner, otherlines) = separate (== '\n') s (secondliner, rest) = separate (== '\n') otherlines firstline = dropWhileEnd (== '\r') firstliner secondline = dropWhileEnd (== '\r') secondliner - secondline = mpid' = readish secondline #else (firstline, rest) = separate (== '\n') s @@ -327,16 +329,18 @@ readTransferInfo mpid s = TransferInfo else pure Nothing -- not failure {- The directory holding transfer information files for a given Direction. -} -transferDir :: Direction -> Git.Repo -> RawFilePath -transferDir direction r = gitAnnexTransferDir r P. formatDirection direction +transferDir :: Direction -> Git.Repo -> OsPath +transferDir direction r = + gitAnnexTransferDir r + toOsPath (formatDirection direction) {- The directory holding failed transfer information files for a given - Direction and UUID -} -failedTransferDir :: UUID -> Direction -> Git.Repo -> RawFilePath +failedTransferDir :: UUID -> Direction -> Git.Repo -> OsPath failedTransferDir u direction r = gitAnnexTransferDir r - P. "failed" - P. formatDirection direction - P. B8.filter (/= '/') (fromUUID u) + literalOsPath "failed" + toOsPath (formatDirection direction) + OS.filter (/= unsafeFromChar '/') (fromUUID u) prop_read_write_transferinfo :: TransferInfo -> Bool prop_read_write_transferinfo info diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs index c352709c0f..5846b4ffd3 100644 --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -32,8 +32,8 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 -transitionsLog :: RawFilePath -transitionsLog = "transitions.log" +transitionsLog :: OsPath +transitionsLog = literalOsPath "transitions.log" data Transition = ForgetGitHistory @@ -102,7 +102,7 @@ knownTransitionList = nub . rights . map transition . S.elems {- Typically ran with Annex.Branch.change, but we can't import Annex.Branch - here since it depends on this module. -} -recordTransitions :: (RawFilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () +recordTransitions :: (OsPath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () recordTransitions changer t = changer transitionsLog $ buildTransitions . S.union t . parseTransitionsStrictly "local" diff --git a/Logs/Unused.hs b/Logs/Unused.hs index fa2b2ce3cc..4b3ad4f0f6 100644 --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -58,13 +58,13 @@ preserveTimestamps oldl newl = M.intersection (M.unionWith oldts oldl newl) newl where oldts _old@(_, ts) _new@(int, _) = (int, ts) -updateUnusedLog :: RawFilePath -> UnusedMap -> Annex () +updateUnusedLog :: OsPath -> UnusedMap -> Annex () updateUnusedLog prefix m = do oldl <- readUnusedLog prefix newl <- preserveTimestamps oldl . flip map2log m <$> liftIO getPOSIXTime writeUnusedLog prefix newl -writeUnusedLog :: RawFilePath -> UnusedLog -> Annex () +writeUnusedLog :: OsPath -> UnusedLog -> Annex () writeUnusedLog prefix l = do logfile <- fromRepo $ gitAnnexUnusedLog prefix writeLogFile logfile $ unlines $ map format $ M.toList l @@ -72,12 +72,12 @@ writeUnusedLog prefix l = do format (k, (i, Just t)) = show i ++ " " ++ serializeKey k ++ " " ++ show t format (k, (i, Nothing)) = show i ++ " " ++ serializeKey k -readUnusedLog :: RawFilePath -> Annex UnusedLog +readUnusedLog :: OsPath -> Annex UnusedLog readUnusedLog prefix = do f <- fromRepo (gitAnnexUnusedLog prefix) - ifM (liftIO $ doesFileExist (fromRawFilePath f)) + ifM (liftIO $ doesFileExist f) ( M.fromList . mapMaybe (parse . decodeBS) . fileLines' - <$> liftIO (F.readFile' (toOsPath f)) + <$> liftIO (F.readFile' f) , return M.empty ) where @@ -90,13 +90,13 @@ readUnusedLog prefix = do skey = reverse rskey ts = reverse rts -readUnusedMap :: RawFilePath -> Annex UnusedMap +readUnusedMap :: OsPath -> Annex UnusedMap readUnusedMap = log2map <$$> readUnusedLog -dateUnusedLog :: RawFilePath -> Annex (Maybe UTCTime) +dateUnusedLog :: OsPath -> Annex (Maybe UTCTime) dateUnusedLog prefix = do f <- fromRepo $ gitAnnexUnusedLog prefix - liftIO $ catchMaybeIO $ getModificationTime $ fromRawFilePath f + liftIO $ catchMaybeIO $ getModificationTime f {- Set of unused keys. This is cached for speed. -} unusedKeys :: Annex (S.Set Key) @@ -104,7 +104,7 @@ unusedKeys = maybe (setUnusedKeys =<< unusedKeys') return =<< Annex.getState Annex.unusedkeys unusedKeys' :: Annex [Key] -unusedKeys' = M.keys <$> readUnusedLog "" +unusedKeys' = M.keys <$> readUnusedLog (literalOsPath "") setUnusedKeys :: [Key] -> Annex (S.Set Key) setUnusedKeys ks = do diff --git a/Logs/Upgrade.hs b/Logs/Upgrade.hs index bc63e0021f..f40d93004d 100644 --- a/Logs/Upgrade.hs +++ b/Logs/Upgrade.hs @@ -33,9 +33,9 @@ writeUpgradeLog v t = do readUpgradeLog :: Annex [(RepoVersion, POSIXTime)] readUpgradeLog = do logfile <- fromRepo gitAnnexUpgradeLog - ifM (liftIO $ doesFileExist (fromRawFilePath logfile)) + ifM (liftIO $ doesFileExist logfile) ( mapMaybe (parse . decodeBS) . fileLines' - <$> liftIO (F.readFile' (toOsPath logfile)) + <$> liftIO (F.readFile' logfile) , return [] ) where diff --git a/Logs/View.hs b/Logs/View.hs index afb036c202..14ee8dcd37 100644 --- a/Logs/View.hs +++ b/Logs/View.hs @@ -54,7 +54,7 @@ removeView v = writeViews =<< filter (/= v) <$> recentViews recentViews :: Annex [View] recentViews = do - f <- fromRawFilePath <$> fromRepo gitAnnexViewLog + f <- fromOsPath <$> fromRepo gitAnnexViewLog liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f) {- Gets the currently checked out view, if there is one. diff --git a/Messages.hs b/Messages.hs index b989d1dd8b..704d5cfeac 100644 --- a/Messages.hs +++ b/Messages.hs @@ -190,7 +190,7 @@ endResult False = "failed" toplevelMsg :: (Semigroup t, IsString t) => t -> t toplevelMsg s = fromString "git-annex: " <> s -toplevelFileProblem :: Bool -> MessageId -> StringContainingQuotedPath -> String -> RawFilePath -> Maybe Key -> SeekInput -> Annex () +toplevelFileProblem :: Bool -> MessageId -> StringContainingQuotedPath -> String -> OsPath -> Maybe Key -> SeekInput -> Annex () toplevelFileProblem makeway messageid msg action file mkey si = do maybeShowJSON' $ JSON.start action (Just file) mkey si maybeShowJSON' $ JSON.messageid messageid diff --git a/Messages/JSON.hs b/Messages/JSON.hs index 70032d9b9c..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 @@ -50,7 +51,7 @@ import Key import Utility.Metered import Utility.Percentage import Utility.Aeson -import Utility.FileSystemEncoding +import Utility.OsPath import Types.Messages -- A global lock to avoid concurrent threads emitting json at the same time. @@ -76,7 +77,7 @@ type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool) none :: JSONBuilder none = id -start :: String -> Maybe RawFilePath -> Maybe Key -> SeekInput -> JSONBuilder +start :: String -> Maybe OsPath -> Maybe Key -> SeekInput -> JSONBuilder start command file key si _ = case j of Object o -> Just (o, False) _ -> Nothing @@ -84,7 +85,7 @@ start command file key si _ = case j of j = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = key - , itemFile = fromRawFilePath <$> 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 = fromRawFilePath <$> 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/Messages/Progress.hs b/Messages/Progress.hs index c726149d18..5d5e818d3b 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -55,7 +55,7 @@ instance MeterSize KeySource where - This allows uploads of keys without size to still have progress - displayed. -} -data KeySizer = KeySizer Key (Annex (Maybe RawFilePath)) +data KeySizer = KeySizer Key (Annex (Maybe OsPath)) instance MeterSize KeySizer where getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of @@ -171,7 +171,7 @@ metered' st setclear othermeterupdate msize bwlimit showoutput a = go st minratelimit = min consoleratelimit jsonratelimit {- Poll file size to display meter. -} -meteredFile :: RawFilePath -> Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a +meteredFile :: OsPath -> Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a meteredFile file combinemeterupdate key a = metered combinemeterupdate key Nothing $ \_ p -> watchFileSize file p a diff --git a/P2P/Address.hs b/P2P/Address.hs index a7b3c6db07..1a3186aca9 100644 --- a/P2P/Address.hs +++ b/P2P/Address.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module P2P.Address where import qualified Annex @@ -75,24 +77,24 @@ storeP2PAddress addr = do addrs <- loadP2PAddresses unless (addr `elem` addrs) $ do let s = unlines $ map formatP2PAddress (addr:addrs) - let tmpnam = p2pAddressCredsFile ++ ".new" + let tmpnam = p2pAddressCredsFile <> literalOsPath ".new" writeCreds s tmpnam tmpf <- credsFile tmpnam destf <- credsFile p2pAddressCredsFile -- This may be run by root, so make the creds file -- and directory have the same owner and group as -- the git repository directory has. - st <- liftIO . R.getFileStatus . toRawFilePath - =<< Annex.fromRepo repoLocation - let fixowner f = R.setOwnerAndGroup (toRawFilePath f) (fileOwner st) (fileGroup st) + st <- liftIO . R.getFileStatus . fromOsPath + =<< Annex.fromRepo repoPath + let fixowner f = R.setOwnerAndGroup (fromOsPath f) (fileOwner st) (fileGroup st) liftIO $ do fixowner tmpf fixowner (takeDirectory tmpf) fixowner (takeDirectory (takeDirectory tmpf)) renameFile tmpf destf -p2pAddressCredsFile :: FilePath -p2pAddressCredsFile = "p2paddrs" +p2pAddressCredsFile :: OsPath +p2pAddressCredsFile = literalOsPath "p2paddrs" torAppName :: AppName torAppName = "tor-annex" diff --git a/P2P/Annex.hs b/P2P/Annex.hs index c4328547a2..a6beb64eb3 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -18,13 +18,14 @@ import Annex.Common import Annex.Content import Annex.Transfer import Annex.ChangedRefs +import Annex.Verify import P2P.Protocol import P2P.IO import Logs.Location import Types.NumCopies import Utility.Metered import Utility.MonotonicClock -import Annex.Verify +import qualified Utility.FileIO as F import Control.Monad.Free import Control.Concurrent.STM @@ -46,7 +47,7 @@ runLocal runst runner a = case a of size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp runner (next (Len size)) FileSize f next -> do - size <- liftIO $ catchDefaultIO 0 $ getFileSize (toRawFilePath f) + size <- liftIO $ catchDefaultIO 0 $ getFileSize f runner (next (Len size)) ContentSize k next -> do let getsize = liftIO . catchMaybeIO . getFileSize @@ -81,7 +82,7 @@ runLocal runst runner a = case a of let runtransfer ti = Right <$> transfer download' k af Nothing (\p -> logStatusAfter NoLiveUpdate k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp -> - storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti) + storefile tmp o l getb iv validitycheck p ti) let fallback = return $ Left $ ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" checktransfer runtransfer fallback @@ -194,13 +195,13 @@ runLocal runst runner a = case a of v <- runner getb case v of Right b -> do - liftIO $ withBinaryFile dest ReadWriteMode $ \h -> do + liftIO $ F.withBinaryFile dest ReadWriteMode $ \h -> do p' <- resumeVerifyFromOffset o incrementalverifier p h meteredWrite p' (writeVerifyChunk incrementalverifier h) b indicatetransferred ti rightsize <- do - sz <- liftIO $ getFileSize (toRawFilePath dest) + sz <- liftIO $ getFileSize dest return (toInteger sz == l + o) runner validitycheck >>= \case @@ -210,7 +211,7 @@ runLocal runst runner a = case a of Nothing -> return (True, UnVerified) Just True -> return (True, Verified) Just False -> do - verificationOfContentFailed (toRawFilePath dest) + verificationOfContentFailed dest return (False, UnVerified) | otherwise -> return (False, UnVerified) Nothing -> return (rightsize, UnVerified) @@ -232,7 +233,7 @@ runLocal runst runner a = case a of sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go where - setup = liftIO $ openBinaryFile f ReadMode + setup = liftIO $ F.openBinaryFile f ReadMode cleanup = liftIO . hClose go h = do let p' = offsetMeterUpdate p (toBytesProcessed o) diff --git a/P2P/Auth.hs b/P2P/Auth.hs index 346b781b37..20a8ce460d 100644 --- a/P2P/Auth.hs +++ b/P2P/Auth.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module P2P.Auth where import Annex.Common @@ -35,8 +37,8 @@ storeP2PAuthToken t = do let d = unlines $ map (T.unpack . fromAuthToken) (t:ts) writeCreds d p2pAuthCredsFile -p2pAuthCredsFile :: FilePath -p2pAuthCredsFile = "p2pauth" +p2pAuthCredsFile :: OsPath +p2pAuthCredsFile = literalOsPath "p2pauth" -- | Loads the AuthToken to use when connecting with a given P2P address. -- @@ -59,8 +61,9 @@ storeP2PRemoteAuthToken addr t = writeCreds (T.unpack $ fromAuthToken t) (addressCredsFile addr) -addressCredsFile :: P2PAddress -> FilePath +addressCredsFile :: P2PAddress -> OsPath -- We can omit the port and just use the onion address for the creds file, -- because any given tor hidden service runs on a single port and has a -- unique onion address. -addressCredsFile (TorAnnex (OnionAddress onionaddr) _port) = onionaddr +addressCredsFile (TorAnnex (OnionAddress onionaddr) _port) = + toOsPath onionaddr diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs index 7e40419beb..bfaa14bc89 100644 --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -37,6 +37,7 @@ import Annex.Concurrent import Utility.Url (BasicAuth(..)) import Utility.HumanTime import Utility.STM +import qualified Utility.FileIO as F import qualified Git.Credential as Git import Servant hiding (BasicAuthData(..)) @@ -340,7 +341,7 @@ clientPut -> Key -> Maybe Offset -> AssociatedFile - -> FilePath + -> OsPath -> FileSize -> Annex Bool -- ^ Called after sending the file to check if it's valid. @@ -358,7 +359,7 @@ clientPut meterupdate k moffset af contentfile contentfilesize validitycheck dat liftIO $ atomically $ takeTMVar checkv validitycheck >>= liftIO . atomically . putTMVar checkresultv checkerthread <- liftIO . async =<< forkState checker - v <- liftIO $ withBinaryFile contentfile ReadMode $ \h -> do + v <- liftIO $ F.withBinaryFile contentfile ReadMode $ \h -> do when (offset /= 0) $ hSeek h AbsoluteSeek offset withClientM (cli (stream h checkv checkresultv)) clientenv return diff --git a/P2P/Http/Types.hs b/P2P/Http/Types.hs index 3faabad475..5da418416f 100644 --- a/P2P/Http/Types.hs +++ b/P2P/Http/Types.hs @@ -52,7 +52,7 @@ instance APIVersion V0 where protocolVersion _ = P2P.ProtocolVersion 0 newtype B64Key = B64Key Key deriving (Show) -newtype B64FilePath = B64FilePath RawFilePath +newtype B64FilePath = B64FilePath OsPath deriving (Show) associatedFileToB64FilePath :: AssociatedFile -> Maybe B64FilePath @@ -233,11 +233,11 @@ instance FromHttpApiData (B64UUID t) where Left err -> Left err instance ToHttpApiData B64FilePath where - toUrlPiece (B64FilePath f) = encodeB64Text f + toUrlPiece (B64FilePath f) = encodeB64Text (fromOsPath f) instance FromHttpApiData B64FilePath where parseUrlPiece t = case decodeB64Text t of - Right b -> Right (B64FilePath b) + Right b -> Right (B64FilePath (toOsPath b)) Left err -> Left err instance ToHttpApiData Offset where diff --git a/P2P/IO.hs b/P2P/IO.hs index 025c52da9f..611f6982cf 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -42,7 +42,6 @@ import Utility.Debug import Utility.MonotonicClock import Types.UUID import Annex.ChangedRefs -import qualified Utility.RawFilePath as R import Control.Monad.Free import Control.Monad.IO.Class @@ -162,11 +161,11 @@ closeConnection conn = do -- Note that while the callback is running, other connections won't be -- processed, so longterm work should be run in a separate thread by -- the callback. -serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO () +serveUnixSocket :: OsPath -> (Handle -> IO ()) -> IO () serveUnixSocket unixsocket serveconn = do - removeWhenExistsWith R.removeLink (toRawFilePath unixsocket) + removeWhenExistsWith removeFile unixsocket soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol - S.bind soc (S.SockAddrUnix unixsocket) + S.bind soc (S.SockAddrUnix (fromOsPath unixsocket)) -- Allow everyone to read and write to the socket, -- so a daemon like tor, that is probably running as a different -- de sock $ addModes @@ -175,7 +174,7 @@ serveUnixSocket unixsocket serveconn = do -- Connections have to authenticate to do anything, -- so it's fine that other local users can connect to the -- socket. - modifyFileMode (toRawFilePath unixsocket) $ addModes + modifyFileMode unixsocket $ addModes [groupReadMode, groupWriteMode, otherReadMode, otherWriteMode] S.listen soc 2 forever $ do @@ -381,7 +380,7 @@ runRelayService conn runner service = case connRepo conn of serviceproc repo = gitCreateProcess [ Param cmd - , File (fromRawFilePath (repoPath repo)) + , File (fromOsPath (repoPath repo)) ] repo serviceproc' repo = (serviceproc repo) { std_out = CreatePipe diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index db461382ef..8eb602d00b 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -10,6 +10,7 @@ {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module P2P.Protocol where @@ -25,8 +26,9 @@ import Utility.AuthToken import Utility.Applicative import Utility.PartialPrelude import Utility.Metered -import Utility.FileSystemEncoding import Utility.MonotonicClock +import Utility.OsPath +import qualified Utility.OsString as OS import Git.FilePath import Annex.ChangedRefs (ChangedRefs) import Types.NumCopies @@ -37,8 +39,6 @@ import Control.Monad.Free.TH import Control.Monad.Catch import System.Exit (ExitCode(..)) import System.IO -import qualified System.FilePath.ByteString as P -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Set as S import Data.Char @@ -224,17 +224,19 @@ instance Proto.Serializable Service where instance Proto.Serializable ProtoAssociatedFile where serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = "" serialize (ProtoAssociatedFile (AssociatedFile (Just af))) = - decodeBS $ toInternalGitPath $ encodeBS $ concatMap esc $ fromRawFilePath af + fromOsPath $ toInternalGitPath $ + OS.concat $ map esc $ OS.unpack af where - esc '%' = "%%" - esc c - | isSpace c = "%" - | otherwise = [c] + esc c = case OS.toChar c of + '%' -> literalOsPath "%%" + c' | isSpace c' -> literalOsPath "%" + _ -> OS.singleton c - deserialize s = case fromInternalGitPath $ toRawFilePath $ deesc [] s of + deserialize s = case fromInternalGitPath $ toOsPath $ deesc [] s of f - | B.null f -> Just $ ProtoAssociatedFile $ AssociatedFile Nothing - | P.isRelative f -> Just $ ProtoAssociatedFile $ + | OS.null f -> Just $ ProtoAssociatedFile $ + AssociatedFile Nothing + | isRelative f -> Just $ ProtoAssociatedFile $ AssociatedFile $ Just f | otherwise -> Nothing where @@ -291,12 +293,12 @@ data LocalF c = TmpContentSize Key (Len -> c) -- ^ Gets size of the temp file where received content may have -- been stored. If not present, returns 0. - | FileSize FilePath (Len -> c) + | FileSize OsPath (Len -> c) -- ^ Gets size of the content of a file. If not present, returns 0. | ContentSize Key (Maybe Len -> c) -- ^ Gets size of the content of a key, when the full content is -- present. - | ReadContent Key AssociatedFile (Maybe FilePath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c) + | ReadContent Key AssociatedFile (Maybe OsPath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c) -- ^ Reads the content of a key and sends it to the callback. -- Must run the callback, or terminate the protocol connection. -- @@ -321,7 +323,7 @@ data LocalF c -- Note: The ByteString may not contain the entire remaining content -- of the key. Only once the temp file size == Len has the whole -- content been transferred. - | StoreContentTo FilePath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c) + | StoreContentTo OsPath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c) -- ^ Like StoreContent, but stores the content to a temp file. | SendContentWith (L.ByteString -> Annex (Maybe Validity -> Annex Bool)) (Proto L.ByteString) (Proto (Maybe Validity)) (Bool -> c) -- ^ Reads content from the Proto L.ByteString and sends it to the @@ -479,7 +481,7 @@ removeBeforeRemoteEndTime remoteendtime key = do REMOVE_BEFORE remoteendtime key checkSuccessFailurePlus -get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) +get :: OsPath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) get dest key iv af m p = receiveContent (Just m) p sizer storer noothermessages $ \offset -> GET offset (ProtoAssociatedFile af) key @@ -725,7 +727,7 @@ checkCONNECTServerMode service servermode a = (ServeReadOnly, UploadPack) -> a Nothing (ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError) -sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID]) +sendContent :: Key -> AssociatedFile -> Maybe OsPath -> Offset -> MeterUpdate -> Proto (Maybe [UUID]) sendContent key af o offset@(Offset n) p = go =<< local (contentSize key) where go (Just (Len totallen)) = do diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 48f0f0de77..41f815fb0e 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -25,6 +25,7 @@ import Utility.Metered import Types.ProposedAccepted import Annex.SpecialRemote.Config import Annex.Verify +import qualified Utility.OsString as OS import qualified Data.Map as M import qualified System.FilePath.Posix as Posix @@ -34,7 +35,7 @@ newtype AndroidSerial = AndroidSerial { fromAndroidSerial :: String } deriving (Show, Eq) -- | A location on an Android device. -newtype AndroidPath = AndroidPath { fromAndroidPath :: FilePath } +newtype AndroidPath = AndroidPath { fromAndroidPath :: Posix.FilePath } remote :: RemoteType remote = specialRemoteType $ RemoteType @@ -182,20 +183,20 @@ store serial adir = fileStorer $ \k src _p -> in unlessM (store' serial dest src) $ giveup "adb failed" -store' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool +store' :: AndroidSerial -> AndroidPath -> OsPath -> Annex Bool store' serial dest src = checkAdbInPath False $ do - let destdir = takeDirectory $ fromAndroidPath dest + let destdir = Posix.takeDirectory $ fromAndroidPath dest void $ adbShell serial [Param "mkdir", Param "-p", File destdir] showOutput -- make way for adb push output liftIO $ boolSystem "adb" $ mkAdbCommand serial - [Param "push", File src, File (fromAndroidPath dest)] + [Param "push", File (fromOsPath src), File (fromAndroidPath dest)] retrieve :: AndroidSerial -> AndroidPath -> Retriever retrieve serial adir = fileRetriever $ \dest k _p -> let src = androidLocation adir k - in retrieve' serial src (fromRawFilePath dest) + in retrieve' serial src dest -retrieve' :: AndroidSerial -> AndroidPath -> FilePath -> Annex () +retrieve' :: AndroidSerial -> AndroidPath -> OsPath -> Annex () retrieve' serial src dest = unlessM go $ giveup "adb pull failed" @@ -206,7 +207,7 @@ retrieve' serial src dest = [ Param "pull" , Param "-a" , File $ fromAndroidPath src - , File dest + , File $ fromOsPath dest ] remove :: AndroidSerial -> AndroidPath -> Remover @@ -240,21 +241,22 @@ androidLocation adir k = AndroidPath $ androidHashDir :: AndroidPath -> Key -> AndroidPath androidHashDir adir k = AndroidPath $ - fromAndroidPath adir ++ "/" ++ hdir + fromAndroidPath adir ++ "/" ++ fromOsPath hdir where - hdir = replace [pathSeparator] "/" (fromRawFilePath (hashDirLower def k)) + hdir = OS.intercalate (literalOsPath "/") $ OS.split pathSeparator $ + hashDirLower def k -storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM :: AndroidSerial -> AndroidPath -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM serial adir src _k loc _p = unlessM (store' serial dest src) $ giveup "adb failed" where dest = androidExportLocation adir loc -retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retrieveExportM serial adir k loc dest _p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> - tailVerify iv (toRawFilePath dest) $ + tailVerify iv dest $ retrieve' serial src dest where src = androidExportLocation adir loc @@ -342,7 +344,7 @@ listImportableContentsM serial adir c = adbfind >>= \case let (stat, fn) = separate (== '\t') l sz = fromMaybe 0 (readish (takeWhile (/= ' ') stat)) cid = ContentIdentifier (encodeBS stat) - loc = mkImportLocation $ toRawFilePath $ + loc = mkImportLocation $ toOsPath $ Posix.makeRelative (fromAndroidPath adir) fn in Just (loc, (cid, sz)) mk _ = Nothing @@ -351,7 +353,7 @@ listImportableContentsM serial adir c = adbfind >>= \case -- connection is reasonably fast, it's probably as good as -- git's handling of similar situations with files being modified while -- it's updating the working tree for a merge. -retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) +retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) retrieveExportWithContentIdentifierM serial adir loc cids dest gk _p = do case gk of Right mkkey -> do @@ -360,7 +362,7 @@ retrieveExportWithContentIdentifierM serial adir loc cids dest gk _p = do return (k, UnVerified) Left k -> do v <- verifyKeyContentIncrementally DefaultVerify k - (\iv -> tailVerify iv (toRawFilePath dest) go) + (\iv -> tailVerify iv dest go) return (k, v) where go = do @@ -371,7 +373,7 @@ retrieveExportWithContentIdentifierM serial adir loc cids dest gk _p = do _ -> giveup "the file on the android device has changed" src = androidExportLocation adir loc -storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p = ifM checkcanoverwrite ( ifM (store' serial dest src) @@ -410,7 +412,7 @@ checkPresentExportWithContentIdentifierM serial adir _k loc knowncids = androidExportLocation :: AndroidPath -> ExportLocation -> AndroidPath androidExportLocation adir loc = AndroidPath $ - fromAndroidPath adir ++ "/" ++ fromRawFilePath (fromExportLocation loc) + fromAndroidPath adir ++ "/" ++ fromOsPath (fromExportLocation loc) -- | List all connected Android devices. enumerateAdbConnected :: Annex [AndroidSerial] diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 6d3599764f..5b7a1d6c84 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -31,12 +31,9 @@ import Annex.UUID import qualified Annex.Url as Url import Remote.Helper.ExportImport import Annex.SpecialRemote.Config -import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS import Network.URI -import qualified System.FilePath.ByteString as P -import qualified Data.ByteString as S - #ifdef WITH_TORRENTPARSER import Data.Torrent import qualified Utility.FileIO as F @@ -101,7 +98,7 @@ gen r _ rc gc rs = do , remoteStateHandle = rs } -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification downloadKey key _file dest p _ = do get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key -- While bittorrent verifies the hash in the torrent file, @@ -122,7 +119,7 @@ downloadKey key _file dest p _ = do unless ok $ get [] -uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +uploadKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () uploadKey _ _ _ _ = giveup "upload to bittorrent not supported" dropKey :: Maybe SafeDropProof -> Key -> Annex () @@ -180,7 +177,7 @@ torrentUrlKey :: URLString -> Annex Key torrentUrlKey u = return $ fromUrl (fst $ torrentUrlNum u) Nothing False {- Temporary filename to use to store the torrent file. -} -tmpTorrentFile :: URLString -> Annex RawFilePath +tmpTorrentFile :: URLString -> Annex OsPath tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u {- A cleanup action is registered to delete the torrent file @@ -192,13 +189,13 @@ tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u -} registerTorrentCleanup :: URLString -> Annex () registerTorrentCleanup u = Annex.addCleanupAction (TorrentCleanup u) $ - liftIO . removeWhenExistsWith R.removeLink =<< tmpTorrentFile u + liftIO . removeWhenExistsWith removeFile =<< tmpTorrentFile u {- Downloads the torrent file. (Not its contents.) -} downloadTorrentFile :: URLString -> Annex Bool downloadTorrentFile u = do torrent <- tmpTorrentFile u - ifM (liftIO $ doesFileExist (fromRawFilePath torrent)) + ifM (liftIO $ doesFileExist torrent) ( return True , do showAction "downloading torrent file" @@ -206,28 +203,27 @@ downloadTorrentFile u = do if isTorrentMagnetUrl u then withOtherTmp $ \othertmp -> do kf <- keyFile <$> torrentUrlKey u - let metadir = othertmp P. "torrentmeta" P. kf + let metadir = othertmp literalOsPath "torrentmeta" kf createAnnexDirectory metadir showOutput ok <- downloadMagnetLink u metadir torrent - liftIO $ removeDirectoryRecursive - (fromRawFilePath metadir) + liftIO $ removeDirectoryRecursive metadir return ok else withOtherTmp $ \othertmp -> do - withTmpFileIn (toOsPath othertmp) (toOsPath "torrent") $ \f h -> do + withTmpFileIn othertmp (literalOsPath "torrent") $ \f h -> do liftIO $ hClose h - resetAnnexFilePerm (fromOsPath f) + resetAnnexFilePerm f ok <- Url.withUrlOptions $ - Url.download nullMeterUpdate Nothing u (fromRawFilePath (fromOsPath f)) + Url.download nullMeterUpdate Nothing u f when ok $ - liftIO $ moveFile (fromOsPath f) torrent + liftIO $ moveFile f torrent return ok ) -downloadMagnetLink :: URLString -> RawFilePath -> RawFilePath -> Annex Bool +downloadMagnetLink :: URLString -> OsPath -> OsPath -> Annex Bool downloadMagnetLink u metadir dest = ifM download ( liftIO $ do - ts <- filter (".torrent" `S.isSuffixOf`) + ts <- filter (literalOsPath ".torrent" `OS.isSuffixOf`) <$> dirContents metadir case ts of (t:[]) -> do @@ -244,22 +240,22 @@ downloadMagnetLink u metadir dest = ifM download , Param "--seed-time=0" , Param "--summary-interval=0" , Param "-d" - , File (fromRawFilePath metadir) + , File (fromOsPath metadir) ] -downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool +downloadTorrentContent :: Key -> URLString -> OsPath -> Int -> MeterUpdate -> Annex Bool downloadTorrentContent k u dest filenum p = do torrent <- tmpTorrentFile u withOtherTmp $ \othertmp -> do kf <- keyFile <$> torrentUrlKey u - let downloaddir = othertmp P. "torrent" P. kf + let downloaddir = othertmp literalOsPath "torrent" kf createAnnexDirectory downloaddir f <- wantedfile torrent - let dlf = fromRawFilePath downloaddir f + let dlf = downloaddir f showOutput ifM (download torrent downloaddir <&&> liftIO (doesFileExist dlf)) ( do - liftIO $ moveFile (toRawFilePath dlf) (toRawFilePath dest) + liftIO $ moveFile dlf dest -- The downloaddir is not removed here, -- so if aria downloaded parts of other -- files, and this is called again, it will @@ -273,9 +269,9 @@ downloadTorrentContent k u dest filenum p = do where download torrent tmpdir = ariaProgress (fromKey keySize k) p [ Param $ "--select-file=" ++ show filenum - , File (fromRawFilePath torrent) + , File (fromOsPath torrent) , Param "-d" - , File (fromRawFilePath tmpdir) + , File (fromOsPath tmpdir) , Param "--seed-time=0" , Param "--summary-interval=0" , Param "--file-allocation=none" @@ -362,11 +358,11 @@ btshowmetainfo torrent field = {- Examines the torrent file and gets the list of files in it, - and their sizes. -} -torrentFileSizes :: RawFilePath -> IO [(FilePath, Integer)] +torrentFileSizes :: OsPath -> IO [(OsPath, Integer)] torrentFileSizes torrent = do #ifdef WITH_TORRENTPARSER - let mkfile = joinPath . map (scrub . decodeBL) - b <- F.readFile (toOsPath torrent) + let mkfile = joinPath . map (scrub . toOsPath) + b <- F.readFile torrent return $ case readTorrent b of Left e -> giveup $ "failed to parse torrent: " ++ e Right t -> case tInfo t of @@ -382,19 +378,19 @@ torrentFileSizes torrent = do fnl <- getfield "file name" szl <- map readish <$> getfield "file size" case (fnl, szl) of - ((fn:[]), (Just sz:[])) -> return [(scrub fn, sz)] + ((fn:[]), (Just sz:[])) -> return [(scrub (toOsPath fn), sz)] _ -> parsefailed (show (fnl, szl)) else do v <- getfield "directory name" case v of - (d:[]) -> return $ map (splitsize d) files + (d:[]) -> return $ map (splitsize (toOsPath d)) files _ -> parsefailed (show v) where - getfield = btshowmetainfo (fromRawFilePath torrent) + getfield = btshowmetainfo (fromOsPath torrent) parsefailed s = giveup $ "failed to parse btshowmetainfo output for torrent file: " ++ show s -- btshowmetainfo outputs a list of "filename (size)" - splitsize d l = (scrub (d fn), sz) + splitsize d l = (scrub (d toOsPath fn), sz) where sz = fromMaybe (parsefailed l) $ readish $ reverse $ takeWhile (/= '(') $ dropWhile (== ')') $ @@ -403,7 +399,7 @@ torrentFileSizes torrent = do dropWhile (/= '(') $ dropWhile (== ')') $ reverse l #endif -- a malicious torrent file might try to do directory traversal - scrub f = if isAbsolute f || any (== "..") (splitPath f) + scrub f = if isAbsolute f || any (== literalOsPath "..") (splitPath f) then giveup "found unsafe filename in torrent!" else f diff --git a/Remote/Borg.hs b/Remote/Borg.hs index d197af9856..aa68455b85 100644 --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -39,7 +39,6 @@ import Control.DeepSeq 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 newtype BorgRepo = BorgRepo { locBorgRepo :: String } @@ -156,18 +155,17 @@ borgArchive (BorgRepo r) n = r ++ "::" ++ decodeBS n absBorgRepo :: BorgRepo -> IO BorgRepo absBorgRepo r@(BorgRepo p) - | borgLocal r = BorgRepo . fromRawFilePath - <$> absPath (toRawFilePath p) + | borgLocal r = BorgRepo . fromOsPath <$> absPath (toOsPath p) | otherwise = return r -borgRepoLocalPath :: BorgRepo -> Maybe FilePath +borgRepoLocalPath :: BorgRepo -> Maybe OsPath borgRepoLocalPath r@(BorgRepo p) - | borgLocal r = Just p + | borgLocal r = Just (toOsPath p) | otherwise = Nothing checkAvailability :: BorgRepo -> Annex Availability checkAvailability borgrepo@(BorgRepo r) = - checkPathAvailability (borgLocal borgrepo) r + checkPathAvailability (borgLocal borgrepo) (toOsPath r) listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM u borgrepo c = prompt $ do @@ -218,7 +216,7 @@ listImportableContentsM u borgrepo c = prompt $ do parsefilelist archivename (bsz:f:extra:rest) = case readMaybe (fromRawFilePath bsz) of Nothing -> parsefilelist archivename rest Just sz -> - let loc = genImportLocation f + let loc = genImportLocation (toOsPath f) -- borg list reports hard links as 0 byte files, -- with the extra field set to " link to ". -- When the annex object is a hard link to @@ -270,7 +268,7 @@ listImportableContentsM u borgrepo c = prompt $ do borgContentIdentifier :: ContentIdentifier borgContentIdentifier = ContentIdentifier mempty --- Convert a path file a borg archive to a path that can be used as an +-- Convert a path from a borg archive to a path that can be used as an -- ImportLocation. The archive name gets used as a subdirectory, -- which this path is inside. -- @@ -279,25 +277,26 @@ borgContentIdentifier = ContentIdentifier mempty -- -- This scheme also relies on the fact that paths in a borg archive are -- always relative, not absolute. -genImportLocation :: RawFilePath -> RawFilePath +genImportLocation :: OsPath -> OsPath genImportLocation = fromImportLocation . ThirdPartyPopulated.mkThirdPartyImportLocation genImportChunkSubDir :: BorgArchiveName -> ImportChunkSubDir -genImportChunkSubDir = ImportChunkSubDir . fromImportLocation . ThirdPartyPopulated.mkThirdPartyImportLocation +genImportChunkSubDir = ImportChunkSubDir . fromImportLocation + . ThirdPartyPopulated.mkThirdPartyImportLocation . toOsPath -extractImportLocation :: ImportLocation -> (BorgArchiveName, RawFilePath) -extractImportLocation loc = go $ P.splitDirectories $ +extractImportLocation :: ImportLocation -> (BorgArchiveName, OsPath) +extractImportLocation loc = go $ splitDirectories $ ThirdPartyPopulated.fromThirdPartyImportLocation loc where - go (archivename:rest) = (archivename, P.joinPath rest) - go _ = giveup $ "Unable to parse import location " ++ fromRawFilePath (fromImportLocation loc) + go (archivename:rest) = (fromOsPath archivename, joinPath rest) + go _ = giveup $ "Unable to parse import location " ++ fromOsPath (fromImportLocation loc) -- Since the ImportLocation starts with the archive name, a list of all -- archive names we've already imported can be found by just listing the -- last imported tree. And the contents of those archives can be retrieved -- by listing the subtree recursively, which will likely be quite a lot -- faster than running borg. -getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(RawFilePath, (ContentIdentifier, ByteSize))])) +getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(OsPath, (ContentIdentifier, ByteSize))])) getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u) where go t = M.fromList . mapMaybe mk @@ -305,7 +304,7 @@ getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u) mk ti | toTreeItemType (LsTree.mode ti) == Just TreeSubtree = Just - ( getTopFilePath (LsTree.file ti) + ( fromOsPath (getTopFilePath (LsTree.file ti)) , getcontents (LsTree.sha ti) ) | otherwise = Nothing @@ -316,7 +315,7 @@ getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u) mkcontents ti = do let f = ThirdPartyPopulated.fromThirdPartyImportLocation $ mkImportLocation $ getTopFilePath $ LsTree.file ti - k <- fileKey (P.takeFileName f) + k <- fileKey (takeFileName f) return ( genImportLocation f , @@ -341,7 +340,7 @@ checkPresentExportWithContentIdentifierM borgrepo _ loc _ = prompt $ liftIO $ do , Param "--format" , Param "1" , Param (borgArchive borgrepo archivename) - , File (fromRawFilePath archivefile) + , File (fromOsPath archivefile) ] -- borg list exits nonzero with an error message if an archive -- no longer exists. But, the user can delete archives at any @@ -377,7 +376,7 @@ checkPresentExportWithContentIdentifierM borgrepo _ loc _ = prompt $ liftIO $ do , giveup $ "Unable to access borg repository " ++ locBorgRepo borgrepo ) -retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) +retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) retrieveExportWithContentIdentifierM borgrepo loc _ dest gk _ = do showOutput case gk of @@ -387,7 +386,7 @@ retrieveExportWithContentIdentifierM borgrepo loc _ dest gk _ = do return (k, UnVerified) Left k -> do v <- verifyKeyContentIncrementally DefaultVerify k - (\iv -> tailVerify iv (toRawFilePath dest) go) + (\iv -> tailVerify iv dest go) return (k, v) where go = prompt $ withOtherTmp $ \othertmp -> liftIO $ do @@ -406,14 +405,14 @@ retrieveExportWithContentIdentifierM borgrepo loc _ dest gk _ = do , Param "--noacls" , Param "--nobsdflags" , Param (borgArchive absborgrepo archivename) - , File (fromRawFilePath archivefile) + , File (fromOsPath archivefile) ] (Nothing, Nothing, Nothing, pid) <- createProcess $ p - { cwd = Just (fromRawFilePath othertmp) } + { cwd = Just (fromOsPath othertmp) } forceSuccessProcess p pid -- Filepaths in borg archives are relative, so it's ok to -- combine with - moveFile (othertmp P. archivefile) (toRawFilePath dest) - removeDirectoryRecursive (fromRawFilePath othertmp) + moveFile (othertmp archivefile) dest + removeDirectoryRecursive othertmp (archivename, archivefile) = extractImportLocation loc diff --git a/Remote/Bup.hs b/Remote/Bup.hs index c480d74dee..5003608acd 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -12,7 +12,6 @@ module Remote.Bup (remote) where 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 Data.ByteString.Lazy.UTF8 (fromString) import Control.Concurrent.Async @@ -96,12 +95,12 @@ gen r u rc gc rs = do , getRepo = return r , gitconfig = gc , localpath = if bupLocal buprepo && not (null buprepo) - then Just buprepo + then Just (toOsPath buprepo) else Nothing , remotetype = remote , availability = if null buprepo then pure LocallyAvailable - else checkPathAvailability (bupLocal buprepo) buprepo + else checkPathAvailability (bupLocal buprepo) (toOsPath buprepo) , readonly = False , appendonly = False , untrustworthy = False @@ -270,7 +269,7 @@ onBupRemote r runner command params = do (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd liftIO $ runner sshcmd sshparams where - path = fromRawFilePath $ Git.repoPath r + path = fromOsPath $ Git.repoPath r base = fromMaybe path (stripPrefix "/~/" path) dir = shellEscape base @@ -299,11 +298,11 @@ bup2GitRemote :: BupRepo -> IO Git.Repo bup2GitRemote "" = do -- bup -r "" operates on ~/.bup h <- myHomeDir - Git.Construct.fromPath $ toRawFilePath $ h ".bup" + Git.Construct.fromPath $ toOsPath h literalOsPath ".bup" bup2GitRemote r | bupLocal r = if "/" `isPrefixOf` r - then Git.Construct.fromPath (toRawFilePath r) + then Git.Construct.fromPath (toOsPath r) else giveup "please specify an absolute path" | otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir where @@ -335,10 +334,10 @@ bupLocal = notElem ':' lockBup :: Bool -> Remote -> Annex a -> Annex a lockBup writer r a = do dir <- fromRepo gitAnnexRemotesDir - unlessM (liftIO $ doesDirectoryExist (fromRawFilePath dir)) $ + unlessM (liftIO $ doesDirectoryExist dir) $ createAnnexDirectory dir let remoteid = fromUUID (uuid r) - let lck = dir P. remoteid <> ".lck" + let lck = dir remoteid <> literalOsPath ".lck" if writer then withExclusiveLock lck a else withSharedLock lck a diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 0b9cf8371c..e9e0ba5589 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -97,12 +97,12 @@ gen r u rc gc rs = do , getRepo = return r , gitconfig = gc , localpath = if ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo) - then Just $ ddarRepoLocation ddarrepo + then Just $ toOsPath $ ddarRepoLocation ddarrepo else Nothing , remotetype = remote , availability = checkPathAvailability (ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo)) - (ddarRepoLocation ddarrepo) + (toOsPath (ddarRepoLocation ddarrepo)) , readonly = False , appendonly = False , untrustworthy = False @@ -136,7 +136,7 @@ store ddarrepo = fileStorer $ \k src _p -> do , Param "-N" , Param $ serializeKey k , Param $ ddarRepoLocation ddarrepo - , File src + , File $ fromOsPath src ] unlessM (liftIO $ boolSystem "ddar" params) $ giveup "ddar failed" diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 94dc65250a..6acaf251f6 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -17,7 +17,6 @@ module Remote.Directory ( import qualified Data.Map as M import qualified Data.List.NonEmpty as NE -import qualified System.FilePath.ByteString as P import Data.Default import System.PosixCompat.Files (isRegularFile, deviceID) #ifndef mingw32_HOST_OS @@ -132,11 +131,11 @@ gen r u rc gc rs = do , config = c , getRepo = return r , gitconfig = gc - , localpath = Just dir' + , localpath = Just dir , readonly = False , appendonly = False , untrustworthy = False - , availability = checkPathAvailability True dir' + , availability = checkPathAvailability True dir , remotetype = remote , mkUnavailable = gen r u rc (gc { remoteAnnexDirectory = Just "/dev/null" }) rs @@ -146,8 +145,9 @@ gen r u rc gc rs = do , remoteStateHandle = rs } where - dir = toRawFilePath dir' - dir' = fromMaybe (giveup "missing directory") (remoteAnnexDirectory gc) + dir = toOsPath dir' + dir' = fromMaybe (giveup "missing directory") + (remoteAnnexDirectory gc) directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) directorySetup _ mu _ c gc = do @@ -155,43 +155,41 @@ directorySetup _ mu _ c gc = do -- verify configuration is sane let dir = maybe (giveup "Specify directory=") fromProposedAccepted $ M.lookup directoryField c - absdir <- liftIO $ fromRawFilePath <$> absPath (toRawFilePath dir) + absdir <- liftIO $ absPath (toOsPath dir) liftIO $ unlessM (doesDirectoryExist absdir) $ - giveup $ "Directory does not exist: " ++ absdir + giveup $ "Directory does not exist: " ++ fromOsPath absdir (c', _encsetup) <- encryptionSetup c gc -- The directory is stored in git config, not in this remote's -- persistent state, so it can vary between hosts. - gitConfigSpecialRemote u c' [("directory", absdir)] + gitConfigSpecialRemote u c' [("directory", fromOsPath absdir)] return (M.delete directoryField c', u) {- 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 :: RawFilePath -> Key -> NE.NonEmpty RawFilePath -locations d k = NE.map (d P.) (keyPaths k) +locations :: OsPath -> Key -> NE.NonEmpty OsPath +locations d k = NE.map (d ) (keyPaths k) -locations' :: RawFilePath -> Key -> [RawFilePath] +locations' :: OsPath -> Key -> [OsPath] locations' d k = NE.toList (locations d k) {- Returns the location of a Key in the directory. If the key is - present, returns the location that is actually used, otherwise - returns the first, default location. -} -getLocation :: RawFilePath -> Key -> IO RawFilePath +getLocation :: OsPath -> Key -> IO OsPath getLocation d k = do let locs = locations d k - fromMaybe (NE.head locs) - <$> firstM (doesFileExist . fromRawFilePath) - (NE.toList locs) + fromMaybe (NE.head locs) <$> firstM doesFileExist (NE.toList locs) {- Directory where the file(s) for a key are stored. -} -storeDir :: RawFilePath -> Key -> RawFilePath -storeDir d k = P.addTrailingPathSeparator $ - d P. hashDirLower def k P. keyFile k +storeDir :: OsPath -> Key -> OsPath +storeDir d k = addTrailingPathSeparator $ + d hashDirLower def k 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 :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Storer +storeKeyM :: OsPath -> ChunkConfig -> CopyCoWTried -> Storer storeKeyM d chunkconfig cow k c m = ifM (checkDiskSpaceDirectory d k) ( do @@ -203,16 +201,16 @@ storeKeyM d chunkconfig cow k c m = store = case chunkconfig of LegacyChunks chunksize -> let go _k b p = liftIO $ Legacy.store - (fromRawFilePath d) + (fromOsPath d) chunksize (finalizeStoreGeneric d) k b p - (fromRawFilePath tmpdir) - (fromRawFilePath destdir) + (fromOsPath tmpdir) + (fromOsPath destdir) in byteStorer go k c m NoChunks -> let go _k src p = liftIO $ do - void $ fileCopier cow src tmpf p Nothing + void $ fileCopier cow (fromOsPath src) (fromOsPath tmpf) p Nothing finalizeStoreGeneric d tmpdir destdir in fileStorer go k c m _ -> @@ -221,63 +219,59 @@ storeKeyM d chunkconfig cow k c m = finalizeStoreGeneric d tmpdir destdir in byteStorer go k c m - tmpdir = P.addTrailingPathSeparator $ d P. "tmp" P. kf - tmpf = fromRawFilePath tmpdir fromRawFilePath kf + tmpdir = addTrailingPathSeparator $ d literalOsPath "tmp" kf + tmpf = tmpdir kf kf = keyFile k destdir = storeDir d k -checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool +checkDiskSpaceDirectory :: OsPath -> Key -> Annex Bool checkDiskSpaceDirectory d k = do annexdir <- fromRepo gitAnnexObjectDir samefilesystem <- liftIO $ catchDefaultIO False $ (\a b -> deviceID a == deviceID b) - <$> R.getSymbolicLinkStatus d - <*> R.getSymbolicLinkStatus annexdir + <$> R.getSymbolicLinkStatus (fromOsPath d) + <*> R.getSymbolicLinkStatus (fromOsPath annexdir) checkDiskSpace Nothing (Just d) k 0 samefilesystem {- 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 :: RawFilePath -> RawFilePath -> RawFilePath -> IO () +finalizeStoreGeneric :: OsPath -> OsPath -> OsPath -> IO () finalizeStoreGeneric d tmp dest = do - removeDirGeneric False (fromRawFilePath d) dest' + removeDirGeneric False d dest createDirectoryUnder [d] (parentDir dest) - renameDirectory (fromRawFilePath tmp) dest' + renameDirectory tmp dest -- may fail on some filesystems void $ tryIO $ do mapM_ preventWrite =<< dirContents dest preventWrite dest - where - dest' = fromRawFilePath dest -retrieveKeyFileM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Retriever +retrieveKeyFileM :: OsPath -> ChunkConfig -> CopyCoWTried -> Retriever retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations' d retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do - src <- liftIO $ fromRawFilePath <$> getLocation d k - void $ liftIO $ fileCopier cow src (fromRawFilePath dest) p iv + src <- liftIO $ getLocation d k + void $ liftIO $ fileCopier cow (fromOsPath src) (fromOsPath dest) p iv retrieveKeyFileM d _ _ = byteRetriever $ \k sink -> - sink =<< liftIO (F.readFile . toOsPath =<< getLocation d k) + sink =<< liftIO (F.readFile =<< getLocation d k) -retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) +retrieveKeyFileCheapM :: OsPath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> OsPath -> 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 <- fromRawFilePath <$> (absPath =<< getLocation d k) + file <- absPath =<< getLocation d k ifM (doesFileExist file) - ( R.createSymbolicLink (toRawFilePath file) (toRawFilePath f) + ( R.createSymbolicLink (fromOsPath file) (fromOsPath f) , giveup "content file not present in remote" ) #else retrieveKeyFileCheapM _ _ = Nothing #endif -removeKeyM :: RawFilePath -> Remover -removeKeyM d _proof k = liftIO $ removeDirGeneric True - (fromRawFilePath d) - (fromRawFilePath (storeDir d k)) +removeKeyM :: OsPath -> Remover +removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k) {- Removes the directory, which must be located under the topdir. - @@ -293,13 +287,13 @@ removeKeyM d _proof k = liftIO $ removeDirGeneric True - can also be removed. Failure to remove such a directory is not treated - as an error. -} -removeDirGeneric :: Bool -> FilePath -> FilePath -> IO () +removeDirGeneric :: Bool -> OsPath -> OsPath -> IO () removeDirGeneric removeemptyparents topdir dir = do - void $ tryIO $ allowWrite (toRawFilePath dir) + void $ tryIO $ allowWrite dir #ifdef mingw32_HOST_OS {- Windows needs the files inside the directory to be writable - before it can delete them. -} - void $ tryIO $ mapM_ (allowWrite . toRawFilePath) =<< dirContents dir + void $ tryIO $ mapM_ allowWrite =<< dirContents dir #endif tryNonAsync (removeDirectoryRecursive dir) >>= \case Right () -> return () @@ -307,94 +301,94 @@ removeDirGeneric removeemptyparents topdir dir = do unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $ throwM e when removeemptyparents $ do - subdir <- relPathDirToFile (toRawFilePath topdir) (P.takeDirectory (toRawFilePath dir)) - goparents (Just (P.takeDirectory subdir)) (Right ()) + subdir <- relPathDirToFile topdir (takeDirectory dir) + goparents (Just (takeDirectory subdir)) (Right ()) where goparents _ (Left _e) = return () goparents Nothing _ = return () goparents (Just subdir) _ = do - let d = topdir fromRawFilePath subdir + let d = topdir subdir goparents (upFrom subdir) =<< tryIO (removeDirectory d) -checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent +checkPresentM :: OsPath -> ChunkConfig -> CheckPresent checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k checkPresentM d _ k = checkPresentGeneric d (locations' d k) -checkPresentGeneric :: RawFilePath -> [RawFilePath] -> Annex Bool +checkPresentGeneric :: OsPath -> [OsPath] -> Annex Bool checkPresentGeneric d ps = checkPresentGeneric' d $ - liftIO $ anyM (doesFileExist . fromRawFilePath) ps + liftIO $ anyM doesFileExist ps -checkPresentGeneric' :: RawFilePath -> Annex Bool -> Annex Bool +checkPresentGeneric' :: OsPath -> Annex Bool -> Annex Bool checkPresentGeneric' d check = ifM check ( return True - , ifM (liftIO $ doesDirectoryExist (fromRawFilePath d)) + , ifM (liftIO $ doesDirectoryExist d) ( return False - , giveup $ "directory " ++ fromRawFilePath d ++ " is not accessible" + , giveup $ "directory " ++ fromOsPath d ++ " is not accessible" ) ) -storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM :: OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM d cow src _k loc p = do - liftIO $ createDirectoryUnder [d] (P.takeDirectory dest) + liftIO $ createDirectoryUnder [d] (takeDirectory dest) -- Write via temp file so that checkPresentGeneric will not -- see it until it's fully stored. - viaTmp go (toOsPath dest) () + viaTmp go dest () where dest = exportPath d loc - go tmp () = void $ liftIO $ fileCopier cow src (fromRawFilePath (fromOsPath tmp)) p Nothing + go tmp () = void $ liftIO $ + fileCopier cow (fromOsPath src) (fromOsPath tmp) p Nothing -retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM :: OsPath -> CopyCoWTried -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retrieveExportM d cow k loc dest p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> - void $ liftIO $ fileCopier cow src dest p iv + void $ liftIO $ fileCopier cow src (fromOsPath dest) p iv where - src = fromRawFilePath $ exportPath d loc + src = fromOsPath $ exportPath d loc -removeExportM :: RawFilePath -> Key -> ExportLocation -> Annex () +removeExportM :: OsPath -> Key -> ExportLocation -> Annex () removeExportM d _k loc = liftIO $ do - removeWhenExistsWith R.removeLink src + removeWhenExistsWith removeFile src removeExportLocation d loc where src = exportPath d loc -checkPresentExportM :: RawFilePath -> Key -> ExportLocation -> Annex Bool +checkPresentExportM :: OsPath -> Key -> ExportLocation -> Annex Bool checkPresentExportM d _k loc = checkPresentGeneric d [exportPath d loc] -renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) +renameExportM :: OsPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM d _k oldloc newloc = liftIO $ do - createDirectoryUnder [d] (P.takeDirectory dest) - renameFile (fromRawFilePath src) (fromRawFilePath dest) + createDirectoryUnder [d] (takeDirectory dest) + renameFile src dest removeExportLocation d oldloc return (Just ()) where src = exportPath d oldloc dest = exportPath d newloc -exportPath :: RawFilePath -> ExportLocation -> RawFilePath -exportPath d loc = d P. fromExportLocation loc +exportPath :: OsPath -> ExportLocation -> OsPath +exportPath d loc = d 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 :: RawFilePath -> ExportLocation -> IO () +removeExportLocation :: OsPath -> ExportLocation -> IO () removeExportLocation topdir loc = - go (Just $ P.takeDirectory $ fromExportLocation loc) (Right ()) + go (Just $ takeDirectory $ fromExportLocation loc) (Right ()) where go _ (Left _e) = return () go Nothing _ = return () go (Just loc') _ = - let p = fromRawFilePath $ exportPath topdir $ - mkExportLocation loc' + let p = exportPath topdir $ mkExportLocation loc' in go (upFrom loc') =<< tryIO (removeDirectory p) -listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableContentsM :: IgnoreInodes -> OsPath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM ii dir = liftIO $ do l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir return $ Just $ ImportableContentsComplete $ ImportableContents (catMaybes l') [] where go f = do - st <- R.getSymbolicLinkStatus f + st <- R.getSymbolicLinkStatus (fromOsPath f) mkContentIdentifier ii f st >>= \case Nothing -> return Nothing Just cid -> do @@ -408,7 +402,7 @@ newtype IgnoreInodes = IgnoreInodes Bool -- and also normally the inode, unless ignoreinodes=yes. -- -- If the file is not a regular file, this will return Nothing. -mkContentIdentifier :: IgnoreInodes -> RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier) +mkContentIdentifier :: IgnoreInodes -> OsPath -> FileStatus -> IO (Maybe ContentIdentifier) mkContentIdentifier (IgnoreInodes ii) f st = liftIO $ fmap (ContentIdentifier . encodeBS . showInodeCache) <$> if ii @@ -434,25 +428,25 @@ guardSameContentIdentifiers cont olds (Just new) let ic' = replaceInode 0 ic in ContentIdentifier (encodeBS (showInodeCache ic')) -importKeyM :: IgnoreInodes -> RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) +importKeyM :: IgnoreInodes -> OsPath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) importKeyM ii dir loc cid sz p = do backend <- chooseBackend f unsizedk <- fst <$> genKey ks p backend let k = alterKey unsizedk $ \kd -> kd { keySize = keySize kd <|> Just sz } currcid <- liftIO $ mkContentIdentifier ii absf - =<< R.getSymbolicLinkStatus absf + =<< R.getSymbolicLinkStatus (fromOsPath absf) guardSameContentIdentifiers (return (Just k)) [cid] currcid where f = fromExportLocation loc - absf = dir P. f + absf = dir f ks = KeySource { keyFilename = f , contentLocation = absf , inodeCache = Nothing } -retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) +retrieveExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> ExportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = case gk of Right mkkey -> do @@ -464,11 +458,11 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = return (k, v) where f = exportPath dir loc - f' = fromRawFilePath f - + f' = fromOsPath f + go iv = precheck (docopy iv) - docopy iv = ifM (liftIO $ tryCopyCoW cow f' dest p) + docopy iv = ifM (liftIO $ tryCopyCoW cow (fromOsPath f) (fromOsPath dest) p) ( postcheckcow (liftIO $ maybe noop unableIncrementalVerifier iv) , docopynoncow iv ) @@ -477,7 +471,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = #ifndef mingw32_HOST_OS let open = do -- Need a duplicate fd for the post check. - fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags + fd <- openFdWithMode f' ReadOnly Nothing defaultFileFlags dupfd <- dup fd h <- fdToHandle fd return (h, dupfd) @@ -490,7 +484,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = let close = hClose bracketIO open close $ \h -> do #endif - liftIO $ fileContentCopier h dest p iv + liftIO $ fileContentCopier h (fromOsPath dest) p iv #ifndef mingw32_HOST_OS postchecknoncow dupfd (return ()) #else @@ -501,7 +495,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = -- content. precheck cont = guardSameContentIdentifiers cont cids =<< liftIO . mkContentIdentifier ii f - =<< liftIO (R.getSymbolicLinkStatus f) + =<< liftIO (R.getSymbolicLinkStatus f') -- Check after copy, in case the file was changed while it was -- being copied. @@ -525,7 +519,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = #ifndef mingw32_HOST_OS =<< getFdStatus fd #else - =<< R.getSymbolicLinkStatus f + =<< R.getSymbolicLinkStatus f' #endif guardSameContentIdentifiers cont cids currcid @@ -536,37 +530,37 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = -- restored to the original content before this check. postcheckcow cont = do currcid <- liftIO $ mkContentIdentifier ii f - =<< R.getSymbolicLinkStatus f + =<< R.getSymbolicLinkStatus f' guardSameContentIdentifiers cont cids currcid -storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +storeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do liftIO $ createDirectoryUnder [dir] destdir - withTmpFileIn (toOsPath destdir) template $ \tmpf tmph -> do + withTmpFileIn destdir template $ \tmpf tmph -> do let tmpf' = fromOsPath tmpf liftIO $ hClose tmph - void $ liftIO $ fileCopier cow src (fromRawFilePath tmpf') p Nothing - resetAnnexFilePerm tmpf' - liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case + void $ liftIO $ fileCopier cow (fromOsPath src) (fromOsPath tmpf) p Nothing + resetAnnexFilePerm tmpf + liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf >>= \case Nothing -> giveup "unable to generate content identifier" Just newcid -> do checkExportContent ii dir loc overwritablecids (giveup "unsafe to overwrite file") - (const $ liftIO $ R.rename tmpf' dest) + (const $ liftIO $ R.rename tmpf' (fromOsPath dest)) return newcid where dest = exportPath dir loc - (destdir, base) = P.splitFileName dest - template = relatedTemplate (base <> ".tmp") + (destdir, base) = splitFileName dest + template = relatedTemplate (fromOsPath base <> ".tmp") -removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () +removeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () removeExportWithContentIdentifierM ii dir k loc removeablecids = checkExportContent ii dir loc removeablecids (giveup "unsafe to remove modified file") $ \case DoesNotExist -> return () KnownContentIdentifier -> removeExportM dir k loc -checkPresentExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +checkPresentExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierM ii dir _k loc knowncids = checkPresentGeneric' dir $ checkExportContent ii dir loc knowncids (return False) $ \case @@ -590,9 +584,9 @@ data CheckResult = DoesNotExist | KnownContentIdentifier -- -- So, it suffices to check if the destination file's current -- content is known, and immediately run the callback. -checkExportContent :: IgnoreInodes -> RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a +checkExportContent :: IgnoreInodes -> OsPath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a checkExportContent ii dir loc knowncids unsafe callback = - tryWhenExists (liftIO $ R.getSymbolicLinkStatus dest) >>= \case + tryWhenExists (liftIO $ R.getSymbolicLinkStatus (fromOsPath dest)) >>= \case Just destst | not (isRegularFile destst) -> unsafe | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier ii dest destst) >>= \case diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs index b1b2438b7d..03dd7e398d 100644 --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -14,7 +14,6 @@ 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 @@ -23,7 +22,6 @@ import qualified Remote.Helper.Chunked.Legacy as Legacy import Annex.Tmp import Utility.Metered import Utility.Directory.Create -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool @@ -45,7 +43,7 @@ withCheckedFiles check d locations k a = go $ locations d k else a chunks ) withStoredFiles :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool -withStoredFiles = withCheckedFiles doesFileExist +withStoredFiles = withCheckedFiles (doesFileExist . toOsPath) {- Splits a ByteString into chunks and writes to dests, obeying configured - chunk size (not to be confused with the L.ByteString chunk size). -} @@ -77,20 +75,20 @@ storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do feed bytes' (sz - s) ls h else return (l:ls) -storeHelper :: FilePath -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO () +storeHelper :: FilePath -> (OsPath -> OsPath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO () storeHelper repotop finalizer key storer tmpdir destdir = do void $ liftIO $ tryIO $ createDirectoryUnder - [toRawFilePath repotop] - (toRawFilePath tmpdir) + [toOsPath repotop] + (toOsPath tmpdir) Legacy.storeChunks key tmpdir destdir storer recorder (legacyFinalizer finalizer) where recorder f s = do - let f' = toRawFilePath f + let f' = toOsPath f void $ tryIO $ allowWrite f' writeFile f s void $ tryIO $ preventWrite f' -store :: FilePath -> ChunkSize -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO () +store :: FilePath -> ChunkSize -> (OsPath -> OsPath -> 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 @@ -98,30 +96,29 @@ store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \des - Done very innefficiently, by writing to a temp file. - :/ This is legacy code.. -} -retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever +retrieve :: (OsPath -> Key -> [OsPath]) -> OsPath -> Retriever retrieve locations d basek p _dest miv c = withOtherTmp $ \tmpdir -> do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." - let tmp = tmpdir P. keyFile basek <> ".directorylegacy.tmp" - let tmp' = toOsPath tmp + let tmp = tmpdir keyFile basek <> literalOsPath ".directorylegacy.tmp" let go = \k sink -> do - liftIO $ void $ withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ \fs -> do + liftIO $ void $ withStoredFiles (fromOsPath d) (legacyLocations locations) k $ \fs -> do forM_ fs $ - F.appendFile' tmp' <=< S.readFile + F.appendFile' tmp <=< S.readFile return True - b <- liftIO $ F.readFile tmp' - liftIO $ removeWhenExistsWith R.removeLink tmp + b <- liftIO $ F.readFile tmp + liftIO $ removeWhenExistsWith removeFile tmp sink b byteRetriever go basek p tmp miv c -checkKey :: RawFilePath -> (RawFilePath -> Key -> [RawFilePath]) -> Key -> Annex Bool +checkKey :: OsPath -> (OsPath -> Key -> [OsPath]) -> Key -> Annex Bool checkKey d locations k = liftIO $ - withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ + withStoredFiles (fromOsPath 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) +legacyFinalizer :: (OsPath -> OsPath -> IO ()) -> (FilePath -> FilePath -> IO ()) +legacyFinalizer f = \a b -> f (toOsPath a) (toOsPath b) -legacyLocations :: (RawFilePath -> Key -> [RawFilePath]) -> (FilePath -> Key -> [FilePath]) +legacyLocations :: (OsPath -> Key -> [OsPath]) -> (FilePath -> Key -> [FilePath]) legacyLocations locations = \f k -> - map fromRawFilePath $ locations (toRawFilePath f) k + map fromOsPath $ locations (toOsPath f) k diff --git a/Remote/External.hs b/Remote/External.hs index 882fa22888..251ca666fe 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -237,9 +237,10 @@ checkExportSupported' external = go `catchNonAsync` (const (return False)) storeKeyM :: External -> Storer storeKeyM external = fileStorer $ \k f p -> - either giveup return =<< go k f p + either giveup return =<< go k p + (\sk -> TRANSFER Upload sk (fromOsPath f)) where - go k f p = handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp -> + go k p mkreq = handleRequestKey external mkreq k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Upload k' | k == k' -> result (Right ()) @@ -251,7 +252,7 @@ retrieveKeyFileM :: External -> Retriever retrieveKeyFileM external = fileRetriever $ \d k p -> either giveup return =<< watchFileSize d p (go d k) where - go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromRawFilePath d)) k (Just p) $ \resp -> + go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromOsPath d)) k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Download k' | k == k' -> result $ Right () @@ -293,7 +294,7 @@ whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> UNSUPPORTED_REQUEST -> result [] _ -> Nothing -storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM :: External -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM external f k loc p = either giveup return =<< go where go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of @@ -303,12 +304,12 @@ storeExportM external f k loc p = either giveup return =<< go UNSUPPORTED_REQUEST -> result $ Left "TRANSFEREXPORT not implemented by external special remote" _ -> Nothing - req sk = TRANSFEREXPORT Upload sk f + req sk = TRANSFEREXPORT Upload sk (fromOsPath f) -retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM :: External -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retrieveExportM external k loc dest p = do verifyKeyContentIncrementally AlwaysVerify k $ \iv -> - tailVerify iv (toRawFilePath dest) $ + tailVerify iv dest $ either giveup return =<< go where go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of @@ -319,7 +320,7 @@ retrieveExportM external k loc dest p = do UNSUPPORTED_REQUEST -> result $ Left "TRANSFEREXPORT not implemented by external special remote" _ -> Nothing - req sk = TRANSFEREXPORT Download sk dest + req sk = TRANSFEREXPORT Download sk (fromOsPath dest) checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool checkPresentExportM external k loc = either giveup id <$> go @@ -429,9 +430,9 @@ handleRequest' st external req mp responsehandler handleRemoteRequest (PROGRESS bytesprocessed) = maybe noop (\a -> liftIO $ a bytesprocessed) mp handleRemoteRequest (DIRHASH k) = - send $ VALUE $ fromRawFilePath $ hashDirMixed def k + send $ VALUE $ fromOsPath $ hashDirMixed def k handleRemoteRequest (DIRHASH_LOWER k) = - send $ VALUE $ fromRawFilePath $ hashDirLower def k + send $ VALUE $ fromOsPath $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) = liftIO $ atomically $ do ParsedRemoteConfig m c <- takeTMVar (externalConfig st) @@ -480,7 +481,7 @@ handleRequest' st external req mp responsehandler Just u -> send $ VALUE $ fromUUID u Nothing -> senderror "cannot send GETUUID here" handleRemoteRequest GETGITDIR = - send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir + send . VALUE . fromOsPath =<< fromRepo Git.localGitDir handleRemoteRequest GETGITREMOTENAME = case externalRemoteName external of Just n -> send $ VALUE n @@ -526,7 +527,7 @@ handleRequest' st external req mp responsehandler senderror = sendMessage st . ERROR credstorage setting u = CredPairStorage - { credPairFile = base + { credPairFile = toOsPath base , credPairEnvironment = (base ++ "login", base ++ "password") , credPairRemoteField = Accepted setting } @@ -824,19 +825,19 @@ checkUrlM :: External -> URLString -> Annex UrlContents checkUrlM external url = handleRequest external (CHECKURL url) Nothing $ \req -> case req of CHECKURL_CONTENTS sz f -> result $ UrlContents sz $ - if null f then Nothing else Just f + if null f then Nothing else Just (toOsPath f) CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l CHECKURL_FAILURE errmsg -> Just $ giveup $ respErrorMessage "CHECKURL" errmsg UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote" _ -> Nothing where - mkmulti (u, s, f) = (u, s, f) + mkmulti (u, s, f) = (u, s, toOsPath f) retrieveUrl :: Retriever retrieveUrl = fileRetriever' $ \f k p iv -> do us <- getWebUrls k - unlessM (withUrlOptions $ downloadUrl True k p iv us (fromRawFilePath f)) $ + unlessM (withUrlOptions $ downloadUrl True k p iv us f) $ giveup "failed to download content" checkKeyUrl :: CheckPresent diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 17968672e2..58bbc9f656 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -480,12 +480,12 @@ instance Proto.Serializable URI where deserialize = parseURIPortable instance Proto.Serializable ExportLocation where - serialize = fromRawFilePath . fromExportLocation - deserialize = Just . mkExportLocation . toRawFilePath + serialize = fromOsPath . fromExportLocation + deserialize = Just . mkExportLocation . toOsPath instance Proto.Serializable ExportDirectory where - serialize = fromRawFilePath . fromExportDirectory - deserialize = Just . mkExportDirectory . toRawFilePath + serialize = fromOsPath . fromExportDirectory + deserialize = Just . mkExportDirectory . toOsPath instance Proto.Serializable ExtensionList where serialize (ExtensionList l) = unwords l diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 8103622580..a06ceb2c91 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -20,8 +20,6 @@ module Remote.GCrypt ( 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 Data.Default import Annex.Common @@ -51,16 +49,17 @@ import Utility.Metered import Annex.UUID import Annex.Ssh import Annex.Perms +import Messages.Progress +import Types.ProposedAccepted +import Logs.Remote import qualified Remote.Rsync import qualified Remote.Directory import Utility.Rsync import Utility.Tmp -import Logs.Remote import Utility.Gpg import Utility.SshHost import Utility.Directory.Create -import Messages.Progress -import Types.ProposedAccepted +import qualified Utility.FileIO as F remote :: RemoteType remote = specialRemoteType $ RemoteType @@ -304,10 +303,10 @@ setupRepo gcryptid r - which is needed for rsync of objects to it to work. -} rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do - createAnnexDirectory (toRawFilePath tmp P. objectDir) + createAnnexDirectory (tmp objectDir) dummycfg <- liftIO dummyRemoteGitConfig let (rsynctransport, rsyncurl, _) = rsyncTransport r dummycfg - let tmpconfig = tmp "config" + let tmpconfig = fromOsPath $ tmp literalOsPath "config" opts <- rsynctransport void $ liftIO $ rsync $ opts ++ [ Param $ rsyncurl ++ "/config" @@ -318,7 +317,7 @@ setupRepo gcryptid r void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False) ok <- liftIO $ rsync $ opts ++ [ Param "--recursive" - , Param $ tmp ++ "/" + , Param $ fromOsPath tmp ++ "/" , Param rsyncurl ] unless ok $ @@ -388,17 +387,18 @@ store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Storer store' repo r rsyncopts accessmethod | not $ Git.repoIsUrl repo = byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do - let tmpdir = Git.repoPath repo P. "tmp" P. keyFile k + let tmpdir = Git.repoPath repo literalOsPath "tmp" 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 + let tmpf = tmpdir keyFile k + meteredWriteFile p tmpf b + let destdir = parentDir $ 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 ok <- Ssh.rsyncHelper oh (Just p) - =<< Ssh.rsyncParamsRemote r Upload k f + =<< Ssh.rsyncParamsRemote r Upload k + (fromOsPath f) unless ok $ giveup "rsync failed" else storersync @@ -416,11 +416,11 @@ retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Ret retrieve' repo r rsyncopts accessmethod | not $ Git.repoIsUrl repo = byteRetriever $ \k sink -> guardUsable repo (giveup "cannot access remote") $ - sink =<< liftIO (L.readFile $ gCryptLocation repo k) + sink =<< liftIO (F.readFile $ gCryptLocation repo k) | Git.repoIsSsh repo = if accessShell r then fileRetriever $ \f k p -> do ps <- Ssh.rsyncParamsRemote r Download k - (fromRawFilePath f) + (fromOsPath f) oh <- mkOutputHandler unlessM (Ssh.rsyncHelper oh (Just p) ps) $ giveup "rsync failed" @@ -440,7 +440,7 @@ remove' repo r rsyncopts accessmethod proof k | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ liftIO $ Remote.Directory.removeDirGeneric True (gCryptTopDir repo) - (fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k)))) + (parentDir (gCryptLocation repo k)) | Git.repoIsSsh repo = shellOrRsync r removeshell removersync | accessmethod == AccessRsyncOverSsh = removersync | otherwise = unsupportedUrl @@ -465,14 +465,14 @@ checkKey' repo r rsyncopts accessmethod k checkrsync = Remote.Rsync.checkKey rsyncopts k checkshell = Ssh.inAnnex repo k -gCryptTopDir :: Git.Repo -> FilePath -gCryptTopDir repo = Git.repoLocation repo fromRawFilePath objectDir +gCryptTopDir :: Git.Repo -> OsPath +gCryptTopDir repo = toOsPath (Git.repoLocation repo) objectDir {- Annexed objects are hashed using lower-case directories for max - portability. -} -gCryptLocation :: Git.Repo -> Key -> FilePath +gCryptLocation :: Git.Repo -> Key -> OsPath gCryptLocation repo key = gCryptTopDir repo - fromRawFilePath (keyPath key (hashDirLower def)) + keyPath key (hashDirLower def) data AccessMethod = AccessRsyncOverSsh | AccessGitAnnexShell deriving (Eq) @@ -529,8 +529,8 @@ getConfigViaRsync r gc = do let (rsynctransport, rsyncurl, _) = rsyncTransport r gc opts <- rsynctransport liftIO $ do - withTmpFile (toOsPath "tmpconfig") $ \tmpconfig _ -> do - let tmpconfig' = fromRawFilePath $ fromOsPath tmpconfig + withTmpFile (literalOsPath "tmpconfig") $ \tmpconfig _ -> do + let tmpconfig' = fromOsPath tmpconfig void $ rsync $ opts ++ [ Param $ rsyncurl ++ "/config" , Param tmpconfig' diff --git a/Remote/Git.hs b/Remote/Git.hs index c9108700e4..15e99be129 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -49,6 +49,7 @@ import Logs.Cluster.Basic import Utility.Metered import Utility.Env import Utility.Batch +import qualified Utility.FileIO as F import Remote.Helper.Git import Remote.Helper.Messages import Remote.Helper.ExportImport @@ -324,10 +325,9 @@ tryGitConfigRead autoinit r hasuuid geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do let url = Git.repoLocation r ++ "/config" - v <- withTmpFile (toOsPath "git-annex.tmp") $ \tmpfile h -> do + v <- withTmpFile (literalOsPath "git-annex.tmp") $ \tmpfile h -> do liftIO $ hClose h - let tmpfile' = fromRawFilePath $ fromOsPath tmpfile - Url.download' nullMeterUpdate Nothing url tmpfile' uo >>= \case + Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case Right () -> pipedconfig Git.Config.ConfigNullList False url "git" @@ -335,7 +335,7 @@ tryGitConfigRead autoinit r hasuuid , Param "--null" , Param "--list" , Param "--file" - , File tmpfile' + , File (fromOsPath tmpfile) ] >>= return . \case Right r' -> Right r' Left exitcode -> Left $ "git config exited " ++ show exitcode @@ -470,9 +470,9 @@ keyUrls gc repo r key = map tourl locs' | remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key | otherwise = annexLocationsBare gc key #ifndef mingw32_HOST_OS - locs' = map fromRawFilePath locs + locs' = map fromOsPath locs #else - locs' = map (replace "\\" "/" . fromRawFilePath) locs + locs' = map (replace "\\" "/" . fromOsPath) locs #endif remoteconfig = gitconfig r @@ -560,12 +560,12 @@ lockKey' repo r st@(State connpool duc _ _ _) key callback failedlock = giveup "can't lock content" {- Tries to copy a key's content from a remote's annex to a file. -} -copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification copyFromRemote r st key file dest meterupdate vc = do repo <- getRepo r copyFromRemote'' repo r st key file dest meterupdate vc -copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc | isP2PHttp r = copyp2phttp | Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do @@ -603,9 +603,8 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc <|> remoteAnnexBwLimit (gitconfig r) copyp2phttp = verifyKeyContentIncrementally vc key $ \iv -> do - startsz <- liftIO $ tryWhenExists $ - getFileSize (toRawFilePath dest) - bracketIO (openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do + startsz <- liftIO $ tryWhenExists $ getFileSize dest + bracketIO (F.openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do metered (Just meterupdate) key bwlimit $ \_ p -> do p' <- case startsz of Just startsz' -> liftIO $ do @@ -617,16 +616,18 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc Valid -> return () Invalid -> giveup "Transfer failed" -copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) +copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ()) #ifndef mingw32_HOST_OS copyFromRemoteCheap st repo | not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do gc <- getGitConfigFromState st loc <- liftIO $ gitAnnexLocation key repo gc - liftIO $ ifM (R.doesPathExist loc) + liftIO $ ifM (doesFileExist loc) ( do absloc <- absPath loc - R.createSymbolicLink absloc (toRawFilePath file) + R.createSymbolicLink + (fromOsPath absloc) + (fromOsPath file) , giveup "remote does not contain key" ) | otherwise = Nothing @@ -635,12 +636,12 @@ copyFromRemoteCheap _ _ = Nothing #endif {- Tries to copy a key's content to a remote's annex. -} -copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () copyToRemote r st key af o meterupdate = do repo <- getRepo r copyToRemote' repo r st key af o meterupdate -copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate | isP2PHttp r = prepsendwith copyp2phttp | not $ Git.repoIsUrl repo = ifM duc @@ -683,7 +684,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate Nothing -> return True logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' -> - copier object (fromRawFilePath dest) key p' checksuccess verify + copier object dest key p' checksuccess verify ) unless res $ failedsend @@ -719,10 +720,12 @@ fsckOnRemote r params r' <- Git.Config.read r environ <- getEnvironment let environ' = addEntries - [ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r') - , ("GIT_DIR", fromRawFilePath $ Git.localGitDir r') + [ ("GIT_WORK_TREE", fromOsPath $ Git.repoPath r') + , ("GIT_DIR", fromOsPath $ Git.localGitDir r') ] environ - batchCommandEnv program (Param "fsck" : params) (Just environ') + batchCommandEnv (fromOsPath program) + (Param "fsck" : params) + (Just environ') {- The passed repair action is run in the Annex monad of the remote. -} repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool) @@ -816,7 +819,7 @@ wantHardLink = (annexHardLink <$> Annex.getGitConfig) -- because they can be modified at any time. <&&> (not <$> annexThin <$> Annex.getGitConfig) -type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification) +type FileCopier = OsPath -> OsPath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification) -- If either the remote or local repository wants to use hard links, -- the copier will do so (falling back to copying if a hard link cannot be @@ -829,14 +832,14 @@ type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> Ve mkFileCopier :: Bool -> State -> Annex FileCopier mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do localwanthardlink <- wantHardLink - let linker = \src dest -> R.createLink (toRawFilePath src) (toRawFilePath dest) >> return True + let linker = \src dest -> R.createLink (fromOsPath src) (fromOsPath dest) >> return True if remotewanthardlink || localwanthardlink then return $ \src dest k p check verifyconfig -> ifM (liftIO (catchBoolIO (linker src dest))) ( ifM check ( return (True, Verified) , do - verificationOfContentFailed (toRawFilePath dest) + verificationOfContentFailed dest return (False, UnVerified) ) , copier src dest k p check verifyconfig @@ -845,11 +848,11 @@ mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do where copier src dest k p check verifyconfig = do iv <- startVerifyKeyContentIncrementally verifyconfig k - liftIO (fileCopier copycowtried src dest p iv) >>= \case + liftIO (fileCopier copycowtried (fromOsPath src) (fromOsPath dest) p iv) >>= \case Copied -> ifM check ( finishVerifyKeyContentIncrementally iv , do - verificationOfContentFailed (toRawFilePath dest) + verificationOfContentFailed dest return (False, UnVerified) ) CopiedCoW -> unVerified check diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 841c51a1f5..4103309286 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -20,6 +20,7 @@ import Types.NumCopies import qualified Annex import qualified Git import qualified Git.Types as Git +import qualified Git.Config import qualified Git.Url import qualified Git.Remote import qualified Git.GCrypt @@ -36,12 +37,12 @@ import Annex.Ssh import Annex.UUID import Crypto import Backend.Hash +import Logs.Remote +import Logs.RemoteState import Utility.Hash import Utility.SshHost import Utility.Url -import Logs.Remote -import Logs.RemoteState -import qualified Git.Config +import qualified Utility.FileIO as F import qualified Network.GitLFS as LFS import Control.Concurrent.STM @@ -380,7 +381,7 @@ extractKeySize k | isEncKey k = Nothing | otherwise = fromKey keySize k -mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer) +mkUploadRequest :: RemoteStateHandle -> Key -> OsPath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer) mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of (Just sha256, Just size) -> ret sha256 size @@ -390,11 +391,11 @@ mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of ret sha256 size _ -> do sha256 <- calcsha256 - size <- liftIO $ getFileSize (toRawFilePath content) + size <- liftIO $ getFileSize content rememberboth sha256 size ret sha256 size where - calcsha256 = liftIO $ T.pack . show . sha2_256 <$> L.readFile content + calcsha256 = liftIO $ T.pack . show . sha2_256 <$> F.readFile content ret sha256 size = do let obj = LFS.TransferRequestObject { LFS.req_oid = sha256 @@ -497,7 +498,7 @@ retrieve rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownl Nothing -> giveup "unable to parse git-lfs server download url" Just req -> do uo <- getUrlOptions - liftIO $ downloadConduit p iv req (fromRawFilePath dest) uo + liftIO $ downloadConduit p iv req dest uo -- Since git-lfs does not support removing content, nothing needs to be -- done to lock content in the remote, except for checking that the content diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index b37e5d294e..4e32b88cf0 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -178,7 +178,7 @@ store' r k b p = go =<< glacierEnv c gc u forceSuccessProcess cmd pid go' _ _ _ _ _ = error "internal" -retrieve :: forall a. Remote -> Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a +retrieve :: forall a. Remote -> Key -> MeterUpdate -> OsPath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a retrieve = byteRetriever . retrieve' retrieve' :: forall a. Remote -> Key -> (L.ByteString -> Annex a) -> Annex a diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs index 0f5f4b885a..92608ee0a8 100644 --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -23,7 +23,7 @@ import Data.Text (Text) creds :: UUID -> CredPairStorage creds u = CredPairStorage - { credPairFile = fromUUID u + { credPairFile = literalOsPath (fromUUID u) , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") , credPairRemoteField = s3credsField } diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 9b40d5b10c..6ee90c2c9d 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -33,7 +33,7 @@ import Crypto import Backend (isStableKey) import Annex.SpecialRemote.Config import Annex.Verify -import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -120,7 +120,7 @@ storeChunks -> ChunkConfig -> EncKey -> Key - -> FilePath + -> OsPath -> MeterUpdate -> Maybe (Cipher, EncKey) -> encc @@ -135,7 +135,7 @@ storeChunks u chunkconfig encryptor k f p enc encc storer checker = -- possible without this check. (UnpaddedChunks chunksize) -> ifM (isStableKey k) ( do - h <- liftIO $ openBinaryFile f ReadMode + h <- liftIO $ F.openBinaryFile f ReadMode go chunksize h liftIO $ hClose h , storechunk k (FileContent f) p @@ -257,7 +257,7 @@ retrieveChunks -> ChunkConfig -> EncKey -> Key - -> FilePath + -> OsPath -> MeterUpdate -> Maybe (Cipher, EncKey) -> encc @@ -276,7 +276,7 @@ retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc where go pe cks = do let ls = map chunkKeyList cks - currsize <- liftIO $ catchMaybeIO $ getFileSize (toRawFilePath dest) + currsize <- liftIO $ catchMaybeIO $ getFileSize dest let ls' = maybe ls (setupResume ls) currsize if any null ls' -- dest is already complete @@ -339,7 +339,7 @@ retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc -- passing the whole file content to the -- incremental verifier though. Nothing -> do - retriever (encryptor basek) basep (toRawFilePath dest) iv $ + retriever (encryptor basek) basep dest iv $ retrieved iv Nothing basep return $ case iv of Nothing -> Right iv @@ -347,13 +347,13 @@ retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc opennew = do iv <- startVerifyKeyContentIncrementally vc basek - h <- liftIO $ openBinaryFile dest WriteMode + h <- liftIO $ F.openBinaryFile dest WriteMode return (h, iv) -- Open the file and seek to the start point in order to resume. openresume startpoint = do -- ReadWriteMode allows seeking; AppendMode does not. - h <- liftIO $ openBinaryFile dest ReadWriteMode + h <- liftIO $ F.openBinaryFile dest ReadWriteMode liftIO $ hSeek h AbsoluteSeek startpoint -- No incremental verification when resuming, since that -- would need to read up to the startpoint. @@ -398,7 +398,7 @@ retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc -} writeRetrievedContent :: LensEncParams encc - => FilePath + => OsPath -> Maybe (Cipher, EncKey) -> encc -> Maybe Handle @@ -409,7 +409,7 @@ writeRetrievedContent writeRetrievedContent dest enc encc mh mp content miv = case (enc, mh, content) of (Nothing, Nothing, FileContent f) | f == dest -> noop - | otherwise -> liftIO $ moveFile (toRawFilePath f) (toRawFilePath dest) + | otherwise -> liftIO $ moveFile f dest (Just (cipher, _), _, ByteContent b) -> do cmd <- gpgCmd <$> Annex.getGitConfig decrypt cmd encc cipher (feedBytes b) $ @@ -419,10 +419,10 @@ writeRetrievedContent dest enc encc mh mp content miv = case (enc, mh, content) withBytes content $ \b -> decrypt cmd encc cipher (feedBytes b) $ readBytes write - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + liftIO $ removeWhenExistsWith removeFile f (Nothing, _, FileContent f) -> do withBytes content write - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + liftIO $ removeWhenExistsWith removeFile f (Nothing, _, ByteContent b) -> write b where write b = case mh of @@ -437,7 +437,7 @@ writeRetrievedContent dest enc encc mh mp content miv = case (enc, mh, content) Nothing -> S.hPut h in meteredWrite p writer b Nothing -> L.hPut h b - opendest = openBinaryFile dest WriteMode + opendest = F.openBinaryFile dest WriteMode {- Can resume when the chunk's offset is at or before the end of - the dest file. -} @@ -583,4 +583,4 @@ ensureChunksAreLogged _ _ (ChunkKeys _) = return () withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a withBytes (ByteContent b) a = a b -withBytes (FileContent f) a = a =<< liftIO (L.readFile f) +withBytes (FileContent f) a = a =<< liftIO (F.readFile f) diff --git a/Remote/Helper/Chunked/Legacy.hs b/Remote/Helper/Chunked/Legacy.hs index faae6ddc90..9f4c3fea36 100644 --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -72,7 +72,7 @@ storeChunks key tmp dest storer recorder finalizer = do when (null stored) $ giveup "no chunks were stored" where - basef = tmp ++ fromRawFilePath (keyFile key) + basef = tmp ++ fromOsPath (keyFile key) tmpdests = map (basef ++ ) chunkStream {- Given a list of destinations to use, chunks the data according to the diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs index a8f6798662..ae43c0ece5 100644 --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -23,15 +23,14 @@ import Data.Time.Clock.POSIX import System.PosixCompat.Files (modificationTime) import qualified Data.Map as M import qualified Data.Set as S -import qualified System.FilePath.ByteString as P repoCheap :: Git.Repo -> Bool repoCheap = not . Git.repoIsUrl -localpathCalc :: Git.Repo -> Maybe FilePath +localpathCalc :: Git.Repo -> Maybe OsPath localpathCalc r | not (Git.repoIsLocal r) && not (Git.repoIsLocalUnknown r) = Nothing - | otherwise = Just $ fromRawFilePath $ Git.repoPath r + | otherwise = Just $ Git.repoPath r {- Checks relatively inexpensively if a repository is available for use. -} repoAvail :: Git.Repo -> Annex Availability @@ -63,8 +62,11 @@ guardUsable r fallback a gitRepoInfo :: Remote -> Annex [(String, String)] gitRepoInfo r = do d <- fromRepo Git.localGitDir - mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus p) - =<< emptyWhenDoesNotExist (dirContentsRecursive (d P. "refs" P. "remotes" P. encodeBS (Remote.name r))) + let refsdir = d literalOsPath "refs" + literalOsPath "remotes" + toOsPath (Remote.name r) + mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (fromOsPath p)) + =<< emptyWhenDoesNotExist (dirContentsRecursive refsdir) let lastsynctime = case mtimes of [] -> "never" _ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index d1f5182e38..4bafc11811 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -11,7 +11,6 @@ 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 @@ -51,7 +50,7 @@ addHooks' r starthook stophook = r' runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a runHooks r starthook stophook a = do dir <- fromRepo gitAnnexRemotesDir - let lck = dir P. remoteid <> ".lck" + let lck = dir remoteid <> literalOsPath ".lck" whenM (notElem lck . M.keys <$> getLockCache) $ do createAnnexDirectory dir firstrun lck diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs index 09e246b31f..803230c0d0 100644 --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -14,6 +14,7 @@ import Types.StoreRetrieve import Remote.Helper.Special import Utility.Metered import Utility.Hash (IncrementalVerifier(..)) +import qualified Utility.FileIO as F import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -31,14 +32,14 @@ httpStorer a = fileStorer $ \k f m -> a k =<< liftIO (httpBodyStorer f m) -- Reads the file and generates a streaming request body, that will update -- the meter as it's sent. -httpBodyStorer :: FilePath -> MeterUpdate -> IO RequestBody +httpBodyStorer :: OsPath -> MeterUpdate -> IO RequestBody httpBodyStorer src m = do - size <- getFileSize (toRawFilePath src) + size <- getFileSize src let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink return $ RequestBodyStream (fromInteger size) streamer -- Like httpBodyStorer, but generates a chunked request body. -httpBodyStorerChunked :: FilePath -> MeterUpdate -> RequestBody +httpBodyStorerChunked :: OsPath -> MeterUpdate -> RequestBody httpBodyStorerChunked src m = let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink in RequestBodyStreamChunked streamer @@ -75,10 +76,10 @@ handlePopper numchunks chunksize meterupdate h sink = do -- Reads the http body and stores it to the specified file, updating the -- meter and incremental verifier as it goes. -httpBodyRetriever :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Response BodyReader -> IO () +httpBodyRetriever :: OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> Response BodyReader -> IO () httpBodyRetriever dest meterupdate iv resp | responseStatus resp /= ok200 = giveup $ show $ responseStatus resp - | otherwise = bracket (openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed) + | otherwise = bracket (F.openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed) where reader = responseBody resp go sofar h = do diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index 29c4a6ecf1..d7f4b1048b 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -36,9 +36,9 @@ type ProtoConnRunner c = forall a. P2P.Proto a -> ClosableConnection c -> Annex -- the pool when done. type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a -store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () store remoteuuid gc runner k af o p = do - let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k o) + let sizer = KeySizer k (fmap fst3 <$> prepSendAnnex k o) let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc metered (Just p) sizer bwlimit $ \_ p' -> runner (P2P.put k af p') >>= \case @@ -53,7 +53,7 @@ storeFanout lu k logstatus remoteuuid us = when (u /= remoteuuid) $ logChange lu k u logstatus -retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieve gc runner k af dest p verifyconfig = do iv <- startVerifyKeyContentIncrementally verifyconfig k let bwlimit = remoteAnnexBwLimitDownload gc <|> remoteAnnexBwLimit gc diff --git a/Remote/Helper/Path.hs b/Remote/Helper/Path.hs index fef6b486f7..ff58edd31d 100644 --- a/Remote/Helper/Path.hs +++ b/Remote/Helper/Path.hs @@ -10,7 +10,7 @@ module Remote.Helper.Path where import Annex.Common import Types.Availability -checkPathAvailability :: Bool -> FilePath -> Annex Availability +checkPathAvailability :: Bool -> OsPath -> Annex Availability checkPathAvailability islocal d | not islocal = return GloballyAvailable | otherwise = ifM (liftIO $ doesDirectoryExist d) diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs index 7a5a1bae9b..f3a54e3922 100644 --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -44,7 +44,7 @@ adjustReadOnly r } | otherwise = r -readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +readonlyStoreKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () readonlyStoreKey _ _ _ _ = readonlyFail readonlyRemoveKey :: Maybe SafeDropProof -> Key -> Annex () @@ -53,7 +53,7 @@ readonlyRemoveKey _ _ = readonlyFail readonlyStorer :: Storer readonlyStorer _ _ _ = readonlyFail -readonlyStoreExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +readonlyStoreExport :: OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () readonlyStoreExport _ _ _ _ = readonlyFail readonlyRemoveExport :: Key -> ExportLocation -> Annex () @@ -62,7 +62,7 @@ readonlyRemoveExport _ _ = readonlyFail readonlyRemoveExportDirectory :: ExportDirectory -> Annex () readonlyRemoveExportDirectory _ = readonlyFail -readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +readonlyStoreExportWithContentIdentifier :: OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier readonlyStoreExportWithContentIdentifier _ _ _ _ _ = readonlyFail readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex () diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 1a3c88ab1d..cc1fdf20a3 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -53,6 +53,7 @@ import Messages.Progress import qualified Git import qualified Git.Construct import Git.Types +import qualified Utility.FileIO as F import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -92,12 +93,11 @@ mkRetrievalVerifiableKeysSecure gc -- A Storer that expects to be provided with a file containing -- the content of the key to store. -fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex ()) -> Storer +fileStorer :: (Key -> OsPath -> MeterUpdate -> Annex ()) -> Storer fileStorer a k (FileContent f) m = a k f m fileStorer a k (ByteContent b) m = withTmp k $ \f -> do - let f' = fromRawFilePath f - liftIO $ L.writeFile f' b - a k f' m + liftIO $ L.writeFile (fromOsPath f) b + a k f m -- A Storer that expects to be provided with a L.ByteString of -- the content to store. @@ -107,7 +107,7 @@ byteStorer a k c m = withBytes c $ \b -> a k b m -- A Retriever that generates a lazy ByteString containing the Key's -- content, and passes it to a callback action which will fully consume it -- before returning. -byteRetriever :: (Key -> (L.ByteString -> Annex a) -> Annex a) -> Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a +byteRetriever :: (Key -> (L.ByteString -> Annex a) -> Annex a) -> Key -> MeterUpdate -> OsPath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a byteRetriever a k _m _dest _miv callback = a k (callback . ByteContent) -- A Retriever that writes the content of a Key to a file. @@ -115,7 +115,7 @@ byteRetriever a k _m _dest _miv callback = a k (callback . ByteContent) -- retrieves data. The incremental verifier is updated in the background as -- the action writes to the file, but may not be updated with the entire -- content of the file. -fileRetriever :: (RawFilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever +fileRetriever :: (OsPath -> Key -> MeterUpdate -> Annex ()) -> Retriever fileRetriever a = fileRetriever' $ \f k m miv -> let retrieve = a f k m in tailVerify miv f retrieve @@ -124,20 +124,20 @@ fileRetriever a = fileRetriever' $ \f k m miv -> - The action is responsible for updating the progress meter and the - incremental verifier as it retrieves data. -} -fileRetriever' :: (RawFilePath -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()) -> Retriever +fileRetriever' :: (OsPath -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()) -> Retriever fileRetriever' a k m dest miv callback = do createAnnexDirectory (parentDir dest) a dest k m miv - pruneTmpWorkDirBefore dest (callback . FileContent . fromRawFilePath) + pruneTmpWorkDirBefore dest (callback . FileContent) {- The base Remote that is provided to specialRemote needs to have - storeKey, retrieveKeyFile, removeKey, and checkPresent methods, - but they are never actually used (since specialRemote replaces them). - Here are some dummy ones. -} -storeKeyDummy :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +storeKeyDummy :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () storeKeyDummy _ _ _ _ = error "missing storeKey implementation" -retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +retrieveKeyFileDummy :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation" removeKeyDummy :: Maybe SafeDropProof -> Key -> Annex () removeKeyDummy _ _ = error "missing removeKey implementation" @@ -258,9 +258,9 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr displayprogress bwlimit p k srcfile a | displayProgress cfg = do - metered (Just p) (KeySizer k (pure (fmap toRawFilePath srcfile))) bwlimit (const a) + metered (Just p) (KeySizer k (pure srcfile)) bwlimit (const a) | otherwise = a p withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a withBytes (ByteContent b) a = a b -withBytes (FileContent f) a = a =<< liftIO (L.readFile f) +withBytes (FileContent f) a = a =<< liftIO (F.readFile f) diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 3832a88568..d279476488 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -66,7 +66,7 @@ git_annex_shell cs r command params fields let params' = case (debugenabled, debugselector) of (True, NoDebugSelector) -> Param "--debug" : params _ -> params - return (Param command : File (fromRawFilePath dir) : params') + return (Param command : File (fromOsPath dir) : params') uuidcheck NoUUID = [] uuidcheck u@(UUID _) = ["--uuid", fromUUID u] fieldopts diff --git a/Remote/Helper/ThirdPartyPopulated.hs b/Remote/Helper/ThirdPartyPopulated.hs index beeadd3109..9df1662811 100644 --- a/Remote/Helper/ThirdPartyPopulated.hs +++ b/Remote/Helper/ThirdPartyPopulated.hs @@ -14,9 +14,7 @@ import Types.Remote import Types.Import import Crypto (isEncKey) import Utility.Metered - -import qualified System.FilePath.ByteString as P -import qualified Data.ByteString as S +import qualified Utility.OsString as OS -- When a remote is thirdPartyPopulated, the files we want are probably -- in the .git directory. But, git does not really support .git in paths @@ -24,22 +22,22 @@ import qualified Data.ByteString as S -- And so anything in .git is prevented from being imported. -- To work around that, this renames that directory when generating an -- ImportLocation. -mkThirdPartyImportLocation :: RawFilePath -> ImportLocation +mkThirdPartyImportLocation :: OsPath -> ImportLocation mkThirdPartyImportLocation = - mkImportLocation . P.joinPath . map esc . P.splitDirectories + mkImportLocation . joinPath . map esc . splitDirectories where - esc ".git" = "dotgit" esc x - | "dotgit" `S.isSuffixOf` x = "dot" <> x + | x == literalOsPath ".git" = literalOsPath "dotgit" + | literalOsPath "dotgit" `OS.isSuffixOf` x = literalOsPath "dot" <> x | otherwise = x -fromThirdPartyImportLocation :: ImportLocation -> RawFilePath +fromThirdPartyImportLocation :: ImportLocation -> OsPath fromThirdPartyImportLocation = - P.joinPath . map unesc . P.splitDirectories . fromImportLocation + joinPath . map unesc . splitDirectories . fromImportLocation where - unesc "dotgit" = ".git" unesc x - | "dotgit" `S.isSuffixOf` x = S.drop 3 x + | x == literalOsPath "dotgit" = literalOsPath ".git" + | literalOsPath "dotgit" `OS.isSuffixOf` x = OS.drop 3 x | otherwise = x -- When a remote is thirdPartyPopulated, and contains a backup of a @@ -49,7 +47,7 @@ fromThirdPartyImportLocation = importKey :: ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) importKey loc _cid sz _ = return $ importKey' (fromImportLocation loc) (Just sz) -importKey' :: RawFilePath -> Maybe ByteSize -> Maybe Key +importKey' :: OsPath -> Maybe ByteSize -> Maybe Key importKey' p msz = case fileKey f of Just k -- Annex objects always are in a subdirectory with the same @@ -62,7 +60,7 @@ importKey' p msz = case fileKey f of -- part of special remotes that don't use that layout. The most -- likely special remote to be in a backup, the directory -- special remote, does use that layout at least.) - | lastMaybe (P.splitDirectories (P.dropFileName p)) /= Just f -> Nothing + | lastMaybe (splitDirectories (dropFileName p)) /= Just f -> Nothing -- Chunked or encrypted keys used in special remotes are not -- supported. | isChunkKey k || isEncKey k -> Nothing @@ -82,4 +80,4 @@ importKey' p msz = case fileKey f of _ -> Just k Nothing -> Nothing where - f = P.takeFileName p + f = takeFileName p diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 491bf86144..02a3b22101 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -118,8 +118,8 @@ hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv) ] fileenv Nothing = [] fileenv (Just file) = [envvar "FILE" file] - hashbits = map takeDirectory $ splitPath $ - fromRawFilePath $ hashDirMixed def k + hashbits = map (fromOsPath . takeDirectory) $ + splitPath $ hashDirMixed def k lookupHook :: HookName -> Action -> Annex (Maybe String) lookupHook hookname action = do @@ -159,11 +159,11 @@ runHook' hook action k f a = maybe (return False) run =<< lookupHook hook action ) store :: HookName -> Storer -store h = fileStorer $ \k src _p -> runHook h "store" k (Just src) +store h = fileStorer $ \k src _p -> runHook h "store" k (Just (fromOsPath src)) retrieve :: HookName -> Retriever retrieve h = fileRetriever $ \d k _p -> - unlessM (runHook' h "retrieve" k (Just (fromRawFilePath d)) $ return True) $ + unlessM (runHook' h "retrieve" k (Just (fromOsPath d)) $ return True) $ giveup "failed to retrieve content" remove :: HookName -> Remover diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs index b297770150..de0d9e4c09 100644 --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -122,14 +122,14 @@ httpAlsoSetup _ (Just u) _ c gc = do downloadKey :: Maybe URLString -> LearnedLayout -> Retriever downloadKey baseurl ll = fileRetriever' $ \dest key p iv -> - downloadAction (fromRawFilePath dest) p iv (keyUrlAction baseurl ll key) + downloadAction dest p iv (keyUrlAction baseurl ll key) -retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retriveExportHttpAlso baseurl key loc dest p = do verifyKeyContentIncrementally AlwaysVerify key $ \iv -> downloadAction dest p iv (exportLocationUrlAction baseurl loc) -downloadAction :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () +downloadAction :: OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () downloadAction dest p iv run = Url.withUrlOptions $ \uo -> run (\url -> Url.download' p iv url dest uo) @@ -192,7 +192,7 @@ exportLocationUrlAction -> (URLString -> Annex (Either String ())) -> Annex (Either String ()) exportLocationUrlAction (Just baseurl) loc a = - a (baseurl P. fromRawFilePath (fromExportLocation loc)) + a (baseurl P. fromOsPath (fromExportLocation loc)) exportLocationUrlAction Nothing _ _ = noBaseUrlError -- cannot normally happen @@ -228,5 +228,5 @@ supportedLayouts baseurl = ] ] where - mkurl k hasher = baseurl P. fromRawFilePath (hasher k) P. kf k - kf k = fromRawFilePath (keyFile k) + mkurl k hasher = baseurl P. fromOsPath (hasher k) P. kf k + kf k = fromOsPath (keyFile k) diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 5a908f9c67..c1e205a31c 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -117,12 +117,13 @@ gen r u rc gc rs = do , getRepo = return r , gitconfig = gc , localpath = if islocal - then Just $ rsyncUrl o + then Just $ toOsPath $ rsyncUrl o else Nothing , readonly = False , appendonly = False , untrustworthy = False - , availability = checkPathAvailability islocal (rsyncUrl o) + , availability = checkPathAvailability islocal + (toOsPath (rsyncUrl o)) , remotetype = remote , mkUnavailable = return Nothing , getInfo = return [("url", url)] @@ -221,45 +222,45 @@ rsyncSetup _ mu _ c gc = do - (When we have the right hash directory structure, we can just - pass --include=X --include=X/Y --include=X/Y/file --exclude=*) -} -store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex () +store :: RsyncOpts -> Key -> OsPath -> MeterUpdate -> Annex () store o k src meterupdate = storeGeneric o meterupdate basedest populatedest where - basedest = fromRawFilePath $ NE.head (keyPaths k) + basedest = NE.head (keyPaths k) populatedest dest = liftIO $ if canrename then do - R.rename (toRawFilePath src) (toRawFilePath dest) + R.rename (fromOsPath src) (fromOsPath dest) return True - else createLinkOrCopy (toRawFilePath src) (toRawFilePath dest) + else createLinkOrCopy src dest {- If the key being sent is encrypted or chunked, the file - containing its content is a temp file, and so can be - renamed into place. Otherwise, the file is the annexed - object file, and has to be copied or hard linked into place. -} canrename = isEncKey k || isChunkKey k -storeGeneric :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex () +storeGeneric :: RsyncOpts -> MeterUpdate -> OsPath -> (OsPath -> Annex Bool) -> Annex () storeGeneric o meterupdate basedest populatedest = unlessM (storeGeneric' o meterupdate basedest populatedest) $ giveup "failed to rsync content" -storeGeneric' :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex Bool +storeGeneric' :: RsyncOpts -> MeterUpdate -> OsPath -> (OsPath -> Annex Bool) -> Annex Bool storeGeneric' o meterupdate basedest populatedest = withRsyncScratchDir $ \tmp -> do let dest = tmp basedest - createAnnexDirectory (parentDir (toRawFilePath dest)) + createAnnexDirectory (parentDir dest) ok <- populatedest dest ps <- sendParams if ok then showResumable $ rsyncRemote Upload o (Just meterupdate) $ ps ++ Param "--recursive" : partialParams ++ -- tmp/ to send contents of tmp dir - [ File $ addTrailingPathSeparator tmp + [ File $ fromOsPath $ addTrailingPathSeparator tmp , Param $ rsyncUrl o ] else return False -retrieve :: RsyncOpts -> RawFilePath -> Key -> MeterUpdate -> Annex () -retrieve o f k p = rsyncRetrieveKey o k (fromRawFilePath f) (Just p) +retrieve :: RsyncOpts -> OsPath -> Key -> MeterUpdate -> Annex () +retrieve o f k p = rsyncRetrieveKey o k f (Just p) -retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex () +retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> OsPath -> Annex () retrieveCheap o k _af f = ifM (preseedTmp k f) ( rsyncRetrieveKey o k f Nothing , giveup "cannot preseed rsync with existing content" @@ -269,11 +270,11 @@ remove :: RsyncOpts -> Remover remove o _proof k = removeGeneric o includes where includes = concatMap use dirHashes - use h = let dir = fromRawFilePath (h def k) in - [ fromRawFilePath (parentDir (toRawFilePath dir)) - , dir + use h = let dir = h def k in + [ fromOsPath (parentDir dir) + , fromOsPath dir -- match content directory and anything in it - , dir fromRawFilePath (keyFile k) "***" + , fromOsPath $ dir keyFile k literalOsPath "***" ] {- An empty directory is rsynced to make it delete. Everything is excluded, @@ -291,7 +292,7 @@ removeGeneric o includes = do [ Param "--exclude=*" -- exclude everything else , Param "--quiet", Param "--delete", Param "--recursive" ] ++ partialParams ++ - [ Param $ addTrailingPathSeparator tmp + [ Param $ fromOsPath $ addTrailingPathSeparator tmp , Param $ rsyncUrl o ] unless ok $ @@ -313,43 +314,43 @@ checkPresentGeneric o rsyncurls = do } in withCreateProcess p $ \_ _ _ -> checkSuccessProcess -storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM :: RsyncOpts -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM o src _k loc meterupdate = storeGeneric o meterupdate basedest populatedest where - basedest = fromRawFilePath (fromExportLocation loc) - populatedest = liftIO . createLinkOrCopy (toRawFilePath src) . toRawFilePath + basedest = fromExportLocation loc + populatedest = liftIO . createLinkOrCopy src -retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retrieveExportM o k loc dest p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> - tailVerify iv (toRawFilePath dest) $ + tailVerify iv dest $ rsyncRetrieve o [rsyncurl] dest (Just p) where - rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc)) + rsyncurl = mkRsyncUrl o (fromOsPath (fromExportLocation loc)) checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl] where - rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc)) + rsyncurl = mkRsyncUrl o (fromOsPath (fromExportLocation loc)) removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex () removeExportM o _k loc = - removeGeneric o $ map fromRawFilePath $ - includes $ fromExportLocation loc + removeGeneric o $ map fromOsPath $ includes $ fromExportLocation loc where includes f = f : case upFrom f of Nothing -> [] Just f' -> includes f' removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex () -removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d) +removeExportDirectoryM o ed = removeGeneric o $ + map fromOsPath (allbelow d : includes d) where - d = fromRawFilePath $ fromExportDirectory ed - allbelow f = f "***" - includes f = f : case upFrom (toRawFilePath f) of + d = fromExportDirectory ed + allbelow f = f literalOsPath "***" + includes f = f : case upFrom f of Nothing -> [] - Just f' -> includes (fromRawFilePath f') + Just f' -> includes f' renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM _ _ _ _ = return Nothing @@ -371,12 +372,12 @@ sendParams = ifM crippledFileSystem {- Runs an action in an empty scratch directory that can be used to build - up trees for rsync. -} -withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a +withRsyncScratchDir :: (OsPath -> Annex a) -> Annex a withRsyncScratchDir a = do - t <- fromRawFilePath <$> fromRepo gitAnnexTmpObjectDir - withTmpDirIn t (toOsPath "rsynctmp") a + t <- fromRepo gitAnnexTmpObjectDir + withTmpDirIn t (literalOsPath "rsynctmp") a -rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> FilePath -> Maybe MeterUpdate -> Annex () +rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> OsPath -> Maybe MeterUpdate -> Annex () rsyncRetrieve o rsyncurls dest meterupdate = unlessM go $ giveup "rsync failed" @@ -385,10 +386,10 @@ rsyncRetrieve o rsyncurls dest meterupdate = -- use inplace when retrieving to support resuming [ Param "--inplace" , Param u - , File dest + , File (fromOsPath dest) ] -rsyncRetrieveKey :: RsyncOpts -> Key -> FilePath -> Maybe MeterUpdate -> Annex () +rsyncRetrieveKey :: RsyncOpts -> Key -> OsPath -> Maybe MeterUpdate -> Annex () rsyncRetrieveKey o k dest meterupdate = rsyncRetrieve o (rsyncUrls o k) dest meterupdate diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs index 8b3c2eba14..0264d10397 100644 --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -14,14 +14,14 @@ import Annex.Locations import Utility.Rsync import Utility.SafeCommand import Utility.ShellEscape -import Utility.FileSystemEncoding +import Utility.OsPath import Annex.DirHashes #ifdef mingw32_HOST_OS import Utility.Split #endif import Data.Default -import System.FilePath.Posix +import qualified System.FilePath.Posix as Posix import qualified Data.List.NonEmpty as NE type RsyncUrl = String @@ -40,15 +40,15 @@ rsyncEscape o u | otherwise = u mkRsyncUrl :: RsyncOpts -> FilePath -> RsyncUrl -mkRsyncUrl o f = rsyncUrl o rsyncEscape o f +mkRsyncUrl o f = rsyncUrl o Posix. rsyncEscape o f rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl] rsyncUrls o k = map use (NE.toList dirHashes) where - use h = rsyncUrl o hash h rsyncEscape o (f f) - f = fromRawFilePath (keyFile k) + use h = rsyncUrl o Posix. hash h Posix. rsyncEscape o (f Posix. f) + f = fromOsPath (keyFile k) #ifndef mingw32_HOST_OS - hash h = fromRawFilePath $ h def k + hash h = fromOsPath $ h def k #else - hash h = replace "\\" "/" $ fromRawFilePath $ h def k + hash h = replace "\\" "/" $ fromOsPath $ h def k #endif diff --git a/Remote/S3.hs b/Remote/S3.hs index 17ad6809f7..df6f4e6c3c 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -68,6 +68,7 @@ import Utility.Url (extractFromResourceT, UserAgent) import Annex.Url (getUserAgent, getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env import Annex.Verify +import qualified Utility.FileIO as F type BucketName = String type BucketObject = String @@ -349,10 +350,10 @@ store mh r info magic = fileStorer $ \k f p -> withS3HandleOrFail (uuid r) mh $ when (isIA info && not (isChunkKey k)) $ setUrlPresent k (iaPublicUrl info (bucketObject info k)) -storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) +storeHelper :: S3Info -> S3Handle -> Maybe Magic -> OsPath -> 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 (toRawFilePath f) + fsz <- getFileSize f if fsz > partsz then multipartupload fsz partsz else singlepartupload @@ -385,7 +386,7 @@ storeHelper info h magic f object p = liftIO $ case partSize info of -- Send parts of the file, taking care to stream each part -- w/o buffering in memory, since the parts can be large. - etags <- bracketIO (openBinaryFile f ReadMode) hClose $ \fh -> do + etags <- bracketIO (F.openBinaryFile f ReadMode) hClose $ \fh -> do let sendparts meter etags partnum = do pos <- liftIO $ hTell fh if pos >= fsz @@ -420,24 +421,24 @@ retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case Left failreason -> do warning (UnquotedString failreason) giveup "cannot download content" - Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv + Right loc -> retrieveHelper info h loc f p iv Left S3HandleNeedCreds -> getPublicWebUrls' rs info c k >>= \case Left failreason -> do warning (UnquotedString failreason) giveup "cannot download content" - Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $ + Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us f) $ giveup "failed to download content" Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) -retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () +retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () retrieveHelper info h loc f p iv = retrieveHelper' h f p iv $ case loc of Left o -> S3.getObject (bucket info) o Right (S3VersionID o vid) -> (S3.getObject (bucket info) o) { S3.goVersionId = Just vid } -retrieveHelper' :: S3Handle -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> S3.GetObject -> Annex () +retrieveHelper' :: S3Handle -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> S3.GetObject -> Annex () retrieveHelper' h f p iv req = liftIO $ runResourceT $ do S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle h req Url.sinkResponseFile p iv zeroBytesProcessed f WriteMode rsp @@ -495,10 +496,10 @@ checkKeyHelper' info h o limit = liftIO $ runResourceT $ do where req = limit $ S3.headObject (bucket info) o -storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportS3 hv r rs info magic f k loc p = void $ storeExportS3' hv r rs info magic f k loc p -storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) +storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case Right h -> go h Left pr -> giveupS3HandleProblem pr (uuid r) @@ -509,7 +510,7 @@ storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case setS3VersionID info rs k mvid return (metag, mvid) -retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retrieveExportS3 hv r info k loc f p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> withS3Handle hv $ \case Right h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv @@ -700,7 +701,7 @@ mkImportableContentsVersioned = build . groupfiles | otherwise = i : removemostrecent mtime rest -retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) +retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) retrieveExportWithContentIdentifierS3 hv r rs info loc (cid:_) dest gk p = case gk of Right _mkkey -> do @@ -744,7 +745,7 @@ rewritePreconditionException a = catchJust (Url.matchStatusCodeException want) a -- -- When the bucket is not versioned, data loss can result. -- This is why that configuration requires --force to enable. -storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecids p | versioning info = go | otherwise = go @@ -835,7 +836,7 @@ writeUUIDFile c u info h = unless (exportTree c || importTree c) $ do giveup "Cannot reuse this bucket." _ -> void $ liftIO $ runResourceT $ sendS3Handle h mkobject where - file = T.pack $ uuidFile c + file = T.pack $ fromOsPath $ uuidFile c uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u] mkobject = putObject info file (RequestBodyLBS uuidb) @@ -858,11 +859,11 @@ checkUUIDFile c u info h check (S3.GetObjectMemoryResponse _meta rsp) = responseStatus rsp == ok200 && responseBody rsp == uuidb - file = T.pack $ uuidFile c + file = T.pack $ fromOsPath $ uuidFile c uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u] -uuidFile :: ParsedRemoteConfig -> FilePath -uuidFile c = getFilePrefix c ++ "annex-uuid" +uuidFile :: ParsedRemoteConfig -> OsPath +uuidFile c = toOsPath (getFilePrefix c) <> literalOsPath "annex-uuid" tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a) tryS3 a = (Right <$> a) `catch` (pure . Left) @@ -1090,16 +1091,16 @@ getBucketObject c = munge . serializeKey getBucketExportLocation :: ParsedRemoteConfig -> ExportLocation -> BucketObject getBucketExportLocation c loc = - getFilePrefix c ++ fromRawFilePath (fromExportLocation loc) + getFilePrefix c ++ fromOsPath (fromExportLocation loc) getBucketImportLocation :: ParsedRemoteConfig -> BucketObject -> Maybe ImportLocation getBucketImportLocation c obj -- The uuidFile should not be imported. - | obj == uuidfile = Nothing + | obj == fromOsPath uuidfile = Nothing -- Only import files that are under the fileprefix, when -- one is configured. | prefix `isPrefixOf` obj = Just $ mkImportLocation $ - toRawFilePath $ drop prefixlen obj + toOsPath $ drop prefixlen obj | otherwise = Nothing where prefix = getFilePrefix c diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 9bd88b351e..9495a3c082 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -49,7 +49,7 @@ import Utility.ThreadScheduler {- The TMVar is left empty until tahoe has been verified to be running. -} data TahoeHandle = TahoeHandle TahoeConfigDir (TMVar ()) -type TahoeConfigDir = FilePath +type TahoeConfigDir = OsPath type SharedConvergenceSecret = String type IntroducerFurl = String type Capability = String @@ -81,7 +81,9 @@ gen r u rc gc rs = do c <- parsedRemoteConfig remote rc cst <- remoteCost gc c expensiveRemoteCost hdl <- liftIO $ TahoeHandle - <$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc) + <$> maybe (defaultTahoeConfigDir u) + (return . toOsPath) + (remoteAnnexTahoe gc) <*> newEmptyTMVarIO return $ Just $ Remote { uuid = u @@ -136,18 +138,18 @@ tahoeSetup _ mu _ c _ = do , (scsField, Proposed scs) ] else c - gitConfigSpecialRemote u c' [("tahoe", configdir)] + gitConfigSpecialRemote u c' [("tahoe", fromOsPath configdir)] return (c', u) where missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." -store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz -> - parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe + parsePut <$> liftIO (readTahoe hdl "put" [File (fromOsPath src)]) >>= maybe (giveup "tahoe failed to store content") (\cap -> storeCapability rs k cap) -retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieve rs hdl k _f d _p _ = do go =<< getCapability rs k -- Tahoe verifies the content it retrieves using cryptographically @@ -155,7 +157,7 @@ retrieve rs hdl k _f d _p _ = do return Verified where go Nothing = giveup "tahoe capability is not known" - go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File d]) $ + go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File (fromOsPath d)]) $ giveup "tahoe failed to reteieve content" remove :: Maybe SafeDropProof -> Key -> Annex () @@ -185,7 +187,7 @@ checkKey rs hdl k = go =<< getCapability rs k defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir defaultTahoeConfigDir u = do h <- myHomeDir - return $ h ".tahoe-git-annex" fromUUID u + return $ toOsPath h literalOsPath ".tahoe-git-annex" fromUUID u tahoeConfigure :: TahoeConfigDir -> IntroducerFurl -> Maybe SharedConvergenceSecret -> IO SharedConvergenceSecret tahoeConfigure configdir furl mscs = do @@ -197,8 +199,7 @@ tahoeConfigure configdir furl mscs = do createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool createClient configdir furl = do - createDirectoryIfMissing True $ - fromRawFilePath $ parentDir $ toRawFilePath configdir + createDirectoryIfMissing True $ parentDir configdir boolTahoe configdir "create-client" [ Param "--nickname", Param "git-annex" , Param "--introducer", Param furl @@ -206,7 +207,8 @@ createClient configdir furl = do writeSharedConvergenceSecret :: TahoeConfigDir -> SharedConvergenceSecret -> IO () writeSharedConvergenceSecret configdir scs = - writeFile (convergenceFile configdir) (unlines [scs]) + writeFile (fromOsPath (convergenceFile configdir)) + (unlines [scs]) {- The tahoe daemon writes the convergenceFile shortly after it starts - (it does not need to connect to the network). So, try repeatedly to read @@ -215,7 +217,7 @@ writeSharedConvergenceSecret configdir scs = getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret getSharedConvergenceSecret configdir = go (60 :: Int) where - f = convergenceFile configdir + f = fromOsPath $ convergenceFile configdir go n | n == 0 = giveup $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?" | otherwise = do @@ -227,8 +229,9 @@ getSharedConvergenceSecret configdir = go (60 :: Int) threadDelaySeconds (Seconds 1) go (n - 1) -convergenceFile :: TahoeConfigDir -> FilePath -convergenceFile configdir = configdir "private" "convergence" +convergenceFile :: TahoeConfigDir -> OsPath +convergenceFile configdir = + configdir literalOsPath "private" literalOsPath "convergence" startTahoeDaemon :: TahoeConfigDir -> IO () startTahoeDaemon configdir = void $ boolTahoe configdir "start" [] @@ -267,7 +270,7 @@ readTahoe hdl command params = withTahoeConfigDir hdl $ \configdir -> tahoeParams :: TahoeConfigDir -> String -> [CommandParam] -> [CommandParam] tahoeParams configdir command params = - Param "-d" : File configdir : Param command : params + Param "-d" : File (fromOsPath configdir) : Param command : params storeCapability :: RemoteStateHandle -> Key -> Capability -> Annex () storeCapability rs k cap = setRemoteState rs k cap diff --git a/Remote/Web.hs b/Remote/Web.hs index 87232b3dfb..4728a64c6a 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -116,7 +116,7 @@ setupInstance _ mu _ c _ = do gitConfigSpecialRemote u c [("web", "true")] return (c, u) -downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification downloadKey urlincludeexclude key _af dest p vc = go =<< getWebUrls' urlincludeexclude key where @@ -175,14 +175,14 @@ downloadKey urlincludeexclude key _af dest p vc = let b = if isCryptographicallySecure db then db else defaultHashBackend - generateEquivilantKey b (toRawFilePath dest) >>= \case + generateEquivilantKey b dest >>= \case Nothing -> return Nothing Just ek -> do unless (ek `elem` eks) $ setEquivilantKey key ek return (Just Verified) -uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +uploadKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () uploadKey _ _ _ _ = giveup "upload to web not supported" dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex () diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index aaf8b8f059..222cadb876 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -176,11 +176,11 @@ retrieve hv cc = fileRetriever' $ \d k p iv -> LegacyChunks _ -> do -- Not doing incremental verification for chunks. liftIO $ maybe noop unableIncrementalVerifier iv - retrieveLegacyChunked (fromRawFilePath d) k p dav + retrieveLegacyChunked (fromOsPath d) k p dav _ -> liftIO $ goDAV dav $ - retrieveHelper (keyLocation k) (fromRawFilePath d) p iv + retrieveHelper (keyLocation k) d p iv -retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> DAVT IO () +retrieveHelper :: DavLocation -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> DAVT IO () retrieveHelper loc d p iv = do debugDav $ "retrieve " ++ loc inLocation loc $ @@ -213,14 +213,14 @@ checkKey hv chunkconfig k = withDavHandle hv $ \dav -> existsDAV (keyLocation k) either giveup return v -storeExportDav :: DavHandleVar -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportDav :: DavHandleVar -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportDav hdl f k loc p = case exportLocation loc of Right dest -> withDavHandle hdl $ \h -> runExport h $ \dav -> do reqbody <- liftIO $ httpBodyStorer f p storeHelper dav (exportTmpLocation loc k) dest reqbody Left err -> giveup err -retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification +retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retrieveExportDav hdl k loc d p = case exportLocation loc of Right src -> verifyKeyContentIncrementally AlwaysVerify k $ \iv -> withDavHandle hdl $ \h -> runExport h $ \_dav -> @@ -247,7 +247,7 @@ removeExportDav hdl _k loc = case exportLocation loc of removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex () removeExportDirectoryDav hdl dir = withDavHandle hdl $ \h -> runExport h $ \_dav -> do - let d = fromRawFilePath $ fromExportDirectory dir + let d = fromOsPath $ fromExportDirectory dir debugDav $ "delContent " ++ d inLocation d delContentM @@ -481,7 +481,7 @@ storeLegacyChunked annexrunner chunksize k dav b = finalizer tmp' dest' = goDAV dav $ finalizeStore dav tmp' (fromJust $ locationParent dest') - tmp = addTrailingPathSeparator $ keyTmpLocation k + tmp = fromOsPath $ addTrailingPathSeparator $ toOsPath $ keyTmpLocation k dest = keyLocation k retrieveLegacyChunked :: FilePath -> Key -> MeterUpdate -> DavHandle -> Annex () diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs index e836acd8a9..2dedc894db 100644 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -17,9 +17,9 @@ import Utility.Url (URLString) #ifdef mingw32_HOST_OS import Utility.Split #endif -import Utility.FileSystemEncoding +import Utility.OsPath -import System.FilePath.Posix -- for manipulating url paths +import qualified System.FilePath.Posix as UrlPath import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) import Control.Monad.IO.Class (MonadIO) import Network.URI @@ -30,28 +30,29 @@ type DavLocation = String {- Runs action with a new location relative to the current location. -} inLocation :: (MonadIO m) => DavLocation -> DAVT m a -> DAVT m a -inLocation d = inDAVLocation ( d') +inLocation d = inDAVLocation (UrlPath. d') where d' = escapeURIString isUnescapedInURI d {- The directory where files(s) for a key are stored. -} keyDir :: Key -> DavLocation -keyDir k = addTrailingPathSeparator $ hashdir fromRawFilePath (keyFile k) +keyDir k = UrlPath.addTrailingPathSeparator $ + hashdir UrlPath. fromOsPath (keyFile k) where #ifndef mingw32_HOST_OS - hashdir = fromRawFilePath $ hashDirLower def k + hashdir = fromOsPath $ hashDirLower def k #else - hashdir = replace "\\" "/" (fromRawFilePath $ hashDirLower def k) + hashdir = replace "\\" "/" (fromOsPath $ hashDirLower def k) #endif keyLocation :: Key -> DavLocation -keyLocation k = keyDir k ++ fromRawFilePath (keyFile k) +keyLocation k = keyDir k ++ fromOsPath (keyFile k) {- Paths containing # or ? cannot be represented in an url, so fails on - those. -} exportLocation :: ExportLocation -> Either String DavLocation exportLocation l = - let p = fromRawFilePath $ fromExportLocation l + let p = fromOsPath $ fromExportLocation l in if any (`elem` p) illegalinurl then Left ("Cannot store file containing '#' or '?' on webdav: " ++ p) else Right p @@ -60,7 +61,7 @@ exportLocation l = {- Where we store temporary data for a key as it's being uploaded. -} keyTmpLocation :: Key -> DavLocation -keyTmpLocation = tmpLocation . fromRawFilePath . keyFile +keyTmpLocation = tmpLocation . fromOsPath . keyFile {- Where we store temporary data for a file as it's being exported. - @@ -72,10 +73,11 @@ keyTmpLocation = tmpLocation . fromRawFilePath . keyFile -} exportTmpLocation :: ExportLocation -> Key -> DavLocation exportTmpLocation l k - | length (splitDirectories p) > 1 = takeDirectory p keyTmpLocation k + | length (UrlPath.splitDirectories p) > 1 = + UrlPath.takeDirectory p UrlPath. keyTmpLocation k | otherwise = keyTmpLocation k where - p = fromRawFilePath (fromExportLocation l) + p = fromOsPath (fromExportLocation l) tmpLocation :: FilePath -> DavLocation tmpLocation f = "git-annex-webdav-tmp-" ++ f @@ -86,7 +88,7 @@ locationParent loc | otherwise = Just parent where tops = ["/", "", "."] - parent = takeDirectory loc + parent = UrlPath.takeDirectory loc locationUrl :: URLString -> DavLocation -> URLString -locationUrl baseurl loc = baseurl loc +locationUrl baseurl loc = baseurl UrlPath. loc diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 515e3d333b..550a9404dd 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -191,7 +191,7 @@ transport (RemoteRepo r gc) url@(RemoteURI uri) th ichan ochan = runBool [Param "fetch", Param $ Git.repoDescribe r] send (DONESYNCING url ok) -torSocketFile :: Annex.Annex (Maybe FilePath) +torSocketFile :: Annex.Annex (Maybe OsPath) torSocketFile = do u <- getUUID let ident = fromUUID u diff --git a/Test.hs b/Test.hs index 6c231c9859..b66dd9b78e 100644 --- a/Test.hs +++ b/Test.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Test where @@ -37,9 +38,9 @@ import qualified Git.Types import qualified Git.Ref import qualified Git.LsTree import qualified Git.FilePath -import qualified Git.Bundle import qualified Annex.Locations #ifndef mingw32_HOST_OS +import qualified Git.Bundle import qualified Types.GitConfig #endif import qualified Types.TrustLevel @@ -87,6 +88,7 @@ import qualified Utility.Aeson import qualified Utility.CopyFile import qualified Utility.MoveFile import qualified Utility.StatelessOpenPGP +import qualified Utility.OsString as OS import qualified Types.Remote #ifndef mingw32_HOST_OS import qualified Remote.Helper.Encryptable @@ -216,7 +218,7 @@ testGitRemote = testRemote False "git" $ \remotename -> do testDirectoryRemote :: TestTree testDirectoryRemote = testRemote True "directory" $ \remotename -> do - createDirectory "remotedir" + createDirectory (literalOsPath "remotedir") git_annex "initremote" [ remotename , "type=directory" @@ -437,7 +439,7 @@ test_git_remote_annex exporttree runtest cfg populate = whenM Git.Bundle.versionSupported $ intmpclonerepo $ do let cfg' = ["type=directory", "encryption=none", "directory=dir"] ++ cfg - createDirectory "dir" + createDirectory (literalOsPath "dir") git_annex "initremote" ("foo":("uuid=" ++ diruuid):cfg') "initremote" git_annex "get" [] "get failed" () <- populate @@ -452,7 +454,7 @@ test_git_remote_annex exporttree git_annex "get" [annexedfile] "get from origin special remote" diruuid="89ddefa4-a04c-11ef-87b5-e880882a4f98" #else -test_git_remote_annex exporttree = +test_git_remote_annex _exporttree = -- git-remote-annex is not currently installed on Windows return () #endif @@ -461,14 +463,14 @@ test_add_moved :: Assertion test_add_moved = intmpclonerepo $ do git_annex "get" [annexedfile] "get failed" annexed_present annexedfile - createDirectory subdir - Utility.MoveFile.moveFile (toRawFilePath annexedfile) (toRawFilePath subfile) + createDirectory (toOsPath subdir) + Utility.MoveFile.moveFile (toOsPath annexedfile) subfile git_annex "add" [subdir] "add of moved annexed file" git "mv" [sha1annexedfile, sha1annexedfile ++ ".renamed"] "git mv" git_annex "add" [] "add does not fail on deleted file after move" where subdir = "subdir" - subfile = subdir "file" + subfile = toOsPath subdir literalOsPath "file" test_readonly_remote :: Assertion test_readonly_remote = @@ -494,7 +496,7 @@ test_ignore_deleted_files :: Assertion test_ignore_deleted_files = intmpclonerepo $ do git_annex "get" [annexedfile] "get" git_annex_expectoutput "find" [] [annexedfile] - removeWhenExistsWith R.removeLink (toRawFilePath annexedfile) + removeWhenExistsWith removeFile (toOsPath 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" [] [] @@ -563,18 +565,18 @@ test_magic = intmpclonerepo $ do #endif test_import :: Assertion -test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "importtest")) $ \importdir -> do - (toimport1, importf1, imported1) <- mktoimport importdir "import1" +test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (literalOsPath "importtest") $ \importdir -> do + (toimport1, importf1, imported1) <- mktoimport importdir (literalOsPath "import1") git_annex "import" [toimport1] "import" annexed_present_imported imported1 checkdoesnotexist importf1 - (toimport2, importf2, imported2) <- mktoimport importdir "import2" + (toimport2, importf2, imported2) <- mktoimport importdir (literalOsPath "import2") git_annex "import" [toimport2] "import of duplicate" annexed_present_imported imported2 checkdoesnotexist importf2 - (toimport3, importf3, imported3) <- mktoimport importdir "import3" + (toimport3, importf3, imported3) <- mktoimport importdir (literalOsPath "import3") git_annex "import" ["--skip-duplicates", toimport3] "import of duplicate with --skip-duplicates" checkdoesnotexist imported3 @@ -584,19 +586,19 @@ test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePa checkdoesnotexist imported3 checkdoesnotexist importf3 - (toimport4, importf4, imported4) <- mktoimport importdir "import4" + (toimport4, importf4, imported4) <- mktoimport importdir (literalOsPath "import4") git_annex "import" ["--deduplicate", toimport4] "import --deduplicate" checkdoesnotexist imported4 checkdoesnotexist importf4 - (toimport5, importf5, imported5) <- mktoimport importdir "import5" + (toimport5, importf5, imported5) <- mktoimport importdir (literalOsPath "import5") git_annex "import" ["--duplicate", toimport5] "import --duplicate" annexed_present_imported imported5 checkexists importf5 git_annex "drop" ["--force", imported1, imported2, imported5] "drop" annexed_notpresent_imported imported2 - (toimportdup, importfdup, importeddup) <- mktoimport importdir "importdup" + (toimportdup, importfdup, importeddup) <- mktoimport importdir (literalOsPath "importdup") git_annex_shouldfail "import" ["--clean-duplicates", toimportdup] "import of missing duplicate with --clean-duplicates not allowed" checkdoesnotexist importeddup @@ -604,9 +606,14 @@ test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePa where mktoimport importdir subdir = do createDirectory (importdir subdir) - let importf = subdir "f" - writecontent (importdir importf) (content importf) - return (importdir subdir, importdir importf, importf) + let importf = subdir literalOsPath "f" + writecontent (fromOsPath (importdir importf)) + (content (fromOsPath importf)) + return + ( fromOsPath (importdir subdir) + , fromOsPath (importdir importf) + , fromOsPath importf + ) test_reinject :: Assertion test_reinject = intmpclonerepo $ do @@ -880,10 +887,10 @@ test_lock_force = intmpclonerepo $ do git_annex "get" [annexedfile] "get of file" git_annex "unlock" [annexedfile] "unlock" annexeval $ do - Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) + Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile) Database.Keys.removeInodeCaches k Database.Keys.closeDb - liftIO . removeWhenExistsWith R.removeLink + liftIO . removeWhenExistsWith removeFile =<< Annex.calcRepo' Annex.Locations.gitAnnexKeysDbIndexCache writecontent annexedfile "test_lock_force content" git_annex_shouldfail "lock" [annexedfile] "lock of modified file should not be allowed" @@ -930,7 +937,7 @@ test_fix = intmpclonerepo $ unlessM (hasUnlockedFiles <$> getTestMode) $ do annexed_present annexedfile git_annex "fix" [annexedfile] "fix of present file" annexed_present annexedfile - createDirectory subdir + createDirectory (toOsPath subdir) git "mv" [annexedfile, subdir] "git mv" git_annex "fix" [newfile] "fix of moved file" runchecks [checklink, checkunwritable] newfile @@ -978,7 +985,7 @@ test_fsck_basic = intmpclonerepo $ do where corrupt f = do git_annex "get" [f] "get of file" - Utility.FileMode.allowWrite (toRawFilePath f) + Utility.FileMode.allowWrite (toOsPath f) writecontent f (changedcontent f) ifM (hasUnlockedFiles <$> getTestMode) ( git_annex "fsck" []"fsck on unlocked file with changed file content" @@ -1119,10 +1126,12 @@ test_unused = intmpclonerepo $ do writecontent "unusedfile" "unusedcontent" git_annex "add" ["unusedfile"] "add of unusedfile" unusedfilekey <- getKey backendSHA256E "unusedfile" - renameFile "unusedfile" "unusedunstagedfile" + renameFile + (literalOsPath "unusedfile") + (literalOsPath "unusedunstagedfile") git "rm" ["-qf", "unusedfile"] "git rm" checkunused [] "with unstaged link" - removeFile "unusedunstagedfile" + removeFile (literalOsPath "unusedunstagedfile") checkunused [unusedfilekey] "with renamed link deleted" -- unused used to miss symlinks that were deleted or modified @@ -1141,7 +1150,7 @@ test_unused = intmpclonerepo $ do git_annex "add" ["unusedfile"] "add of unusedfile" git "add" ["unusedfile"] "git add" checkunused [] "with staged file" - removeFile "unusedfile" + removeFile (literalOsPath "unusedfile") checkunused [] "with staged deleted file" -- When an unlocked file is modified, git diff will cause git-annex @@ -1190,7 +1199,7 @@ test_find = intmpclonerepo $ do {- --include=* should match files in subdirectories too, - and --exclude=* should exclude them. -} - createDirectory "dir" + createDirectory (literalOsPath "dir") writecontent "dir/subfile" "subfile" git_annex "add" ["dir"] "add of subdir" git_annex_expectoutput "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] @@ -1258,8 +1267,11 @@ test_concurrent_get_of_dup_key_regression = intmpclonerepo $ do dupfile = annexedfile ++ "2" dupfile2 = annexedfile ++ "3" makedup f = do - Utility.CopyFile.copyFileExternal Utility.CopyFile.CopyAllMetaData annexedfile f - @? "copying annexed file failed" + Utility.CopyFile.copyFileExternal + Utility.CopyFile.CopyAllMetaData + (toOsPath annexedfile) + (toOsPath f) + @? "copying annexed file failed" git "add" [f] "git add" {- Regression test for union merge bug fixed in @@ -1345,7 +1357,7 @@ test_conflict_resolution = conflictor = "conflictor" variantprefix = conflictor ++ ".variant" checkmerge what d = do - l <- getDirectoryContents d + l <- map fromOsPath <$> getDirectoryContents (toOsPath d) let v = filter (variantprefix `isPrefixOf`) l length v == 2 @? (what ++ " not exactly 2 variant files in: " ++ show l) @@ -1382,7 +1394,7 @@ test_conflict_resolution_adjusted_branch = conflictor = "conflictor" variantprefix = conflictor ++ ".variant" checkmerge what d = do - l <- getDirectoryContents d + l <- map fromOsPath <$> getDirectoryContents (toOsPath d) let v = filter (variantprefix `isPrefixOf`) l length v == 2 @? (what ++ " not exactly 2 variant files in: " ++ show l) @@ -1407,7 +1419,7 @@ test_mixed_conflict_resolution = do git_annex "sync" ["--no-content"] "sync in r1" intopdir r2 $ do disconnectOrigin - createDirectory conflictor + createDirectory (toOsPath conflictor) writecontent subfile "subfile" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r2" @@ -1418,19 +1430,19 @@ test_mixed_conflict_resolution = do checkmerge "r1" r1 checkmerge "r2" r2 conflictor = "conflictor" - subfile = conflictor "subfile" + subfile = fromOsPath (toOsPath conflictor literalOsPath "subfile") checkmerge what d = do - doesDirectoryExist (d conflictor) + doesDirectoryExist (toOsPath d toOsPath conflictor) @? (d ++ " conflictor directory missing") - l <- getDirectoryContents d - let v = filter (Annex.VariantFile.variantMarker `isInfixOf`) l + l <- map fromOsPath <$> getDirectoryContents (toOsPath d) + let v = filter (fromOsPath Annex.VariantFile.variantMarker `isInfixOf`) l not (null v) @? (what ++ " conflictor variant file missing in: " ++ show l ) length v == 1 @? (what ++ " too many variant files in: " ++ show v) intopdir d $ do git_annex "get" (conflictor:v) ("get in " ++ what) - git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))] + git_annex_expectoutput "find" [conflictor] [fromOsPath (Git.FilePath.toInternalGitPath (toOsPath subfile))] git_annex_expectoutput "find" v v {- Check merge conflict resolution when both repos start with an annexed @@ -1456,7 +1468,7 @@ test_remove_conflict_resolution = do git_annex "unlock" [conflictor] "unlock conflictor" writecontent conflictor "newconflictor" intopdir r1 $ - removeWhenExistsWith R.removeLink (toRawFilePath conflictor) + removeWhenExistsWith removeFile (toOsPath conflictor) let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] forM_ l $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync" @@ -1465,7 +1477,7 @@ test_remove_conflict_resolution = do conflictor = "conflictor" variantprefix = conflictor ++ ".variant" checkmerge what d = do - l <- getDirectoryContents d + l <- map fromOsPath <$> getDirectoryContents (toOsPath d) let v = filter (variantprefix `isPrefixOf`) l not (null v) @? (what ++ " conflictor variant file missing in: " ++ show l ) @@ -1506,14 +1518,15 @@ test_nonannexed_file_conflict_resolution = do nonannexed_content = "nonannexed" variantprefix = conflictor ++ ".variant" checkmerge what d = do - l <- getDirectoryContents d + l <- map fromOsPath <$> getDirectoryContents (toOsPath d) let v = filter (variantprefix `isPrefixOf`) l not (null v) @? (what ++ " conflictor variant file missing in: " ++ show l ) length v == 1 @? (what ++ " too many variant files in: " ++ show v) conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l) - s <- catchMaybeIO (readFile (d conflictor)) + s <- catchMaybeIO $ readFile $ fromOsPath $ + toOsPath d toOsPath conflictor s == Just nonannexed_content @? (what ++ " wrong content for nonannexed file: " ++ show s) @@ -1552,14 +1565,15 @@ test_nonannexed_symlink_conflict_resolution = do symlinktarget = "dummy-target" variantprefix = conflictor ++ ".variant" checkmerge what d = do - l <- getDirectoryContents d + l <- map fromOsPath <$> getDirectoryContents (toOsPath d) let v = filter (variantprefix `isPrefixOf`) l not (null v) @? (what ++ " conflictor variant file missing in: " ++ show l ) length v == 1 @? (what ++ " too many variant files in: " ++ show v) conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l) - s <- catchMaybeIO (R.readSymbolicLink (toRawFilePath (d conflictor))) + s <- catchMaybeIO $ R.readSymbolicLink $ fromOsPath $ + toOsPath d toOsPath conflictor s == Just (toRawFilePath symlinktarget) @? (what ++ " wrong target for nonannexed symlink: " ++ show s) @@ -1575,13 +1589,13 @@ test_nonannexed_symlink_conflict_resolution = do test_uncommitted_conflict_resolution :: Assertion test_uncommitted_conflict_resolution = do check conflictor - check (conflictor "file") + check (fromOsPath (toOsPath conflictor literalOsPath "file")) where check remoteconflictor = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do intopdir r1 $ do disconnectOrigin - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor))) + createDirectoryIfMissing True (parentDir (toOsPath remoteconflictor)) writecontent remoteconflictor annexedcontent add_annex conflictor "add remoteconflicter" git_annex "sync" ["--no-content"] "sync in r1" @@ -1610,20 +1624,22 @@ test_conflict_resolution_symlink_bit = unlessM (hasUnlockedFiles <$> getTestMode git_annex "sync" ["--no-content"] "sync in r1" check_is_link conflictor "r1" intopdir r2 $ do - createDirectory conflictor - writecontent (conflictor "subfile") "subfile" + createDirectory (toOsPath conflictor) + writecontent conflictorsubfile "subfile" git_annex "add" [conflictor] "add conflicter" git_annex "sync" ["--no-content"] "sync in r2" - check_is_link (conflictor "subfile") "r2" + check_is_link conflictorsubfile "r2" intopdir r3 $ do writecontent conflictor "conflictor" git_annex "add" [conflictor] "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - check_is_link (conflictor "subfile") "r3" + check_is_link conflictorsubfile "r3" where conflictor = "conflictor" + conflictorsubfile = fromOsPath $ + toOsPath conflictor literalOsPath "subfile" check_is_link f what = do - git_annex_expectoutput "find" ["--include=*", f] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath f))] + git_annex_expectoutput "find" ["--include=*", f] [fromOsPath (Git.FilePath.toInternalGitPath (toOsPath f))] l <- annexeval $ Annex.inRepo $ Git.LsTree.lsTreeFiles (Git.LsTree.LsTreeLong False) Git.Ref.headRef [f] all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l @? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l) @@ -1655,7 +1671,7 @@ test_mixed_lock_conflict_resolution = conflictor = "conflictor" variantprefix = conflictor ++ ".variant" checkmerge what d = intopdir d $ do - l <- getDirectoryContents "." + l <- map fromOsPath <$> getDirectoryContents (literalOsPath ".") let v = filter (variantprefix `isPrefixOf`) l length v == 0 @? (what ++ " not exactly 0 variant files in: " ++ show l) @@ -1688,7 +1704,7 @@ test_adjusted_branch_merge_regression = do git_annex "sync" ["--no-content"] "sync" checkmerge what d = intopdir d $ whensupported $ do git_annex "sync" ["--no-content"] ("sync should not work in " ++ what) - l <- getDirectoryContents "." + l <- map fromOsPath <$> getDirectoryContents (literalOsPath ".") conflictor `elem` l @? ("conflictor not present after merge in " ++ what) -- Currently this fails on FAT, for unknown reasons not to @@ -1705,16 +1721,17 @@ test_adjusted_branch_subtree_regression = origbranch <- annexeval origBranch git_annex "upgrade" [] "upgrade" git_annex "adjust" ["--unlock", "--force"] "adjust" - createDirectoryIfMissing True "a/b/c" + createDirectoryIfMissing True (literalOsPath "a/b/c") writecontent "a/b/c/d" "foo" git_annex "add" ["a/b/c"] "add a/b/c" git_annex "sync" ["--no-content"] "sync" - createDirectoryIfMissing True "a/b/x" + createDirectoryIfMissing True (literalOsPath "a/b/x") writecontent "a/b/x/y" "foo" git_annex "add" ["a/b/x"] "add a/b/x" git_annex "sync" ["--no-content"] "sync" git "checkout" [origbranch] "git checkout" - doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") + doesFileExist (literalOsPath "a/b/x/y") + @? ("a/b/x/y missing from master after adjusted branch sync") test_map :: Assertion test_map = intmpclonerepo $ do @@ -1731,7 +1748,7 @@ test_uninit = intmpclonerepo $ do -- any exit status is accepted; does abnormal exit git_annex'' (const True) (const True) "uninit" [] Nothing "uninit" checkregularfile annexedfile - doesDirectoryExist ".git" @? ".git vanished in uninit" + doesDirectoryExist (literalOsPath ".git") @? ".git vanished in uninit" test_uninit_inbranch :: Assertion test_uninit_inbranch = intmpclonerepo $ do @@ -1760,7 +1777,7 @@ test_hook_remote :: Assertion test_hook_remote = intmpclonerepo $ do #ifndef mingw32_HOST_OS git_annex "initremote" (words "foo type=hook encryption=none hooktype=foo") "initremote" - createDirectory dir + createDirectory (toOsPath dir) git_config "annex.foo-store-hook" $ "cp $ANNEX_FILE " ++ loc git_config "annex.foo-retrieve-hook" $ @@ -1790,7 +1807,7 @@ test_hook_remote = intmpclonerepo $ do test_directory_remote :: Assertion test_directory_remote = intmpclonerepo $ do - createDirectory "dir" + createDirectory (literalOsPath "dir") git_annex "initremote" (words "foo type=directory encryption=none directory=dir") "initremote" git_annex "get" [annexedfile] "get of file" annexed_present annexedfile @@ -1806,7 +1823,7 @@ test_directory_remote = intmpclonerepo $ do test_rsync_remote :: Assertion test_rsync_remote = intmpclonerepo $ do #ifndef mingw32_HOST_OS - createDirectory "dir" + createDirectory (literalOsPath "dir") git_annex "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") "initremote" git_annex "get" [annexedfile] "get of file" annexed_present annexedfile @@ -1825,9 +1842,9 @@ test_rsync_remote = intmpclonerepo $ do test_bup_remote :: Assertion test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do -- bup special remote needs an absolute path - dir <- fromRawFilePath <$> absPath (toRawFilePath "dir") + dir <- absPath (literalOsPath "dir") createDirectory dir - git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) "initremote" + git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++fromOsPath dir) "initremote" git_annex "get" [annexedfile] "get of file" annexed_present annexedfile git_annex "copy" [annexedfile, "--to", "foo"] "copy --to bup remote" @@ -1841,8 +1858,8 @@ test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do test_borg_remote :: Assertion test_borg_remote = when BuildInfo.borg $ do - borgdirparent <- fromRawFilePath <$> (absPath . toRawFilePath =<< tmprepodir) - let borgdir = borgdirparent "borgrepo" + borgdirparent <- absPath . toOsPath =<< tmprepodir + let borgdir = fromOsPath (borgdirparent literalOsPath "borgrepo") intmpclonerepo $ do testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) (const True) "borg init" testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) (const True) "borg create" @@ -1894,27 +1911,27 @@ test_gpg_crypto = do testscheme "pubkey" where gpgcmd = Utility.Gpg.mkGpgCmd Nothing - testscheme scheme = Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "gpgtmp")) $ \gpgtmp -> do + testscheme scheme = Utility.Tmp.Dir.withTmpDir (literalOsPath "gpgtmp") $ \gpgtmp -> do -- Use the system temp directory as gpg temp directory because -- it needs to be able to store the agent socket there, -- which can be problematic when testing some filesystems. - absgpgtmp <- fromRawFilePath <$> absPath (toRawFilePath gpgtmp) + absgpgtmp <- absPath gpgtmp res <- testscheme' scheme absgpgtmp -- gpg may still be running and would prevent -- removeDirectoryRecursive from succeeding, so -- force removal of the temp directory. - liftIO $ removeDirectoryForCleanup gpgtmp + liftIO $ removeDirectoryForCleanup (fromOsPath gpgtmp) return res testscheme' scheme absgpgtmp = intmpclonerepo $ do -- Since gpg uses a unix socket, which is limited to a -- short path, use whichever is shorter of absolute -- or relative path. - relgpgtmp <- fromRawFilePath <$> relPathCwdToFile (toRawFilePath absgpgtmp) - let gpgtmp = if length relgpgtmp < length absgpgtmp + relgpgtmp <- relPathCwdToFile absgpgtmp + let gpgtmp = if OS.length relgpgtmp < OS.length absgpgtmp then relgpgtmp else absgpgtmp - void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ \environ -> do - createDirectory "dir" + void $ Utility.Gpg.testHarness (fromOsPath gpgtmp) gpgcmd $ \environ -> do + createDirectory (literalOsPath "dir") let initps = [ "foo" , "type=directory" @@ -1934,7 +1951,7 @@ test_gpg_crypto = do (c,k) <- annexeval $ do uuid <- Remote.nameToUUID "foo" rs <- Logs.Remote.readRemoteLog - Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) + Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile) return (fromJust $ M.lookup uuid rs, k) let key = if scheme `elem` ["hybrid","pubkey"] then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId] @@ -1971,12 +1988,12 @@ test_gpg_crypto = do let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg) cipher <- Crypto.decryptCipher' gpgcmd (Just environ) encparams cip files <- filterM doesFileExist $ - map ("dir" ) $ concatMap (serializeKeys cipher) keys + map (literalOsPath "dir" ) $ concatMap (serializeKeys cipher) keys return (not $ null files) <&&> allM (checkFile mvariant) files checkFile mvariant filename = - Utility.Gpg.checkEncryptionFile gpgcmd (Just environ) filename $ + Utility.Gpg.checkEncryptionFile gpgcmd (Just environ) (fromOsPath filename) $ if mvariant == Just Types.Crypto.PubKey then ks else Nothing - serializeKeys cipher = map fromRawFilePath . NE.toList + serializeKeys cipher = NE.toList . Annex.Locations.keyPaths . Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else @@ -1985,8 +2002,9 @@ test_gpg_crypto = putStrLn "gpg testing not implemented on Windows" test_add_subdirs :: Assertion test_add_subdirs = intmpclonerepo $ do - createDirectory "dir" - writecontent ("dir" "foo") $ "dir/" ++ content annexedfile + createDirectory (literalOsPath "dir") + writecontent (fromOsPath (literalOsPath "dir" literalOsPath "foo")) + ("dir/" ++ content annexedfile) git_annex "add" ["dir"] "add of subdir" {- Regression test for Windows bug where symlinks were not @@ -1997,27 +2015,30 @@ test_add_subdirs = intmpclonerepo $ do <$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo")) "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) - createDirectory "dir2" - writecontent ("dir2" "foo") $ content annexedfile - setCurrentDirectory "dir" - git_annex "add" [".." "dir2"] "add of ../subdir" + createDirectory (literalOsPath "dir2") + writecontent (fromOsPath (literalOsPath "dir2" literalOsPath "foo")) + (content annexedfile) + setCurrentDirectory (literalOsPath "dir") + git_annex "add" [fromOsPath (literalOsPath ".." literalOsPath "dir2")] + "add of ../subdir" test_addurl :: Assertion 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 <- fromRawFilePath <$> absPath (toRawFilePath "myurl") - let url = replace "\\" "/" ("file:///" ++ dropDrive f) - writecontent f "foo" + f <- absPath (literalOsPath "myurl") + let url = replace "\\" "/" ("file:///" ++ fromOsPath (dropDrive f)) + writecontent (fromOsPath f) "foo" git_annex_shouldfail "addurl" [url] "addurl should not work on file url" filecmd "addurl" [url] ("addurl on " ++ url) let dest = "addurlurldest" filecmd "addurl" ["--file", dest, url] ("addurl on " ++ url ++ " with --file") - doesFileExist dest @? (dest ++ " missing after addurl --file") + doesFileExist (toOsPath dest) + @? (dest ++ " missing after addurl --file") test_export_import :: Assertion test_export_import = intmpclonerepo $ do - createDirectory "dir" + createDirectory (literalOsPath "dir") git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote" git_annex "get" [] "get of files" annexed_present annexedfile @@ -2035,7 +2056,7 @@ test_export_import = intmpclonerepo $ do git_annex "merge" ["foo/" ++ origbranch] "git annex merge" annexed_present_imported "import" - removeWhenExistsWith R.removeLink (toRawFilePath "import") + removeWhenExistsWith removeFile (literalOsPath "import") writecontent "import" (content "newimport1") git_annex "add" ["import"] "add of import" commitchanges @@ -2044,7 +2065,7 @@ test_export_import = intmpclonerepo $ do -- verify that export refuses to overwrite modified file writedir "import" (content "newimport2") - removeWhenExistsWith R.removeLink (toRawFilePath "import") + removeWhenExistsWith removeFile (literalOsPath "import") writecontent "import" (content "newimport3") git_annex "add" ["import"] "add of import" commitchanges @@ -2054,17 +2075,18 @@ test_export_import = intmpclonerepo $ do -- resolving import conflict git_annex "import" [origbranch, "--from", "foo"] "import from dir" git_shouldfail "merge" ["foo/master", "-mmerge"] "git merge of conflict should exit nonzero" - removeWhenExistsWith R.removeLink (toRawFilePath "import") + removeWhenExistsWith removeFile (literalOsPath "import") writecontent "import" (content "newimport3") git_annex "add" ["import"] "add of import" commitchanges git_annex "export" [origbranch, "--to", "foo"] "export after import conflict" dircontains "import" (content "newimport3") where - dircontains f v = - ((v==) <$> readFile ("dir" f)) - @? ("did not find expected content of " ++ "dir" f) - writedir f = writecontent ("dir" f) + dircontains f v = do + let df = fromOsPath (literalOsPath "dir" stringToOsPath f) + ((v==) <$> readFile df) + @? ("did not find expected content of " ++ df) + writedir f = writecontent (fromOsPath (literalOsPath "dir" stringToOsPath f)) -- When on an adjusted branch, this updates the master branch -- to match it, which is necessary since the master branch is going -- to be exported. @@ -2072,12 +2094,12 @@ test_export_import = intmpclonerepo $ do test_export_import_subdir :: Assertion test_export_import_subdir = intmpclonerepo $ do - createDirectory "dir" + createDirectory (literalOsPath "dir") git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote" git_annex "get" [] "get of files" annexed_present annexedfile - createDirectory subdir + createDirectory (toOsPath subdir) git "mv" [annexedfile, subannexedfile] "git mv" git "commit" ["-m", "moved"] "git commit" @@ -2096,12 +2118,14 @@ test_export_import_subdir = intmpclonerepo $ do testimport testexport where - dircontains f v = - ((v==) <$> readFile ("dir" f)) - @? ("did not find expected content of " ++ "dir" f) + dircontains f v = do + let df = fromOsPath (literalOsPath "dir" toOsPath f) + ((v==) <$> readFile df) + @? ("did not find expected content of " ++ df) subdir = "subdir" - subannexedfile = "subdir" annexedfile + subannexedfile = fromOsPath $ + literalOsPath "subdir" toOsPath annexedfile testexport = do origbranch <- annexeval origBranch diff --git a/Test/Framework.hs b/Test/Framework.hs index 94354eb521..71191dffc6 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -66,6 +66,7 @@ import qualified Utility.Tmp.Dir import qualified Utility.Metered import qualified Utility.HumanTime import qualified Command.Uninit +import qualified Utility.OsString as OS -- Run a process. The output and stderr is captured, and is only -- displayed if the process does not return the expected value. @@ -123,13 +124,14 @@ git_annex'' expectedret expectedtranscript command params environ faildesc = do let params' = if debug then "--debug":params else params - testProcess pp (command:params') environ expectedret expectedtranscript faildesc + testProcess (fromOsPath pp) (command:params') environ + expectedret expectedtranscript faildesc {- Runs git-annex and returns its standard output. -} git_annex_output :: String -> [String] -> IO String git_annex_output command params = do pp <- Annex.Path.programPath - Utility.Process.readProcess pp (command:params) + Utility.Process.readProcess (fromOsPath pp) (command:params) git_annex_expectoutput :: String -> [String] -> [String] -> Assertion git_annex_expectoutput command params expected = do @@ -159,7 +161,7 @@ with_ssh_origin cloner a = cloner $ do let v = Git.Types.ConfigValue (toRawFilePath "/dev/null") origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) - let originurl = "localhost:" ++ fromRawFilePath origindir + let originurl = "localhost:" ++ fromOsPath origindir git "config" [config, originurl] "git config failed" a where @@ -170,7 +172,7 @@ intmpclonerepo a = withtmpclonerepo $ \r -> intopdir r a checkRepo :: Types.Annex a -> FilePath -> IO a checkRepo getval d = do - s <- Annex.new =<< Git.Construct.fromPath (toRawFilePath d) + s <- Annex.new =<< Git.Construct.fromPath (toOsPath d) Annex.eval s $ getval `finally` Annex.Action.stopCoProcesses @@ -218,7 +220,7 @@ inpath path a = do -- any type of error and change back to currdir before -- rethrowing. r <- bracket_ - (setCurrentDirectory path) + (setCurrentDirectory (toOsPath path)) (setCurrentDirectory currdir) (tryNonAsync a) case r of @@ -295,17 +297,18 @@ configrepo dir = intopdir dir $ do ensuredir :: FilePath -> IO () ensuredir d = do - e <- doesDirectoryExist d + let d' = toOsPath d + e <- doesDirectoryExist d' unless e $ - createDirectory d + createDirectory d' {- This is the only place in the test suite that can use setEnv. - Using it elsewhere can conflict with tasty's use of getEnv, which can - happen concurrently with a test case running, and would be a problem - since setEnv is not thread safe. This is run before tasty. -} setTestEnv :: IO a -> IO a -setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do - tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome) +setTestEnv a = Utility.Tmp.Dir.withTmpDir (literalOsPath "testhome") $ \tmphome -> do + tmphomeabs <- fromOsPath <$> absPath tmphome {- Prevent global git configs from affecting the test suite. -} Utility.Env.Set.setEnv "HOME" tmphomeabs True Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True @@ -313,9 +316,11 @@ setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do -- Ensure that the same git-annex binary that is running -- git-annex test is at the front of the PATH. - p <- Utility.Env.getEnvDefault "PATH" "" pp <- Annex.Path.programPath - Utility.Env.Set.setEnv "PATH" (takeDirectory pp ++ [searchPathSeparator] ++ p) True + p <- Utility.Env.getEnvDefault "PATH" "" + let p' = fromOsPath $ + takeDirectory pp <> OS.singleton searchPathSeparator <> toOsPath p + Utility.Env.Set.setEnv "PATH" p' True -- Avoid git complaining if it cannot determine the user's -- email address, or exploding if it doesn't know the user's name. @@ -332,34 +337,34 @@ setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do -- Record top directory. currdir <- getCurrentDirectory - Utility.Env.Set.setEnv "TOPDIR" currdir True + Utility.Env.Set.setEnv "TOPDIR" (fromOsPath currdir) True a removeDirectoryForCleanup :: FilePath -> IO () -removeDirectoryForCleanup = removePathForcibly +removeDirectoryForCleanup = removePathForcibly . toOsPath cleanup :: FilePath -> IO () -cleanup dir = whenM (doesDirectoryExist dir) $ do - Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath dir) +cleanup dir = whenM (doesDirectoryExist (toOsPath dir)) $ do + Command.Uninit.prepareRemoveAnnexDir' (toOsPath dir) -- This can fail if files in the directory are still open by a -- subprocess. void $ tryIO $ removeDirectoryForCleanup dir finalCleanup :: IO () -finalCleanup = whenM (doesDirectoryExist tmpdir) $ do - Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir) +finalCleanup = whenM (doesDirectoryExist (toOsPath tmpdir)) $ do + Command.Uninit.prepareRemoveAnnexDir' (toOsPath tmpdir) catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do print e putStrLn "sleeping 10 seconds and will retry directory cleanup" Utility.ThreadScheduler.threadDelaySeconds $ Utility.ThreadScheduler.Seconds 10 - whenM (doesDirectoryExist tmpdir) $ + whenM (doesDirectoryExist (toOsPath tmpdir)) $ removeDirectoryForCleanup tmpdir checklink :: FilePath -> Assertion checklink f = ifM (annexeval Config.crippledFileSystem) - ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f))) + ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toOsPath f))) @? f ++ " is not a (crippled) symlink" , do s <- R.getSymbolicLinkStatus (toRawFilePath f) @@ -417,7 +422,7 @@ checkdangling f = ifM (annexeval Config.crippledFileSystem) checklocationlog :: FilePath -> Bool -> Assertion checklocationlog f expected = do thisuuid <- annexeval Annex.UUID.getUUID - r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f) + r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f) case r of Just k -> do uuids <- annexeval $ Remote.keyLocations k @@ -427,12 +432,13 @@ checklocationlog f expected = do checkbackend :: FilePath -> Types.Backend -> Assertion checkbackend file expected = do - b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) - =<< Annex.WorkTree.lookupKey (toRawFilePath 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 -checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toRawFilePath f)) $ +checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toOsPath f)) $ assertFailure $ f ++ " is not a pointer file" inlocationlog :: FilePath -> Assertion @@ -501,7 +507,7 @@ unannexed = runchecks [checkregularfile, checkcontent, checkwritable] unannexed_in_git :: FilePath -> Assertion unannexed_in_git f = do unannexed f - r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f) + r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f) case r of Just _k -> assertFailure $ f ++ " is annexed in git" Nothing -> return () @@ -585,10 +591,10 @@ newmainrepodir = go (0 :: Int) where go n = do let d = "main" ++ show n - ifM (doesDirectoryExist d) + ifM (doesDirectoryExist (toOsPath d)) ( go $ n + 1 , do - createDirectory d + createDirectory (toOsPath d) return d ) @@ -597,7 +603,7 @@ tmprepodir = go (0 :: Int) where go n = do let d = "tmprepo" ++ show n - ifM (doesDirectoryExist d) + ifM (doesDirectoryExist (toOsPath d)) ( go $ n + 1 , return d ) @@ -637,9 +643,9 @@ writecontent :: FilePath -> String -> IO () writecontent f c = go (10000000 :: Integer) where go ticsleft = do - oldmtime <- catchMaybeIO $ getModificationTime f + oldmtime <- catchMaybeIO $ getModificationTime (toOsPath f) writeFile f c - newmtime <- getModificationTime f + newmtime <- getModificationTime (toOsPath f) if Just newmtime == oldmtime then do threadDelay 100000 @@ -679,8 +685,8 @@ getKey b f = case Types.Backend.genKey b of Nothing -> error "internal" where ks = Types.KeySource.KeySource - { Types.KeySource.keyFilename = toRawFilePath f - , Types.KeySource.contentLocation = toRawFilePath f + { Types.KeySource.keyFilename = toOsPath f + , Types.KeySource.contentLocation = toOsPath f , Types.KeySource.inodeCache = Nothing } @@ -799,7 +805,7 @@ parallelTestRunner' numjobs opts mkts go Nothing = summarizeresults $ withConcurrentOutput $ do ensuredir tmpdir crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' - (toRawFilePath tmpdir) + (toOsPath tmpdir) Nothing Nothing False adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported let ts = mkts numparts crippledfilesystem adjustedbranchok opts @@ -809,13 +815,13 @@ parallelTestRunner' numjobs opts mkts mapM_ (hPutStrLn stderr) warnings environ <- Utility.Env.getEnvironment args <- getArgs - pp <- Annex.Path.programPath + pp <- fromOsPath <$> Annex.Path.programPath termcolor <- hSupportsANSIColor stdout let ps = if useColor (lookupOption tastyopts) termcolor then "--color=always":args else "--color=never":args let runone n = do - let subdir = tmpdir show n + let subdir = fromOsPath $ toOsPath tmpdir toOsPath (show n) ensuredir subdir let p = (proc pp ps) { env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ) diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs index 8ba52b1107..53e7822a74 100644 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -18,14 +18,14 @@ import Types.UUID import Types.FileMatcher import Git.FilePath import Git.Quote (StringContainingQuotedPath(..)) -import Utility.FileSystemEncoding +import Utility.OsPath data ActionItem = ActionItemAssociatedFile AssociatedFile Key | ActionItemKey Key | ActionItemBranchFilePath BranchFilePath Key | ActionItemFailedTransfer Transfer TransferInfo - | ActionItemTreeFile RawFilePath + | ActionItemTreeFile OsPath | ActionItemUUID UUID StringContainingQuotedPath -- ^ UUID with a description or name of the repository | ActionItemOther (Maybe StringContainingQuotedPath) @@ -46,10 +46,10 @@ instance MkActionItem (AssociatedFile, Key) where instance MkActionItem (Key, AssociatedFile) where mkActionItem = uncurry $ flip ActionItemAssociatedFile -instance MkActionItem (Key, RawFilePath) where +instance MkActionItem (Key, OsPath) where mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key -instance MkActionItem (RawFilePath, Key) where +instance MkActionItem (OsPath, Key) where mkActionItem (file, key) = mkActionItem (key, file) instance MkActionItem Key where @@ -97,7 +97,7 @@ actionItemKey (ActionItemUUID _ _) = Nothing actionItemKey (ActionItemOther _) = Nothing actionItemKey (OnlyActionOn _ ai) = actionItemKey ai -actionItemFile :: ActionItem -> Maybe RawFilePath +actionItemFile :: ActionItem -> Maybe OsPath actionItemFile (ActionItemAssociatedFile (AssociatedFile af) _) = af actionItemFile (ActionItemTreeFile f) = Just f actionItemFile (ActionItemUUID _ _) = Nothing diff --git a/Types/Backend.hs b/Types/Backend.hs index e4035916ee..b57953d319 100644 --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -12,6 +12,7 @@ module Types.Backend where import Types.Key import Types.KeySource import Utility.Metered +import Utility.OsPath import Utility.FileSystemEncoding import Utility.Hash (IncrementalVerifier) @@ -20,7 +21,7 @@ data BackendA a = Backend , genKey :: Maybe (KeySource -> MeterUpdate -> a Key) -- Verifies the content of a key, stored in a file, using a hash. -- This does not need to be cryptographically secure. - , verifyKeyContent :: Maybe (Key -> RawFilePath -> a Bool) + , verifyKeyContent :: Maybe (Key -> OsPath -> a Bool) -- Incrementally verifies the content of a key, using the same -- hash as verifyKeyContent, but with the content provided -- incrementally a piece at a time, until finalized. diff --git a/Types/BranchState.hs b/Types/BranchState.hs index d79a1c70a6..069c89c927 100644 --- a/Types/BranchState.hs +++ b/Types/BranchState.hs @@ -29,14 +29,14 @@ data BranchState = BranchState , unhandledTransitions :: [TransitionCalculator] -- ^ when the branch was not able to be updated due to permissions, -- this is transitions that need to be applied when making queries. - , cachedFileContents :: [(RawFilePath, L.ByteString)] + , cachedFileContents :: [(OsPath, L.ByteString)] -- ^ contents of a few files recently read from the branch , needInteractiveAccess :: Bool -- ^ do new changes written to the journal or branch by another -- process need to be noticed while the current process is running? -- (This makes the journal always be read, and avoids using the -- cache.) - , alternateJournal :: Maybe RawFilePath + , alternateJournal :: Maybe OsPath -- ^ use this directory for all journals, rather than the -- gitAnnexJournalDir and gitAnnexPrivateJournalDir. } diff --git a/Types/Direction.hs b/Types/Direction.hs index 814b66f72b..8ae1038ada 100644 --- a/Types/Direction.hs +++ b/Types/Direction.hs @@ -9,16 +9,16 @@ module Types.Direction where -import qualified Data.ByteString as B +import Data.ByteString.Short data Direction = Upload | Download deriving (Eq, Ord, Show, Read) -formatDirection :: Direction -> B.ByteString +formatDirection :: Direction -> ShortByteString formatDirection Upload = "upload" formatDirection Download = "download" -parseDirection :: B.ByteString -> Maybe Direction +parseDirection :: ShortByteString -> Maybe Direction parseDirection "upload" = Just Upload parseDirection "download" = Just Download parseDirection _ = Nothing diff --git a/Types/Export.hs b/Types/Export.hs index 1116b67b8c..735a235285 100644 --- a/Types/Export.hs +++ b/Types/Export.hs @@ -1,11 +1,12 @@ {- git-annex export types - - - Copyright 2017-2021 Joey Hess + - Copyright 2017-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} module Types.Export ( ExportLocation, @@ -19,48 +20,63 @@ module Types.Export ( import Git.FilePath import Utility.Split -import Utility.FileSystemEncoding +import Utility.OsPath -import qualified Data.ByteString.Short as S -import qualified System.FilePath.Posix as Posix import GHC.Generics import Control.DeepSeq +#ifdef WITH_OSPATH +import qualified System.OsPath.Posix as Posix +import System.OsString.Internal.Types +#else +import qualified System.FilePath.Posix as Posix +import Utility.FileSystemEncoding +#endif -- A location such as a path on a remote, that a key can be exported to. -- The path is relative to the top of the remote, and uses unix-style -- path separators. -- --- This uses a ShortByteString to avoid problems with ByteString getting --- PINNED in memory which caused memory fragmentation and excessive memory --- use. -newtype ExportLocation = ExportLocation S.ShortByteString +-- This must be a ShortByteString (which OsPath is) in order to to avoid +-- problems with ByteString getting PINNED in memory which caused memory +-- fragmentation and excessive memory use. +newtype ExportLocation = ExportLocation OsPath deriving (Show, Eq, Generic, Ord) instance NFData ExportLocation -mkExportLocation :: RawFilePath -> ExportLocation -mkExportLocation = ExportLocation . S.toShort . toInternalGitPath +mkExportLocation :: OsPath -> ExportLocation +mkExportLocation = ExportLocation . toInternalGitPath -fromExportLocation :: ExportLocation -> RawFilePath -fromExportLocation (ExportLocation f) = S.fromShort f +fromExportLocation :: ExportLocation -> OsPath +fromExportLocation (ExportLocation f) = f -newtype ExportDirectory = ExportDirectory RawFilePath +newtype ExportDirectory = ExportDirectory OsPath deriving (Show, Eq) -mkExportDirectory :: RawFilePath -> ExportDirectory +mkExportDirectory :: OsPath -> ExportDirectory mkExportDirectory = ExportDirectory . toInternalGitPath -fromExportDirectory :: ExportDirectory -> RawFilePath +fromExportDirectory :: ExportDirectory -> OsPath fromExportDirectory (ExportDirectory f) = f -- | All subdirectories down to the ExportLocation, with the deepest ones -- last. Does not include the top of the export. exportDirectories :: ExportLocation -> [ExportDirectory] exportDirectories (ExportLocation f) = - map (ExportDirectory . encodeBS . Posix.joinPath . reverse) (subs [] dirs) + map (ExportDirectory . fromposixpath . Posix.joinPath . reverse) + (subs [] dirs) where subs _ [] = [] subs ps (d:ds) = (d:ps) : subs (d:ps) ds +#ifdef WITH_OSPATH dirs = map Posix.dropTrailingPathSeparator $ - dropFromEnd 1 $ Posix.splitPath $ decodeBS $ S.fromShort f + dropFromEnd 1 $ Posix.splitPath $ PosixString $ fromOsPath f + + fromposixpath = toOsPath . getPosixString +#else + dirs = map Posix.dropTrailingPathSeparator $ + dropFromEnd 1 $ Posix.splitPath $ fromOsPath f + + fromposixpath = encodeBS +#endif diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs index c52d28d5b2..24e53c1650 100644 --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -14,7 +14,7 @@ import Types.Mime import Types.RepoSize (LiveUpdate) import Utility.Matcher (Matcher, Token, MatchDesc) import Utility.FileSize -import Utility.FileSystemEncoding +import Utility.OsPath import Control.Monad.IO.Class import qualified Data.Map as M @@ -27,10 +27,10 @@ data MatchInfo | MatchingUserInfo UserProvidedInfo data FileInfo = FileInfo - { contentFile :: RawFilePath + { contentFile :: OsPath -- ^ path to a file containing the content, for operations -- that examine it - , matchFile :: RawFilePath + , matchFile :: OsPath -- ^ filepath to match on; may be relative to top of repo or cwd, -- depending on how globs in preferred content expressions -- are intended to be matched @@ -39,7 +39,7 @@ data FileInfo = FileInfo } data ProvidedInfo = ProvidedInfo - { providedFilePath :: Maybe RawFilePath + { providedFilePath :: Maybe OsPath -- ^ filepath to match on, should not be accessed from disk. , providedKey :: Maybe Key , providedFileSize :: Maybe FileSize @@ -48,7 +48,7 @@ data ProvidedInfo = ProvidedInfo , providedLinkType :: Maybe LinkType } -keyMatchInfoWithoutContent :: Key -> RawFilePath -> MatchInfo +keyMatchInfoWithoutContent :: Key -> OsPath -> MatchInfo keyMatchInfoWithoutContent key file = MatchingInfo $ ProvidedInfo { providedFilePath = Just file , providedKey = Just key @@ -61,7 +61,7 @@ keyMatchInfoWithoutContent key file = MatchingInfo $ ProvidedInfo -- This is used when testing a matcher, with values to match against -- provided by the user. data UserProvidedInfo = UserProvidedInfo - { userProvidedFilePath :: UserInfo FilePath + { userProvidedFilePath :: UserInfo OsPath , userProvidedKey :: UserInfo Key , userProvidedFileSize :: UserInfo FileSize , userProvidedMimeType :: UserInfo MimeType diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 053a9c8c66..55a5403c5f 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -138,7 +138,7 @@ data GitConfig = GitConfig , annexVerify :: Bool , annexPidLock :: Bool , annexPidLockTimeout :: Seconds - , annexDbDir :: Maybe RawFilePath + , annexDbDir :: Maybe OsPath , annexAddUnlocked :: GlobalConfigurable (Maybe String) , annexSecureHashesOnly :: Bool , annexRetry :: Maybe Integer @@ -244,7 +244,7 @@ extractGitConfig configsource r = GitConfig , annexPidLock = getbool (annexConfig "pidlock") False , annexPidLockTimeout = Seconds $ fromMaybe 300 $ getmayberead (annexConfig "pidlocktimeout") - , annexDbDir = (\d -> toRawFilePath d P. fromUUID hereuuid) + , annexDbDir = (\d -> toOsPath (toRawFilePath d P. fromUUID hereuuid)) <$> getmaybe (annexConfig "dbdir") , annexAddUnlocked = configurable Nothing $ fmap Just $ getmaybe (annexConfig "addunlocked") diff --git a/Types/Import.hs b/Types/Import.hs index 9b0fa226d6..c17adb4115 100644 --- a/Types/Import.hs +++ b/Types/Import.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE DeriveGeneric, DeriveFunctor #-} +{-# LANGUAGE CPP #-} module Types.Import where @@ -13,21 +14,27 @@ import qualified Data.ByteString as S import Data.Char import Control.DeepSeq import GHC.Generics +#ifdef WITH_OSPATH +import qualified System.OsPath.Posix as Posix +import System.OsString.Internal.Types +#else import qualified System.FilePath.Posix.ByteString as Posix +#endif import Types.Export import Utility.QuickCheck import Utility.FileSystemEncoding +import Utility.OsPath {- Location of content on a remote that can be imported. - This is just an alias to ExportLocation, because both are referring to a - location on the remote. -} type ImportLocation = ExportLocation -mkImportLocation :: RawFilePath -> ImportLocation +mkImportLocation :: OsPath -> ImportLocation mkImportLocation = mkExportLocation -fromImportLocation :: ImportLocation -> RawFilePath +fromImportLocation :: ImportLocation -> OsPath fromImportLocation = fromExportLocation {- An identifier for content stored on a remote that has been imported into @@ -87,7 +94,7 @@ data ImportableContentsChunkable m info - of the main tree. Nested subtrees are not allowed. -} data ImportableContentsChunk m info = ImportableContentsChunk { importableContentsSubDir :: ImportChunkSubDir - , importableContentsSubTree :: [(RawFilePath, info)] + , importableContentsSubTree :: [(OsPath, info)] -- ^ locations are relative to importableContentsSubDir , importableContentsNextChunk :: m (Maybe (ImportableContentsChunk m info)) -- ^ Continuation to get the next chunk. @@ -95,11 +102,17 @@ data ImportableContentsChunk m info = ImportableContentsChunk } deriving (Functor) -newtype ImportChunkSubDir = ImportChunkSubDir { importChunkSubDir :: RawFilePath } +newtype ImportChunkSubDir = ImportChunkSubDir { importChunkSubDir :: OsPath } importableContentsChunkFullLocation :: ImportChunkSubDir - -> RawFilePath + -> OsPath -> ImportLocation importableContentsChunkFullLocation (ImportChunkSubDir root) loc = +#ifdef WITH_OSPATH + mkImportLocation $ toOsPath $ getPosixString $ Posix.combine + (PosixString $ fromOsPath root) + (PosixString $ fromOsPath loc) +#else mkImportLocation $ Posix.combine root loc +#endif diff --git a/Types/Key.hs b/Types/Key.hs index 7302605c8a..69f1c4fe1e 100644 --- a/Types/Key.hs +++ b/Types/Key.hs @@ -28,6 +28,8 @@ module Types.Key ( parseKeyVariety, ) where +import Utility.OsPath + import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (ShortByteString, toShort, fromShort) import qualified Data.ByteString.Char8 as S8 @@ -36,7 +38,6 @@ import Data.ByteString.Builder import Data.ByteString.Builder.Extra import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as A8 -import Utility.FileSystemEncoding import Data.List import Data.Char import System.Posix.Types @@ -202,8 +203,8 @@ splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString) splitKeyNameExtension' keyname = S8.span (/= '.') keyname {- A filename may be associated with a Key. -} -newtype AssociatedFile = AssociatedFile (Maybe RawFilePath) - deriving (Show, Read, Eq, Ord) +newtype AssociatedFile = AssociatedFile (Maybe OsPath) + deriving (Show, Eq, Ord) {- There are several different varieties of keys. -} data KeyVariety diff --git a/Types/KeySource.hs b/Types/KeySource.hs index e139340548..a96889f797 100644 --- a/Types/KeySource.hs +++ b/Types/KeySource.hs @@ -8,7 +8,7 @@ module Types.KeySource where import Utility.InodeCache -import System.FilePath.ByteString (RawFilePath) +import Utility.OsPath {- When content is in the process of being ingested into the annex, - and a Key generated from it, this data type is used. @@ -23,8 +23,8 @@ import System.FilePath.ByteString (RawFilePath) - files that may be made while they're in the process of being ingested. -} data KeySource = KeySource - { keyFilename :: RawFilePath - , contentLocation :: RawFilePath + { keyFilename :: OsPath + , contentLocation :: OsPath , inodeCache :: Maybe InodeCache } deriving (Show) diff --git a/Types/LockCache.hs b/Types/LockCache.hs index 5b921be17d..c1b7ad77b8 100644 --- a/Types/LockCache.hs +++ b/Types/LockCache.hs @@ -13,6 +13,6 @@ module Types.LockCache ( import Utility.LockPool (LockHandle) import qualified Data.Map as M -import System.FilePath.ByteString (RawFilePath) +import Utility.OsPath -type LockCache = M.Map RawFilePath LockHandle +type LockCache = M.Map OsPath LockHandle diff --git a/Types/Remote.hs b/Types/Remote.hs index 7a9728a667..1c9920c0c4 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -31,6 +31,7 @@ module Types.Remote import Data.Ord +import Common import qualified Git import Types.Key import Types.UUID @@ -47,7 +48,6 @@ import Utility.Hash (IncrementalVerifier) import Config.Cost import Utility.Metered import Git.Types (RemoteName) -import Utility.SafeCommand import Utility.Url import Utility.DataUnits @@ -92,18 +92,18 @@ data RemoteA a = Remote -- The key should not appear to be present on the remote until -- all of its contents have been transferred. -- Throws exception on failure. - , storeKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> a () + , storeKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> a () -- Retrieves a key's contents to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) -- Throws exception on failure. - , retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfigA a -> a Verification + , retrieveKeyFile :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfigA a -> a Verification {- Will retrieveKeyFile write to the file in order? -} , retrieveKeyFileInOrder :: a Bool -- Retrieves a key's contents to a tmp file, if it can be done cheaply. -- It's ok to create a symlink or hardlink. -- Throws exception on failure. - , retrieveKeyFileCheap :: Maybe (Key -> AssociatedFile -> FilePath -> a ()) + , retrieveKeyFileCheap :: Maybe (Key -> AssociatedFile -> OsPath -> a ()) -- Security policy for reteiving keys from this remote. , retrievalSecurityPolicy :: RetrievalSecurityPolicy -- Removes a key's contents (succeeds even the contents are not present) @@ -147,7 +147,7 @@ data RemoteA a = Remote -- a Remote's configuration from git , gitconfig :: RemoteGitConfig -- a Remote can be associated with a specific local filesystem path - , localpath :: Maybe FilePath + , localpath :: Maybe OsPath -- a Remote can be known to be readonly , readonly :: Bool -- a Remote can allow writes but not have a way to delete content @@ -270,12 +270,12 @@ data ExportActions a = ExportActions -- The exported file should not appear to be present on the remote -- until all of its contents have been transferred. -- Throws exception on failure. - { storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a () + { storeExport :: OsPath -> Key -> ExportLocation -> MeterUpdate -> a () -- Retrieves exported content to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) -- Throws exception on failure. - , retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Verification + , retrieveExport :: Key -> ExportLocation -> OsPath -> MeterUpdate -> a Verification -- Removes an exported file (succeeds if the contents are not present) -- Can throw exception if unable to access remote, or if remote -- refuses to remove the content. @@ -351,7 +351,7 @@ data ImportActions a = ImportActions :: ExportLocation -> [ContentIdentifier] -- file to write content to - -> FilePath + -> OsPath -- Either the key, or when it's not yet known, a callback -- that generates a key from the downloaded content. -> Either Key (a Key) @@ -376,7 +376,7 @@ data ImportActions a = ImportActions -- -- Throws exception on failure. , storeExportWithContentIdentifier - :: FilePath + :: OsPath -> Key -> ExportLocation -- old content that it's safe to overwrite diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs index ce7d228d74..1de9dea067 100644 --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -18,7 +18,7 @@ import qualified Data.ByteString.Lazy as L -- A source of a Key's content. data ContentSource - = FileContent FilePath + = FileContent OsPath | ByteContent L.ByteString isByteContent :: ContentSource -> Bool @@ -43,7 +43,7 @@ type Storer = Key -> ContentSource -> MeterUpdate -> Annex () -- content to the verifier before running the callback. -- This should not be done when it retrieves ByteContent. type Retriever = forall a. - Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier + Key -> MeterUpdate -> OsPath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a -- Action that removes a Key's content from a remote. diff --git a/Types/Transfer.hs b/Types/Transfer.hs index 73745436ca..853237e254 100644 --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -19,7 +19,7 @@ import Types.Direction import Utility.PID import Utility.QuickCheck import Utility.Url -import Utility.FileSystemEncoding +import Utility.OsPath import Data.Time.Clock.POSIX import Control.Concurrent @@ -99,7 +99,7 @@ class Transferrable t where descTransfrerrable :: t -> Maybe String instance Transferrable AssociatedFile where - descTransfrerrable (AssociatedFile af) = fromRawFilePath <$> af + descTransfrerrable (AssociatedFile af) = fromOsPath <$> af instance Transferrable URLString where descTransfrerrable = Just diff --git a/Types/Transferrer.hs b/Types/Transferrer.hs index 7cdfd10f36..2a7bcf4101 100644 --- a/Types/Transferrer.hs +++ b/Types/Transferrer.hs @@ -153,10 +153,10 @@ instance Proto.Serializable TransferAssociatedFile where -- Comes last, so whitespace is ok. But, in case the filename -- contains eg a newline, escape it. Use C-style encoding. serialize (TransferAssociatedFile (AssociatedFile (Just f))) = - decodeBS (encode_c isUtf8Byte f) + fromRawFilePath (encode_c isUtf8Byte (fromOsPath f)) serialize (TransferAssociatedFile (AssociatedFile Nothing)) = "" deserialize "" = Just $ TransferAssociatedFile $ AssociatedFile Nothing deserialize s = Just $ TransferAssociatedFile $ - AssociatedFile $ Just $ decode_c $ encodeBS s + AssociatedFile $ Just $ toOsPath $ decode_c $ toRawFilePath s diff --git a/Types/Transitions.hs b/Types/Transitions.hs index 5cd5ffa247..f8177697a4 100644 --- a/Types/Transitions.hs +++ b/Types/Transitions.hs @@ -7,7 +7,7 @@ module Types.Transitions where -import Utility.RawFilePath +import Utility.OsPath import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder @@ -16,4 +16,4 @@ data FileTransition = ChangeFile Builder | PreserveFile -type TransitionCalculator = RawFilePath -> L.ByteString -> FileTransition +type TransitionCalculator = OsPath -> L.ByteString -> FileTransition diff --git a/Types/UUID.hs b/Types/UUID.hs index 5d25d57aaf..63eef53a43 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -5,11 +5,14 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} module Types.UUID where import qualified Data.ByteString as B +import qualified Data.ByteString.Short as SB import qualified Data.Text as T import qualified Data.Map as M import qualified Data.UUID as U @@ -19,8 +22,8 @@ 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 qualified Utility.SimpleProtocol as Proto @@ -54,6 +57,25 @@ instance ToUUID B.ByteString where | B.null b = NoUUID | otherwise = UUID b +instance FromUUID SB.ShortByteString where + fromUUID (UUID u) = SB.toShort u + fromUUID NoUUID = SB.empty + +instance ToUUID SB.ShortByteString where + toUUID b + | 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 + fromUUID s = toOsPath (fromUUID s :: SB.ShortByteString) + +instance ToUUID OsPath where + toUUID s = toUUID (fromOsPath s :: SB.ShortByteString) +#endif + instance FromUUID String where fromUUID s = decodeBS (fromUUID s) diff --git a/Types/UrlContents.hs b/Types/UrlContents.hs index c2d2ca86ad..46b94afe76 100644 --- a/Types/UrlContents.hs +++ b/Types/UrlContents.hs @@ -10,11 +10,12 @@ module Types.UrlContents ( ) where import Utility.Url +import Utility.OsPath data UrlContents -- An URL contains a file, whose size may be known. -- There might be a nicer filename to use. - = UrlContents (Maybe Integer) (Maybe FilePath) + = UrlContents (Maybe Integer) (Maybe OsPath) -- Sometimes an URL points to multiple files, each accessible -- by their own URL. - | UrlMulti [(URLString, Maybe Integer, FilePath)] + | UrlMulti [(URLString, Maybe Integer, OsPath)] diff --git a/Upgrade.hs b/Upgrade.hs index 4f6585b2ea..d2caa63dbb 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -60,7 +60,7 @@ needsUpgrade v g <- Annex.gitRepo p <- liftIO $ absPath $ Git.repoPath g return $ Just $ unwords - [ "Repository", fromRawFilePath p + [ "Repository", fromOsPath p , "is at" , if v `elem` supportedVersions then "supported" @@ -117,7 +117,7 @@ upgrade automatic destversion = go =<< getVersion -- This avoids complicating the upgrade code by needing to handle -- upgrading a git repo other than the current repo. upgraderemote = do - rp <- fromRawFilePath <$> fromRepo Git.repoPath + rp <- fromOsPath <$> fromRepo Git.repoPath ok <- gitAnnexChildProcess "upgrade" [ Param "--quiet" , Param "--autoonly" diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index 7880b481e7..ea8c8e7de9 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -22,11 +22,11 @@ upgrade = do showAction "v0 to v1" -- do the reorganisation of the key files - olddir <- fromRawFilePath <$> fromRepo gitAnnexDir + olddir <- fromRepo gitAnnexDir keys <- getKeysPresent0 olddir forM_ keys $ \k -> moveAnnex k (AssociatedFile Nothing) - (toRawFilePath $ olddir keyFile0 k) + (olddir toOsPath (keyFile0 k)) -- update the symlinks to the key files -- No longer needed here; V1.upgrade does the same thing @@ -39,20 +39,18 @@ keyFile0 :: Key -> FilePath keyFile0 = Upgrade.V1.keyFile1 fileKey0 :: FilePath -> Key fileKey0 = Upgrade.V1.fileKey1 -lookupKey0 :: FilePath -> Annex (Maybe (Key, Backend)) -lookupKey0 = Upgrade.V1.lookupKey1 -getKeysPresent0 :: FilePath -> Annex [Key] +getKeysPresent0 :: OsPath -> Annex [Key] getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir) - ( liftIO $ map fileKey0 + ( liftIO $ map (fileKey0 . fromOsPath) <$> (filterM present =<< getDirectoryContents dir) , return [] ) where present d = do result <- tryIO $ - R.getFileStatus $ toRawFilePath $ - dir ++ "/" ++ takeFileName d + R.getFileStatus $ fromOsPath $ + dir <> literalOsPath "/" <> takeFileName d case result of Right s -> return $ isRegularFile s Left _ -> return False diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 5540844a70..b9ae3af8a8 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -15,7 +15,6 @@ import Data.Default import Data.ByteString.Builder import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (toShort, fromShort) -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (isRegularFile) import Text.Read @@ -82,20 +81,19 @@ moveContent = do forM_ files move where move f = do - let f' = toRawFilePath f - let k = fileKey1 (fromRawFilePath (P.takeFileName f')) - let d = parentDir f' + let k = fileKey1 (fromOsPath $ takeFileName f) + let d = parentDir f liftIO $ allowWrite d - liftIO $ allowWrite f' - _ <- moveAnnex k (AssociatedFile Nothing) f' - liftIO $ removeDirectory (fromRawFilePath d) + liftIO $ allowWrite f + _ <- moveAnnex k (AssociatedFile Nothing) f + liftIO $ removeDirectory d updateSymlinks :: Annex () updateSymlinks = do showAction "updating symlinks" top <- fromRepo Git.repoPath (files, cleanup) <- inRepo $ LsFiles.inRepo [] [top] - forM_ files (fixlink . fromRawFilePath) + forM_ files fixlink void $ liftIO cleanup where fixlink f = do @@ -103,11 +101,10 @@ updateSymlinks = do case r of Nothing -> noop Just (k, _) -> do - link <- fromRawFilePath - <$> calcRepo (gitAnnexLink (toRawFilePath f) k) + link <- calcRepo (gitAnnexLink f k) liftIO $ removeFile f - liftIO $ R.createSymbolicLink (toRawFilePath link) (toRawFilePath f) - Annex.Queue.addCommand [] "add" [Param "--"] [f] + liftIO $ R.createSymbolicLink (fromOsPath link) (fromOsPath f) + Annex.Queue.addCommand [] "add" [Param "--"] [(fromOsPath f)] moveLocationLogs :: Annex () moveLocationLogs = do @@ -118,15 +115,15 @@ moveLocationLogs = do oldlocationlogs = do dir <- fromRepo Upgrade.V2.gitStateDir ifM (liftIO $ doesDirectoryExist dir) - ( mapMaybe oldlog2key + ( mapMaybe (oldlog2key . fromOsPath) <$> liftIO (getDirectoryContents dir) , return [] ) move (l, k) = do dest <- fromRepo (logFile2 k) dir <- fromRepo Upgrade.V2.gitStateDir - let f = dir l - createWorkTreeDirectory (parentDir (toRawFilePath dest)) + let f = dir toOsPath l + createWorkTreeDirectory (parentDir 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 @@ -134,9 +131,9 @@ moveLocationLogs = do old <- liftIO $ readLog1 f new <- liftIO $ readLog1 dest liftIO $ writeLog1 dest (old++new) - Annex.Queue.addCommand [] "add" [Param "--"] [dest] - Annex.Queue.addCommand [] "add" [Param "--"] [f] - Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [f] + Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath dest] + Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath f] + Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [fromOsPath f] oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key l @@ -197,70 +194,64 @@ fileKey1 :: FilePath -> Key fileKey1 file = readKey1 $ replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file -writeLog1 :: FilePath -> [LogLine] -> IO () -writeLog1 file ls = viaTmp F.writeFile - (toOsPath (toRawFilePath file)) - (toLazyByteString $ buildLog ls) +writeLog1 :: OsPath -> [LogLine] -> IO () +writeLog1 file ls = viaTmp F.writeFile file (toLazyByteString $ buildLog ls) -readLog1 :: FilePath -> IO [LogLine] -readLog1 file = catchDefaultIO [] $ - parseLog <$> F.readFile (toOsPath (toRawFilePath file)) +readLog1 :: OsPath -> IO [LogLine] +readLog1 file = catchDefaultIO [] $ parseLog <$> F.readFile file -lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend)) +lookupKey1 :: OsPath -> Annex (Maybe (Key, Backend)) lookupKey1 file = do tl <- liftIO $ tryIO getsymlink case tl of Left _ -> return Nothing Right l -> makekey l where - getsymlink = takeFileName . fromRawFilePath - <$> R.readSymbolicLink (toRawFilePath file) + getsymlink :: IO OsPath + getsymlink = takeFileName . toOsPath + <$> R.readSymbolicLink (fromOsPath file) makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case Nothing -> do unless (null kname || null bname || - not (isLinkToAnnex (toRawFilePath l))) $ + not (isLinkToAnnex (fromOsPath l))) $ warning (UnquotedString skip) return Nothing Just backend -> return $ Just (k, backend) where - k = fileKey1 l + k = fileKey1 (fromOsPath l) bname = decodeBS (formatKeyVariety (fromKey keyVariety k)) kname = decodeBS (S.fromShort (fromKey keyName k)) - skip = "skipping " ++ file ++ + skip = "skipping " ++ fromOsPath file ++ " (unknown backend " ++ bname ++ ")" -getKeyFilesPresent1 :: Annex [FilePath] -getKeyFilesPresent1 = getKeyFilesPresent1' . fromRawFilePath - =<< fromRepo gitAnnexObjectDir -getKeyFilesPresent1' :: FilePath -> Annex [FilePath] +getKeyFilesPresent1 :: Annex [OsPath] +getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir +getKeyFilesPresent1' :: OsPath -> Annex [OsPath] getKeyFilesPresent1' dir = ifM (liftIO $ doesDirectoryExist dir) ( do dirs <- liftIO $ getDirectoryContents dir - let files = map (\d -> dir ++ "/" ++ d ++ "/" ++ takeFileName d) dirs + let files = map (\d -> dir <> literalOsPath "/" <> d <> literalOsPath "/" <> takeFileName d) dirs liftIO $ filterM present files , return [] ) where + present :: OsPath -> IO Bool present f = do - result <- tryIO $ R.getFileStatus (toRawFilePath f) + result <- tryIO $ R.getFileStatus (fromOsPath f) case result of Right s -> return $ isRegularFile s Left _ -> return False -logFile1 :: Git.Repo -> Key -> String -logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log" - -logFile2 :: Key -> Git.Repo -> String +logFile2 :: Key -> Git.Repo -> OsPath logFile2 = logFile' (hashDirLower def) -logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String +logFile' :: (Key -> OsPath) -> Key -> Git.Repo -> OsPath logFile' hasher key repo = - gitStateDir repo ++ fromRawFilePath (hasher key) ++ fromRawFilePath (keyFile key) ++ ".log" + gitStateDir repo <> hasher key <> keyFile key <> literalOsPath ".log" -stateDir :: FilePath -stateDir = addTrailingPathSeparator ".git-annex" +stateDir :: OsPath +stateDir = addTrailingPathSeparator (literalOsPath ".git-annex") -gitStateDir :: Git.Repo -> FilePath -gitStateDir repo = addTrailingPathSeparator $ - fromRawFilePath (Git.repoPath repo) stateDir +gitStateDir :: Git.Repo -> OsPath +gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo stateDir diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 7690921232..bd01cb5ab0 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -21,11 +21,12 @@ import Utility.Tmp import Logs import Messages.Progress import qualified Utility.FileIO as F +import qualified Utility.OsString as OS -olddir :: Git.Repo -> FilePath +olddir :: Git.Repo -> OsPath olddir g - | Git.repoIsLocalBare g = "" - | otherwise = ".git-annex" + | Git.repoIsLocalBare g = literalOsPath "" + | otherwise = literalOsPath ".git-annex" {- .git-annex/ moved to a git-annex branch. - @@ -54,14 +55,14 @@ upgrade = do e <- liftIO $ doesDirectoryExist old when e $ do config <- Annex.getGitConfig - mapM_ (\(k, f) -> inject f $ fromRawFilePath $ locationLogFile config k) =<< locationLogs + mapM_ (\(k, f) -> inject f $ locationLogFile config k) =<< locationLogs mapM_ (\f -> inject f f) =<< logFiles old saveState False showProgressDots when e $ do - inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File old] + inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File (fromOsPath old)] unless bare $ inRepo gitAttributesUnWrite showProgressDots @@ -69,29 +70,29 @@ upgrade = do return UpgradeSuccess -locationLogs :: Annex [(Key, FilePath)] +locationLogs :: Annex [(Key, OsPath)] locationLogs = do config <- Annex.getGitConfig dir <- fromRepo gitStateDir liftIO $ do - levela <- dirContents (toRawFilePath dir) + levela <- dirContents dir levelb <- mapM tryDirContents levela files <- mapM tryDirContents (concat levelb) return $ mapMaybe (islogfile config) (concat files) where tryDirContents d = catchDefaultIO [] $ dirContents d - islogfile config f = maybe Nothing (\k -> Just (k, fromRawFilePath f)) $ + islogfile config f = maybe Nothing (\k -> Just (k, f)) $ locationLogFileKey config f -inject :: FilePath -> FilePath -> Annex () +inject :: OsPath -> OsPath -> Annex () inject source dest = do old <- fromRepo olddir - new <- liftIO (readFile $ old source) - Annex.Branch.change (Annex.Branch.RegardingUUID []) (toRawFilePath dest) $ \prev -> + new <- liftIO (readFile $ fromOsPath $ old source) + Annex.Branch.change (Annex.Branch.RegardingUUID []) dest $ \prev -> encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new -logFiles :: FilePath -> Annex [FilePath] -logFiles dir = return . filter (".log" `isSuffixOf`) +logFiles :: OsPath -> Annex [OsPath] +logFiles dir = return . filter (literalOsPath ".log" `OS.isSuffixOf`) <=< liftIO $ getDirectoryContents dir push :: Annex () @@ -130,25 +131,22 @@ push = do {- Old .gitattributes contents, not needed anymore. -} attrLines :: [String] attrLines = - [ stateDir "*.log merge=union" - , stateDir "*/*/*.log merge=union" + [ fromOsPath $ stateDir literalOsPath "*.log merge=union" + , fromOsPath $ stateDir literalOsPath "*/*/*.log merge=union" ] gitAttributesUnWrite :: Git.Repo -> IO () gitAttributesUnWrite repo = do let attributes = Git.attributes repo - let attributes' = fromRawFilePath attributes - whenM (doesFileExist attributes') $ do + whenM (doesFileExist attributes) $ do c <- map decodeBS . fileLines' - <$> F.readFile' (toOsPath attributes) - liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath) - (toOsPath attributes) + <$> F.readFile' attributes + liftIO $ viaTmp (writeFile . fromOsPath) attributes (unlines $ filter (`notElem` attrLines) c) - Git.Command.run [Param "add", File attributes'] repo + Git.Command.run [Param "add", File (fromOsPath attributes)] repo -stateDir :: FilePath -stateDir = addTrailingPathSeparator ".git-annex" +stateDir :: OsPath +stateDir = addTrailingPathSeparator (literalOsPath ".git-annex") -gitStateDir :: Git.Repo -> FilePath -gitStateDir repo = addTrailingPathSeparator $ - fromRawFilePath (Git.repoPath repo) stateDir +gitStateDir :: Git.Repo -> OsPath +gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo stateDir diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index 708c838977..ee90ba7cd8 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -33,7 +33,6 @@ import Git.Ref import Utility.InodeCache import Utility.DottedVersion import Annex.AdjustedBranch -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F upgrade :: Bool -> Annex UpgradeResult @@ -130,7 +129,7 @@ upgradeDirectWorkTree = do stagePointerFile f Nothing =<< hashPointerFile k ifM (isJust <$> getAnnexLinkTarget f) ( writepointer f k - , fromdirect (fromRawFilePath f) k + , fromdirect f k ) Database.Keys.addAssociatedFile k =<< inRepo (toTopFilePath f) @@ -138,14 +137,13 @@ upgradeDirectWorkTree = do 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 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 @@ -157,8 +155,8 @@ upgradeDirectWorkTree = do ) writepointer f k = liftIO $ do - removeWhenExistsWith R.removeLink f - F.writeFile' (toOsPath f) (formatPointer k) + removeWhenExistsWith removeFile f + F.writeFile' f (formatPointer k) {- Remove all direct mode bookkeeping files. -} removeDirectCruft :: Annex () diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index f03d7b3780..f3ba856996 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -28,7 +28,6 @@ import Config import Annex.Perms import Utility.InodeCache import Annex.InodeSentinal -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F setIndirect :: Annex () @@ -79,27 +78,27 @@ switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe Nothing -> inRepo $ Git.Branch.checkout orighead {- Absolute FilePaths of Files in the tree that are associated with a key. -} -associatedFiles :: Key -> Annex [FilePath] +associatedFiles :: Key -> Annex [OsPath] associatedFiles key = do files <- associatedFilesRelative key - top <- fromRawFilePath <$> fromRepo Git.repoPath + top <- fromRepo Git.repoPath return $ map (top ) files {- List of files in the tree that are associated with a key, relative to - the top of the repo. -} -associatedFilesRelative :: Key -> Annex [FilePath] +associatedFilesRelative :: Key -> Annex [OsPath] associatedFilesRelative key = do mapping <- calcRepo (gitAnnexMapping key) - liftIO $ catchDefaultIO [] $ F.withFile (toOsPath mapping) ReadMode $ \h -> + liftIO $ catchDefaultIO [] $ F.withFile mapping ReadMode $ \h -> -- Read strictly to ensure the file is closed promptly - lines <$> hGetContentsStrict h + map toOsPath . lines <$> hGetContentsStrict h {- Removes the list of associated files. -} removeAssociatedFiles :: Key -> Annex () removeAssociatedFiles key = do mapping <- calcRepo $ gitAnnexMapping key modifyContentDir mapping $ - liftIO $ removeWhenExistsWith R.removeLink mapping + liftIO $ removeWhenExistsWith removeFile mapping {- Checks if a file in the tree, associated with a key, has not been modified. - @@ -107,10 +106,8 @@ removeAssociatedFiles key = do - expensive checksum, this relies on a cache that contains the file's - expected mtime and inode. -} -goodContent :: Key -> FilePath -> Annex Bool -goodContent key file = - sameInodeCache (toRawFilePath file) - =<< recordedInodeCache key +goodContent :: Key -> OsPath -> Annex Bool +goodContent key file = sameInodeCache file =<< recordedInodeCache key {- Gets the recorded inode cache for a key. - @@ -120,26 +117,25 @@ recordedInodeCache :: Key -> Annex [InodeCache] recordedInodeCache key = withInodeCacheFile key $ \f -> liftIO $ catchDefaultIO [] $ mapMaybe (readInodeCache . decodeBS) . fileLines' - <$> F.readFile' (toOsPath f) + <$> F.readFile' f {- Removes an inode cache. -} removeInodeCache :: Key -> Annex () removeInodeCache key = withInodeCacheFile key $ \f -> - modifyContentDir f $ - liftIO $ removeWhenExistsWith R.removeLink f + modifyContentDir f $ liftIO $ removeWhenExistsWith removeFile f -withInodeCacheFile :: Key -> (RawFilePath -> Annex a) -> Annex a +withInodeCacheFile :: Key -> (OsPath -> 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 -> Git.Repo -> GitConfig -> IO OsPath gitAnnexMapping key r c = do loc <- gitAnnexLocation key r c - return $ loc <> ".map" + return $ loc <> literalOsPath ".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 -> Git.Repo -> GitConfig -> IO OsPath gitAnnexInodeCache key r c = do loc <- gitAnnexLocation key r c - return $ loc <> ".cache" + return $ loc <> literalOsPath ".cache" diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs index 0e301bd09d..caabe13d2f 100644 --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -24,7 +24,6 @@ import Config import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (isSymbolicLink) upgrade :: Bool -> Annex UpgradeResult @@ -40,48 +39,52 @@ upgrade automatic = do -- The old content identifier database is deleted here, but the -- new database is not populated. It will be automatically -- populated from the git-annex branch the next time it is used. - removeOldDb . fromRawFilePath =<< fromRepo gitAnnexContentIdentifierDbDirOld - liftIO . removeWhenExistsWith R.removeLink + removeOldDb =<< fromRepo gitAnnexContentIdentifierDbDirOld + liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexContentIdentifierLockOld -- The export databases are deleted here. The new databases -- will be populated by the next thing that needs them, the same -- way as they would be in a fresh clone. - removeOldDb . fromRawFilePath =<< calcRepo' gitAnnexExportDir + removeOldDb =<< calcRepo' gitAnnexExportDir populateKeysDb - removeOldDb . fromRawFilePath =<< fromRepo gitAnnexKeysDbOld - liftIO . removeWhenExistsWith R.removeLink + removeOldDb =<< fromRepo gitAnnexKeysDbOld + liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexKeysDbIndexCacheOld - liftIO . removeWhenExistsWith R.removeLink + liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexKeysDbLockOld updateSmudgeFilter return UpgradeSuccess -gitAnnexKeysDbOld :: Git.Repo -> RawFilePath -gitAnnexKeysDbOld r = gitAnnexDir r P. "keys" +gitAnnexKeysDbOld :: Git.Repo -> OsPath +gitAnnexKeysDbOld r = gitAnnexDir r literalOsPath "keys" -gitAnnexKeysDbLockOld :: Git.Repo -> RawFilePath -gitAnnexKeysDbLockOld r = gitAnnexKeysDbOld r <> ".lck" +gitAnnexKeysDbLockOld :: Git.Repo -> OsPath +gitAnnexKeysDbLockOld r = + gitAnnexKeysDbOld r <> literalOsPath ".lck" -gitAnnexKeysDbIndexCacheOld :: Git.Repo -> RawFilePath -gitAnnexKeysDbIndexCacheOld r = gitAnnexKeysDbOld r <> ".cache" +gitAnnexKeysDbIndexCacheOld :: Git.Repo -> OsPath +gitAnnexKeysDbIndexCacheOld r = + gitAnnexKeysDbOld r <> literalOsPath ".cache" -gitAnnexContentIdentifierDbDirOld :: Git.Repo -> RawFilePath -gitAnnexContentIdentifierDbDirOld r = gitAnnexDir r P. "cids" +gitAnnexContentIdentifierDbDirOld :: Git.Repo -> OsPath +gitAnnexContentIdentifierDbDirOld r = + gitAnnexDir r literalOsPath "cids" -gitAnnexContentIdentifierLockOld :: Git.Repo -> RawFilePath -gitAnnexContentIdentifierLockOld r = gitAnnexContentIdentifierDbDirOld r <> ".lck" +gitAnnexContentIdentifierLockOld :: Git.Repo -> OsPath +gitAnnexContentIdentifierLockOld r = + gitAnnexContentIdentifierDbDirOld r <> literalOsPath ".lck" -removeOldDb :: FilePath -> Annex () +removeOldDb :: OsPath -> Annex () removeOldDb db = whenM (liftIO $ doesDirectoryExist db) $ do v <- liftIO $ tryNonAsync $ removePathForcibly db case v of - Left ex -> giveup $ "Failed removing old database directory " ++ db ++ " during upgrade (" ++ show ex ++ ") -- delete that and re-run git-annex to finish the upgrade." + Left ex -> giveup $ "Failed removing old database directory " ++ fromOsPath db ++ " during upgrade (" ++ show ex ++ ") -- delete that and re-run git-annex to finish the upgrade." Right () -> return () -- Populate the new keys database with associated files and inode caches. @@ -108,11 +111,11 @@ populateKeysDb = unlessM isBareRepo $ do (l, cleanup) <- inRepo $ LsFiles.inodeCaches [top] forM_ l $ \case (_f, Nothing) -> giveup "Unable to parse git ls-files --debug output while upgrading git-annex sqlite databases." - (f, Just ic) -> unlessM (liftIO $ catchBoolIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (toRawFilePath f)) $ do - catKeyFile (toRawFilePath f) >>= \case + (f, Just ic) -> unlessM (liftIO $ catchBoolIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f)) $ do + catKeyFile f >>= \case Nothing -> noop Just k -> do - topf <- inRepo $ toTopFilePath $ toRawFilePath f + topf <- inRepo $ toTopFilePath f Database.Keys.runWriter AssociatedTable $ \h -> liftIO $ Database.Keys.SQL.addAssociatedFile k topf h Database.Keys.runWriter ContentTable $ \h -> liftIO $ @@ -130,10 +133,10 @@ updateSmudgeFilter :: Annex () updateSmudgeFilter = do lf <- Annex.fromRepo Git.attributesLocal ls <- liftIO $ map decodeBS . fileLines' - <$> catchDefaultIO "" (F.readFile' (toOsPath lf)) + <$> catchDefaultIO "" (F.readFile' lf) let ls' = removedotfilter ls when (ls /= ls') $ - liftIO $ writeFile (fromRawFilePath lf) (unlines ls') + liftIO $ writeFile (fromOsPath lf) (unlines ls') where removedotfilter ("* filter=annex":".* !filter":rest) = "* filter=annex" : removedotfilter rest diff --git a/Upgrade/V9.hs b/Upgrade/V9.hs index 700f1f6387..52f94092b4 100644 --- a/Upgrade/V9.hs +++ b/Upgrade/V9.hs @@ -55,7 +55,7 @@ upgrade automatic - run for an entire year and so predate the v9 upgrade. -} assistantrunning = do pidfile <- fromRepo gitAnnexPidFile - isJust <$> liftIO (checkDaemon (fromRawFilePath pidfile)) + isJust <$> liftIO (checkDaemon pidfile) unsafeupgrade = [ "Not upgrading from v9 to v10, because there may be git-annex" diff --git a/Utility/Aeson.hs b/Utility/Aeson.hs index e03a707051..5de512d314 100644 --- a/Utility/Aeson.hs +++ b/Utility/Aeson.hs @@ -8,6 +8,7 @@ -} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} module Utility.Aeson ( module X, @@ -32,6 +33,9 @@ import qualified Data.Vector import Prelude import Utility.FileSystemEncoding +#ifdef WITH_OSPATH +import Utility.OsPath +#endif -- | Use this instead of Data.Aeson.encode to make sure that the -- below String instance is used. @@ -60,6 +64,11 @@ instance ToJSON' String where instance ToJSON' S.ByteString where toJSON' = toJSON . packByteString +#ifdef WITH_OSPATH +instance ToJSON' OsPath where + toJSON' p = toJSON' (fromOsPath p :: S.ByteString) +#endif + -- | Pack a String to Text, correctly handling the filesystem encoding. -- -- Use this instead of Data.Text.pack. diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index 207153d1b6..d0dc34eef2 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -44,12 +44,12 @@ copyMetaDataParams meta = map snd $ filter fst {- The cp command is used, because I hate reinventing the wheel, - and because this allows easy access to features like cp --reflink - and preserving metadata. -} -copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool +copyFileExternal :: CopyMetaData -> OsPath -> OsPath -> IO Bool copyFileExternal meta src dest = do -- Delete any existing dest file because an unwritable file -- would prevent cp from working. void $ tryIO $ removeFile dest - boolSystem "cp" $ params ++ [File src, File dest] + boolSystem "cp" $ params ++ [File (fromOsPath src), File (fromOsPath dest)] where params | BuildInfo.cp_reflink_supported = @@ -76,7 +76,7 @@ copyCoW meta src dest -- When CoW is not supported, cp creates the destination -- file but leaves it empty. unless ok $ - void $ tryIO $ removeFile dest + void $ tryIO $ removeFile $ toOsPath dest return ok | otherwise = return False where @@ -87,10 +87,10 @@ copyCoW meta src dest {- Create a hard link if the filesystem allows it, and fall back to copying - the file. -} -createLinkOrCopy :: RawFilePath -> RawFilePath -> IO Bool +createLinkOrCopy :: OsPath -> OsPath -> IO Bool createLinkOrCopy src dest = go `catchIO` const fallback where go = do - R.createLink src dest + R.createLink (fromOsPath src) (fromOsPath dest) return True - fallback = copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest) + fallback = copyFileExternal CopyAllMetaData src dest diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index c2a3d1bde7..8fd142da36 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -5,6 +5,7 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Utility.Daemon ( @@ -25,6 +26,7 @@ import Utility.OpenFd #else import System.Win32.Process (terminateProcessById) import Utility.LockFile +import qualified Utility.OsString as OS #endif #ifndef mingw32_HOST_OS @@ -42,7 +44,7 @@ import System.Posix hiding (getEnv, getEnvironment) - Instead, it runs the cmd with provided params, in the background, - which the caller should arrange to run this again. -} -daemonize :: String -> [CommandParam] -> IO Fd -> Maybe FilePath -> Bool -> IO () -> IO () +daemonize :: String -> [CommandParam] -> IO Fd -> Maybe OsPath -> Bool -> IO () -> IO () daemonize cmd params openlogfd pidfile changedirectory a = do maybe noop checkalreadyrunning pidfile getEnv envvar >>= \case @@ -70,10 +72,10 @@ daemonize cmd params openlogfd pidfile changedirectory a = do {- To run an action that is normally daemonized in the foreground. -} #ifndef mingw32_HOST_OS -foreground :: IO Fd -> Maybe FilePath -> IO () -> IO () +foreground :: IO Fd -> Maybe OsPath -> IO () -> IO () foreground openlogfd pidfile a = do #else -foreground :: Maybe FilePath -> IO () -> IO () +foreground :: Maybe OsPath -> IO () -> IO () foreground pidfile a = do #endif maybe noop lockPidFile pidfile @@ -93,12 +95,12 @@ foreground pidfile a = do - - Writes the pid to the file, fully atomically. - Fails if the pid file is already locked by another process. -} -lockPidFile :: FilePath -> IO () +lockPidFile :: OsPath -> IO () lockPidFile pidfile = do #ifndef mingw32_HOST_OS - fd <- openFdWithMode (toRawFilePath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags + fd <- openFdWithMode (fromOsPath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) - fd' <- openFdWithMode (toRawFilePath newfile) ReadWrite (Just stdFileMode) defaultFileFlags + fd' <- openFdWithMode (fromOsPath newfile) ReadWrite (Just stdFileMode) defaultFileFlags { trunc = True } locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0) case (locked, locked') of @@ -107,17 +109,17 @@ lockPidFile pidfile = do _ -> do _ <- fdWrite fd' =<< show <$> getPID closeFd fd - rename newfile pidfile + renameFile newfile pidfile where - newfile = pidfile ++ ".new" + newfile = pidfile <> literalOsPath ".new" #else {- Not atomic on Windows, oh well. -} unlessM (isNothing <$> checkDaemon pidfile) alreadyRunning pid <- getPID - writeFile pidfile (show pid) + writeFile (fromOsPath pidfile) (show pid) lckfile <- winLockFile pid pidfile - writeFile (fromRawFilePath lckfile) "" + writeFile (fromOsPath lckfile) "" void $ lockExclusive lckfile #endif @@ -128,17 +130,17 @@ alreadyRunning = giveup "Daemon is already running." - is locked by the same process that is listed in the pid file. - - If it's running, returns its pid. -} -checkDaemon :: FilePath -> IO (Maybe PID) +checkDaemon :: OsPath -> IO (Maybe PID) #ifndef mingw32_HOST_OS checkDaemon pidfile = bracket setup cleanup go where setup = catchMaybeIO $ - openFdWithMode (toRawFilePath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags + openFdWithMode (fromOsPath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags cleanup (Just fd) = closeFd fd cleanup Nothing = return () go (Just fd) = catchDefaultIO Nothing $ do locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) - p <- readish <$> readFile pidfile + p <- readish <$> readFile (fromOsPath pidfile) return (check locked p) go Nothing = return Nothing @@ -147,16 +149,16 @@ checkDaemon pidfile = bracket setup cleanup go check (Just (pid, _)) (Just pid') | pid == pid' = Just pid | otherwise = giveup $ - "stale pid in " ++ pidfile ++ + "stale pid in " ++ fromOsPath pidfile ++ " (got " ++ show pid' ++ "; expected " ++ show pid ++ " )" #else checkDaemon pidfile = maybe (return Nothing) (check . readish) - =<< catchMaybeIO (readFile pidfile) + =<< catchMaybeIO (readFile (fromOsPath pidfile)) where check Nothing = return Nothing check (Just pid) = do - v <- lockShared =<< winLockFile pid pidfile + v <- lockShared =<< winLockFile pid (fromOsPath pidfile) case v of Just h -> do dropLock h @@ -165,7 +167,7 @@ checkDaemon pidfile = maybe (return Nothing) (check . readish) #endif {- Stops the daemon, safely. -} -stopDaemon :: FilePath -> IO () +stopDaemon :: OsPath -> IO () stopDaemon pidfile = go =<< checkDaemon pidfile where go Nothing = noop @@ -181,14 +183,14 @@ stopDaemon pidfile = go =<< checkDaemon pidfile - when eg, restarting the daemon. -} #ifdef mingw32_HOST_OS -winLockFile :: PID -> FilePath -> IO RawFilePath +winLockFile :: PID -> OsPath -> IO OsPath winLockFile pid pidfile = do cleanstale - return $ toRawFilePath $ prefix ++ show pid ++ suffix + return $ prefix <> toOsPath (show pid) <> suffix where - prefix = pidfile ++ "." - suffix = ".lck" + prefix = pidfile <> literalOsPath "." + suffix = literalOsPath ".lck" cleanstale = mapM_ (void . tryIO . removeFile) =<< - (filter iswinlockfile <$> dirContents (fromRawFilePath (parentDir (toRawFilePath pidfile)))) - iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f + (filter iswinlockfile <$> dirContents (parentDir pidfile)) + iswinlockfile f = suffix `OS.isSuffixOf` f && prefix `OS.isPrefixOf` f #endif diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs index 99eede4173..f0805aa2c0 100644 --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -22,6 +22,7 @@ module Utility.DirWatcher ( ) where import Utility.DirWatcher.Types +import Utility.OsPath #if WITH_INOTIFY import qualified Utility.DirWatcher.INotify as INotify @@ -40,7 +41,7 @@ import qualified Utility.DirWatcher.Win32Notify as Win32Notify import qualified System.Win32.Notify as Win32Notify #endif -type Pruner = FilePath -> Bool +type Pruner = OsPath -> Bool canWatch :: Bool #if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS || WITH_WIN32NOTIFY) @@ -112,7 +113,7 @@ modifyTracked = error "modifyTracked not defined" - to shutdown later. -} #if WITH_INOTIFY type DirWatcherHandle = INotify.INotify -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle watchDir dir prune scanevents hooks runstartup = do i <- INotify.initINotify runstartup $ INotify.watchDir i dir prune scanevents hooks @@ -120,14 +121,14 @@ watchDir dir prune scanevents hooks runstartup = do #else #if WITH_KQUEUE type DirWatcherHandle = ThreadId -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle watchDir dir prune _scanevents hooks runstartup = do kq <- runstartup $ Kqueue.initKqueue dir prune forkIO $ Kqueue.runHooks kq hooks #else #if WITH_FSEVENTS type DirWatcherHandle = FSEvents.EventStream -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle watchDir dir prune scanevents hooks runstartup = runstartup $ FSEvents.watchDir dir prune scanevents hooks #else diff --git a/Utility/DirWatcher/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs index 7b6be6f13b..da2b3194bc 100644 --- a/Utility/DirWatcher/FSEvents.hs +++ b/Utility/DirWatcher/FSEvents.hs @@ -70,7 +70,8 @@ watchDir dir ignored scanevents hooks = do scan d = unless (ignoredPath ignored d) $ -- Do not follow symlinks when scanning. -- This mirrors the inotify startup scan behavior. - mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d) + mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist + (dirContentsRecursiveSkipping (const False) False (toRawFilePath d)) where go f | ignoredPath ignored f = noop diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs index 4b14e85bd2..fa289b149e 100644 --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -47,7 +47,7 @@ import Control.Exception (throw) - So this will fail if there are too many subdirectories. The - errHook is called when this happens. -} -watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO () +watchDir :: INotify -> OsPath -> (OsPath -> Bool) -> Bool -> WatchHooks -> IO () watchDir i dir ignored scanevents hooks | ignored dir = noop | otherwise = do @@ -56,10 +56,10 @@ watchDir i dir ignored scanevents hooks lock <- newLock let handler event = withLock lock (void $ go event) flip catchNonAsync failedwatch $ do - void (addWatch i watchevents (toInternalFilePath dir) handler) + void (addWatch i watchevents (fromOsPath dir) handler) `catchIO` failedaddwatch withLock lock $ - mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$> + mapM_ scan =<< filter (`notElem` dirCruft) <$> getDirectoryContents dir where recurse d = watchDir i d ignored scanevents hooks @@ -108,22 +108,21 @@ watchDir i dir ignored scanevents hooks runhook addHook f ms _ -> noop where - f = fromInternalFilePath fi + f = toOsPath fi -- Closing a file is assumed to mean it's done being written, -- so a new add event is sent. go (Closed { isDirectory = False, maybeFilePath = Just fi }) = - checkfiletype Files.isRegularFile addHook $ - fromInternalFilePath fi + checkfiletype Files.isRegularFile addHook (toOsPath fi) -- When a file or directory is moved in, scan it to add new -- stuff. - go (MovedIn { filePath = fi }) = scan $ fromInternalFilePath fi + go (MovedIn { filePath = fi }) = scan (toOsPath fi) go (MovedOut { isDirectory = isd, filePath = fi }) | isd = runhook delDirHook f Nothing | otherwise = runhook delHook f Nothing where - f = fromInternalFilePath fi + f = toOsPath fi -- Verify that the deleted item really doesn't exist, -- since there can be spurious deletion events for items @@ -134,11 +133,11 @@ watchDir i dir ignored scanevents hooks | otherwise = guarded $ runhook delHook f Nothing where guarded = unlessM (filetype (const True) f) - f = fromInternalFilePath fi + f = toOsPath fi go (Modified { isDirectory = isd, maybeFilePath = Just fi }) | isd = noop - | otherwise = runhook modifyHook (fromInternalFilePath fi) Nothing + | otherwise = runhook modifyHook (toOsPath fi) Nothing go _ = noop @@ -150,35 +149,36 @@ watchDir i dir ignored scanevents hooks indir f = dir f - getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ toRawFilePath $ indir f + getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath $ indir f + checkfiletype check h f = do ms <- getstatus f case ms of Just s | check s -> runhook h f ms _ -> noop - filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (toRawFilePath (indir f)) + filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (fromOsPath (indir f)) failedaddwatch e -- Inotify fails when there are too many watches with a -- disk full error. | isFullError e = case errHook hooks of - Nothing -> giveup $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")" + Nothing -> giveup $ "failed to add inotify watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")" Just hook -> tooManyWatches hook dir -- The directory could have been deleted. | isDoesNotExistError e = return () | otherwise = throw e - failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")" + failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")" -tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO () +tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> OsPath -> IO () tooManyWatches hook dir = do sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing where maxwatches = "fs.inotify.max_user_watches" - basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" + basewarning = "Too many directories to watch! (Not watching " ++ fromOsPath dir ++")" withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] withsysctl n = let new = n * 10 in [ "Increase the limit permanently by running:" @@ -197,9 +197,3 @@ querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"] Nothing -> return Nothing Just s -> return $ parsesysctl s parsesysctl s = readish =<< lastMaybe (words s) - -toInternalFilePath :: FilePath -> RawFilePath -toInternalFilePath = toRawFilePath - -fromInternalFilePath :: RawFilePath -> FilePath -fromInternalFilePath = fromRawFilePath diff --git a/Utility/DirWatcher/Types.hs b/Utility/DirWatcher/Types.hs index 9abd5f36a1..ff68295c62 100644 --- a/Utility/DirWatcher/Types.hs +++ b/Utility/DirWatcher/Types.hs @@ -16,12 +16,12 @@ import Common type Hook a = Maybe (a -> Maybe FileStatus -> IO ()) data WatchHooks = WatchHooks - { addHook :: Hook FilePath - , addSymlinkHook :: Hook FilePath - , delHook :: Hook FilePath - , delDirHook :: Hook FilePath + { addHook :: Hook OsPath + , addSymlinkHook :: Hook OsPath + , delHook :: Hook OsPath + , delDirHook :: Hook OsPath , errHook :: Hook String -- error message - , modifyHook :: Hook FilePath + , modifyHook :: Hook OsPath } mkWatchHooks :: WatchHooks diff --git a/Utility/DirWatcher/Win32Notify.hs b/Utility/DirWatcher/Win32Notify.hs index e5ce316ce6..5f53c13bf5 100644 --- a/Utility/DirWatcher/Win32Notify.hs +++ b/Utility/DirWatcher/Win32Notify.hs @@ -43,7 +43,8 @@ watchDir dir ignored scanevents hooks = do runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks) scan d = unless (ignoredPath ignored d) $ - mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d) + mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist + (dirContentsRecursiveSkipping (const False) False (toRawFilePath d)) where go f | ignoredPath ignored f = noop diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 3648a4454d..0051dd75fc 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -21,28 +21,22 @@ import Control.Monad import System.PosixCompat.Files (isDirectory, isSymbolicLink) import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) -import qualified System.FilePath.ByteString as P import Data.Maybe import Prelude import Utility.OsPath import Utility.Exception import Utility.Monad -import Utility.FileSystemEncoding import qualified Utility.RawFilePath as R -dirCruft :: R.RawFilePath -> Bool -dirCruft "." = True -dirCruft ".." = True -dirCruft _ = False +dirCruft :: [OsPath] +dirCruft = [literalOsPath ".", literalOsPath ".."] {- Lists the contents of a directory. - Unlike getDirectoryContents, paths are not relative to the directory. -} -dirContents :: RawFilePath -> IO [RawFilePath] -dirContents d = - map (\p -> d P. fromOsPath p) - . filter (not . dirCruft . fromOsPath) - <$> getDirectoryContents (toOsPath d) +dirContents :: OsPath -> IO [OsPath] +dirContents d = map (d ) . filter (`notElem` dirCruft) + <$> getDirectoryContents d {- Gets files in a directory, and then its subdirectories, recursively, - and lazily. @@ -54,13 +48,13 @@ dirContents d = - be accessed (the use of unsafeInterleaveIO would make it difficult to - trap such exceptions). -} -dirContentsRecursive :: RawFilePath -> IO [RawFilePath] +dirContentsRecursive :: OsPath -> IO [OsPath] dirContentsRecursive = dirContentsRecursiveSkipping (const False) True {- Skips directories whose basenames match the skipdir. -} -dirContentsRecursiveSkipping :: (RawFilePath -> Bool) -> Bool -> RawFilePath -> IO [RawFilePath] +dirContentsRecursiveSkipping :: (OsPath -> Bool) -> Bool -> OsPath -> IO [OsPath] dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir - | skipdir (P.takeFileName topdir) = return [] + | skipdir (takeFileName topdir) = return [] | otherwise = do -- Get the contents of the top directory outside of -- unsafeInterleaveIO, which allows throwing exceptions if @@ -72,26 +66,26 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir where go [] = return [] go (dir:dirs) - | skipdir (P.takeFileName dir) = go dirs + | skipdir (takeFileName dir) = go dirs | otherwise = unsafeInterleaveIO $ do (files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir) files' <- go (dirs' ++ dirs) return (files ++ files') - collect :: [RawFilePath] -> [RawFilePath] -> [RawFilePath] -> IO ([RawFilePath], [RawFilePath]) + collect :: [OsPath] -> [OsPath] -> [OsPath] -> IO ([OsPath], [OsPath]) collect files dirs' [] = return (reverse files, reverse dirs') collect files dirs' (entry:entries) - | dirCruft entry = collect files dirs' entries + | entry `elem` dirCruft = collect files dirs' entries | otherwise = do let skip = collect (entry:files) dirs' entries let recurse = collect files (entry:dirs') entries - ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry + ms <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath entry) case ms of (Just s) | isDirectory s -> recurse | isSymbolicLink s && followsubdirsymlinks -> - ifM (doesDirectoryExist (toOsPath entry)) + ifM (doesDirectoryExist entry) ( recurse , skip ) @@ -106,22 +100,22 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir - be accessed (the use of unsafeInterleaveIO would make it difficult to - trap such exceptions). -} -dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath] +dirTreeRecursiveSkipping :: (OsPath -> Bool) -> OsPath -> IO [OsPath] dirTreeRecursiveSkipping skipdir topdir - | skipdir (P.takeFileName topdir) = return [] + | skipdir (takeFileName topdir) = return [] | otherwise = do subdirs <- filterM isdir =<< dirContents topdir go [] subdirs where go c [] = return c go c (dir:dirs) - | skipdir (P.takeFileName dir) = go c dirs + | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do subdirs <- go [] =<< filterM isdir =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs - isdir p = isDirectory <$> R.getSymbolicLinkStatus p + isdir p = isDirectory <$> R.getSymbolicLinkStatus (fromOsPath p) {- When the action fails due to the directory not existing, returns []. -} emptyWhenDoesNotExist :: IO [a] -> IO [a] diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs index d97ee026e0..5aad1fb63a 100644 --- a/Utility/Directory/Create.hs +++ b/Utility/Directory/Create.hs @@ -20,14 +20,12 @@ 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.OsPath import Utility.PartialPrelude {- Like createDirectoryIfMissing True, but it will only create @@ -51,39 +49,39 @@ import Utility.PartialPrelude - Note that, the second FilePath, if relative, is relative to the current - working directory. -} -createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO () +createDirectoryUnder :: [OsPath] -> OsPath -> IO () createDirectoryUnder topdirs dir = - createDirectoryUnder' topdirs dir R.createDirectory + createDirectoryUnder' topdirs dir createDirectory createDirectoryUnder' :: (MonadIO m, MonadCatch m) - => [RawFilePath] - -> RawFilePath - -> (RawFilePath -> m ()) + => [OsPath] + -> OsPath + -> (OsPath -> m ()) -> m () createDirectoryUnder' topdirs dir0 mkdir = do relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0 - let relparts = map P.splitDirectories relps + let relparts = map splitDirectories relps -- Catch cases where dir0 is not beneath a 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. let notbeneath = \(_topdir, (relp, dirs)) -> - headMaybe dirs /= Just ".." && not (P.isAbsolute relp) + headMaybe dirs /= Just (literalOsPath "..") && not (isAbsolute relp) case filter notbeneath $ zip topdirs (zip relps relparts) of ((topdir, (_relp, dirs)):_) -- If dir0 is the same as the topdir, don't try to -- create it, but make sure it does exist. | null dirs -> - liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ + liftIO $ unlessM (doesDirectoryExist topdir) $ ioError $ customerror doesNotExistErrorType $ - "createDirectoryUnder: " ++ fromRawFilePath topdir ++ " does not exist" + "createDirectoryUnder: " ++ fromOsPath topdir ++ " does not exist" | otherwise -> createdirs $ - map (topdir P.) (reverse (scanl1 (P.) dirs)) + map (topdir ) (reverse (scanl1 () dirs)) _ -> liftIO $ ioError $ customerror userErrorType - ("createDirectoryUnder: not located in " ++ unwords (map fromRawFilePath topdirs)) + ("createDirectoryUnder: not located in " ++ unwords (map fromOsPath topdirs)) where - customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) + customerror t s = mkIOError t s Nothing (Just (fromOsPath dir0)) createdirs [] = pure () createdirs (dir:[]) = createdir dir (liftIO . ioError) @@ -100,6 +98,6 @@ createDirectoryUnder' topdirs dir0 mkdir = do Left e | isDoesNotExistError e -> notexisthandler e | isAlreadyExistsError e || isPermissionError e -> - liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $ + liftIO $ unlessM (doesDirectoryExist dir) $ ioError e | otherwise -> liftIO $ ioError e diff --git a/Utility/Directory/Stream.hs b/Utility/Directory/Stream.hs index 509abb68de..2dd975955c 100644 --- a/Utility/Directory/Stream.hs +++ b/Utility/Directory/Stream.hs @@ -19,7 +19,6 @@ module Utility.Directory.Stream ( import Control.Monad import Control.Concurrent -import qualified Data.ByteString as B import Data.Maybe import Prelude @@ -27,12 +26,14 @@ import Prelude import qualified System.Win32 as Win32 import System.FilePath #else +import qualified Data.ByteString as B import qualified System.Posix.Directory.ByteString as Posix #endif import Utility.Directory import Utility.Exception import Utility.FileSystemEncoding +import Utility.OsPath #ifndef mingw32_HOST_OS data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream @@ -117,5 +118,5 @@ isDirectoryPopulated d = bracket (openDirectory d) closeDirectory check case v of Nothing -> return False Just f - | not (dirCruft f) -> return True + | not (toOsPath f `elem` dirCruft) -> return True | otherwise -> check h diff --git a/Utility/FileIO.hs b/Utility/FileIO.hs index 5a8f661ce5..e0cd546a28 100644 --- a/Utility/FileIO.hs +++ b/Utility/FileIO.hs @@ -16,6 +16,8 @@ module Utility.FileIO ( withFile, openFile, + withBinaryFile, + openBinaryFile, readFile, readFile', writeFile, @@ -35,8 +37,9 @@ import System.File.OsPath -- https://github.com/haskell/file-io/issues/39 import Utility.Path.Windows import Utility.OsPath +import System.OsPath import System.IO (IO, Handle, IOMode) -import System.OsPath (OsPath) +import Prelude (return) import qualified System.File.OsPath as O import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -52,6 +55,16 @@ openFile f m = do f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) O.openFile f' m +withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile f m a = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.withBinaryFile f' m a + +openBinaryFile :: OsPath -> IOMode -> IO Handle +openBinaryFile f m = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.openBinaryFile f' m + readFile :: OsPath -> IO L.ByteString readFile f = do f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) @@ -85,25 +98,57 @@ appendFile' f b = do openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle) openTempFile p s = do p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p) - O.openTempFile p' s + (t, h) <- O.openTempFile p' s + -- Avoid returning mangled path from convertToWindowsNativeNamespace + let t' = p takeFileName t + return (t', h) #endif #else --- When not building with OsPath, export FilePath versions --- instead. However, functions still use ByteString for the --- file content in that case, unlike the Strings used by the Prelude. +-- When not building with OsPath, export RawFilePath versions +-- instead. import Utility.OsPath -import System.IO (withFile, openFile, openTempFile, IO) +import Utility.FileSystemEncoding +import System.IO (IO, Handle, IOMode) +import Prelude ((.), return) import qualified System.IO -import Data.ByteString.Lazy (readFile, writeFile, appendFile) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withFile = System.IO.withFile . fromRawFilePath + +openFile :: OsPath -> IOMode -> IO Handle +openFile = System.IO.openFile . fromRawFilePath + +withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile = System.IO.withBinaryFile . fromRawFilePath + +openBinaryFile :: OsPath -> IOMode -> IO Handle +openBinaryFile = System.IO.openBinaryFile . fromRawFilePath + +readFile :: OsPath -> IO L.ByteString +readFile = L.readFile . fromRawFilePath readFile' :: OsPath -> IO B.ByteString -readFile' = B.readFile +readFile' = B.readFile . fromRawFilePath + +writeFile :: OsPath -> L.ByteString -> IO () +writeFile = L.writeFile . fromRawFilePath writeFile' :: OsPath -> B.ByteString -> IO () -writeFile' = B.writeFile +writeFile' = B.writeFile . fromRawFilePath + +appendFile :: OsPath -> L.ByteString -> IO () +appendFile = L.appendFile . fromRawFilePath appendFile' :: OsPath -> B.ByteString -> IO () -appendFile' = B.appendFile +appendFile' = B.appendFile . fromRawFilePath + +openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle) +openTempFile p s = do + (t, h) <- System.IO.openTempFile + (fromRawFilePath p) + (fromRawFilePath s) + return (toRawFilePath t, h) #endif diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 95e5d570ef..a4d5cc5a20 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -25,26 +25,27 @@ import Foreign (complement) import Control.Monad.Catch import Utility.Exception -import Utility.FileSystemEncoding import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F import Utility.OsPath {- Applies a conversion function to a file's mode. -} -modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO () +modifyFileMode :: OsPath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert -modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' :: OsPath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' f convert = do - s <- R.getFileStatus f + s <- R.getFileStatus f' let old = fileMode s let new = convert old when (new /= old) $ - R.setFileMode f new + R.setFileMode f' new return old + where + f' = fromOsPath f {- Runs an action after changing a file's mode, then restores the old mode. -} -withModifiedFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode :: OsPath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode file convert a = bracket setup cleanup go where setup = modifyFileMode' file convert @@ -77,15 +78,15 @@ otherGroupModes = ] {- Removes the write bits from a file. -} -preventWrite :: RawFilePath -> IO () +preventWrite :: OsPath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes {- Turns a file's owner write bit back on. -} -allowWrite :: RawFilePath -> IO () +allowWrite :: OsPath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] {- Turns a file's owner read bit back on. -} -allowRead :: RawFilePath -> IO () +allowRead :: OsPath -> IO () allowRead f = modifyFileMode f $ addModes [ownerReadMode] {- Allows owner and group to read and write to a file. -} @@ -95,7 +96,7 @@ groupSharedModes = , ownerReadMode, groupReadMode ] -groupWriteRead :: RawFilePath -> IO () +groupWriteRead :: OsPath -> IO () groupWriteRead f = modifyFileMode f $ addModes groupSharedModes checkMode :: FileMode -> FileMode -> Bool @@ -105,13 +106,13 @@ checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor isExecutable :: FileMode -> Bool isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 -data ModeSetter = ModeSetter FileMode (RawFilePath -> IO ()) +data ModeSetter = ModeSetter FileMode (OsPath -> IO ()) {- Runs an action which should create the file, passing it the desired - initial file mode. Then runs the ModeSetter's action on the file, which - can adjust the initial mode if umask prevented the file from being - created with the right mode. -} -applyModeSetter :: Maybe ModeSetter -> RawFilePath -> (Maybe FileMode -> IO a) -> IO a +applyModeSetter :: Maybe ModeSetter -> OsPath -> (Maybe FileMode -> IO a) -> IO a applyModeSetter (Just (ModeSetter mode modeaction)) file a = do r <- a (Just mode) void $ tryIO $ modeaction file @@ -159,7 +160,7 @@ isSticky = checkMode stickyMode stickyMode :: FileMode stickyMode = 512 -setSticky :: RawFilePath -> IO () +setSticky :: OsPath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -172,15 +173,15 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - On a filesystem that does not support file permissions, this is the same - as writeFile. -} -writeFileProtected :: RawFilePath -> String -> IO () +writeFileProtected :: OsPath -> String -> IO () writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) -writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' :: OsPath -> (Handle -> IO ()) -> IO () writeFileProtected' file writer = bracket setup cleanup writer where setup = do - h <- protectedOutput $ F.openFile (toOsPath file) WriteMode + h <- protectedOutput $ F.openFile file WriteMode void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes return h cleanup = hClose diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index ad23647606..e275771d05 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -17,7 +17,6 @@ module Utility.FileSize ( #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO -import Utility.FileSystemEncoding import qualified Utility.FileIO as F import Utility.OsPath #else @@ -25,6 +24,7 @@ import System.PosixCompat.Files (fileSize) #endif import System.PosixCompat.Files (FileStatus) import qualified Utility.RawFilePath as R +import Utility.OsPath type FileSize = Integer @@ -34,18 +34,18 @@ type FileSize = Integer - FileOffset which maxes out at 2 gb. - See https://github.com/jystic/unix-compat/issues/16 -} -getFileSize :: R.RawFilePath -> IO FileSize +getFileSize :: OsPath -> IO FileSize #ifndef mingw32_HOST_OS -getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f) +getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus (fromOsPath f)) #else -getFileSize f = bracket (F.openFile (toOsPath f) ReadMode) hClose hFileSize +getFileSize f = bracket (F.openFile 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' :: R.RawFilePath -> FileStatus -> IO FileSize +getFileSize' :: OsPath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s #else diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index b4497f30af..cf9355ccd5 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -157,10 +157,13 @@ truncateFilePath n = toRawFilePath . reverse . go [] n go coll cnt bs | cnt <= 0 = coll | otherwise = case S8.decode bs of - Just (c, x) | c /= S8.replacement_char -> - let x' = fromIntegral x - in if cnt - x' < 0 - then coll - else go (c:coll) (cnt - x') (S8.drop 1 bs) + Just (c, x) + | c /= S8.replacement_char -> + let x' = fromIntegral x + in if cnt - x' < 0 + then coll + else go (c:coll) (cnt - x') (S8.drop 1 bs) + | otherwise -> + go ('_':coll) (cnt - 1) (S8.drop 1 bs) _ -> coll #endif diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs index 896b89b991..71ec3a3c7b 100644 --- a/Utility/FreeDesktop.hs +++ b/Utility/FreeDesktop.hs @@ -10,6 +10,7 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FreeDesktop ( @@ -28,17 +29,10 @@ module Utility.FreeDesktop ( userDesktopDir ) where -import Utility.Exception +import Common import Utility.UserInfo -import Utility.Process import System.Environment -import System.FilePath -import System.Directory -import Data.List -import Data.Maybe -import Control.Applicative -import Prelude type DesktopEntry = [(Key, Value)] @@ -78,53 +72,53 @@ buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n" where keyvalue (k, v) = k ++ "=" ++ toString v -writeDesktopMenuFile :: DesktopEntry -> String -> IO () +writeDesktopMenuFile :: DesktopEntry -> OsPath -> IO () writeDesktopMenuFile d file = do createDirectoryIfMissing True (takeDirectory file) - writeFile file $ buildDesktopMenuFile d + writeFile (fromOsPath file) $ buildDesktopMenuFile d {- Path to use for a desktop menu file, in either the systemDataDir or - the userDataDir -} -desktopMenuFilePath :: String -> FilePath -> FilePath +desktopMenuFilePath :: String -> OsPath -> OsPath desktopMenuFilePath basename datadir = - datadir "applications" desktopfile basename + datadir literalOsPath "applications" desktopfile basename {- Path to use for a desktop autostart file, in either the systemDataDir - or the userDataDir -} -autoStartPath :: String -> FilePath -> FilePath +autoStartPath :: String -> OsPath -> OsPath autoStartPath basename configdir = - configdir "autostart" desktopfile basename + configdir literalOsPath "autostart" desktopfile basename {- Base directory to install an icon file, in either the systemDataDir - or the userDatadir. -} -iconDir :: FilePath -> FilePath -iconDir datadir = datadir "icons" "hicolor" +iconDir :: OsPath -> OsPath +iconDir datadir = datadir literalOsPath "icons" literalOsPath "hicolor" {- Filename of an icon, given the iconDir to use. - - The resolution is something like "48x48" or "scalable". -} -iconFilePath :: FilePath -> String -> FilePath -> FilePath +iconFilePath :: OsPath -> String -> OsPath -> OsPath iconFilePath file resolution icondir = - icondir resolution "apps" file + icondir toOsPath resolution literalOsPath "apps" file -desktopfile :: FilePath -> FilePath -desktopfile f = f ++ ".desktop" +desktopfile :: FilePath -> OsPath +desktopfile f = toOsPath $ f ++ ".desktop" {- Directory used for installation of system wide data files.. -} -systemDataDir :: FilePath -systemDataDir = "/usr/share" +systemDataDir :: OsPath +systemDataDir = literalOsPath "/usr/share" {- Directory used for installation of system wide config files. -} -systemConfigDir :: FilePath -systemConfigDir = "/etc/xdg" +systemConfigDir :: OsPath +systemConfigDir = literalOsPath "/etc/xdg" {- Directory for user data files. -} -userDataDir :: IO FilePath -userDataDir = xdgEnvHome "DATA_HOME" ".local/share" +userDataDir :: IO OsPath +userDataDir = toOsPath <$> xdgEnvHome "DATA_HOME" ".local/share" {- Directory for user config files. -} -userConfigDir :: IO FilePath -userConfigDir = xdgEnvHome "CONFIG_HOME" ".config" +userConfigDir :: IO OsPath +userConfigDir = toOsPath <$> xdgEnvHome "CONFIG_HOME" ".config" {- Directory for the user's Desktop, may be localized. - @@ -142,6 +136,6 @@ userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir) xdgEnvHome :: String -> String -> IO String xdgEnvHome envbase homedef = do - home <- myHomeDir - catchDefaultIO (home homedef) $ - getEnv $ "XDG_" ++ envbase + home <- toOsPath <$> myHomeDir + catchDefaultIO (fromOsPath $ home toOsPath homedef) $ + getEnv ("XDG_" ++ envbase) diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 19dd7f5395..781b9a4a58 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -179,10 +179,10 @@ feedRead cmd params passphrase feeder reader = do go (passphrasefd ++ params) #else -- store the passphrase in a temp file for gpg - withTmpFile "gpg" $ \tmpfile h -> do + withTmpFile (toOsPath "gpg") $ \tmpfile h -> do liftIO $ B.hPutStr h passphrase liftIO $ hClose h - let passphrasefile = [Param "--passphrase-file", File tmpfile] + let passphrasefile = [Param "--passphrase-file", File (fromOsPath tmpfile)] go $ passphrasefile ++ params #endif where @@ -416,9 +416,9 @@ testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd)) setup = do subdir <- makenewdir (1 :: Integer) origenviron <- getEnvironment - let environ = addEntry var subdir origenviron + let environ = addEntry var (fromOsPath subdir) origenviron -- gpg is picky about permissions on its home dir - liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $ + liftIO $ void $ tryIO $ modifyFileMode subdir $ removeModes $ otherGroupModes -- For some reason, recent gpg needs a trustdb to be set up. _ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty @@ -441,7 +441,7 @@ testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd)) go Nothing = return Nothing makenewdir n = do - let subdir = tmpdir show n + let subdir = toOsPath tmpdir toOsPath (show n) catchIOErrorType AlreadyExists (const $ makenewdir $ n + 1) $ do createDirectory subdir return subdir diff --git a/Utility/HtmlDetect.hs b/Utility/HtmlDetect.hs index cf83e52f08..e1739a94e9 100644 --- a/Utility/HtmlDetect.hs +++ b/Utility/HtmlDetect.hs @@ -14,7 +14,6 @@ module Utility.HtmlDetect ( import Author import qualified Utility.FileIO as F -import Utility.RawFilePath import Utility.OsPath import Text.HTML.TagSoup @@ -60,8 +59,8 @@ isHtmlBs = isHtml . B8.unpack -- It would be equivalent to use isHtml <$> readFile file, -- but since that would not read all of the file, the handle -- would remain open until it got garbage collected sometime later. -isHtmlFile :: RawFilePath -> IO Bool -isHtmlFile file = F.withFile (toOsPath file) ReadMode $ \h -> +isHtmlFile :: OsPath -> IO Bool +isHtmlFile file = F.withFile file ReadMode $ \h -> isHtmlBs <$> B.hGet h htmlPrefixLength -- | How much of the beginning of a html document is needed to detect it. diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 6f8008dd5f..7e1b18aa35 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -49,6 +49,7 @@ import Common import Utility.TimeStamp import Utility.QuickCheck import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F import System.PosixCompat.Types import System.PosixCompat.Files (isRegularFile, fileID) @@ -189,20 +190,20 @@ readInodeCache s = case words s of return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) _ -> Nothing -genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) +genInodeCache :: OsPath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta f =<< R.getSymbolicLinkStatus f + toInodeCache delta f =<< R.getSymbolicLinkStatus (fromOsPath f) -toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) +toInodeCache :: TSDelta -> OsPath -> FileStatus -> IO (Maybe InodeCache) toInodeCache d f s = toInodeCache' d f s (fileID s) -toInodeCache' :: TSDelta -> RawFilePath -> FileStatus -> FileID -> IO (Maybe InodeCache) +toInodeCache' :: TSDelta -> OsPath -> FileStatus -> FileID -> IO (Maybe InodeCache) toInodeCache' (TSDelta getdelta) f s inode | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s #ifdef mingw32_HOST_OS - mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) + mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f #else let mtime = Posix.modificationTimeHiRes s #endif @@ -214,8 +215,8 @@ toInodeCache' (TSDelta getdelta) f s inode - Its InodeCache at the time of its creation is written to the cache file, - so changes can later be detected. -} data SentinalFile = SentinalFile - { sentinalFile :: RawFilePath - , sentinalCacheFile :: RawFilePath + { sentinalFile :: OsPath + , sentinalCacheFile :: OsPath } deriving (Show) @@ -232,8 +233,8 @@ noTSDelta = TSDelta (pure 0) writeSentinalFile :: SentinalFile -> IO () writeSentinalFile s = do - writeFile (fromRawFilePath (sentinalFile s)) "" - maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache) + F.writeFile' (sentinalFile s) mempty + maybe noop (writeFile (fromOsPath (sentinalCacheFile s)) . showInodeCache) =<< genInodeCache (sentinalFile s) noTSDelta data SentinalStatus = SentinalStatus @@ -262,7 +263,7 @@ checkSentinalFile s = do Just new -> return $ calc old new where loadoldcache = catchDefaultIO Nothing $ - readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s)) + readInodeCache <$> readFile (fromOsPath (sentinalCacheFile s)) gennewcache = genInodeCache (sentinalFile s) noTSDelta calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = SentinalStatus (not unchanged) tsdelta @@ -287,7 +288,7 @@ checkSentinalFile s = do dummy = SentinalStatus True noTSDelta sentinalFileExists :: SentinalFile -> IO Bool -sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s] +sentinalFileExists s = allM doesPathExist [sentinalCacheFile s, sentinalFile s] instance Arbitrary InodeCache where arbitrary = diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs index ec482a1465..54c786b8de 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -27,10 +27,11 @@ import Utility.Split import Utility.FileSystemEncoding import Utility.Env import Utility.Exception +import Utility.OsPath +import Utility.RawFilePath import Data.Maybe -import System.FilePath -import System.Posix.Files +import System.Posix.Files (isSymbolicLink) import Data.Char import Control.Monad.IfElse import Control.Applicative @@ -39,28 +40,28 @@ import Prelude {- Installs a library. If the library is a symlink to another file, - install the file it links to, and update the symlink to be relative. -} installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath) -installLib installfile top lib = ifM (doesFileExist lib) +installLib installfile top lib = ifM (doesFileExist (toOsPath lib)) ( do installfile top lib checksymlink lib - return $ Just $ fromRawFilePath $ parentDir $ toRawFilePath lib + return $ Just $ fromOsPath $ parentDir $ toOsPath lib , return Nothing ) where checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) 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) + (parentDir (toOsPath f)) + (toOsPath l) + target <- relPathDirToFile (takeDirectory (toOsPath f)) absl + installfile top (fromOsPath absl) + removeWhenExistsWith removeLink (toRawFilePath (top ++ f)) + createSymbolicLink (fromOsPath target) (inTop top f) + checksymlink (fromOsPath absl) -- Note that f is not relative, so cannot use -inTop :: FilePath -> FilePath -> FilePath -inTop top f = top ++ f +inTop :: FilePath -> FilePath -> RawFilePath +inTop top f = toRawFilePath $ top ++ f {- Parse ldd output, getting all the libraries that the input files - link to. Note that some of the libraries may not exist diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 4ed730ccff..505196c718 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -50,21 +50,19 @@ 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 -import System.FilePath import Control.Applicative import Prelude -type PidLockFile = RawFilePath +type PidLockFile = OsPath data LockHandle = LockHandle PidLockFile FileStatus SideLockHandle | ParentLocked -type SideLockHandle = Maybe (RawFilePath, Posix.LockHandle) +type SideLockHandle = Maybe (OsPath, Posix.LockHandle) data PidLock = PidLock { lockingPid :: ProcessID @@ -79,7 +77,7 @@ mkPidLock = PidLock readPidLock :: PidLockFile -> IO (Maybe PidLock) readPidLock lockfile = (readish =<<) - <$> catchMaybeIO (readFile (fromRawFilePath lockfile)) + <$> catchMaybeIO (readFile (fromOsPath lockfile)) -- To avoid races when taking over a stale pid lock, a side lock is used. -- This is a regular posix exclusive lock. @@ -112,25 +110,26 @@ dropSideLock (Just (f, h)) = do -- 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 (fromRawFilePath f) + _ <- tryIO $ removeFile f Posix.dropLock h -- The side lock is put in /dev/shm. This will work on most any -- Linux system, even if its whole root filesystem doesn't support posix -- locks. /tmp is used as a fallback. -sideLockFile :: PidLockFile -> IO RawFilePath +sideLockFile :: PidLockFile -> IO OsPath sideLockFile lockfile = do - f <- fromRawFilePath <$> absPath lockfile - let base = intercalate "_" (splitDirectories (makeRelative "/" f)) + f <- absPath lockfile + let base = intercalate "_" $ map fromOsPath $ + splitDirectories $ makeRelative (literalOsPath "/") f let shortbase = reverse $ take 32 $ reverse base let md5sum = if base == shortbase then "" - else toRawFilePath $ show (md5 (encodeBL base)) - dir <- ifM (doesDirectoryExist "/dev/shm") - ( return "/dev/shm" - , return "/tmp" + else show (md5 (encodeBL base)) + dir <- ifM (doesDirectoryExist (literalOsPath "/dev/shm")) + ( return (literalOsPath "/dev/shm") + , return (literalOsPath "/tmp") ) - return $ dir P. md5sum <> toRawFilePath shortbase <> ".lck" + return $ dir toOsPath md5sum <> toOsPath shortbase <> literalOsPath ".lck" -- | Tries to take a lock; does not block when the lock is already held. -- @@ -151,20 +150,20 @@ tryLock lockfile = do where go abslockfile sidelock = do (tmp, h) <- openTmpFileIn - (toOsPath (P.takeDirectory abslockfile)) - (toOsPath "locktmp") + (takeDirectory abslockfile) + (literalOsPath "locktmp") let tmp' = fromOsPath tmp setFileMode tmp' (combineModes readModes) hPutStr h . show =<< mkPidLock hClose h let failedlock = do dropSideLock sidelock - removeWhenExistsWith removeLink tmp' + removeWhenExistsWith removeFile tmp return Nothing let tooklock st = return $ Just $ LockHandle abslockfile st sidelock - linkToLock sidelock tmp' abslockfile >>= \case + linkToLock sidelock tmp' (fromOsPath abslockfile) >>= \case Just lckst -> do - removeWhenExistsWith removeLink tmp' + removeWhenExistsWith removeFile tmp tooklock lckst Nothing -> do v <- readPidLock abslockfile @@ -177,7 +176,7 @@ tryLock lockfile = do -- the pidlock was taken on, -- we know that the pidlock is -- stale, and can take it over. - rename tmp' abslockfile + rename tmp' (fromOsPath abslockfile) tooklock tmpst _ -> failedlock @@ -201,7 +200,7 @@ linkToLock (Just _) src dest = do Right _ -> do _ <- tryIO $ createLink src dest ifM (catchBoolIO checklinked) - ( ifM (catchBoolIO $ not <$> checkInsaneLustre dest) + ( ifM (catchBoolIO $ not <$> checkInsaneLustre (toOsPath dest)) ( catchMaybeIO $ getFileStatus dest , return Nothing ) @@ -243,16 +242,16 @@ linkToLock (Just _) src dest = do -- 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 :: RawFilePath -> IO Bool +checkInsaneLustre :: OsPath -> IO Bool checkInsaneLustre dest = do - fs <- dirContents (P.takeDirectory 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 $ removeLink dest + _ <- tryIO $ removeFile dest return True -- | Waits as necessary to take a lock. @@ -268,7 +267,7 @@ waitLock (Seconds timeout) lockfile displaymessage sem = go timeout | n > 0 = liftIO (tryLock lockfile) >>= \case Nothing -> do when (n == pred timeout) $ - displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)" + displaymessage $ "waiting for pid lock file " ++ fromOsPath lockfile ++ " which is held by another process (or may be stale)" liftIO $ threadDelaySeconds (Seconds 1) go (pred n) Just lckh -> do @@ -280,15 +279,15 @@ waitLock (Seconds timeout) lockfile displaymessage sem = go timeout waitedLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> m a waitedLock (Seconds timeout) lockfile displaymessage = do - displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile - giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile + displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromOsPath lockfile + giveup $ "Gave up waiting for pid lock file " ++ fromOsPath lockfile -- | Use when the pid lock has already been taken by another thread of the -- same process. alreadyLocked :: MonadIO m => PidLockFile -> m LockHandle alreadyLocked lockfile = liftIO $ do abslockfile <- absPath lockfile - st <- getFileStatus abslockfile + st <- getFileStatus (fromOsPath abslockfile) return $ LockHandle abslockfile st Nothing dropLock :: LockHandle -> IO () @@ -296,7 +295,7 @@ dropLock (LockHandle lockfile _ sidelock) = do -- Drop side lock first, at which point the pid lock will be -- considered stale. dropSideLock sidelock - removeWhenExistsWith removeLink lockfile + removeWhenExistsWith removeFile lockfile dropLock ParentLocked = return () getLockStatus :: PidLockFile -> IO LockStatus @@ -312,7 +311,7 @@ checkLocked lockfile = conv <$> getLockStatus lockfile -- locked to get the LockHandle. checkSaneLock :: PidLockFile -> LockHandle -> IO Bool checkSaneLock lockfile (LockHandle _ st _) = - go =<< catchMaybeIO (getFileStatus lockfile) + go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile)) where go Nothing = return False go (Just st') = return $ @@ -327,9 +326,9 @@ checkSaneLock _ ParentLocked = return True -- 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 :: RawFilePath -> IO String +pidLockEnv :: OsPath -> IO String pidLockEnv lockfile = do - abslockfile <- fromRawFilePath <$> absPath lockfile + abslockfile <- fromOsPath <$> absPath lockfile return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile pidLockEnvValue :: String diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index e7d49b81e3..f74e3691a7 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -25,15 +25,15 @@ import Utility.Applicative import Utility.FileMode import Utility.LockFile.LockStatus import Utility.OpenFd +import Utility.OsPath import System.IO import System.Posix.Types import System.Posix.IO.ByteString import System.Posix.Files.ByteString -import System.FilePath.ByteString (RawFilePath) import Data.Maybe -type LockFile = RawFilePath +type LockFile = OsPath newtype LockHandle = LockHandle Fd @@ -76,7 +76,7 @@ tryLock lockreq mode lockfile = uninterruptibleMask_ $ do openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd openLockFile lockreq filemode lockfile = do l <- applyModeSetter filemode lockfile $ \filemode' -> - openFdWithMode lockfile openfor filemode' defaultFileFlags + openFdWithMode (fromOsPath lockfile) openfor filemode' defaultFileFlags setFdOption l CloseOnExec True return l where @@ -120,7 +120,7 @@ dropLock (LockHandle fd) = closeFd fd -- else. checkSaneLock :: LockFile -> LockHandle -> IO Bool checkSaneLock lockfile (LockHandle fd) = - go =<< catchMaybeIO (getFileStatus lockfile) + go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile)) where go Nothing = return False go (Just st) = do diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs index c8e7c1bf52..8e6c6d2905 100644 --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -70,14 +70,12 @@ openLock sharemode f = do Right h -> Just h #else h <- withTString (fromRawFilePath f') $ \c_f -> - c_CreateFile c_f gENERIC_READ sharemode security_attributes + c_CreateFile c_f gENERIC_READ sharemode (maybePtr Nothing) oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) return $ if h == iNVALID_HANDLE_VALUE then Nothing else Just h #endif - where - security_attributes = maybePtr Nothing dropLock :: LockHandle -> IO () dropLock = closeHandle diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs index 2c3eb66aef..370ef1c65e 100644 --- a/Utility/LockPool/STM.hs +++ b/Utility/LockPool/STM.hs @@ -23,14 +23,14 @@ module Utility.LockPool.STM ( ) where import Utility.Monad +import Utility.OsPath import System.IO.Unsafe (unsafePerformIO) -import System.FilePath.ByteString (RawFilePath) import qualified Data.Map.Strict as M import Control.Concurrent.STM import Control.Exception -type LockFile = RawFilePath +type LockFile = OsPath data LockMode = LockExclusive | LockShared deriving (Eq) diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs index 64ab78576b..4adfcdcbbe 100644 --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -35,7 +35,7 @@ rotateLog logfile = go 0 where go num | num > maxLogs = return () - | otherwise = whenM (doesFileExist currfile) $ do + | otherwise = whenM (doesFileExist (toOsPath currfile)) $ do go (num + 1) rename (toRawFilePath currfile) (toRawFilePath nextfile) where @@ -50,7 +50,7 @@ rotatedLog logfile n = logfile ++ "." ++ show n {- Lists most recent logs last. -} listLogs :: FilePath -> IO [FilePath] -listLogs logfile = filterM doesFileExist $ reverse $ +listLogs logfile = filterM (doesFileExist . toOsPath) $ reverse $ logfile : map (rotatedLog logfile) [1..maxLogs] maxLogs :: Int diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index e8569ee023..7864b045b4 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -15,6 +15,7 @@ module Utility.Lsof ( import Common import BuildInfo import Utility.Env.Set +import qualified Utility.OsString as OS import System.Posix.Types @@ -30,12 +31,14 @@ data ProcessInfo = ProcessInfo ProcessID CmdLine - path where the program was found. Make sure at runtime that lsof is - available, and if it's not in PATH, adjust PATH to contain it. -} setup :: IO () -setup = do - let cmd = fromMaybe "lsof" BuildInfo.lsof - when (isAbsolute cmd) $ do - path <- getSearchPath - let path' = takeDirectory cmd : path - setEnv "PATH" (intercalate [searchPathSeparator] path') True +setup = when (isAbsolute cmd) $ do + path <- getSearchPath + let path' = fromOsPath $ OS.intercalate sep $ + takeDirectory cmd : path + setEnv "PATH" path' True + where + cmd = toOsPath $ fromMaybe "lsof" BuildInfo.lsof + sep = OS.singleton searchPathSeparator {- Checks each of the files in a directory to find open files. - Note that this will find hard links to files elsewhere that are open. -} diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 0b7097b732..f66e3833f1 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -55,6 +55,7 @@ import Utility.HumanTime import Utility.SimpleProtocol as Proto import Utility.ThreadScheduler import Utility.SafeOutput +import qualified Utility.FileIO as F import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -121,8 +122,8 @@ zeroBytesProcessed = BytesProcessed 0 {- Sends the content of a file to an action, updating the meter as it's - consumed. -} -withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a -withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> +withMeteredFile :: OsPath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a +withMeteredFile f meterupdate a = F.withBinaryFile f ReadMode $ \h -> hGetContentsMetered h meterupdate >>= a {- Calls the action repeatedly with chunks from the lazy ByteString. @@ -140,8 +141,8 @@ meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks meterupdate sofar' go sofar' cs -meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () -meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> +meteredWriteFile :: MeterUpdate -> OsPath -> L.ByteString -> IO () +meteredWriteFile meterupdate f b = F.withBinaryFile f WriteMode $ \h -> meteredWrite meterupdate (S.hPut h) b {- Applies an offset to a MeterUpdate. This can be useful when @@ -227,7 +228,7 @@ defaultChunkSize = 32 * k - chunkOverhead -} watchFileSize :: (MonadIO m, MonadMask m) - => RawFilePath + => OsPath -> MeterUpdate -> (MeterUpdate -> m a) -> m a diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs index d80c9203f8..7bc0297532 100644 --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -27,26 +27,24 @@ import Utility.SystemDirectory import Utility.Tmp import Utility.Exception import Utility.Monad -import Utility.FileSystemEncoding import Utility.OsPath import qualified Utility.RawFilePath as R import Author {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} -moveFile :: RawFilePath -> RawFilePath -> IO () -moveFile src dest = tryIO (R.rename src dest) >>= onrename +moveFile :: OsPath -> OsPath -> IO () +moveFile src dest = tryIO (renamePath src dest) >>= onrename where onrename (Right _) = noop onrename (Left e) | isPermissionError e = rethrow | isDoesNotExistError e = rethrow - | otherwise = viaTmp mv (toOsPath dest) () + | otherwise = viaTmp mv dest () where rethrow = throwM e mv tmp () = do - let tmp' = fromRawFilePath (fromOsPath tmp) -- copyFile is likely not as optimised as -- the mv command, so we'll use the command. -- @@ -58,28 +56,28 @@ moveFile src dest = tryIO (R.rename src dest) >>= onrename whenM (isdir dest) rethrow ok <- copyright =<< boolSystem "mv" [ Param "-f" - , Param (fromRawFilePath src) - , Param tmp' + , Param (fromOsPath src) + , Param (fromOsPath tmp) ] let e' = e #else - r <- tryIO $ copyFile (fromRawFilePath src) tmp' + 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' + _ <- tryIO $ removeFile tmp throwM e' #ifndef mingw32_HOST_OS isdir f = do - r <- tryIO $ R.getSymbolicLinkStatus f + r <- tryIO $ R.getSymbolicLinkStatus (fromOsPath f) case r of (Left _) -> return False (Right s) -> return $ isDirectory s +#endif copyright :: Copyright copyright = author JoeyHess (2022-11) -#endif diff --git a/Utility/OSX.hs b/Utility/OSX.hs index f5820a78d6..1bcbe4c628 100644 --- a/Utility/OSX.hs +++ b/Utility/OSX.hs @@ -5,6 +5,7 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.OSX ( @@ -14,20 +15,21 @@ module Utility.OSX ( genOSXAutoStartFile, ) where +import Common import Utility.UserInfo -import System.FilePath +autoStartBase :: String -> OsPath +autoStartBase label = literalOsPath "Library" + literalOsPath "LaunchAgents" + toOsPath label <> literalOsPath ".plist" -autoStartBase :: String -> FilePath -autoStartBase label = "Library" "LaunchAgents" label ++ ".plist" +systemAutoStart :: String -> OsPath +systemAutoStart label = literalOsPath "/" autoStartBase label -systemAutoStart :: String -> FilePath -systemAutoStart label = "/" autoStartBase label - -userAutoStart :: String -> IO FilePath +userAutoStart :: String -> IO OsPath userAutoStart label = do home <- myHomeDir - return $ home autoStartBase label + return $ toOsPath home autoStartBase label {- Generates an OSX autostart plist file with a given label, command, and - params to run at boot or login. -} diff --git a/Utility/OsPath.hs b/Utility/OsPath.hs index 5a62e61004..fb4e23dca5 100644 --- a/Utility/OsPath.hs +++ b/Utility/OsPath.hs @@ -7,51 +7,132 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.OsPath ( OsPath, OsString, + RawFilePath, + literalOsPath, + stringToOsPath, toOsPath, fromOsPath, + module X, + getSearchPath, + unsafeFromChar, ) where import Utility.FileSystemEncoding - +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as S +import qualified Data.ByteString.Lazy as L #ifdef WITH_OSPATH +import System.OsPath as X hiding (OsPath, OsString, pack, unpack, unsafeFromChar) import System.OsPath import "os-string" System.OsString.Internal.Types -import qualified Data.ByteString.Short as S - -{- Unlike System.OsString.fromBytes, on Windows this does not ensure a - - valid USC-2LE encoding. The input ByteString must be in a valid encoding - - already or uses of the OsPath will fail. -} -toOsPath :: RawFilePath -> OsPath +import qualified System.FilePath.ByteString as PB #if defined(mingw32_HOST_OS) -toOsPath = OsString . WindowsString . S.toShort +import GHC.IO (unsafePerformIO) +import System.OsString.Encoding.Internal (cWcharsToChars_UCS2) +import qualified System.OsString.Data.ByteString.Short.Word16 as BS16 +#endif #else -toOsPath = OsString . PosixString . S.toShort +import System.FilePath.ByteString as X hiding (RawFilePath, getSearchPath) +import System.FilePath.ByteString (getSearchPath) +import Data.ByteString (ByteString) +import Data.Char +import Data.Word #endif -fromOsPath :: OsPath -> RawFilePath +class OsPathConv t where + toOsPath :: t -> OsPath + fromOsPath :: OsPath -> t + +instance OsPathConv FilePath where + toOsPath = toOsPath . toRawFilePath + fromOsPath = fromRawFilePath . fromOsPath + +#ifdef WITH_OSPATH +instance OsPathConv RawFilePath where #if defined(mingw32_HOST_OS) -fromOsPath = S.fromShort . getWindowsString . getOsString + toOsPath = bytesToOsPath + fromOsPath = bytesFromOsPath #else -fromOsPath = S.fromShort . getPosixString . getOsString + toOsPath = bytesToOsPath . S.toShort + fromOsPath = S.fromShort . bytesFromOsPath #endif +instance OsPathConv ShortByteString where +#if defined(mingw32_HOST_OS) + toOsPath = bytesToOsPath . S.fromShort + fromOsPath = S.toShort . bytesFromOsPath #else -{- When not building with WITH_OSPATH, use FilePath. This allows - - using functions from legacy FilePath libraries interchangeably with - - newer OsPath libraries. + toOsPath = bytesToOsPath + fromOsPath = bytesFromOsPath +#endif + +instance OsPathConv L.ByteString where + toOsPath = toOsPath . L.toStrict + fromOsPath = L.fromStrict . fromOsPath + +#if defined(mingw32_HOST_OS) +-- On Windows, OsString contains a ShortByteString that is +-- utf-16 encoded. But the input RawFilePath is assumed to +-- be utf-8. So this is a relatively expensive conversion. +bytesToOsPath :: RawFilePath -> OsPath +bytesToOsPath = unsafePerformIO . encodeFS . fromRawFilePath +#else +bytesToOsPath :: ShortByteString -> OsPath +bytesToOsPath = OsString . PosixString +#endif + +#if defined(mingw32_HOST_OS) +bytesFromOsPath :: OsPath -> RawFilePath +-- On Windows, OsString contains a ShortByteString that is +-- utf-16 encoded, but RawFilePath is utf-8. +-- So this is relatively expensive conversion. +bytesFromOsPath = toRawFilePath . cWcharsToChars_UCS2 . BS16.unpack . getWindowsString . getOsString +#else +bytesFromOsPath :: OsPath -> ShortByteString +bytesFromOsPath = getPosixString . getOsString +#endif + +{- For some reason not included in System.OsPath -} +getSearchPath :: IO [OsPath] +getSearchPath = map toOsPath <$> PB.getSearchPath + +{- Used for string constants. Note that when using OverloadedStrings, + - the IsString instance for ShortByteString only works properly with + - ASCII characters. -} +literalOsPath :: ShortByteString -> OsPath +literalOsPath = toOsPath + +#else +{- When not building with WITH_OSPATH, use RawFilePath. -} -type OsPath = FilePath +type OsPath = RawFilePath -type OsString = String +type OsString = ByteString -toOsPath :: RawFilePath -> OsPath -toOsPath = fromRawFilePath +instance OsPathConv RawFilePath where + toOsPath = id + fromOsPath = id -fromOsPath :: OsPath -> RawFilePath -fromOsPath = toRawFilePath +instance OsPathConv ShortByteString where + toOsPath = S.fromShort + fromOsPath = S.toShort + +instance OsPathConv L.ByteString where + toOsPath = L.toStrict + fromOsPath = L.fromStrict + +unsafeFromChar :: Char -> Word8 +unsafeFromChar = fromIntegral . ord + +literalOsPath :: RawFilePath -> OsPath +literalOsPath = id #endif + +stringToOsPath :: String -> OsPath +stringToOsPath = toOsPath diff --git a/Utility/OsString.hs b/Utility/OsString.hs new file mode 100644 index 0000000000..ba563a568e --- /dev/null +++ b/Utility/OsString.hs @@ -0,0 +1,42 @@ +{- OsString manipulation. Or ByteString when not built with OsString. + - Import qualified. + - + - Copyright 2025 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.OsString ( + module X, + length, +#ifndef WITH_OSPATH + toChar, +#endif +) where + +#ifdef WITH_OSPATH +import System.OsString as X hiding (length) +import qualified System.OsString +import qualified Data.ByteString as B +import Utility.OsPath +import Prelude ((.), Int) + +{- Avoid System.OsString.length, which returns the number of code points on + - windows. This is the number of bytes. -} +length :: System.OsString.OsString -> Int +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/Path.hs b/Utility/Path.hs index de13712d32..da30b2f917 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -27,8 +27,6 @@ module Utility.Path ( searchPathContents, ) where -import System.FilePath.ByteString -import qualified System.FilePath as P import qualified Data.ByteString as B import Data.List import Data.Maybe @@ -40,6 +38,8 @@ import Author import Utility.Monad import Utility.SystemDirectory import Utility.Exception +import Utility.OsPath +import qualified Utility.OsString as OS #ifdef mingw32_HOST_OS import Data.Char @@ -53,15 +53,15 @@ copyright = author JoeyHess (1996+14) - and removing the trailing path separator. - - On Windows, preserves whichever style of path separator might be used in - - the input RawFilePaths. This is done because some programs in Windows + - the input paths. 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 - - yield the same result. Run both through normalise from System.RawFilePath + - yield the same result. Run both through normalise from System.OsPath - to ensure that. -} -simplifyPath :: RawFilePath -> RawFilePath +simplifyPath :: OsPath -> OsPath simplifyPath path = dropTrailingPathSeparator $ joinDrive drive $ joinPath $ norm [] $ splitPath path' where @@ -69,39 +69,40 @@ simplifyPath path = dropTrailingPathSeparator $ norm c [] = reverse c norm c (p:ps) - | p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = - norm (drop 1 c) ps - | p' == "." = norm c ps + | p' == dotdot && not (null c) + && dropTrailingPathSeparator (c !! 0) /= dotdot = + norm (drop 1 c) ps + | p' == dot = norm c ps | otherwise = norm (p:c) ps where p' = dropTrailingPathSeparator p {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} -parentDir :: RawFilePath -> RawFilePath +parentDir :: OsPath -> OsPath parentDir = takeDirectory . dropTrailingPathSeparator {- Just the parent directory of a path, or Nothing if the path has no - parent (ie for "/" or "." or "foo") -} -upFrom :: RawFilePath -> Maybe RawFilePath +upFrom :: OsPath -> Maybe OsPath upFrom dir | length dirs < 2 = Nothing | otherwise = Just $ joinDrive drive $ - B.intercalate (B.singleton pathSeparator) $ init dirs + OS.intercalate (OS.singleton pathSeparator) $ init dirs where -- on Unix, the drive will be "/" when the dir is absolute, -- otherwise "" (drive, path) = splitDrive dir - dirs = filter (not . B.null) $ B.splitWith isPathSeparator path + dirs = filter (not . OS.null) $ OS.splitWith isPathSeparator path -{- Checks if the first RawFilePath is, or could be said to contain the second. +{- Checks if the first path is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc - are all equivalent. -} -dirContains :: RawFilePath -> RawFilePath -> Bool +dirContains :: OsPath -> OsPath -> Bool dirContains a b = a == b || a' == b' - || (a'' `B.isPrefixOf` b' && avoiddotdotb) - || a' == "." && normalise ("." b') == b' && nodotdot b' + || (a'' `OS.isPrefixOf` b' && avoiddotdotb) + || a' == dot && normalise (dot b') == b' && nodotdot b' || dotdotcontains where a' = norm a @@ -119,11 +120,11 @@ dirContains a b = a == b - a'' is a prefix of b', so all that needs to be done is drop - that prefix, and check if the next path component is ".." -} - avoiddotdotb = nodotdot $ B.drop (B.length a'') b' + avoiddotdotb = nodotdot $ OS.drop (OS.length a'') b' nodotdot p = all (not . isdotdot) (splitPath p) - isdotdot s = dropTrailingPathSeparator s == ".." + isdotdot s = dropTrailingPathSeparator s == dotdot {- This handles the case where a is ".." or "../.." etc, - and b is "foo" or "../foo" etc. The rule is that when @@ -156,10 +157,10 @@ dirContains a b = a == b - we stop preserving ordering at that point. Presumably a user passing - that many paths in doesn't care too much about order of the later ones. -} -segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]] +segmentPaths :: (a -> OsPath) -> [OsPath] -> [a] -> [[a]] segmentPaths = segmentPaths' (\_ r -> r) -segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]] +segmentPaths' :: (Maybe OsPath -> a -> r) -> (a -> OsPath) -> [OsPath] -> [a] -> [[r]] segmentPaths' f _ [] new = [map (f Nothing) new] segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation segmentPaths' f c (i:is) new = @@ -174,37 +175,37 @@ segmentPaths' f c (i:is) new = - than it would be to run the action separately with each path. In - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]] +runSegmentPaths :: (a -> OsPath) -> ([OsPath] -> IO [a]) -> [OsPath] -> IO [[a]] runSegmentPaths c a paths = segmentPaths c paths <$> a paths -runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]] +runSegmentPaths' :: (Maybe OsPath -> a -> r) -> (a -> OsPath) -> ([OsPath] -> IO [a]) -> [OsPath] -> IO [[r]] runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} -dotfile :: RawFilePath -> Bool +dotfile :: OsPath -> Bool dotfile file - | f == "." = False - | f == ".." = False - | f == "" = False - | otherwise = "." `B.isPrefixOf` f || dotfile (takeDirectory file) + | f == dot = False + | f == dotdot = False + | f == literalOsPath "" = False + | otherwise = dot `OS.isPrefixOf` f || dotfile (takeDirectory file) where f = takeFileName file -{- Similar to splitExtensions, but knows that some things in RawFilePaths +{- Similar to splitExtensions, but knows that some things in paths - after a dot are too long to be extensions. -} -splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString]) +splitShortExtensions :: OsPath -> (OsPath, [B.ByteString]) splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" -splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString]) +splitShortExtensions' :: Int -> OsPath -> (OsPath, [B.ByteString]) splitShortExtensions' maxextension = go [] where go c f - | len > 0 && len <= maxextension && not (B.null base) = - go (ext:c) base + | len > 0 && len <= maxextension && not (OS.null base) = + go (fromOsPath ext:c) base | otherwise = (f, c) where (base, ext) = splitExtension f - len = B.length ext + len = OS.length ext {- This requires both paths to be absolute and normalized. - @@ -212,7 +213,7 @@ splitShortExtensions' maxextension = go [] - a relative path is not possible and the path is simply - returned as-is. -} -relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath +relPathDirToFileAbs :: OsPath -> OsPath -> OsPath relPathDirToFileAbs from to #ifdef mingw32_HOST_OS | normdrive from /= normdrive to = to @@ -225,7 +226,7 @@ relPathDirToFileAbs from to common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto - dotdots = replicate (length pfrom - numcommon) ".." + dotdots = replicate (length pfrom - numcommon) dotdot numcommon = length common #ifdef mingw32_HOST_OS normdrive = map toLower @@ -233,7 +234,7 @@ relPathDirToFileAbs from to -- path separator, which takeDrive leaves on the drive -- letter. . dropWhileEnd (isPathSeparator . fromIntegral . ord) - . fromRawFilePath + . fromOsPath . takeDrive #endif @@ -251,15 +252,16 @@ inSearchPath command = isJust <$> searchPath command - - Note that this will find commands in PATH that are not executable. -} -searchPath :: String -> IO (Maybe FilePath) +searchPath :: String -> IO (Maybe OsPath) searchPath command - | P.isAbsolute command = copyright $ check command - | otherwise = P.getSearchPath >>= getM indir + | isAbsolute command' = copyright $ check command' + | otherwise = getSearchPath >>= getM indir where - indir d = check $ d P. command + command' = toOsPath command + indir d = check (d command') check f = firstM doesFileExist #ifdef mingw32_HOST_OS - [f, f ++ ".exe"] + [f, f <> ".exe"] #else [f] #endif @@ -270,10 +272,17 @@ searchPath command - - Note that this will find commands in PATH that are not executable. -} -searchPathContents :: (FilePath -> Bool) -> IO [FilePath] +searchPathContents :: (OsPath -> Bool) -> IO [OsPath] searchPathContents p = filterM doesFileExist - =<< (concat <$> (P.getSearchPath >>= mapM go)) + =<< (concat <$> (getSearchPath >>= mapM go)) where - go d = map (d P.) . filter p + go d = map (d ) . filter p <$> catchDefaultIO [] (getDirectoryContents d) + +dot :: OsPath +dot = literalOsPath "." + +dotdot :: OsPath +dotdot = literalOsPath ".." + diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs index ec521c8f00..f3458b3618 100644 --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -17,15 +17,14 @@ module Utility.Path.AbsRel ( relHome, ) where -import System.FilePath.ByteString import qualified Data.ByteString as B import Control.Applicative import Prelude import Utility.Path import Utility.UserInfo -import Utility.FileSystemEncoding -import qualified Utility.RawFilePath as R +import Utility.OsPath +import Utility.SystemDirectory {- Makes a path absolute. - @@ -37,7 +36,7 @@ import qualified Utility.RawFilePath as R - Does not attempt to deal with edge cases or ensure security with - untrusted inputs. -} -absPathFrom :: RawFilePath -> RawFilePath -> RawFilePath +absPathFrom :: OsPath -> OsPath -> OsPath absPathFrom dir path = simplifyPath (combine dir path) {- Converts a filename into an absolute path. @@ -46,14 +45,14 @@ absPathFrom dir path = simplifyPath (combine dir path) - - Unlike Directory.canonicalizePath, this does not require the path - already exists. -} -absPath :: RawFilePath -> IO RawFilePath +absPath :: OsPath -> IO OsPath absPath file -- Avoid unnecessarily 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 <- R.getCurrentDirectory + cwd <- getCurrentDirectory return $ absPathFrom cwd file {- Constructs the minimal relative path from the CWD to a file. @@ -63,24 +62,23 @@ absPath file - relPathCwdToFile "/tmp/foo/bar" == "" - relPathCwdToFile "../bar/baz" == "baz" -} -relPathCwdToFile :: RawFilePath -> IO RawFilePath +relPathCwdToFile :: OsPath -> IO OsPath relPathCwdToFile f -- Optimisation: Avoid doing any IO when the path is relative -- and does not contain any ".." component. - | isRelative f && not (".." `B.isInfixOf` f) = return f + | isRelative f && not (".." `B.isInfixOf` fromOsPath f) = return f | otherwise = do - c <- R.getCurrentDirectory + c <- getCurrentDirectory relPathDirToFile c f {- Constructs a minimal relative path from a directory to a file. -} -relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath +relPathDirToFile :: OsPath -> OsPath -> IO OsPath relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to {- Converts paths in the home directory to use ~/ -} -relHome :: FilePath -> IO String +relHome :: OsPath -> IO OsPath relHome path = do - let path' = toRawFilePath path - home <- toRawFilePath <$> myHomeDir - return $ if dirContains home path' - then fromRawFilePath ("~/" <> relPathDirToFileAbs home path') + home <- toOsPath <$> myHomeDir + return $ if dirContains home path + then literalOsPath "~/" <> relPathDirToFileAbs home path else path diff --git a/Utility/Path/Tests.hs b/Utility/Path/Tests.hs index 88f94b3faa..e7df275bd3 100644 --- a/Utility/Path/Tests.hs +++ b/Utility/Path/Tests.hs @@ -17,42 +17,39 @@ module Utility.Path.Tests ( prop_dirContains_regressionTest, ) where -import System.FilePath.ByteString -import qualified Data.ByteString as B import Data.List import Data.Maybe -import Data.Char import Control.Applicative import Prelude -import Utility.Path -import Utility.FileSystemEncoding +import Common import Utility.QuickCheck +import qualified Utility.OsString as OS prop_upFrom_basics :: TestableFilePath -> Bool prop_upFrom_basics tdir | dir == "/" = p == Nothing | otherwise = p /= Just dir where - p = fromRawFilePath <$> upFrom (toRawFilePath dir) + p = fromOsPath <$> upFrom (toOsPath dir) dir = fromTestableFilePath tdir prop_relPathDirToFileAbs_basics :: TestableFilePath -> Bool prop_relPathDirToFileAbs_basics pt = and - [ relPathDirToFileAbs p (p "bar") == "bar" - , relPathDirToFileAbs (p "bar") p == ".." - , relPathDirToFileAbs p p == "" + [ relPathDirToFileAbs p (p literalOsPath "bar") == literalOsPath "bar" + , relPathDirToFileAbs (p literalOsPath "bar") p == literalOsPath ".." + , relPathDirToFileAbs p p == literalOsPath "" ] where -- relPathDirToFileAbs needs absolute paths, so make the path -- absolute by adding a path separator to the front. - p = pathSeparator `B.cons` relf + p = pathSeparator `OS.cons` relf -- Make the input a relative path. On windows, make sure it does -- not contain anything that looks like a drive letter. - relf = B.dropWhile isPathSeparator $ - B.filter (not . skipchar) $ - toRawFilePath (fromTestableFilePath pt) - skipchar b = b == (fromIntegral (ord ':')) + relf = OS.dropWhile isPathSeparator $ + OS.filter (not . skipchar) $ + toOsPath (fromTestableFilePath pt) + skipchar b = b == unsafeFromChar ':' prop_relPathDirToFileAbs_regressionTest :: Bool prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference @@ -61,21 +58,25 @@ prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference - 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"] + relPathDirToFileAbs (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", "lll", "xxx", "yyy", "18"]) + (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) + == mkp ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] + where + mkp = joinPath . map literalOsPath prop_dirContains_regressionTest :: Bool prop_dirContains_regressionTest = and - [ not $ dirContains "." ".." - , not $ dirContains ".." "../.." - , dirContains "." "foo" - , dirContains "." "." - , dirContains ".." ".." - , dirContains "../.." "../.." - , dirContains "." "./foo" - , dirContains ".." "../foo" - , dirContains "../.." "../foo" - , dirContains "../.." "../../foo" - , not $ dirContains "../.." "../../.." + [ not $ dc "." ".." + , not $ dc ".." "../.." + , dc "." "foo" + , dc "." "." + , dc ".." ".." + , dc "../.." "../.." + , dc "." "./foo" + , dc ".." "../foo" + , dc "../.." "../foo" + , dc "../.." "../../foo" + , not $ dc "../.." "../../.." ] + where + dc x y = dirContains (literalOsPath x) (literalOsPath y) diff --git a/Utility/Path/Windows.hs b/Utility/Path/Windows.hs index e61a450d7f..583f90dd61 100644 --- a/Utility/Path/Windows.hs +++ b/Utility/Path/Windows.hs @@ -13,12 +13,11 @@ module Utility.Path.Windows ( ) where import Utility.Path -import Utility.FileSystemEncoding +import Utility.OsPath +import Utility.SystemDirectory -import System.FilePath.ByteString (combine) import qualified Data.ByteString as B import qualified System.FilePath.Windows.ByteString as P -import System.Directory (getCurrentDirectory) {- Convert a filepath to use Windows's native namespace. - This avoids filesystem length limits. @@ -36,8 +35,8 @@ convertToWindowsNativeNamespace f | otherwise = do -- Make absolute because any '.' and '..' in the path -- will not be resolved once it's converted. - cwd <- toRawFilePath <$> getCurrentDirectory - let p = simplifyPath (combine cwd f) + cwd <- getCurrentDirectory + let p = fromOsPath (simplifyPath (combine cwd (toOsPath f))) -- Normalize slashes. let p' = P.normalise p return (win32_file_namespace <> p') diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index b39423df5b..f07a39f6c4 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -104,7 +104,7 @@ setFileMode p m = do P.setFileMode p' m {- Using renamePath rather than the rename provided in unix-compat - - because of this bug https://github.com/jacobstanley/unix-compat/issues/56-} + - because of this bug https://github.com/jacobstanley/unix-compat/issues/56 -} rename :: RawFilePath -> RawFilePath -> IO () rename a b = D.renamePath (fromRawFilePath a) (fromRawFilePath b) 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 diff --git a/Utility/Shell.hs b/Utility/Shell.hs index ac2231450d..5d45df434b 100644 --- a/Utility/Shell.hs +++ b/Utility/Shell.hs @@ -13,6 +13,7 @@ module Utility.Shell ( findShellCommand, ) where +import Utility.OsPath import Utility.SafeCommand #ifdef mingw32_HOST_OS import Utility.Path @@ -35,12 +36,12 @@ shebang = "#!" ++ shellPath -- parse it for shebang. -- -- This has no effect on Unix. -findShellCommand :: FilePath -> IO (FilePath, [CommandParam]) +findShellCommand :: OsPath -> IO (FilePath, [CommandParam]) findShellCommand f = do #ifndef mingw32_HOST_OS defcmd #else - l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFile f + l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFile (fromOsPath f) case l of Just ('#':'!':rest) -> case words rest of [] -> defcmd @@ -55,4 +56,4 @@ findShellCommand f = do _ -> defcmd #endif where - defcmd = return (f, []) + defcmd = return (fromOsPath f, []) diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index fb7a6b95ac..fcd725d077 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} + module Utility.SshConfig ( SshConfig(..), Comment(..), @@ -134,21 +136,21 @@ modifyUserSshConfig modifier = changeUserSshConfig $ changeUserSshConfig :: (String -> String) -> IO () changeUserSshConfig modifier = do sshdir <- sshDir - let configfile = sshdir "config" + let configfile = sshdir literalOsPath "config" whenM (doesFileExist configfile) $ do c <- decodeBS . S8.unlines . fileLines' - <$> F.readFile' (toOsPath (toRawFilePath configfile)) + <$> F.readFile' configfile let c' = modifier c when (c /= c') $ do -- If it's a symlink, replace the file it -- points to. f <- catchDefaultIO configfile (canonicalizePath configfile) - viaTmp writeSshConfig (toOsPath (toRawFilePath f)) c' + viaTmp writeSshConfig f c' writeSshConfig :: OsPath -> String -> IO () writeSshConfig f s = do F.writeFile' f (linesFile' (encodeBS s)) - setSshConfigMode (fromOsPath f) + setSshConfigMode 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 @@ -157,11 +159,11 @@ writeSshConfig f s = do - If the chmod fails, ignore the failure, as it might be a filesystem like - Android's that does not support file modes. -} -setSshConfigMode :: RawFilePath -> IO () +setSshConfigMode :: OsPath -> IO () setSshConfigMode f = void $ tryIO $ modifyFileMode f $ removeModes [groupWriteMode, otherWriteMode] -sshDir :: IO FilePath +sshDir :: IO OsPath sshDir = do home <- myHomeDir - return $ home ".ssh" + return $ toOsPath home literalOsPath ".ssh" diff --git a/Utility/StatelessOpenPGP.hs b/Utility/StatelessOpenPGP.hs index 6150bce633..290984c4cc 100644 --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -27,7 +27,6 @@ import System.Posix.Types import System.Posix.IO #else import Utility.Tmp -import Utility.OsPath #endif import Utility.Tmp.Dir import Author @@ -71,7 +70,7 @@ newtype Armoring = Armoring Bool - The directory does not really have to be empty, it just needs to be one - that should not contain any files with names starting with "@". -} -newtype EmptyDirectory = EmptyDirectory FilePath +newtype EmptyDirectory = EmptyDirectory OsPath {- Encrypt using symmetric encryption with the specified password. -} encryptSymmetric @@ -113,7 +112,7 @@ decryptSymmetric sopcmd password emptydirectory feeder reader = {- Test a value round-trips through symmetric encryption and decryption. -} test_encrypt_decrypt_Symmetric :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $ - withTmpDir (toOsPath "test") $ \d -> do + withTmpDir (literalOsPath "test") $ \d -> do let ed = EmptyDirectory d enc <- encryptSymmetric a password ed Nothing armoring (`B.hPutStr` v) B.hGetContents @@ -163,7 +162,7 @@ feedRead cmd subcmd params password emptydirectory feeder reader = do withTmpFile (toOsPath "sop") $ \tmpfile h -> do liftIO $ B.hPutStr h password liftIO $ hClose h - let passwordfile = [Param $ "--with-password="++tmpfile] + let passwordfile = [Param $ "--with-password=" ++ fromOsPath tmpfile] -- Don't need to pass emptydirectory since @FD is not used, -- and so tmpfile also does not need to be made absolute. case emptydirectory of @@ -189,7 +188,7 @@ feedRead' (SOPCmd cmd) subcmd params med feeder reader = do , std_out = CreatePipe , std_err = Inherit , cwd = case med of - Just (EmptyDirectory d) -> Just d + Just (EmptyDirectory d) -> Just (fromOsPath d) Nothing -> Nothing } copyright =<< bracket (setup p) cleanup (go p) diff --git a/Utility/Su.hs b/Utility/Su.hs index d2d970298a..d926692612 100644 --- a/Utility/Su.hs +++ b/Utility/Su.hs @@ -70,7 +70,7 @@ runSuCommand Nothing _ = return False mkSuCommand :: String -> [CommandParam] -> IO (Maybe SuCommand) #ifndef mingw32_HOST_OS mkSuCommand cmd ps = do - pwd <- getCurrentDirectory + pwd <- fromOsPath <$> getCurrentDirectory firstM (\(SuCommand _ p _) -> inSearchPath p) =<< selectcmds pwd where selectcmds pwd = ifM (inx <||> (not <$> atconsole)) diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs index a7d60f931e..4ea9b4dbbe 100644 --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -1,16 +1,107 @@ -{- System.Directory without its conflicting isSymbolicLink and getFileSize. +{- System.Directory wrapped to use OsPath. + - + - getFileSize is omitted, use Utility.FileSize instead - - Copyright 2016 Joey Hess - - License: BSD-2-clause -} --- Disable warnings because only some versions of System.Directory export --- isSymbolicLink. -{-# OPTIONS_GHC -fno-warn-tabs -w #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.SystemDirectory ( - module System.Directory + createDirectory, + createDirectoryIfMissing, + removeDirectory, + removeDirectoryRecursive, + removePathForcibly, + renameDirectory, + listDirectory, + getDirectoryContents, + getCurrentDirectory, + setCurrentDirectory, + withCurrentDirectory, + getTemporaryDirectory, + removeFile, + renameFile, + renamePath, + copyFile, + canonicalizePath, + doesPathExist, + doesFileExist, + doesDirectoryExist, + getModificationTime, ) where -import System.Directory hiding (isSymbolicLink, getFileSize) +#ifdef WITH_OSPATH +import System.Directory.OsPath +#else +import qualified System.Directory as X +import Data.Time.Clock (UTCTime) +import Utility.OsPath +import Utility.FileSystemEncoding + +createDirectory :: OsPath -> IO () +createDirectory = X.createDirectory . fromRawFilePath + +createDirectoryIfMissing :: Bool -> OsPath -> IO () +createDirectoryIfMissing b = X.createDirectoryIfMissing b . fromRawFilePath + +removeDirectory :: OsPath -> IO () +removeDirectory = X.removeDirectory . fromRawFilePath + +removeDirectoryRecursive :: OsPath -> IO () +removeDirectoryRecursive = X.removeDirectoryRecursive . fromRawFilePath + +removePathForcibly :: OsPath -> IO () +removePathForcibly = X.removePathForcibly . fromRawFilePath + +renameDirectory :: OsPath -> OsPath -> IO () +renameDirectory a b = X.renameDirectory (fromRawFilePath a) (fromRawFilePath b) + +listDirectory :: OsPath -> IO [OsPath] +listDirectory p = map toRawFilePath <$> X.listDirectory (fromRawFilePath p) + +getDirectoryContents :: OsPath -> IO [OsPath] +getDirectoryContents p = map toRawFilePath <$> X.getDirectoryContents (fromRawFilePath p) + +getCurrentDirectory :: IO OsPath +getCurrentDirectory = toRawFilePath <$> X.getCurrentDirectory + +setCurrentDirectory :: OsPath -> IO () +setCurrentDirectory = X.setCurrentDirectory . fromRawFilePath + +withCurrentDirectory :: OsPath -> IO a -> IO a +withCurrentDirectory = X.withCurrentDirectory . fromRawFilePath + +getTemporaryDirectory :: IO OsPath +getTemporaryDirectory = toRawFilePath <$> X.getTemporaryDirectory + +removeFile :: OsPath -> IO () +removeFile = X.removeFile . fromRawFilePath + +renameFile :: OsPath -> OsPath -> IO () +renameFile a b = X.renameFile (fromRawFilePath a) (fromRawFilePath b) + +renamePath :: OsPath -> OsPath -> IO () +renamePath a b = X.renamePath (fromRawFilePath a) (fromRawFilePath b) + +copyFile :: OsPath -> OsPath -> IO () +copyFile a b = X.copyFile (fromRawFilePath a) (fromRawFilePath b) + +canonicalizePath :: OsPath -> IO OsPath +canonicalizePath p = toRawFilePath <$> X.canonicalizePath (fromRawFilePath p) + +doesPathExist :: OsPath -> IO Bool +doesPathExist = X.doesPathExist . fromRawFilePath + +doesFileExist :: OsPath -> IO Bool +doesFileExist = X.doesFileExist . fromRawFilePath + +doesDirectoryExist :: OsPath -> IO Bool +doesDirectoryExist = X.doesDirectoryExist . fromRawFilePath + +getModificationTime :: OsPath -> IO UTCTime +getModificationTime = X.getModificationTime . fromRawFilePath +#endif diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 8e0ca10755..11ee051c96 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Tmp ( @@ -19,12 +20,10 @@ module Utility.Tmp ( ) where import System.IO -import System.Directory import Control.Monad.IO.Class import System.IO.Error import Data.Char import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P import Utility.Exception import Utility.FileSystemEncoding @@ -32,6 +31,7 @@ import Utility.FileMode import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F import Utility.OsPath +import Utility.SystemDirectory type Template = OsString @@ -58,14 +58,14 @@ openTmpFileIn dir template = F.openTempFile dir template viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m () viaTmp a file content = bracketIO setup cleanup use where - (dir, base) = P.splitFileName (fromOsPath file) - template = relatedTemplate (base <> ".tmp") + (dir, base) = splitFileName file + template = relatedTemplate (fromOsPath base <> ".tmp") setup = do - createDirectoryIfMissing True (fromRawFilePath dir) - openTmpFileIn (toOsPath dir) template + createDirectoryIfMissing True dir + openTmpFileIn dir template cleanup (tmpfile, h) = do _ <- tryIO $ hClose h - tryIO $ R.removeLink (fromOsPath tmpfile) + tryIO $ removeFile tmpfile use (tmpfile, h) = do let tmpfile' = fromOsPath tmpfile -- Make mode the same as if the file were created usually, @@ -83,8 +83,8 @@ viaTmp a file content = bracketIO setup cleanup use - (or in "." if there is none) then removes the file. -} withTmpFile :: (MonadIO m, MonadMask m) => Template -> (OsPath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory - withTmpFileIn (toOsPath (toRawFilePath tmpdir)) template a + tmpdir <- liftIO $ catchDefaultIO (literalOsPath ".") getTemporaryDirectory + withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - then removes the file. @@ -98,7 +98,7 @@ withTmpFileIn tmpdir template a = bracket create remove use create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h - tryIO $ R.removeLink (fromOsPath name) + tryIO $ removeFile name use (name, h) = a name h {- It's not safe to use a FilePath of an existing file as the template @@ -111,6 +111,7 @@ relatedTemplate :: RawFilePath -> Template relatedTemplate = toOsPath . relatedTemplate' relatedTemplate' :: RawFilePath -> RawFilePath +#ifndef mingw32_HOST_OS relatedTemplate' f | len > templateAddedLength = {- Some filesystems like FAT have issues with filenames @@ -122,6 +123,11 @@ relatedTemplate' f where len = B.length f dot = fromIntegral (ord '.') +#else +-- Avoids a test suite failure on windows, reason unknown, but +-- best to keep paths short on windows anyway. +relatedTemplate' _ = "t" +#endif {- When a Template is used to create a temporary file, some random bytes - are appended to it. This is how many such bytes can be added, maximum. diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs index c359b9d82d..d6448ef749 100644 --- a/Utility/Tmp/Dir.hs +++ b/Utility/Tmp/Dir.hs @@ -1,12 +1,13 @@ {- Temporary directories - - - Copyright 2010-2022 Joey Hess + - Copyright 2010-2025 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} +{-# LANGUAGE OverloadedStrings #-} module Utility.Tmp.Dir ( withTmpDir, @@ -14,8 +15,6 @@ module Utility.Tmp.Dir ( ) where import Control.Monad.IfElse -import System.FilePath -import System.Directory import Control.Monad.IO.Class #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp) @@ -24,18 +23,20 @@ import System.Posix.Temp (mkdtemp) import Utility.Exception import Utility.Tmp (Template) import Utility.OsPath -import Utility.FileSystemEncoding +import Utility.SystemDirectory {- Runs an action with a tmp directory located within the system's tmp - directory (or within "." if there is none), then removes the tmp - directory and all its contents. -} -withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a +withTmpDir :: (MonadMask m, MonadIO m) => Template -> (OsPath -> m a) -> m a withTmpDir template a = do - topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory + topleveltmpdir <- liftIO $ + catchDefaultIO (literalOsPath ".") getTemporaryDirectory + let p = fromOsPath $ topleveltmpdir template #ifndef mingw32_HOST_OS -- Use mkdtemp to create a temp directory securely in /tmp. bracket - (liftIO $ mkdtemp $ topleveltmpdir fromRawFilePath (fromOsPath template)) + (liftIO $ toOsPath <$> mkdtemp p) removeTmpDir a #else @@ -44,21 +45,21 @@ withTmpDir template a = do {- Runs an action with a tmp directory located within a specified directory, - then removes the tmp directory and all its contents. -} -withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a +withTmpDirIn :: (MonadMask m, MonadIO m) => OsPath -> Template -> (OsPath -> m a) -> m a withTmpDirIn tmpdir template = bracketIO create removeTmpDir where create = do createDirectoryIfMissing True tmpdir - makenewdir (tmpdir fromRawFilePath (fromOsPath template)) (0 :: Int) + makenewdir (tmpdir template) (0 :: Int) makenewdir t n = do - let dir = t ++ "." ++ show n + let dir = t <> toOsPath ("." ++ show n) catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do createDirectory dir return dir {- Deletes the entire contents of the the temporary directory, if it - exists. -} -removeTmpDir :: MonadIO m => FilePath -> m () +removeTmpDir :: MonadIO m => OsPath -> m () removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do #if mingw32_HOST_OS -- Windows will often refuse to delete a file diff --git a/Utility/Tor.hs b/Utility/Tor.hs index b6e9484890..cd564d14ae 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Utility.Tor ( OnionPort, OnionAddress(..), @@ -21,6 +23,7 @@ import Common import Utility.ThreadScheduler import Utility.FileMode import Utility.RawFilePath (setOwnerAndGroup) +import qualified Utility.OsString as OS import System.PosixCompat.Types import System.PosixCompat.Files (ownerReadMode, ownerWriteMode, ownerExecuteMode) @@ -35,7 +38,7 @@ type OnionPort = Int newtype OnionAddress = OnionAddress String deriving (Show, Eq) -type OnionSocket = FilePath +type OnionSocket = OsPath -- | A unique identifier for a hidden service. type UniqueIdent = String @@ -68,21 +71,21 @@ connectHiddenService (OnionAddress address) port = do addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort) addHiddenService appname uid ident = do prepHiddenServiceSocketDir appname uid ident - ls <- lines <$> (readFile =<< findTorrc) + ls <- lines <$> (readFile . fromOsPath =<< findTorrc) let portssocks = mapMaybe (parseportsock . separate isSpace) ls - case filter (\(_, s) -> s == sockfile) portssocks of + case filter (\(_, s) -> s == fromOsPath sockfile) portssocks of ((p, _s):_) -> waithiddenservice 1 p _ -> do highports <- R.getStdRandom mkhighports let newport = fromMaybe (error "internal") $ headMaybe $ filter (`notElem` map fst portssocks) highports torrc <- findTorrc - writeFile torrc $ unlines $ + writeFile (fromOsPath torrc) $ unlines $ ls ++ [ "" - , "HiddenServiceDir " ++ hiddenServiceDir appname uid ident + , "HiddenServiceDir " ++ fromOsPath (hiddenServiceDir appname uid ident) , "HiddenServicePort " ++ show newport ++ - " unix:" ++ sockfile + " unix:" ++ fromOsPath sockfile ] -- Reload tor, so it will see the new hidden -- service and generate the hostname file for it. @@ -109,7 +112,8 @@ addHiddenService appname uid ident = do waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort) waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running" waithiddenservice n p = do - v <- tryIO $ readFile $ hiddenServiceHostnameFile appname uid ident + v <- tryIO $ readFile $ fromOsPath $ + hiddenServiceHostnameFile appname uid ident case v of Right s | ".onion\n" `isSuffixOf` s -> return (OnionAddress (takeWhile (/= '\n') s), p) @@ -122,11 +126,13 @@ addHiddenService appname uid ident = do -- Has to be inside the torLibDir so tor can create it. -- -- Has to end with "uid_ident" so getHiddenServiceSocketFile can find it. -hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> FilePath -hiddenServiceDir appname uid ident = torLibDir appname ++ "_" ++ show uid ++ "_" ++ ident +hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> OsPath +hiddenServiceDir appname uid ident = + torLibDir toOsPath (appname ++ "_" ++ show uid ++ "_" ++ ident) -hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> FilePath -hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident "hostname" +hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> OsPath +hiddenServiceHostnameFile appname uid ident = + hiddenServiceDir appname uid ident literalOsPath "hostname" -- | Location of the socket for a hidden service. -- @@ -136,33 +142,36 @@ hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident -- Note that some unix systems limit socket paths to 92 bytes long. -- That should not be a problem if the UniqueIdent is around the length of -- a UUID, and the AppName is short. -hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> FilePath -hiddenServiceSocketFile appname uid ident = varLibDir appname show uid ++ "_" ++ ident "s" +hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> OsPath +hiddenServiceSocketFile appname uid ident = + varLibDir toOsPath appname + toOsPath (show uid ++ "_" ++ ident) literalOsPath "s" -- | Parse torrc, to get the socket file used for a hidden service with -- the specified UniqueIdent. -getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe FilePath) +getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe OsPath) getHiddenServiceSocketFile _appname uid ident = - parse . map words . lines <$> catchDefaultIO "" (readFile =<< findTorrc) + parse . map words . lines <$> catchDefaultIO "" + (readFile . fromOsPath =<< findTorrc) where parse [] = Nothing parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest) - | "unix:" `isPrefixOf` hsaddr && hasident hsdir = - Just (drop (length "unix:") hsaddr) + | "unix:" `isPrefixOf` hsaddr && hasident (toOsPath hsdir) = + Just $ toOsPath $ drop (length ("unix:" :: String)) hsaddr | otherwise = parse rest parse (_:rest) = parse rest -- Don't look for AppName in the hsdir, because it didn't used to -- be included. - hasident hsdir = (show uid ++ "_" ++ ident) `isSuffixOf` takeFileName hsdir + hasident hsdir = toOsPath (show uid ++ "_" ++ ident) `OS.isSuffixOf` takeFileName hsdir -- | Sets up the directory for the socketFile, with appropriate -- permissions. Must run as root. prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO () prepHiddenServiceSocketDir appname uid ident = do createDirectoryIfMissing True d - setOwnerAndGroup (toRawFilePath d) uid (-1) - modifyFileMode (toRawFilePath d) $ + setOwnerAndGroup (fromOsPath d) uid (-1) + modifyFileMode d $ addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] where d = takeDirectory $ hiddenServiceSocketFile appname uid ident @@ -170,21 +179,23 @@ prepHiddenServiceSocketDir appname uid ident = do -- | Finds the system's torrc file, in any of the typical locations of it. -- Returns the first found. If there is no system torrc file, defaults to -- /etc/tor/torrc. -findTorrc :: IO FilePath -findTorrc = fromMaybe "/etc/tor/torrc" <$> firstM doesFileExist - -- Debian - [ "/etc/tor/torrc" +findTorrc :: IO OsPath +findTorrc = fromMaybe deftorrc <$> firstM doesFileExist + [ deftorrc -- Some systems put it here instead. - , "/etc/torrc" + , literalOsPath "/etc/torrc" -- Default when installed from source - , "/usr/local/etc/tor/torrc" + , literalOsPath "/usr/local/etc/tor/torrc" ] + where + -- Debian uses this + deftorrc = literalOsPath "/etc/tor/torrc" -torLibDir :: FilePath -torLibDir = "/var/lib/tor" +torLibDir :: OsPath +torLibDir = literalOsPath "/var/lib/tor" -varLibDir :: FilePath -varLibDir = "/var/lib" +varLibDir :: OsPath +varLibDir = literalOsPath "/var/lib" torIsInstalled :: IO Bool torIsInstalled = inSearchPath "tor" diff --git a/Utility/Url.hs b/Utility/Url.hs index dbe4647527..d98ade2738 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -50,6 +50,7 @@ import Utility.IPAddress import qualified Utility.RawFilePath as R import Utility.Hash (IncrementalVerifier(..)) import Utility.Url.Parse +import qualified Utility.FileIO as F import Network.URI import Network.HTTP.Types @@ -311,8 +312,8 @@ getUrlInfo url uo = case parseURIRelaxed url of =<< curlRestrictedParams r u defport (basecurlparams url') existsfile u = do - let f = toRawFilePath (unEscapeString (uriPath u)) - s <- catchMaybeIO $ R.getSymbolicLinkStatus f + let f = toOsPath (unEscapeString (uriPath u)) + s <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath f) case s of Just stat -> do sz <- getFileSize' f stat @@ -362,10 +363,10 @@ headRequest r = r - - When the download fails, returns an error message. -} -download :: MeterUpdate -> Maybe IncrementalVerifier -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) +download :: MeterUpdate -> Maybe IncrementalVerifier -> URLString -> OsPath -> UrlOptions -> IO (Either String ()) download = download' False -download' :: Bool -> MeterUpdate -> Maybe IncrementalVerifier -> URLString -> FilePath -> UrlOptions -> IO (Either String ()) +download' :: Bool -> MeterUpdate -> Maybe IncrementalVerifier -> URLString -> OsPath -> UrlOptions -> IO (Either String ()) download' nocurlerror meterupdate iv url file uo = catchJust matchHttpException go showhttpexception `catchNonAsync` (dlfailed . show) @@ -421,8 +422,8 @@ download' nocurlerror meterupdate iv url file uo = -- curl does not create destination file -- if the url happens to be empty, so pre-create. unlessM (doesFileExist file) $ - writeFile file "" - ifM (boolSystem "curl" (curlparams ++ [Param "-o", File file, File rawurl])) + F.writeFile file mempty + ifM (boolSystem "curl" (curlparams ++ [Param "-o", File (fromOsPath file), File rawurl])) ( return $ Right () , return $ Left "download failed" ) @@ -432,9 +433,9 @@ download' nocurlerror meterupdate iv url file uo = downloadfile u = do noverification - let src = unEscapeString (uriPath u) + let src = toOsPath $ unEscapeString (uriPath u) withMeteredFile src meterupdate $ - L.writeFile file + F.writeFile file return $ Right () -- Conduit does not support ftp, so will throw an exception on a @@ -461,9 +462,9 @@ download' nocurlerror meterupdate iv url file uo = - thrown for reasons other than http status codes will still be thrown - as usual.) -} -downloadConduit :: MeterUpdate -> Maybe IncrementalVerifier -> Request -> FilePath -> UrlOptions -> IO () +downloadConduit :: MeterUpdate -> Maybe IncrementalVerifier -> Request -> OsPath -> UrlOptions -> IO () downloadConduit meterupdate iv req file uo = - catchMaybeIO (getFileSize (toRawFilePath file)) >>= \case + catchMaybeIO (getFileSize file) >>= \case Just sz | sz > 0 -> resumedownload sz _ -> join $ runResourceT $ do liftIO $ debug "Utility.Url" (show req') @@ -566,7 +567,7 @@ sinkResponseFile => MeterUpdate -> Maybe IncrementalVerifier -> BytesProcessed - -> FilePath + -> OsPath -> IOMode -> Response (ConduitM () B8.ByteString m ()) -> m () @@ -577,7 +578,7 @@ sinkResponseFile meterupdate iv initialp file mode resp = do return (const noop) (Just iv', _) -> return (updateIncrementalVerifier iv') (Nothing, _) -> return (const noop) - (fr, fh) <- allocate (openBinaryFile file mode) hClose + (fr, fh) <- allocate (F.openBinaryFile file mode) hClose runConduit $ responseBody resp .| go ui initialp fh release fr where diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 937b3bad5a..ebff84edaa 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -185,11 +185,9 @@ insertAuthToken extractAuthToken predicate webapp root pathbits params = {- 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 :: String -> String -> OsPath -> IO () writeHtmlShim title url file = - viaTmp (writeFileProtected . fromOsPath) - (toOsPath $ toRawFilePath file) - (genHtmlShim title url) + viaTmp (writeFileProtected) file (genHtmlShim title url) genHtmlShim :: String -> String -> String genHtmlShim title url = unlines diff --git a/git-annex.cabal b/git-annex.cabal index b662fe482e..e189e49459 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1106,6 +1106,7 @@ Executable git-annex Utility.OptParse Utility.OSX Utility.OsPath + Utility.OsString Utility.PID Utility.PartialPrelude Utility.Path