diff --git a/.gitignore b/.gitignore index e21cbf9c80..125468c04f 100644 --- a/.gitignore +++ b/.gitignore @@ -15,8 +15,6 @@ git-annex git-annex-shell git-remote-annex man -git-union-merge -git-union-merge.1 doc/.ikiwiki html *.tix 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..c4a0f8490c 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 $ doesPathExist tmpfile (ok, verification) <- action tmpfile -- When the temp file already had content, we don't know if -- that content is good or not, so only trust if it the action @@ -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 $ doesPathExist 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 = doesPathExist . 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..22657a11c8 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -30,12 +30,13 @@ 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 + destmode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus (fromOsPath f) + liftIO $ removeWhenExistsWith removeFile f (ic, populated) <- replaceWorkTreeFile f $ \tmp -> do ok <- linkOrCopy k obj tmp destmode >>= \case Just _ -> thawContent tmp >> return True @@ -47,23 +48,23 @@ 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 + st <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath file) let mode = fmap fileMode st secureErase file - liftIO $ removeWhenExistsWith R.removeLink file + liftIO $ removeWhenExistsWith removeFile 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..376e8d1a1d 100644 --- a/Annex/Content/Presence.hs +++ b/Annex/Content/Presence.hs @@ -33,7 +33,6 @@ import Types.RepoVersion import qualified Database.Keys import Annex.InodeSentinal import Utility.InodeCache -import qualified Utility.RawFilePath as R import qualified Git import Config @@ -41,18 +40,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 . doesPathExist {- 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 +72,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 +90,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 +99,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,13 +110,13 @@ 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 Just lockhandle -> do dropLock lockhandle - void $ tryIO $ removeWhenExistsWith R.removeLink lockfile + void $ tryIO $ removeWhenExistsWith removeFile lockfile return is_unlocked , return is_missing ) @@ -134,7 +131,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 +143,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 +158,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 +174,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 +182,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 +190,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 +203,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..133ed4f8d7 100644 --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -15,6 +15,7 @@ import Utility.CopyFile import Utility.FileMode import Utility.Touch import Utility.Hash (IncrementalVerifier(..)) +import qualified Utility.FileIO as F import qualified Utility.RawFilePath as R import Control.Concurrent @@ -34,7 +35,7 @@ newCopyCoWTried = CopyCoWTried <$> newEmptyMVar - The destination file must not exist yet (or may exist but be empty), - or it will fail to make a CoW copy, and will return false. -} -tryCopyCoW :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> IO Bool +tryCopyCoW :: CopyCoWTried -> OsPath -> OsPath -> MeterUpdate -> IO Bool tryCopyCoW (CopyCoWTried copycowtried) src dest meterupdate = -- If multiple threads reach this at the same time, they -- will both try CoW, which is acceptable. @@ -57,19 +58,17 @@ tryCopyCoW (CopyCoWTried copycowtried) src dest meterupdate = ) ) where - docopycow = watchFileSize dest' meterupdate $ const $ + docopycow = watchFileSize dest meterupdate $ const $ copyCoW CopyTimeStamps src dest - - dest' = toRawFilePath 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 (fromOsPath dest)) >>= \case Left _ -> return False Right st -> do - sz <- getFileSize' dest' st + sz <- getFileSize' dest st if sz == 0 then tryIO (removeFile dest) >>= \case Right () -> return False @@ -95,7 +94,7 @@ data CopyMethod = CopiedCoW | Copied - (eg when isStableKey is false), and doing this avoids getting a - corrupted file in such cases. -} -fileCopier :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> IO CopyMethod +fileCopier :: CopyCoWTried -> OsPath -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> IO CopyMethod #ifdef mingw32_HOST_OS fileCopier _ src dest meterupdate iv = docopy #else @@ -111,27 +110,26 @@ 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 dest - withBinaryFile src ReadMode $ \hsrc -> + F.withBinaryFile src ReadMode $ \hsrc -> fileContentCopier hsrc dest meterupdate iv -- Copy src mode and mtime. - mode <- fileMode <$> R.getFileStatus (toRawFilePath src) + mode <- fileMode <$> R.getFileStatus (fromOsPath src) mtime <- utcTimeToPOSIXSeconds <$> getModificationTime src + let dest' = fromOsPath dest R.setFileMode dest' mode touch dest' mtime False return Copied - - dest' = toRawFilePath dest {- Copies content from a handle to a destination file. Does not - use copy-on-write, and does not copy file mode and mtime. -} -fileContentCopier :: Handle -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> IO () +fileContentCopier :: Handle -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> IO () fileContentCopier hsrc dest meterupdate iv = - withBinaryFile dest ReadWriteMode $ \hdest -> do + F.withBinaryFile dest ReadWriteMode $ \hdest -> do sofar <- compareexisting hdest zeroBytesProcessed docopy hdest sofar where 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..a0e5730333 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,29 @@ 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 + removeWhenExistsWith removeFile dotgit + R.createSymbolicLink (fromOsPath linktarget) (fromOsPath 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 +143,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 +151,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..b351504ace 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Annex.Import ( ImportTreeConfig(..), @@ -68,9 +69,10 @@ import Backend.Utilities 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 +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Posix as Posix +#endif {- Configures how to build an import tree. -} data ImportTreeConfig @@ -154,7 +156,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 +351,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 +431,12 @@ 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 -> +#ifdef mingw32_HOST_OS + toOsPath $ fromOsPath (getTopFilePath d) Posix. fromOsPath subdir +#else + getTopFilePath d subdir +#endif Tree ts <- converttree (Just fullprefix) $ map (\(p, i) -> (mkImportLocation p, i)) (importableContentsSubTree c) @@ -853,7 +860,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 +878,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 +901,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 +957,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 +1098,11 @@ getImportableContents r importtreeconfig ci matcher = do isknown <||> (matches <&&> notignored) where -- Checks, from least to most expensive. - ingitdir = ".git" `elem` Posix.splitDirectories (fromImportLocation loc) +#ifdef mingw32_HOST_OS + ingitdir = ".git" `elem` Posix.splitDirectories (fromOsPath (fromImportLocation loc)) +#else + ingitdir = literalOsPath ".git" `elem` splitDirectories (fromImportLocation loc) +#endif matches = matchesImportLocation matcher loc sz isknown = isKnownImportLocation dbhandle loc notignored = notIgnoredImportLocation importtreeconfig ci loc @@ -1120,6 +1131,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..695a0cb063 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 removeFile 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..5ed296007b 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,29 @@ 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 $ removeFile file + R.createSymbolicLink linktarget (fromOsPath file) + , liftIO $ F.writeFile' file linktarget ) {- 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 +145,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 +154,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 +190,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 +228,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 +251,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 +329,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 +365,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 +405,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 +439,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 +468,14 @@ isPointerFile f = catchDefaultIO Nothing $ - than .git to be used. -} isLinkToAnnex :: S.ByteString -> Bool -isLinkToAnnex s = p `S.isInfixOf` s +isLinkToAnnex s = p `OS.isInfixOf` 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 + s' = toOsPath s + 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 fe11be06b3..d34c5ef600 100644 --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -36,12 +36,13 @@ import qualified Utility.FileIO as F import Utility.OpenFile #endif +#ifndef mingw32_HOST_OS import Control.Concurrent +#endif import Control.Concurrent.STM import Control.Concurrent.Async import qualified Data.ByteString as B 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 @@ -177,8 +178,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) @@ -188,14 +189,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 @@ -262,8 +263,8 @@ 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 @@ -298,7 +299,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 @@ -350,7 +351,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..07519d0390 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -39,15 +39,14 @@ import Annex.Concurrent.Utility 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 +100,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 +136,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 +166,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 +190,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 +215,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 +287,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 (doesPathExist . socket2lock) =<< filter (not . isLock) <$> catchDefaultIO [] (dirContents dir) @@ -326,45 +325,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 +375,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 +463,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..d6b18332cb 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,19 +58,18 @@ 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 =<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp) -- remove when empty - liftIO $ void $ tryIO $ - removeDirectory (fromRawFilePath oldtmp) + liftIO $ void $ tryIO $ removeDirectory oldtmp where cleanold f = do now <- liftIO getPOSIXTime let oldenough = now - (60 * 60 * 24 * 7) - catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus f) >>= \case + catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus (fromOsPath f)) >>= \case Just mtime | realToFrac mtime <= oldenough -> - void $ tryIO $ removeWhenExistsWith R.removeLink f + void $ tryIO $ removeWhenExistsWith removeFile f _ -> return () diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 1c1abf4fd5..45969003ae 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 @@ -218,8 +216,8 @@ 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 + void $ tryIO $ removeFile lckfile + 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..3ad8926960 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,9 +103,9 @@ 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 + cmd <- fromOsPath <$> programPath ps <- getArgs let p = (proc cmd ps) { env = Just (addEntry flag "1" e) @@ -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 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 1440af10d0..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))) (toOsPath (toRawFilePath "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..c22c24db85 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 @@ -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..f96e540161 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -14,11 +14,11 @@ import qualified Annex import Utility.Hash import Types.Key import Types.KeySource +import qualified Utility.OsString as OS import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (ShortByteString, toShort) import qualified Data.ByteString.Lazy as L -import qualified System.FilePath.ByteString as P import Data.Char import Data.Word @@ -55,7 +55,7 @@ addE source sethasext k = do , keyVariety = sethasext (keyVariety d) } -selectExtension :: Maybe Int -> Maybe Int -> RawFilePath -> S.ByteString +selectExtension :: Maybe Int -> Maybe Int -> OsPath -> S.ByteString selectExtension maxlen maxextensions f | null es = "" | otherwise = S.intercalate "." ("":es) @@ -64,11 +64,12 @@ selectExtension maxlen maxextensions f take (fromMaybe maxExtensions maxextensions) $ filter (S.all validInExtension) $ takeWhile shortenough $ - reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f') + reverse $ S.split (fromIntegral (ord '.')) $ + fromOsPath $ takeExtensions f' shortenough e = S.length e <= fromMaybe maxExtensionLen maxlen -- Avoid treating a file ".foo" as having its whole name as an -- extension. - f' = S.dropWhile (== fromIntegral (ord '.')) (P.takeFileName f) + f' = OS.dropWhile (== unsafeFromChar '.') (takeFileName f) validInExtension :: Word8 -> Bool validInExtension c 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/DistributionUpdate.hs b/Build/DistributionUpdate.hs index 80a0b2cdf3..c7566a5a9e 100644 --- a/Build/DistributionUpdate.hs +++ b/Build/DistributionUpdate.hs @@ -11,6 +11,8 @@ - Also gpg signs the files. -} +{-# LANGUAGE OverloadedStrings #-} + import Annex.Common import Types.Distribution import Build.Version (getChangelogVersion, Version) @@ -22,9 +24,10 @@ import qualified Git.Construct import qualified Annex import Annex.Content import Annex.WorkTree +import Annex.Action import Git.Command import qualified Utility.RawFilePath as R -import Annex.Action +import qualified Utility.OsString as OS import Data.Time.Clock import Data.Char @@ -37,16 +40,16 @@ signingKey = "89C809CB" -- URL to an autobuilt git-annex file, and the place to install -- it in the repository. -autobuilds :: [(URLString, FilePath)] +autobuilds :: [(URLString, OsPath)] autobuilds = (map linuxarch ["i386", "amd64", "armel", "arm64", "arm64-ancient"]) ++ - [ (autobuild "x86_64-apple-catalina/git-annex.dmg", "git-annex/OSX/current/10.15_Catalina/git-annex.dmg") - , (autobuild "windows/git-annex-installer.exe", "git-annex/windows/current/git-annex-installer.exe") + [ (autobuild "x86_64-apple-catalina/git-annex.dmg", literalOsPath "git-annex/OSX/current/10.15_Catalina/git-annex.dmg") + , (autobuild "windows/git-annex-installer.exe", literalOsPath "git-annex/windows/current/git-annex-installer.exe") ] where linuxarch a = ( autobuild (a ++ "/git-annex-standalone-" ++ a ++ ".tar.gz") - , "git-annex/linux/current/git-annex-standalone-" ++ a ++ ".tar.gz" + , literalOsPath "git-annex/linux/current/git-annex-standalone-" <> toOsPath a <> literalOsPath ".tar.gz" ) autobuild f = "https://downloads.kitenet.net/git-annex/autobuild/" ++ f @@ -65,9 +68,9 @@ main = do version <- getChangelogVersion repodir <- getRepoDir topdir <- getCurrentDirectory - changeWorkingDirectory repodir + changeWorkingDirectory (fromOsPath repodir) updated <- catMaybes <$> mapM (getbuild repodir) autobuilds - state <- Annex.new =<< Git.Construct.fromPath (toRawFilePath ".") + state <- Annex.new =<< Git.Construct.fromPath (literalOsPath ".") ood <- Annex.eval state $ do buildrpms topdir updated is <- makeinfos updated version @@ -82,13 +85,13 @@ main = do -- It's very important that the version matches the build, otherwise -- auto-upgrades can loop reatedly. So, check build-version before -- and after downloading the file. -getbuild :: FilePath -> (URLString, FilePath) -> IO (Maybe (FilePath, Version)) +getbuild :: OsPath -> (URLString, OsPath) -> IO (Maybe (OsPath, Version)) getbuild repodir (url, f) = do bv1 <- getbv let dest = repodir f - let tmp = dest ++ ".tmp" + let tmp = dest <> literalOsPath ".tmp" removeWhenExistsWith removeFile tmp - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath dest))) + createDirectoryIfMissing True (parentDir dest) let oops s = do removeWhenExistsWith removeFile tmp putStrLn $ "*** " ++ s @@ -113,15 +116,15 @@ getbuild repodir (url, f) = do , oops $ "failed to download " ++ url ) where - bvurl = takeDirectory url ++ "/build-version" + bvurl = fromOsPath (takeDirectory (toOsPath url)) ++ "/build-version" getbv = do bv <- catchDefaultIO "" $ readProcess "curl" ["--silent", bvurl] return $ if null bv || any (not . versionchar) bv then Nothing else Just bv versionchar c = isAlphaNum c || c == '.' || c == '-' -makeinfos :: [(FilePath, Version)] -> Version -> Annex [([Char], Maybe GitAnnexDistribution)] +makeinfos :: [(OsPath, Version)] -> Version -> Annex [(OsPath, Maybe GitAnnexDistribution)] makeinfos updated changelogversion = do - mapM_ (\f -> inRepo $ runBool [Param "annex", Param "add", File f]) (map fst updated) + mapM_ (\f -> inRepo $ runBool [Param "annex", Param "add", File (fromOsPath f)]) (map fst updated) void $ inRepo $ runBool [ Param "commit" , Param "-a" @@ -132,12 +135,12 @@ makeinfos updated changelogversion = do now <- liftIO getCurrentTime liftIO $ putStrLn $ "building info files" forM_ updated $ \(f, bv) -> do - v <- lookupKey (toRawFilePath f) + v <- lookupKey f case v of Nothing -> noop Just k -> whenM (inAnnex k) $ do - liftIO $ putStrLn f - let infofile = f ++ ".info" + liftIO $ putStrLn (fromOsPath f) + let infofile = f <> literalOsPath ".info" let d = GitAnnexDistribution { distributionUrl = mkUrl f , distributionKey = fromKey id k @@ -145,8 +148,8 @@ makeinfos updated changelogversion = do , distributionReleasedate = now , distributionUrgentUpgrade = Just "6.20180626" } - liftIO $ writeFile infofile $ formatInfoFile d - void $ inRepo $ runBool [Param "add", File infofile] + liftIO $ writeFile (fromOsPath infofile) $ formatInfoFile d + void $ inRepo $ runBool [Param "add", File (fromOsPath infofile)] signFile infofile signFile f void $ inRepo $ runBool @@ -168,9 +171,9 @@ makeinfos updated changelogversion = do ] -- Check for out of date info files. - infos <- liftIO $ filter (".info" `isSuffixOf`) - <$> emptyWhenDoesNotExist (dirContentsRecursive "git-annex") - ds <- liftIO $ forM infos (readish <$$> readFile) + infos <- liftIO $ filter (literalOsPath ".info" `OS.isSuffixOf`) + <$> emptyWhenDoesNotExist (dirContentsRecursive $ literalOsPath "git-annex") + ds <- liftIO $ forM infos (readish <$$> readFile . fromOsPath) let dis = zip infos ds let ood = filter outofdate dis return ood @@ -180,36 +183,39 @@ makeinfos updated changelogversion = do Just d -> distributionVersion d /= changelogversion descversion = unwords (nub (map snd updated)) -getRepoDir :: IO FilePath +getRepoDir :: IO OsPath getRepoDir = do home <- liftIO myHomeDir - return $ home "lib" "downloads" + return $ toOsPath home literalOsPath "lib" literalOsPath "downloads" -mkUrl :: FilePath -> String -mkUrl f = "https://downloads.kitenet.net/" ++ f +mkUrl :: OsPath -> String +mkUrl f = "https://downloads.kitenet.net/" ++ fromOsPath f -signFile :: FilePath -> Annex () +signFile :: OsPath -> Annex () signFile f = do void $ liftIO $ boolSystem "gpg" [ Param "-a" , Param $ "--default-key=" ++ signingKey , Param "--detach-sign" - , File f + , File (fromOsPath f) ] - liftIO $ R.rename (toRawFilePath (f ++ ".asc")) (toRawFilePath (f ++ ".sig")) - void $ inRepo $ runBool [Param "add", File (f ++ ".sig")] + liftIO $ R.rename + (fromOsPath (f <> literalOsPath ".asc")) + (fromOsPath (f <> literalOsPath ".sig")) + void $ inRepo $ runBool [Param "add", File (fromOsPath f ++ ".sig")] -- clamscan should handle unpacking archives, but did not in my -- testing, so do it manually. -virusFree :: FilePath -> IO Bool +virusFree :: OsPath -> IO Bool virusFree f - | ".tar.gz" `isSuffixOf` f = unpack $ \tmpdir -> - boolSystem "tar" [ Param "xf", File f, Param "-C", File tmpdir ] - | ".dmg" `isSuffixOf` f = unpack $ \tmpdir -> do + | literalOsPath ".tar.gz" `OS.isSuffixOf` f = unpack $ \tmpdir -> + boolSystem "tar" [ Param "xf", File (fromOsPath f), Param "-C", File (fromOsPath tmpdir) ] + | literalOsPath ".dmg" `OS.isSuffixOf` f = unpack $ \tmpdir -> do -- 7z can extract partitions from a dmg, and then -- run on partitions can extract their files unhfs tmpdir f - parts <- filter (".hfs" `isSuffixOf`) <$> getDirectoryContents tmpdir + parts <- filter (literalOsPath ".hfs" `OS.isSuffixOf`) + <$> getDirectoryContents tmpdir forM_ parts $ unhfs tmpdir return True | otherwise = clamscan f @@ -217,37 +223,39 @@ virusFree f clamscan f' = boolSystem "clamscan" [ Param "--no-summary" , Param "-r" - , Param f' + , Param (fromOsPath f') ] unpack unpacker = withTmpDir "clamscan" $ \tmpdir -> do unlessM (unpacker tmpdir) $ - error $ "Failed to unpack " ++ f ++ " for virus scan" + error $ "Failed to unpack " ++ fromOsPath f ++ " for virus scan" clamscan tmpdir - unhfs dest f' = unlessM (boolSystem "7z" [ Param "x", Param ("-o" ++ dest), File f' ]) $ - error $ "Failed extracting hfs " ++ f' + unhfs dest f' = unlessM (boolSystem "7z" [ Param "x", Param ("-o" ++ fromOsPath dest), File (fromOsPath f') ]) $ + error $ "Failed extracting hfs " ++ fromOsPath f' -buildrpms :: FilePath -> [(FilePath, Version)] -> Annex () +buildrpms :: OsPath -> [(OsPath, Version)] -> Annex () buildrpms topdir l = do liftIO $ createDirectoryIfMissing True rpmrepo - oldrpms <- map (rpmrepo ) . filter (".rpm" `isSuffixOf`) + oldrpms <- map (rpmrepo ) . filter (literalOsPath ".rpm" `OS.isSuffixOf`) <$> liftIO (getDirectoryContents rpmrepo) forM_ tarrpmarches $ \(tararch, rpmarch) -> forM_ (filter (isstandalonetarball tararch . fst) l) $ \(tarball, v) -> do - liftIO $ mapM_ (removeWhenExistsWith (R.removeLink . toRawFilePath)) - (filter ((rpmarch ++ ".rpm") `isSuffixOf`) oldrpms) - void $ liftIO $ boolSystem script + liftIO $ mapM_ (removeWhenExistsWith removeFile) + (filter ((toOsPath rpmarch <> literalOsPath ".rpm") `OS.isSuffixOf`) oldrpms) + void $ liftIO $ boolSystem (fromOsPath script) [ Param rpmarch - , File tarball + , File (fromOsPath tarball) , Param v - , File rpmrepo + , File (fromOsPath rpmrepo) ] - void $ inRepo $ runBool [Param "annex", Param "get", File rpmrepo] - void $ liftIO $ boolSystem "createrepo_c" [File rpmrepo] - void $ inRepo $ runBool [Param "annex", Param "add", File rpmrepo] + void $ inRepo $ runBool [Param "annex", Param "get", File (fromOsPath rpmrepo)] + void $ liftIO $ boolSystem "createrepo_c" [File (fromOsPath rpmrepo)] + void $ inRepo $ runBool [Param "annex", Param "add", File (fromOsPath rpmrepo)] where isstandalonetarball tararch f = - ("git-annex-standalone-" ++ tararch ++ ".tar.gz") `isSuffixOf` f - script = topdir "standalone" "rpm" "rpmbuild-from-standalone-tarball" + toOsPath ("git-annex-standalone-" ++ tararch ++ ".tar.gz") `OS.isSuffixOf` f + script = topdir literalOsPath "standalone" + literalOsPath "rpm" + literalOsPath "rpmbuild-from-standalone-tarball" rpmrepo = "git-annex/linux/current/rpms" -- My .mrconfig is configured to copy new files to archive.org, diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs index fad73c4c76..c081dd83d5 100644 --- a/Build/LinuxMkLibs.hs +++ b/Build/LinuxMkLibs.hs @@ -5,10 +5,11 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Build.LinuxMkLibs (mklibs) where import Data.Maybe -import System.FilePath import Control.Monad import Data.List import System.Posix.Files @@ -18,6 +19,7 @@ import qualified System.Info import Prelude import Utility.LinuxMkLibs +import Utility.OsPath import Utility.Directory import Utility.Process import Utility.Monad @@ -25,18 +27,18 @@ import Utility.Path import Utility.Path.AbsRel import Utility.FileMode import Utility.CopyFile -import Utility.FileSystemEncoding import Utility.SystemDirectory +import qualified Utility.OsString as OS -mklibs :: FilePath -> a -> IO Bool +mklibs :: OsPath -> a -> IO Bool mklibs top _installedbins = do - fs <- dirContentsRecursive (toRawFilePath top) - exes <- filterM checkExe (map fromRawFilePath fs) + fs <- dirContentsRecursive top + exes <- filterM checkExe fs libs <- runLdd exes glibclibs <- glibcLibs let libs' = nub $ libs ++ glibclibs - let (linkers, otherlibs) = partition ("ld-linux" `isInfixOf`) libs' + let (linkers, otherlibs) = partition (literalOsPath "ld-linux" `OS.isInfixOf`) libs' libdirs <- nub . catMaybes <$> mapM (installLib installFile top) otherlibs libdirs' <- consolidateUsrLib top libdirs @@ -45,11 +47,17 @@ mklibs top _installedbins = do -- Various files used by runshell to set up env vars used by the -- linker shims. - writeFile (top "libdirs") (unlines libdirs') - writeFile (top "gconvdir") (fromRawFilePath $ parentDir $ toRawFilePath $ Prelude.head gconvlibs) + writeFile (fromOsPath (top literalOsPath "libdirs")) + (unlines (map fromOsPath libdirs')) + writeFile (fromOsPath (top literalOsPath "gconvdir")) $ + case gconvlibs of + [] -> "" + (p:_) -> fromOsPath (parentDir p) mapM_ (installLib installFile top) linkers - let linker = Prelude.head linkers + linker <- case linkers of + [] -> error "unable to find linker" + (l:_) -> return l mapM_ (installLinkerShim top linker) exes return (any hwcaplibdir libdirs) @@ -60,9 +68,9 @@ mklibs top _installedbins = do -- fails, a minor optimisation will not happen, but there will be -- no bad results. hwcaplibdir d = not $ or - [ "lib" == takeFileName d + [ literalOsPath "lib" == takeFileName d -- eg, "lib/x86_64-linux-gnu" - , "-linux-" `isInfixOf` takeFileName d + , literalOsPath "-linux-" `OS.isInfixOf` takeFileName d ] {- If there are two libdirs that are the same except one is in @@ -71,17 +79,17 @@ mklibs top _installedbins = do - needs to look in, and so reduces the number of failed stats - and improves startup time. -} -consolidateUsrLib :: FilePath -> [FilePath] -> IO [FilePath] +consolidateUsrLib :: OsPath -> [OsPath] -> IO [OsPath] consolidateUsrLib top libdirs = go [] libdirs where go c [] = return c - go c (x:rest) = case filter (\d -> ("/usr" ++ d) == x) libdirs of + go c (x:rest) = case filter (\d -> (literalOsPath "/usr" <> d) == x) libdirs of (d:_) -> do fs <- getDirectoryContents (inTop top x) forM_ fs $ \f -> do let src = inTop top (x f) let dst = inTop top (d f) - unless (dirCruft (toRawFilePath f)) $ + unless (f `elem` dirCruft) $ unlessM (doesDirectoryExist src) $ renameFile src dst symlinkHwCapDirs top d @@ -96,17 +104,17 @@ consolidateUsrLib top libdirs = go [] libdirs - to the libdir. This way, the linker will find a library the first place - it happens to look for it. -} -symlinkHwCapDirs :: FilePath -> FilePath -> IO () +symlinkHwCapDirs :: OsPath -> OsPath -> IO () symlinkHwCapDirs top libdir = forM_ hwcapdirs $ \d -> - unlessM (doesDirectoryExist (top ++ libdir d)) $ do - createDirectoryIfMissing True (top ++ libdir takeDirectory d) + unlessM (doesDirectoryExist (top <> libdir d)) $ do + createDirectoryIfMissing True (top <> libdir takeDirectory d) link <- relPathDirToFile - (toRawFilePath (top ++ takeDirectory (libdir d))) - (toRawFilePath (top ++ libdir)) - let link' = case fromRawFilePath link of + (top <> takeDirectory (libdir d)) + (top <> libdir) + let link' = case fromOsPath link of "" -> "." l -> l - createSymbolicLink link' (top ++ libdir d) + createSymbolicLink link' (fromOsPath (top <> libdir d)) where hwcapdirs = case System.Info.arch of "x86_64" -> @@ -145,50 +153,48 @@ symlinkHwCapDirs top libdir = forM_ hwcapdirs $ \d -> - The linker is symlinked to a file with the same basename as the binary, - since that looks better in ps than "ld-linux.so". -} -installLinkerShim :: FilePath -> FilePath -> FilePath -> IO () +installLinkerShim :: OsPath -> OsPath -> OsPath -> IO () installLinkerShim top linker exe = do createDirectoryIfMissing True (top shimdir) createDirectoryIfMissing True (top exedir) - ifM (isSymbolicLink <$> getSymbolicLinkStatus exe) + ifM (isSymbolicLink <$> getSymbolicLinkStatus (fromOsPath exe)) ( do - sl <- readSymbolicLink exe - removeWhenExistsWith removeLink exe - removeWhenExistsWith removeLink exedest + sl <- toOsPath <$> readSymbolicLink (fromOsPath exe) + removeWhenExistsWith removeFile exe + removeWhenExistsWith removeFile exedest -- Assume that for a symlink, the destination -- will also be shimmed. - let sl' = ".." takeFileName sl takeFileName sl - createSymbolicLink sl' exedest + let sl' = literalOsPath ".." takeFileName sl takeFileName sl + createSymbolicLink (fromOsPath sl') (fromOsPath exedest) , renameFile exe exedest ) - link <- relPathDirToFile - (toRawFilePath (top exedir)) - (toRawFilePath (top ++ linker)) + link <- relPathDirToFile (top exedir) (top <> linker) unlessM (doesFileExist (top exelink)) $ - createSymbolicLink (fromRawFilePath link) (top exelink) - writeFile exe $ unlines + createSymbolicLink (fromOsPath link) (fromOsPath (top exelink)) + writeFile (fromOsPath exe) $ unlines [ "#!/bin/sh" - , "exec \"$GIT_ANNEX_DIR/" ++ exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ base ++ "/" ++ base ++ "\" \"$@\"" + , "exec \"$GIT_ANNEX_DIR/" ++ fromOsPath exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ fromOsPath base ++ "/" ++ fromOsPath base ++ "\" \"$@\"" ] - modifyFileMode (toRawFilePath exe) $ addModes executeModes + modifyFileMode exe $ addModes executeModes where base = takeFileName exe - shimdir = "shimmed" base - exedir = "exe" + shimdir = literalOsPath "shimmed" base + exedir = literalOsPath "exe" exedest = top shimdir base exelink = exedir base -installFile :: FilePath -> FilePath -> IO () +installFile :: OsPath -> OsPath -> IO () installFile top f = do createDirectoryIfMissing True destdir void $ copyFileExternal CopyTimeStamps f destdir where - destdir = inTop top $ fromRawFilePath $ parentDir $ toRawFilePath f + destdir = inTop top $ parentDir f -checkExe :: FilePath -> IO Bool +checkExe :: OsPath -> IO Bool checkExe f - | ".so" `isSuffixOf` f = return False - | otherwise = ifM (isExecutable . fileMode <$> getFileStatus f) - ( checkFileExe <$> readProcess "file" ["-L", f] + | literalOsPath ".so" `OS.isSuffixOf` f = return False + | otherwise = ifM (isExecutable . fileMode <$> getFileStatus (fromOsPath f)) + ( checkFileExe <$> readProcess "file" ["-L", fromOsPath f] , return False ) diff --git a/Build/NullSoftInstaller.hs b/Build/NullSoftInstaller.hs index b8e3d4dd57..8241ff8dd8 100644 --- a/Build/NullSoftInstaller.hs +++ b/Build/NullSoftInstaller.hs @@ -16,7 +16,7 @@ - A build of libmagic will also be included in the installer, if its files - are found in the current directory: - ./magic.mgc ./libmagic-1.dll ./libgnurx-0.dll - - To build git-annex to usse libmagic, it has to be built with the + - To build git-annex to use libmagic, it has to be built with the - magicmime build flag turned on. - - Copyright 2013-2020 Joey Hess @@ -27,7 +27,6 @@ {-# LANGUAGE OverloadedStrings, FlexibleContexts #-} import Development.NSIS -import System.FilePath import Control.Monad import Control.Applicative import Data.String @@ -43,27 +42,28 @@ import Utility.Process import Utility.Exception import Utility.Directory import Utility.SystemDirectory +import Utility.OsPath import Build.BundledPrograms main = do withTmpDir "nsis-build" $ \tmpdir -> do - let gitannex = tmpdir gitannexprogram + let gitannex = fromOsPath $ tmpdir toOsPath gitannexprogram mustSucceed "ln" [File "git-annex.exe", File gitannex] magicDLLs' <- installwhenpresent magicDLLs tmpdir magicShare' <- installwhenpresent magicShare tmpdir - let license = tmpdir licensefile + let license = fromOsPath $ tmpdir toOsPath licensefile mustSucceed "sh" [Param "-c", Param $ "zcat standalone/licences.gz > '" ++ license ++ "'"] webappscript <- vbsLauncher tmpdir "git-annex-webapp" "git annex webapp" autostartscript <- vbsLauncher tmpdir "git-annex-autostart" "git annex assistant --autostart" - let htmlhelp = tmpdir "git-annex.html" + let htmlhelp = fromOsPath $ tmpdir literalOsPath "git-annex.html" writeFile htmlhelp htmlHelpText - let gitannexcmd = tmpdir "git-annex.cmd" + let gitannexcmd = fromOsPath $ tmpdir literalOsPath "git-annex.cmd" writeFile gitannexcmd "git annex %*" writeFile nsifile $ makeInstaller gitannex gitannexcmd license htmlhelp (winPrograms ++ magicDLLs') magicShare' [ webappscript, autostartscript ] mustSucceed "makensis" [File nsifile] - removeFile nsifile -- left behind if makensis fails + removeFile (toOsPath nsifile) -- left behind if makensis fails where nsifile = "git-annex.nsi" mustSucceed cmd params = do @@ -73,19 +73,19 @@ main = do False -> error $ cmd ++ " failed" installwhenpresent fs tmpdir = do fs' <- forM fs $ \f -> do - present <- doesFileExist f + present <- doesFileExist (toOsPath f) if present then do - mustSucceed "ln" [File f, File (tmpdir f)] + mustSucceed "ln" [File f, File (fromOsPath (tmpdir toOsPath f))] return (Just f) else return Nothing return (catMaybes fs') {- Generates a .vbs launcher which runs a command without any visible DOS - box. It expects to be passed the directory where git-annex is installed. -} -vbsLauncher :: FilePath -> String -> String -> IO String +vbsLauncher :: OsPath -> String -> String -> IO String vbsLauncher tmpdir basename cmd = do - let f = tmpdir basename ++ ".vbs" + let f = fromOsPath $ tmpdir toOsPath (basename ++ ".vbs") writeFile f $ unlines [ "Set objshell=CreateObject(\"Wscript.Shell\")" , "objShell.CurrentDirectory = Wscript.Arguments.item(0)" @@ -208,7 +208,7 @@ makeInstaller gitannex gitannexcmd license htmlhelp extrabins sharefiles launche removefilesFrom "$INSTDIR" [license, uninstaller] where addfile f = file [] (str f) - removefilesFrom d = mapM_ (\f -> delete [RebootOK] $ fromString $ d ++ "/" ++ takeFileName f) + removefilesFrom d = mapM_ (\f -> delete [RebootOK] $ fromString $ d ++ "/" ++ fromOsPath (takeFileName (toOsPath f))) winPrograms :: [FilePath] winPrograms = map (\p -> p ++ ".exe") bundledPrograms diff --git a/Build/OSXMkLibs.hs b/Build/OSXMkLibs.hs index de5f4335d9..6ca0d7d05e 100644 --- a/Build/OSXMkLibs.hs +++ b/Build/OSXMkLibs.hs @@ -5,10 +5,11 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Build.OSXMkLibs (mklibs) where import Data.Maybe -import System.FilePath import System.IO import Control.Monad import Control.Monad.IfElse @@ -18,6 +19,7 @@ import System.Posix.Files import Prelude import Utility.PartialPrelude +import Utility.OsPath import Utility.Directory import Utility.SystemDirectory import Utility.Process @@ -28,32 +30,33 @@ import Utility.Exception import Utility.Env import Utility.Split import Utility.FileSystemEncoding +import qualified Utility.OsString as OS import qualified Data.Map as M import qualified Data.Set as S -type LibMap = M.Map FilePath String +type LibMap = M.Map OsPath String -mklibs :: FilePath -> M.Map FilePath FilePath -> IO Bool +mklibs :: OsPath -> M.Map OsPath OsPath -> IO Bool mklibs appbase installedbins = do mklibs' appbase installedbins [] [] M.empty return True {- Recursively find and install libs, until nothing new to install is found. -} -mklibs' :: FilePath -> M.Map FilePath FilePath -> [FilePath] -> [(FilePath, FilePath)] -> LibMap -> IO () +mklibs' :: OsPath -> M.Map OsPath OsPath -> [OsPath] -> [(OsPath, OsPath)] -> LibMap -> IO () mklibs' appbase installedbins libdirs replacement_libs libmap = do (new, replacement_libs', libmap') <- installLibs appbase installedbins replacement_libs libmap unless (null new) $ mklibs' appbase installedbins (libdirs++new) replacement_libs' libmap' {- Returns directories into which new libs were installed. -} -installLibs :: FilePath -> M.Map FilePath FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap) +installLibs :: OsPath -> M.Map OsPath OsPath -> [(OsPath, OsPath)] -> LibMap -> IO ([OsPath], [(OsPath, OsPath)], LibMap) installLibs appbase installedbins replacement_libs libmap = do (needlibs, replacement_libs', libmap') <- otool appbase installedbins replacement_libs libmap libs <- forM needlibs $ \lib -> do pathlib <- findLibPath lib - let shortlib = fromMaybe (error "internal") (M.lookup lib libmap') - let fulllib = dropWhile (== '/') lib + let shortlib = toOsPath $ fromMaybe (error "internal") (M.lookup lib libmap') + let fulllib = OS.dropWhile (== unsafeFromChar '/') lib let dest = appbase fulllib let symdest = appbase shortlib -- This is a hack; libraries need to be in the same @@ -61,20 +64,20 @@ installLibs appbase installedbins replacement_libs libmap = do -- extra and git-core directories so programs in those will -- find them. let symdestextra = - [ appbase "extra" shortlib - , appbase "git-core" shortlib + [ appbase literalOsPath "extra" shortlib + , appbase literalOsPath "git-core" shortlib ] ifM (doesFileExist dest) ( return Nothing , do - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath dest))) - putStrLn $ "installing " ++ pathlib ++ " as " ++ shortlib - unlessM (boolSystem "cp" [File pathlib, File dest] - <&&> boolSystem "chmod" [Param "644", File dest] - <&&> boolSystem "ln" [Param "-s", File fulllib, File symdest]) $ + createDirectoryIfMissing True (parentDir dest) + putStrLn $ "installing " ++ fromOsPath pathlib ++ " as " ++ fromOsPath shortlib + unlessM (boolSystem "cp" [File (fromOsPath pathlib), File (fromOsPath dest)] + <&&> boolSystem "chmod" [Param "644", File (fromOsPath dest)] + <&&> boolSystem "ln" [Param "-s", File (fromOsPath fulllib), File (fromOsPath symdest)]) $ error "library install failed" forM_ symdestextra $ \d -> - unlessM (boolSystem "ln" [Param "-s", File (".." fulllib), File d]) $ + unlessM (boolSystem "ln" [Param "-s", File (fromOsPath (literalOsPath ".." fulllib)), File (fromOsPath d)]) $ error "library linking failed" return $ Just appbase ) @@ -86,10 +89,9 @@ installLibs appbase installedbins replacement_libs libmap = do - library files returned may need to be run through findLibPath - to find the actual libraries to install. -} -otool :: FilePath -> M.Map FilePath FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap) +otool :: OsPath -> M.Map OsPath OsPath -> [(OsPath, OsPath)] -> LibMap -> IO ([OsPath], [(OsPath, OsPath)], LibMap) otool appbase installedbins replacement_libs libmap = do - files <- filterM doesFileExist - =<< (map fromRawFilePath <$> dirContentsRecursive (toRawFilePath appbase)) + files <- filterM doesFileExist =<< dirContentsRecursive appbase process [] files replacement_libs libmap where want s = @@ -118,21 +120,21 @@ otool appbase installedbins replacement_libs libmap = do ) process c [] rls m = return (nub $ concat c, rls, m) process c (file:rest) rls m = do - _ <- boolSystem "chmod" [Param "755", File file] + _ <- boolSystem "chmod" [Param "755", File (fromOsPath file)] libs <- filterM lib_present =<< filter want . parseOtool - <$> readProcess "otool" ["-L", file] + <$> readProcess "otool" ["-L", fromOsPath file] expanded_libs <- expand_rpath installedbins libs replacement_libs file - let rls' = nub $ rls ++ (zip libs expanded_libs) - m' <- install_name_tool file libs expanded_libs m + let rls' = nub $ rls ++ (zip (map toOsPath libs) expanded_libs) + m' <- install_name_tool file (map toOsPath libs) expanded_libs m process (expanded_libs:c) rest rls' m' -findLibPath :: FilePath -> IO FilePath +findLibPath :: OsPath -> IO OsPath findLibPath l = go =<< getEnv "DYLD_LIBRARY_PATH" where go Nothing = return l go (Just p) = fromMaybe l - <$> firstM doesFileExist (map ( f) (splitc ':' p)) + <$> firstM doesFileExist (map (\p' -> toOsPath p' f) (splitc ':' p)) f = takeFileName l {- Expands any @rpath in the list of libraries. @@ -141,7 +143,7 @@ findLibPath l = go =<< getEnv "DYLD_LIBRARY_PATH" - option (so it doesn't do anything.. hopefully!) and asking the dynamic - linker to print expanded rpaths. -} -expand_rpath :: M.Map FilePath FilePath -> [String] -> [(FilePath, FilePath)] -> FilePath -> IO [String] +expand_rpath :: M.Map OsPath OsPath -> [String] -> [(OsPath, OsPath)] -> OsPath -> IO [OsPath] expand_rpath installedbins libs replacement_libs cmd | any ("@rpath" `isInfixOf`) libs = do let origcmd = case M.lookup cmd installedbins of @@ -151,17 +153,17 @@ expand_rpath installedbins libs replacement_libs cmd let m = if (null s) then M.fromList replacement_libs else M.fromList $ mapMaybe parse $ lines s - return $ map (replacem m) libs - | otherwise = return libs + return $ map (replacem m . toOsPath) libs + | otherwise = return (map toOsPath libs) where - probe c = "DYLD_PRINT_RPATHS=1 " ++ c ++ " --getting-rpath-dummy-option 2>&1 | grep RPATH" + probe c = "DYLD_PRINT_RPATHS=1 " ++ fromOsPath c ++ " --getting-rpath-dummy-option 2>&1 | grep RPATH" parse s = case words s of ("RPATH":"successful":"expansion":"of":old:"to:":new:[]) -> - Just (old, new) + Just (toOsPath old, toOsPath new) _ -> Nothing - replacem m l = fromMaybe l $ M.lookup l m + replacem m l = fromMaybe l $ M.lookup (toOsPath l) m -parseOtool :: String -> [FilePath] +parseOtool :: String -> [String] parseOtool = catMaybes . map parse . lines where parse l @@ -170,23 +172,23 @@ parseOtool = catMaybes . map parse . lines {- Adjusts binaries to use libraries bundled with it, rather than the - system libraries. -} -install_name_tool :: FilePath -> [FilePath] -> [FilePath] -> LibMap -> IO LibMap +install_name_tool :: OsPath -> [OsPath] -> [OsPath] -> LibMap -> IO LibMap install_name_tool _ [] _ libmap = return libmap install_name_tool binary libs expanded_libs libmap = do let (libnames, libmap') = getLibNames expanded_libs libmap let params = concatMap change $ zip libs libnames - ok <- boolSystem "install_name_tool" $ params ++ [File binary] + ok <- boolSystem "install_name_tool" $ params ++ [File (fromOsPath binary)] unless ok $ - error $ "install_name_tool failed for " ++ binary + error $ "install_name_tool failed for " ++ fromOsPath binary return libmap' where change (lib, libname) = [ Param "-change" - , File lib - , Param $ "@executable_path/" ++ libname + , File (fromOsPath lib) + , Param $ "@executable_path/" ++ fromOsPath libname ] -getLibNames :: [FilePath] -> LibMap -> ([FilePath], LibMap) +getLibNames :: [OsPath] -> LibMap -> ([OsPath], LibMap) getLibNames libs libmap = go [] libs libmap where go c [] m = (reverse c, m) @@ -196,10 +198,10 @@ getLibNames libs libmap = go [] libs libmap {- Uses really short names for the library files it installs, because - binaries have arbitrarily short RPATH field limits. -} -getLibName :: FilePath -> LibMap -> (FilePath, LibMap) +getLibName :: OsPath -> LibMap -> (OsPath, LibMap) getLibName lib libmap = case M.lookup lib libmap of - Just n -> (n, libmap) - Nothing -> (nextfreename, M.insert lib nextfreename libmap) + Just n -> (toOsPath n, libmap) + Nothing -> (toOsPath nextfreename, M.insert lib nextfreename libmap) where names = map pure ['A' .. 'Z'] ++ [[n, l] | n <- ['0' .. '9'], l <- ['A' .. 'Z']] diff --git a/Build/Standalone.hs b/Build/Standalone.hs index 36a4d5a002..2c0c8d1b55 100644 --- a/Build/Standalone.hs +++ b/Build/Standalone.hs @@ -7,12 +7,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import System.Environment (getArgs) import Control.Monad.IfElse -import System.FilePath import System.Posix.Files import Control.Monad import qualified Data.ByteString.Lazy as L @@ -20,11 +20,11 @@ import qualified Data.Map as M import Utility.SafeCommand import Utility.Process +import Utility.OsPath import Utility.Path import Utility.Path.AbsRel import Utility.Directory import Utility.Env -import Utility.FileSystemEncoding import Utility.SystemDirectory import Build.BundledPrograms #ifdef darwin_HOST_OS @@ -37,48 +37,46 @@ import Build.LinuxMkLibs (mklibs) import Utility.FileMode #endif -progDir :: FilePath -> FilePath +progDir :: OsPath -> OsPath #ifdef darwin_HOST_OS progDir topdir = topdir #else -progDir topdir = topdir "bin" +progDir topdir = topdir literalOsPath "bin" #endif -extraProgDir :: FilePath -> FilePath +extraProgDir :: OsPath -> OsPath extraProgDir topdir = topdir "extra" -installProg :: FilePath -> FilePath -> IO (FilePath, FilePath) -installProg dir prog = searchPath prog >>= go +installProg :: OsPath -> OsPath -> IO (OsPath, OsPath) +installProg dir prog = searchPath (fromOsPath prog) >>= go where - go Nothing = error $ "cannot find " ++ prog ++ " in PATH" + go Nothing = error $ "cannot find " ++ fromOsPath prog ++ " in PATH" go (Just f) = do let dest = dir takeFileName f - unlessM (boolSystem "install" [File f, File dest]) $ - error $ "install failed for " ++ prog + unlessM (boolSystem "install" [File (fromOsPath f), File (fromOsPath dest)]) $ + error $ "install failed for " ++ fromOsPath prog return (dest, f) -installBundledPrograms :: FilePath -> IO (M.Map FilePath FilePath) +installBundledPrograms :: OsPath -> IO (M.Map OsPath OsPath) installBundledPrograms topdir = M.fromList . concat <$> mapM go - [ (progDir topdir, preferredBundledPrograms) - , (extraProgDir topdir, extraBundledPrograms) + [ (progDir topdir, map toOsPath preferredBundledPrograms) + , (extraProgDir topdir, map toOsPath extraBundledPrograms) ] where go (dir, progs) = do createDirectoryIfMissing True dir forM progs $ installProg dir -installGitLibs :: FilePath -> IO () +installGitLibs :: OsPath -> IO () installGitLibs topdir = do -- install git-core programs; these are run by the git command createDirectoryIfMissing True gitcoredestdir execpath <- getgitpath "exec-path" - cfs <- dirContents (toRawFilePath execpath) + cfs <- dirContents execpath forM_ cfs $ \f -> do - let f' = fromRawFilePath f - destf <- ((gitcoredestdir ) . fromRawFilePath) - <$> relPathDirToFile - (toRawFilePath execpath) - f + let f' = fromOsPath f + destf <- (gitcoredestdir ) + <$> relPathDirToFile execpath f createDirectoryIfMissing True (takeDirectory destf) issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f' if issymlink @@ -93,99 +91,98 @@ 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 <- toOsPath <$> 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' - removeWhenExistsWith removeLink destf + L.readFile f' >>= L.writeFile (fromOsPath linktarget') + removeWhenExistsWith removeFile destf rellinktarget <- relPathDirToFile - (toRawFilePath (takeDirectory destf)) - (toRawFilePath linktarget') - createSymbolicLink (fromRawFilePath rellinktarget) destf - else cp f' destf + (takeDirectory destf) + (linktarget') + createSymbolicLink (fromOsPath rellinktarget) (fromOsPath destf) + else cp f destf -- install git's template files -- git does not have an option to get the path of these, -- but they're architecture independent files, so are located -- next to the --man-path, in eg /usr/share/git-core manpath <- getgitpath "man-path" - let templatepath = manpath ".." "git-core" "templates" - tfs <- dirContents (toRawFilePath templatepath) + let templatepath = manpath literalOsPath ".." literalOsPath "git-core" literalOsPath "templates" + tfs <- dirContents templatepath forM_ tfs $ \f -> do - destf <- ((templatedestdir ) . fromRawFilePath) - <$> relPathDirToFile - (toRawFilePath templatepath) - f + destf <- (templatedestdir ) + <$> relPathDirToFile templatepath f createDirectoryIfMissing True (takeDirectory destf) - cp (fromRawFilePath f) destf + cp f destf where - gitcoredestdir = topdir "git-core" - templatedestdir = topdir "templates" + gitcoredestdir = topdir literalOsPath "git-core" + templatedestdir = topdir literalOsPath "templates" getgitpath v = do let opt = "--" ++ v ls <- lines <$> readProcess "git" [opt] case ls of [] -> error $ "git " ++ opt ++ "did not output a location" - (p:_) -> return p + (p:_) -> return (toOsPath p) -cp :: FilePath -> FilePath -> IO () +cp :: OsPath -> OsPath -> IO () cp src dest = do - removeWhenExistsWith removeLink dest - unlessM (boolSystem "cp" [Param "-a", File src, File dest]) $ + removeWhenExistsWith removeFile dest + unlessM (boolSystem "cp" [Param "-a", File (fromOsPath src), File (fromOsPath dest)]) $ error "cp failed" -installMagic :: FilePath -> IO () +installMagic :: OsPath -> IO () #ifdef darwin_HOST_OS installMagic topdir = getEnv "OSX_MAGIC_FILE" >>= \case Nothing -> hPutStrLn stderr "OSX_MAGIC_FILE not set; not including it" Just f -> do - let mdir = topdir "magic" + let mdir = topdir literalOsPath "magic" createDirectoryIfMissing True mdir - unlessM (boolSystem "cp" [File f, File (mdir "magic.mgc")]) $ + unlessM (boolSystem "cp" [File f, File (fromOsPath (mdir literalOsPath "magic.mgc"))]) $ error "cp failed" #else installMagic topdir = do - let mdir = topdir "magic" + let mdir = topdir literalOsPath "magic" createDirectoryIfMissing True mdir - unlessM (boolSystem "cp" [File "/usr/share/file/magic.mgc", File (mdir "magic.mgc")]) $ + unlessM (boolSystem "cp" [File "/usr/share/file/magic.mgc", File (fromOsPath (mdir literalOsPath "magic.mgc"))]) $ error "cp failed" #endif -installLocales :: FilePath -> IO () +installLocales :: OsPath -> IO () #ifdef darwin_HOST_OS installLocales _ = return () #else -installLocales topdir = cp "/usr/share/i18n" (topdir "i18n") +installLocales topdir = + cp (literalOsPath "/usr/share/i18n") (topdir "i18n") #endif -installSkel :: FilePath -> FilePath -> IO () +installSkel :: OsPath -> OsPath -> IO () #ifdef darwin_HOST_OS installSkel _topdir basedir = do whenM (doesDirectoryExist basedir) $ removeDirectoryRecursive basedir createDirectoryIfMissing True (takeDirectory basedir) - unlessM (boolSystem "cp" [Param "-R", File "standalone/osx/git-annex.app", File basedir]) $ + unlessM (boolSystem "cp" [Param "-R", File "standalone/osx/git-annex.app", File (fromOsPath basedir)]) $ error "cp failed" #else installSkel topdir _basedir = do whenM (doesDirectoryExist topdir) $ removeDirectoryRecursive topdir createDirectoryIfMissing True (takeDirectory topdir) - unlessM (boolSystem "cp" [Param "-R", File "standalone/linux/skel", File topdir]) $ + unlessM (boolSystem "cp" [Param "-R", File "standalone/linux/skel", File (fromOsPath topdir)]) $ error "cp failed" #endif -installSkelRest :: FilePath -> FilePath -> Bool -> IO () +installSkelRest :: OsPath -> OsPath -> Bool -> IO () #ifdef darwin_HOST_OS installSkelRest _topdir basedir _hwcaplibs = do plist <- lines <$> readFile "standalone/osx/Info.plist.template" version <- getVersion - writeFile (basedir "Contents" "Info.plist") + writeFile (fromOsPath (basedir literalOsPath "Contents" literalOsPath "Info.plist")) (unlines (map (expandversion version) plist)) where expandversion v l = replace "GIT_ANNEX_VERSION" v l @@ -195,10 +192,10 @@ installSkelRest topdir _basedir hwcaplibs = do -- GIT_ANNEX_PACKAGE_INSTALL can be set by a distributor and -- runshell will be modified gapi <- getEnv "GIT_ANNEX_PACKAGE_INSTALL" - writeFile (topdir "runshell") + writeFile (fromOsPath (topdir literalOsPath "runshell")) (unlines (map (expandrunshell gapi) runshell)) modifyFileMode - (toRawFilePath (topdir "runshell")) + (topdir literalOsPath "runshell") (addModes executeModes) where expandrunshell (Just gapi) l@"GIT_ANNEX_PACKAGE_INSTALL=" = l ++ gapi @@ -211,25 +208,25 @@ installSkelRest topdir _basedir hwcaplibs = do expandrunshell _ l = l #endif -installGitAnnex :: FilePath -> IO () +installGitAnnex :: OsPath -> IO () #ifdef darwin_HOST_OS installGitAnnex topdir = go topdir #else -installGitAnnex topdir = go (topdir "bin") +installGitAnnex topdir = go (topdir literalOsPath "bin") #endif where go bindir = do createDirectoryIfMissing True bindir - unlessM (boolSystem "cp" [File "git-annex", File bindir]) $ + unlessM (boolSystem "cp" [File "git-annex", File (fromOsPath bindir)]) $ error "cp failed" - unlessM (boolSystem "strip" [File (bindir "git-annex")]) $ + unlessM (boolSystem "strip" [File (fromOsPath (bindir literalOsPath "git-annex"))]) $ error "strip failed" - createSymbolicLink "git-annex" (bindir "git-annex-shell") - createSymbolicLink "git-annex" (bindir "git-remote-tor-annex") - createSymbolicLink "git-annex" (bindir "git-remote-annex") + createSymbolicLink "git-annex" (fromOsPath (bindir literalOsPath "git-annex-shell")) + createSymbolicLink "git-annex" (fromOsPath (bindir literalOsPath "git-remote-tor-annex")) + createSymbolicLink "git-annex" (fromOsPath (bindir literalOsPath "git-remote-annex")) main :: IO () -main = getArgs >>= go +main = getArgs >>= go . map toOsPath where go (topdir:basedir:[]) = do installSkel topdir basedir 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..d81628e6b8 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -38,7 +38,6 @@ import qualified Utility.RawFilePath as R import qualified Annex.Transfer as Transfer import Network.URI -import qualified System.FilePath.ByteString as P cmd :: Command cmd = notBareRepo $ withAnnexOptions @@ -177,14 +176,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 +199,15 @@ 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) $ - P.splitDirectories (toRawFilePath file) + let file' = joinPath $ + map (toOsPath . truncateFilePath pathmax . fromOsPath) $ + splitDirectories (toOsPath 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..4e66755c02 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 $ removeFile 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 $ doesPathExist 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 $ doesPathExist 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 $ doesPathExist 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..4fdfd5b292 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 <$> doesFileExist 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..71fbbec13d 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 $ doesFileExist 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..50ba8f8c30 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 $ doesFileExist 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..8820b84189 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 <$> doesFileExist db when isnew $ initDb db $ void $ runMigrationSilent migrateImportFeed diff --git a/Database/Init.hs b/Database/Init.hs index 6f7ba09faf..eab3a6f32d 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 + 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 :: OsPath -> SqliteConnectionInfo enableWAL db = over walEnabled (const True) $ - mkSqliteConnectionInfo db + mkSqliteConnectionInfo (T.pack (fromOsPath db)) diff --git a/Database/Keys.hs b/Database/Keys.hs index 9704b6ff4c..cc3f189b99 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 $ doesFileExist 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/RawFilePath.hs b/Database/RawFilePath.hs index ba82b9f90d..e154b74a3a 100644 --- a/Database/RawFilePath.hs +++ b/Database/RawFilePath.hs @@ -38,7 +38,7 @@ module Database.RawFilePath where #if MIN_VERSION_persistent_sqlite(2,13,3) import Database.Persist.Sqlite import qualified Database.Sqlite as Sqlite -import qualified System.FilePath.ByteString as P +import Utility.RawFilePath (RawFilePath) import qualified Control.Exception as E import Control.Monad.Logger (MonadLoggerIO) import Control.Monad.IO.Unlift (MonadUnliftIO) @@ -47,7 +47,7 @@ import Control.Monad.Trans.Reader (ReaderT) import UnliftIO.Resource (ResourceT, runResourceT) openWith' - :: P.RawFilePath + :: RawFilePath -> (SqlBackend -> Sqlite.Connection -> r) -> SqliteConnectionInfo -> LogFunc @@ -58,7 +58,7 @@ openWith' db f connInfo logFunc = do return $ f backend conn runSqlite' :: (MonadUnliftIO m) - => P.RawFilePath + => RawFilePath -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a runSqlite' connstr = runResourceT @@ -68,7 +68,7 @@ runSqlite' connstr = runResourceT withSqliteConn' :: (MonadUnliftIO m, MonadLoggerIO m) - => P.RawFilePath + => RawFilePath -> (SqlBackend -> m a) -> m a withSqliteConn' connstr = withSqliteConnInfo' connstr $ @@ -76,7 +76,7 @@ withSqliteConn' connstr = withSqliteConnInfo' connstr $ runSqliteInfo' :: (MonadUnliftIO m) - => P.RawFilePath + => RawFilePath -> SqliteConnectionInfo -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a @@ -87,7 +87,7 @@ runSqliteInfo' db conInfo = runResourceT withSqliteConnInfo' :: (MonadUnliftIO m, MonadLoggerIO m) - => P.RawFilePath + => RawFilePath -> SqliteConnectionInfo -> (SqlBackend -> m a) -> m a diff --git a/Database/RepoSize.hs b/Database/RepoSize.hs index 0118e88a7b..d70de72191 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 $ doesFileExist 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..3d503a5ebc 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -40,15 +40,12 @@ import Git.FilePath 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 = getCurrentDirectory >>= seekUp where seekUp dir = do r <- checkForRepo dir @@ -59,31 +56,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 +105,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 +127,7 @@ localToUrl reference r [ s , "//" , auth - , fromRawFilePath (repoPath r) + , fromOsPath (repoPath r) ] in r { location = Url $ fromJust $ parseURIPortable absurl } _ -> r @@ -176,43 +174,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 +219,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 +232,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 +261,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..e4686e9d88 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -16,10 +16,7 @@ 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 +import qualified Utility.OsString as OS {- Gets the current git repository. - @@ -49,9 +46,9 @@ get = do 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 @@ -59,22 +56,22 @@ get = do case v of Just d -> do unsetEnv s - return (Just (toRawFilePath d)) + return (Just (toOsPath d)) Nothing -> return Nothing - getpathenvprefix s (Just prefix) | not (B.null prefix) = + getpathenvprefix s (Just prefix) | not (OS.null prefix) = getpathenv s >>= \case Nothing -> return Nothing Just d - | d == "." -> return (Just d) + | d == literalOsPath "." -> return (Just d) | otherwise -> Just - <$> absPath (prefix P. d) + <$> absPath (prefix d) getpathenvprefix s _ = 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..4604bd2ddd 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 +{- The input path 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 704d310c9d..69b5b586b6 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -14,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] @@ -40,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 @@ -48,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 () @@ -82,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/Remote.hs b/Git/Remote.hs index b09aee6643..eb4d78e88d 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -122,8 +122,8 @@ parseRemoteLocation s knownurl repo = go #ifdef mingw32_HOST_OS -- git on Windows will write a path to .git/config with "drive:", -- which is not to be confused with a "host:" - dosstyle = hasDrive - dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath + dosstyle = hasDrive . toOsPath + dospath = fromOsPath . fromInternalGitPath . toOsPath #endif insteadOfUrl :: String -> S.ByteString -> RepoFullConfig -> Maybe String 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..bf304ed1fb 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -37,14 +37,13 @@ import Git.Command import Git.Sha import qualified Git.LsTree as LsTree import qualified Utility.CoProcess as CoProcess -import qualified System.FilePath.ByteString as P +import qualified Utility.OsString as OS import Numeric import System.Posix.Types import Control.Monad.IO.Class import qualified Data.Set as S import qualified Data.Map as M -import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 newtype Tree = Tree [TreeContent] @@ -137,7 +136,7 @@ mkTreeOutput fm ot s f = concat , " " , fromRef s , "\t" - , takeFileName (fromRawFilePath (getTopFilePath f)) + , fromOsPath (takeFileName (getTopFilePath f)) , "\NUL" ] @@ -181,7 +180,7 @@ treeItemsToTree = go M.empty go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is where p = gitPath i - idir = P.takeDirectory p + idir = takeDirectory p c = treeItemToTreeContent i addsubtree d m t @@ -194,7 +193,7 @@ treeItemsToTree = go M.empty _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) | otherwise = M.insert d t m where - parent = P.takeDirectory d + parent = takeDirectory d {- Flattens the top N levels of a Tree. -} flattenTree :: Int -> Tree -> Tree @@ -285,9 +284,9 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = addtreeitempathmap = mkPathMap addtreeitems addtreeitemprefixmap = mkSubTreePathPrefixMap addtreeitems - removeset = S.fromList $ map (P.normalise . gitPath) removefiles - removed (TreeBlob f _ _) = S.member (P.normalise (gitPath f)) removeset - removed (TreeCommit f _ _) = S.member (P.normalise (gitPath f)) removeset + removeset = S.fromList $ map (normalise . gitPath) removefiles + removed (TreeBlob f _ _) = S.member (normalise (gitPath f)) removeset + removed (TreeCommit f _ _) = S.member (normalise (gitPath f)) removeset removed (RecordedSubTree _ _ _) = False removed (NewSubTree _ _) = False @@ -303,7 +302,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = addoldnew' (M.delete k oldm) ns Nothing -> n : addoldnew' oldm ns addoldnew' oldm [] = M.elems oldm - mkk = P.normalise . gitPath + mkk = normalise . gitPath {- Grafts subtree into the basetree at the specified location, replacing - anything that the basetree already had at that location. @@ -360,7 +359,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs | d == graftloc = graftin' [] | otherwise = NewSubTree d [graftin' rest] - subdirs = P.splitDirectories $ gitPath graftloc + subdirs = splitDirectories $ gitPath graftloc graftdirs = map (asTopFilePath . toInternalGitPath) $ pathPrefixes subdirs @@ -392,13 +391,13 @@ extractTree l = case go [] inTopTree l of parseerr = Left class GitPath t where - gitPath :: t -> RawFilePath + gitPath :: t -> OsPath -instance GitPath RawFilePath where +instance GitPath OsPath where gitPath = id instance GitPath FilePath where - gitPath = toRawFilePath + gitPath = toOsPath instance GitPath TopFilePath where gitPath = getTopFilePath @@ -418,22 +417,22 @@ instance GitPath TreeContent where inTopTree :: GitPath t => t -> Bool inTopTree = inTree topTreePath -topTreePath :: RawFilePath -topTreePath = "." +topTreePath :: OsPath +topTreePath = literalOsPath "." inTree :: (GitPath t, GitPath f) => t -> f -> Bool -inTree t f = gitPath t == P.takeDirectory (gitPath f) +inTree t f = gitPath t == takeDirectory (gitPath f) beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool -beneathSubTree t f = subTreePrefix t `B.isPrefixOf` subTreePath f +beneathSubTree t f = subTreePrefix t `OS.isPrefixOf` subTreePath f -subTreePath :: GitPath t => t -> RawFilePath -subTreePath = P.normalise . gitPath +subTreePath :: GitPath t => t -> OsPath +subTreePath = normalise . gitPath -subTreePrefix :: GitPath t => t -> RawFilePath +subTreePrefix :: GitPath t => t -> OsPath subTreePrefix t - | B.null tp = tp - | otherwise = P.addTrailingPathSeparator (P.normalise tp) + | OS.null tp = tp + | otherwise = addTrailingPathSeparator (normalise tp) where tp = gitPath t @@ -443,23 +442,23 @@ subTreePrefix t - Values that are not in any subdirectory are placed in - the topTreePath key. -} -mkPathMap :: GitPath t => [t] -> M.Map RawFilePath [t] +mkPathMap :: GitPath t => [t] -> M.Map OsPath [t] mkPathMap l = M.fromListWith (++) $ - map (\ti -> (P.takeDirectory (gitPath ti), [ti])) l + map (\ti -> (takeDirectory (gitPath ti), [ti])) l {- Input is eg splitDirectories "foo/bar/baz", - for which it will output ["foo", "foo/bar", "foo/bar/baz"] -} -pathPrefixes :: [RawFilePath] -> [RawFilePath] +pathPrefixes :: [OsPath] -> [OsPath] pathPrefixes = go [] where go _ [] = [] - go base (d:rest) = (P.joinPath base P. d) : go (base ++ [d]) rest + go base (d:rest) = (joinPath base d) : go (base ++ [d]) rest {- Makes a Map where the keys are all subtree path prefixes, - and the values are items with that subtree path prefix. -} -mkSubTreePathPrefixMap :: GitPath t => [t] -> M.Map RawFilePath [t] +mkSubTreePathPrefixMap :: GitPath t => [t] -> M.Map OsPath [t] mkSubTreePathPrefixMap l = M.fromListWith (++) $ concatMap go l where go ti = map (\p -> (p, [ti])) - (map subTreePrefix $ pathPrefixes $ P.splitDirectories $ subTreePath ti) + (map subTreePrefix $ pathPrefixes $ splitDirectories $ subTreePath ti) 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 387311b219..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,9 +300,13 @@ 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 @@ -326,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/Makefile b/Makefile index a0939a9e9b..b2ee54db83 100644 --- a/Makefile +++ b/Makefile @@ -74,12 +74,6 @@ git-annex-shell: git-annex git-remote-annex: git-annex ln -sf git-annex git-remote-annex -# These are not built normally. -git-union-merge.1: doc/git-union-merge.mdwn - ./Build/mdwn2man git-union-merge 1 doc/git-union-merge.mdwn > git-union-merge.1 -git-union-merge: - $(GHC) --make -threaded $@ - install-mans: mans install -d $(DESTDIR)$(PREFIX)/$(SHAREDIR)/man/man1 install -m 0644 man/*.1 $(DESTDIR)$(PREFIX)/$(SHAREDIR)/man/man1 @@ -146,7 +140,7 @@ clean: doc/.ikiwiki html dist tags Build/SysConfig Build/Version \ Setup Build/InstallDesktopFile Build/Standalone \ Build/DistributionUpdate Build/BuildVersion Build/MakeMans \ - git-annex-shell git-remote-annex git-union-merge .tasty-rerun-log + git-annex-shell git-remote-annex .tasty-rerun-log find . -name \*.o -exec rm {} \; find . -name \*.hi -exec rm {} \; @@ -241,4 +235,4 @@ distributionupdate: ghc -Wall -fno-warn-tabs --make Build/DistributionUpdate -XLambdaCase -XPackageImports ./Build/DistributionUpdate -.PHONY: git-annex git-union-merge tags +.PHONY: git-annex tags 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 d2f03e0735..372a485ba7 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,12 +201,12 @@ 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 @@ -221,60 +219,58 @@ 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 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 src 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 :: OsPath -> Remover removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k) {- Removes the directory, which must be located under the topdir. @@ -291,7 +287,7 @@ removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k) - can also be removed. Failure to remove such a directory is not treated - as an error. -} -removeDirGeneric :: Bool -> RawFilePath -> RawFilePath -> IO () +removeDirGeneric :: Bool -> OsPath -> OsPath -> IO () removeDirGeneric removeemptyparents topdir dir = do void $ tryIO $ allowWrite dir #ifdef mingw32_HOST_OS @@ -299,102 +295,100 @@ removeDirGeneric removeemptyparents topdir dir = do - before it can delete them. -} void $ tryIO $ mapM_ allowWrite =<< dirContents dir #endif - tryNonAsync (removeDirectoryRecursive dir') >>= \case + tryNonAsync (removeDirectoryRecursive dir) >>= \case Right () -> return () Left e -> - unlessM (doesDirectoryExist topdir' <&&> (not <$> doesDirectoryExist dir')) $ + unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $ throwM e when removeemptyparents $ do - subdir <- relPathDirToFile topdir (P.takeDirectory 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) - dir' = fromRawFilePath dir - topdir' = fromRawFilePath topdir -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 src 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 where - src = fromRawFilePath $ exportPath d loc + src = 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 f 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) @@ -486,7 +480,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = closeFd dupfd bracketIO open close $ \(h, dupfd) -> do #else - let open = openBinaryFile f' ReadMode + let open = F.openBinaryFile f ReadMode let close = hClose bracketIO open close $ \h -> do #endif @@ -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 src 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 ce8564bd76..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" @@ -439,8 +439,8 @@ remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remov remove' repo r rsyncopts accessmethod proof k | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ liftIO $ Remote.Directory.removeDirGeneric True - (toRawFilePath (gCryptTopDir repo)) - (parentDir (toRawFilePath (gCryptLocation repo k))) + (gCryptTopDir repo) + (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..71c6571554 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 @@ -849,7 +852,7 @@ mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do 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 2bc999d0f2..0032e855e0 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 @@ -89,6 +90,7 @@ import qualified Utility.MoveFile import qualified Utility.StatelessOpenPGP import qualified Types.Remote #ifndef mingw32_HOST_OS +import qualified Utility.OsString as OS import qualified Remote.Helper.Encryptable import qualified Types.Crypto import qualified Utility.Gpg @@ -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 @@ -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..255778387f 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -64,7 +64,6 @@ import Control.Concurrent.STM import qualified Data.Set as S import qualified Data.Map as M import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P -- | A configurable value, that may not be fully determined yet because -- the global git config has not yet been loaded. @@ -138,7 +137,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 +243,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 d 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..2a838ff735 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 = @@ -62,13 +62,13 @@ copyFileExternal meta src dest = do - The dest file must not exist yet, or it will fail to make a CoW copy, - and will return False. -} -copyCoW :: CopyMetaData -> FilePath -> FilePath -> IO Bool +copyCoW :: CopyMetaData -> OsPath -> OsPath -> IO Bool copyCoW meta src dest | BuildInfo.cp_reflink_supported = do -- When CoW is not supported, cp will complain to stderr, -- so have to discard its stderr. ok <- catchBoolIO $ withNullHandle $ \nullh -> - let p = (proc "cp" $ toCommand $ params ++ [File src, File dest]) + let p = (proc "cp" $ toCommand $ params ++ [File (fromOsPath src), File (fromOsPath dest)]) { std_out = UseHandle nullh , std_err = UseHandle nullh } @@ -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 38f8d09aee..6d5ea6c0bf 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,12 +149,12 @@ 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 @@ -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 . map fromRawFilePath <$> dirContents (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..d7573d7475 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,20 +121,20 @@ 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 #if WITH_WIN32NOTIFY type DirWatcherHandle = Win32Notify.WatchManager -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO Win32Notify.WatchManager -> IO Win32Notify.WatchManager) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO Win32Notify.WatchManager -> IO Win32Notify.WatchManager) -> IO DirWatcherHandle watchDir dir prune scanevents hooks runstartup = runstartup $ Win32Notify.watchDir dir prune scanevents hooks #else 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 5f53c13bf5..3291f4a77a 100644 --- a/Utility/DirWatcher/Win32Notify.hs +++ b/Utility/DirWatcher/Win32Notify.hs @@ -14,15 +14,15 @@ import qualified Utility.RawFilePath as R import System.Win32.Notify import System.PosixCompat.Files (isRegularFile) -watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO WatchManager +watchDir :: OsPath -> (OsPath -> Bool) -> Bool -> WatchHooks -> IO WatchManager watchDir dir ignored scanevents hooks = do scan dir wm <- initWatchManager - void $ watchDirectory wm dir True [Create, Delete, Modify, Move] dispatch + void $ watchDirectory wm (fromOsPath dir) True [Create, Delete, Modify, Move] dispatch return wm where dispatch evt - | ignoredPath ignored (filePath evt) = noop + | ignoredPath ignored (toOsPath (filePath evt)) = noop | otherwise = case evt of (Deleted _ _) | isDirectory evt -> runhook delDirHook Nothing @@ -40,11 +40,11 @@ watchDir dir ignored scanevents hooks = do runhook addHook Nothing runhook modifyHook Nothing where - runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks) + runhook h s = maybe noop (\a -> a (toOsPath (filePath evt)) s) (h hooks) scan d = unless (ignoredPath ignored d) $ - mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist - (dirContentsRecursiveSkipping (const False) False (toRawFilePath d)) + mapM_ go =<< emptyWhenDoesNotExist + (dirContentsRecursiveSkipping (const False) False d) where go f | ignoredPath ignored f = noop @@ -61,8 +61,8 @@ watchDir dir ignored scanevents hooks = do where runhook h s = maybe noop (\a -> a f s) (h hooks) - getstatus = catchMaybeIO . R.getFileStatus . toRawFilePath + getstatus = catchMaybeIO . R.getFileStatus . fromOsPath {- Check each component of the path to see if it's ignored. -} -ignoredPath :: (FilePath -> Bool) -> FilePath -> Bool +ignoredPath :: (OsPath -> Bool) -> OsPath -> Bool ignoredPath ignored = any ignored . map dropTrailingPathSeparator . splitPath 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 a74416d2f8..8ae6b32e40 100644 --- a/Utility/Directory/Stream.hs +++ b/Utility/Directory/Stream.hs @@ -7,6 +7,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory.Stream ( @@ -24,7 +25,6 @@ import Prelude #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 -import System.FilePath #else import qualified Data.ByteString as B import qualified System.Posix.Directory.ByteString as Posix @@ -33,6 +33,7 @@ import qualified System.Posix.Directory.ByteString as Posix import Utility.Directory import Utility.Exception import Utility.FileSystemEncoding +import Utility.OsPath #ifndef mingw32_HOST_OS data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream @@ -49,7 +50,7 @@ openDirectory path = do isopen <- newMVar () return (DirectoryHandle isopen dirp) #else - (h, fdat) <- Win32.findFirstFile (fromRawFilePath path "*") + (h, fdat) <- Win32.findFirstFile (fromOsPath (toOsPath path literalOsPath "*")) -- Indicate that the fdat contains a filename that readDirectory -- has not yet returned, by making the MVar be full. -- (There's always at least a "." entry.) @@ -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 6a22025963..f10cb20ffc 100644 --- a/Utility/FileIO.hs +++ b/Utility/FileIO.hs @@ -16,6 +16,8 @@ module Utility.FileIO ( withFile, openFile, + withBinaryFile, + openBinaryFile, readFile, readFile', writeFile, @@ -35,7 +37,6 @@ 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 Prelude (return) import qualified System.File.OsPath as O @@ -53,6 +54,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) @@ -93,20 +104,50 @@ openTempFile p s = do #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 Data.ByteString.Lazy (readFile, writeFile, appendFile) +import Utility.FileSystemEncoding +import System.IO (IO, Handle, IOMode) +import Prelude ((.), return) +import qualified System.IO 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 4858b0bdff..36f37889a6 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -18,12 +18,12 @@ module Utility.FileSize ( import Control.Exception (bracket) import System.IO import qualified Utility.FileIO as F -import Utility.OsPath #else import System.PosixCompat.Files (fileSize) +import qualified Utility.RawFilePath as R #endif import System.PosixCompat.Files (FileStatus) -import qualified Utility.RawFilePath as R +import Utility.OsPath type FileSize = Integer @@ -33,18 +33,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 cf9355ccd5..d66d8a008c 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -23,7 +23,6 @@ module Utility.FileSystemEncoding ( import qualified GHC.IO.Encoding as Encoding import System.IO -import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS @@ -37,6 +36,9 @@ import Data.Char import Data.List #endif +-- | A literal file path +type RawFilePath = S.ByteString + {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current - locale. @@ -90,9 +92,7 @@ encodeBL = L8.fromString decodeBS :: S.ByteString -> FilePath #ifndef mingw32_HOST_OS -- This does the same thing as System.FilePath.ByteString.decodeFilePath, --- with an identical implementation. However, older versions of that library --- truncated at NUL, which this must not do, because it may end up used on --- something other than a unix filepath. +-- with an identical implementation. {-# NOINLINE decodeBS #-} decodeBS b = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding @@ -104,9 +104,7 @@ decodeBS = S8.toString encodeBS :: FilePath -> S.ByteString #ifndef mingw32_HOST_OS -- This does the same thing as System.FilePath.ByteString.encodeFilePath, --- with an identical implementation. However, older versions of that library --- truncated at NUL, which this must not do, because it may end up used on --- something other than a unix filepath. +-- with an identical implementation. {-# NOINLINE encodeBS #-} encodeBS f = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding @@ -116,10 +114,10 @@ encodeBS = S8.fromString #endif fromRawFilePath :: RawFilePath -> FilePath -fromRawFilePath = decodeFilePath +fromRawFilePath = decodeBS toRawFilePath :: FilePath -> RawFilePath -toRawFilePath = encodeFilePath +toRawFilePath = encodeBS {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. 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 5fe911528d..6c13392032 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 (toOsPath "gpg") $ \tmpfile h -> do + withTmpFile (literalOsPath "gpg") $ \tmpfile h -> do liftIO $ B.hPutStr h passphrase liftIO $ hClose h - let passphrasefile = [Param "--passphrase-file", File (fromRawFilePath (fromOsPath 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..cce5ca99bf 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -24,13 +24,13 @@ import Utility.Monad import Utility.Path import Utility.Path.AbsRel 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 @@ -38,42 +38,42 @@ 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 :: (OsPath -> OsPath -> IO ()) -> OsPath -> OsPath -> IO (Maybe OsPath) installLib installfile top lib = ifM (doesFileExist lib) ( do installfile top lib checksymlink lib - return $ Just $ fromRawFilePath $ parentDir $ toRawFilePath lib + return $ Just $ parentDir 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) + checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (fromOsPath (inTop top f))) $ do + l <- readSymbolicLink (fromOsPath (inTop top f)) + let absl = absPathFrom (parentDir f) (toOsPath l) + target <- relPathDirToFile (takeDirectory f) absl + installfile top absl + removeWhenExistsWith removeFile (inTop top f) + createSymbolicLink (fromOsPath target) (fromOsPath (inTop top f)) + checksymlink absl -- Note that f is not relative, so cannot use -inTop :: FilePath -> FilePath -> FilePath -inTop top f = top ++ f +inTop :: OsPath -> OsPath -> OsPath +inTop top f = top <> f {- Parse ldd output, getting all the libraries that the input files - link to. Note that some of the libraries may not exist - (eg, linux-vdso.so) -} -parseLdd :: String -> [FilePath] -parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines +parseLdd :: String -> [OsPath] +parseLdd = map toOsPath + . mapMaybe (getlib . dropWhile isSpace) + . lines where getlib l = headMaybe . words =<< lastMaybe (split " => " l) -runLdd :: [String] -> IO [FilePath] +runLdd :: [OsPath] -> IO [OsPath] runLdd exes = concat <$> mapM go exes where - go exe = tryNonAsync (readProcess "ldd" [exe]) >>= \case + go exe = tryNonAsync (readProcess "ldd" [fromOsPath exe]) >>= \case Right o -> return (parseLdd o) -- ldd for some reason segfaults when run in an arm64 -- chroot on an amd64 host, on a binary produced by ghc. @@ -81,21 +81,21 @@ runLdd exes = concat <$> mapM go exes Left _e -> do environ <- getEnvironment let environ' =("LD_TRACE_LOADED_OBJECTS","1"):environ - parseLdd <$> readProcessEnv exe [] (Just environ') + parseLdd <$> readProcessEnv (fromOsPath exe) [] (Just environ') {- Get all glibc libs, and also libgcc_s - - XXX Debian specific. -} -glibcLibs :: IO [FilePath] +glibcLibs :: IO [OsPath] glibcLibs = do ls <- lines <$> readProcess "sh" ["-c", "dpkg -L libc6:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"] ls2 <- lines <$> readProcess "sh" ["-c", "(dpkg -L libgcc-s1:$(dpkg --print-architecture 2>/dev/null) || dpkg -L libgcc1:$(dpkg --print-architecture)) | egrep '\\.so'"] - return (ls++ls2) + return (map toOsPath (ls++ls2)) {- Get gblibc's gconv libs, which are handled specially.. -} -gconvLibs :: IO [FilePath] -gconvLibs = lines <$> readProcess "sh" +gconvLibs :: IO [OsPath] +gconvLibs = map toOsPath . lines <$> readProcess "sh" ["-c", "dpkg -L libc6:$(dpkg --print-architecture) | grep /gconv/"] diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 4ed730ccff..7a08f67c58 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 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 @@ -191,36 +190,38 @@ tryLock lockfile = do -- -- However, not all filesystems support hard links. So, first probe -- to see if they are supported. If not, use open with O_EXCL. -linkToLock :: SideLockHandle -> RawFilePath -> RawFilePath -> IO (Maybe FileStatus) +linkToLock :: SideLockHandle -> OsPath -> OsPath -> IO (Maybe FileStatus) linkToLock Nothing _ _ = return Nothing linkToLock (Just _) src dest = do - let probe = src <> ".lnk" - v <- tryIO $ createLink src probe - removeWhenExistsWith removeLink probe + let probe = src <> literalOsPath ".lnk" + v <- tryIO $ createLink src' (fromOsPath probe) + removeWhenExistsWith removeFile probe case v of Right _ -> do - _ <- tryIO $ createLink src dest + _ <- tryIO $ createLink src' dest' ifM (catchBoolIO checklinked) ( ifM (catchBoolIO $ not <$> checkInsaneLustre dest) - ( catchMaybeIO $ getFileStatus dest + ( catchMaybeIO $ getFileStatus dest' , return Nothing ) , return Nothing ) Left _ -> catchMaybeIO $ do let setup = do - fd <- openFdWithMode dest WriteOnly + fd <- openFdWithMode dest' WriteOnly (Just $ combineModes readModes) (defaultFileFlags {exclusive = True}) fdToHandle fd let cleanup = hClose - let go h = readFile (fromRawFilePath src) >>= hPutStr h + let go h = readFile (fromOsPath src) >>= hPutStr h bracket setup cleanup go - getFileStatus dest + getFileStatus dest' where + src' = fromOsPath src + dest' = fromOsPath dest checklinked = do - x <- getSymbolicLinkStatus src - y <- getSymbolicLinkStatus dest + x <- getSymbolicLinkStatus src' + y <- getSymbolicLinkStatus dest' return $ and [ deviceID x == deviceID y , fileID x == fileID y @@ -243,16 +244,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 +269,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 +281,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 +297,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 +313,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 +328,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 8e6c6d2905..9b2248c0a8 100644 --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -21,11 +21,12 @@ import Control.Concurrent import Utility.Path.Windows import Utility.FileSystemEncoding +import Utility.OsPath #if MIN_VERSION_Win32(2,13,4) import Common (tryNonAsync) #endif -type LockFile = RawFilePath +type LockFile = OsPath type LockHandle = HANDLE @@ -60,7 +61,7 @@ lockExclusive = openLock fILE_SHARE_NONE -} openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do - f' <- convertToWindowsNativeNamespace f + f' <- convertToWindowsNativeNamespace (fromOsPath f) #if MIN_VERSION_Win32(2,13,4) r <- tryNonAsync $ createFile_NoRetry (fromRawFilePath f') gENERIC_READ sharemode Nothing oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL 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 12b02cbd81..54e156920b 100644 --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -21,32 +21,30 @@ import Prelude import System.PosixCompat.Files (isDirectory) import Control.Monad.IfElse import Utility.SafeCommand +import qualified Utility.RawFilePath as R #endif 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,24 +56,24 @@ 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 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/OpenFd.hs b/Utility/OpenFd.hs index 16a364a4d1..17be54e016 100644 --- a/Utility/OpenFd.hs +++ b/Utility/OpenFd.hs @@ -14,7 +14,8 @@ module Utility.OpenFd where import System.Posix.IO.ByteString import System.Posix.Types -import System.FilePath.ByteString (RawFilePath) + +import Utility.RawFilePath openFdWithMode :: RawFilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd #if MIN_VERSION_unix(2,8,0) diff --git a/Utility/OsPath.hs b/Utility/OsPath.hs index 59302cd53e..e935b84d3d 100644 --- a/Utility/OsPath.hs +++ b/Utility/OsPath.hs @@ -7,59 +7,131 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.OsPath ( OsPath, OsString, + 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 +import qualified System.FilePath as PS #if defined(mingw32_HOST_OS) import GHC.IO (unsafePerformIO) import System.OsString.Encoding.Internal (cWcharsToChars_UCS2) import qualified System.OsString.Data.ByteString.Short.Word16 as BS16 #endif - -toOsPath :: RawFilePath -> OsPath -#if defined(mingw32_HOST_OS) --- On Windows, OsString contains a ShortByteString that is --- utf-16 encoded. So have to convert the input to that. --- This is relatively expensive. -toOsPath = unsafePerformIO . encodeFS . fromRawFilePath #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) --- On Windows, OsString contains a ShortByteString that is --- utf-16 encoded. So have to convert the input from that. --- This is relatively expensive. -fromOsPath = toRawFilePath . cWcharsToChars_UCS2 . BS16.unpack . 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 <$> PS.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..18abcb250d 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,10 +38,11 @@ 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 -import Utility.FileSystemEncoding #endif copyright :: Authored t => t @@ -53,15 +52,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 +68,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 +119,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 +156,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 +174,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 +212,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,15 +225,15 @@ 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 + . fromOsPath -- Get just the drive letter, removing any leading -- path separator, which takeDrive leaves on the drive -- letter. - . dropWhileEnd (isPathSeparator . fromIntegral . ord) - . fromRawFilePath + . OS.dropWhileEnd isPathSeparator . takeDrive #endif @@ -251,15 +251,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 <> literalOsPath ".exe"] #else [f] #endif @@ -270,10 +271,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..ab9c9518e0 100644 --- a/Utility/Path/Windows.hs +++ b/Utility/Path/Windows.hs @@ -13,12 +13,13 @@ module Utility.Path.Windows ( ) where import Utility.Path +import Utility.OsPath +import qualified Utility.OsString as OS +import Utility.SystemDirectory import Utility.FileSystemEncoding -import System.FilePath.ByteString (combine) import qualified Data.ByteString as B -import qualified System.FilePath.Windows.ByteString as P -import System.Directory (getCurrentDirectory) +import qualified System.FilePath.Windows as WinPath {- Convert a filepath to use Windows's native namespace. - This avoids filesystem length limits. @@ -36,11 +37,17 @@ 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 = simplifyPath (combine cwd (toOsPath f)) + -- If the input path is absolute but does not include a drive, + -- add the drive from the cwd, because a path in the native + -- namespace must include a drive. + let p' = if OS.null (takeDrive p) + then joinDrive (takeDrive cwd) p + else p -- Normalize slashes. - let p' = P.normalise p - return (win32_file_namespace <> p') + let p'' = encodeBS $ WinPath.normalise $ fromOsPath p' + return (win32_file_namespace <> p'') where win32_dev_namespace = "\\\\.\\" win32_file_namespace = "\\\\?\\" diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index b39423df5b..33d69230ac 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -22,12 +22,8 @@ module Utility.RawFilePath ( readSymbolicLink, createSymbolicLink, createLink, - removeLink, getFileStatus, getSymbolicLinkStatus, - doesPathExist, - getCurrentDirectory, - createDirectory, setFileMode, setOwnerAndGroup, rename, @@ -38,18 +34,6 @@ module Utility.RawFilePath ( #ifndef mingw32_HOST_OS import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString -import qualified System.Posix.Directory.ByteString as D - --- | Checks if a file or directory exists. Note that a dangling symlink --- will be false. -doesPathExist :: RawFilePath -> IO Bool -doesPathExist = fileExist - -getCurrentDirectory :: IO RawFilePath -getCurrentDirectory = D.getWorkingDirectory - -createDirectory :: RawFilePath -> IO () -createDirectory p = D.createDirectory p 0o777 #else import System.PosixCompat (FileStatus, FileMode) @@ -76,11 +60,6 @@ createLink a b = do b' <- fromRawFilePath <$> convertToWindowsNativeNamespace b P.createLink a' b' -{- On windows, removeLink is not available, so only remove files, - - not symbolic links. -} -removeLink :: RawFilePath -> IO () -removeLink = D.removeFile . fromRawFilePath - getFileStatus :: RawFilePath -> IO FileStatus getFileStatus p = P.getFileStatus . fromRawFilePath =<< convertToWindowsNativeNamespace p @@ -89,22 +68,13 @@ getSymbolicLinkStatus :: RawFilePath -> IO FileStatus getSymbolicLinkStatus p = P.getSymbolicLinkStatus . fromRawFilePath =<< convertToWindowsNativeNamespace p -doesPathExist :: RawFilePath -> IO Bool -doesPathExist = D.doesPathExist . fromRawFilePath - -getCurrentDirectory :: IO RawFilePath -getCurrentDirectory = toRawFilePath <$> D.getCurrentDirectory - -createDirectory :: RawFilePath -> IO () -createDirectory = D.createDirectory . fromRawFilePath - setFileMode :: RawFilePath -> FileMode -> IO () setFileMode p m = do p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p 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/Rsync.hs b/Utility/Rsync.hs index e377eb965d..1a35aca09c 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -25,6 +25,7 @@ import Utility.Tuple #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix +import qualified Utility.OsString as OS #endif import Data.Char @@ -102,7 +103,7 @@ rsyncUrlIsShell s rsyncUrlIsPath :: String -> Bool rsyncUrlIsPath s #ifdef mingw32_HOST_OS - | not (null (takeDrive s)) = True + | not (OS.null (takeDrive (toOsPath s))) = True #endif | rsyncUrlIsShell s = False | otherwise = ':' `notElem` s @@ -174,15 +175,15 @@ filterRsyncSafeOptions = fst3 . getOpt Permute #ifdef mingw32_HOST_OS toMSYS2Path :: FilePath -> FilePath toMSYS2Path p - | null drive = recombine parts - | otherwise = recombine $ "/" : driveletter drive : parts + | OS.null drive = recombine parts + | otherwise = recombine $ "/" : driveletter (fromOsPath drive) : parts where - (drive, p') = splitDrive p - parts = splitDirectories p' + (drive, p') = splitDrive (toOsPath p) + parts = map fromOsPath $ splitDirectories p' driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath fixtrailing s - | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s + | hasTrailingPathSeparator (toOsPath p) = Posix.addTrailingPathSeparator s | otherwise = s #endif diff --git a/Utility/SafeOutput.hs b/Utility/SafeOutput.hs index d7813860ef..f0da940dee 100644 --- a/Utility/SafeOutput.hs +++ b/Utility/SafeOutput.hs @@ -17,6 +17,11 @@ module Utility.SafeOutput ( import Data.Char import qualified Data.ByteString as S +#ifdef WITH_OSPATH +import qualified Utility.OsString as OS +import Utility.OsPath +#endif + class SafeOutputtable t where safeOutput :: t -> t @@ -26,6 +31,11 @@ instance SafeOutputtable String where instance SafeOutputtable S.ByteString where safeOutput = S.filter (safeOutputChar . chr . fromIntegral) +#ifdef WITH_OSPATH +instance SafeOutputtable OsString where + safeOutput = OS.filter (safeOutputChar . toChar) +#endif + safeOutputChar :: Char -> Bool safeOutputChar c | not (isControl c) = True diff --git a/Utility/Shell.hs b/Utility/Shell.hs index ac2231450d..0d43994f98 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 @@ -20,10 +21,6 @@ import Utility.Exception import Utility.PartialPrelude #endif -#ifdef mingw32_HOST_OS -import System.FilePath -#endif - shellPath :: FilePath shellPath = "/bin/sh" @@ -35,24 +32,24 @@ 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 (c:ps) -> do - let ps' = map Param ps ++ [File f] + let ps' = map Param ps ++ [File (fromOsPath f)] -- If the command is not inSearchPath, -- take the base of it, and run eg "sh" -- which in some cases on windows will work -- despite it not being inSearchPath. ok <- inSearchPath c - return (if ok then c else takeFileName c, ps') + return (if ok then c else fromOsPath (takeFileName (toOsPath c)), ps') _ -> 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 205fa91ff8..8740c6b3d4 100644 --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -70,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 @@ -112,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 @@ -159,10 +159,10 @@ feedRead cmd subcmd params password emptydirectory feeder reader = do go (Just emptydirectory) (passwordfd ++ params) #else -- store the password in a temp file - withTmpFile (toOsPath "sop") $ \tmpfile h -> do + withTmpFile (literalOsPath "sop") $ \tmpfile h -> do liftIO $ B.hPutStr h password liftIO $ hClose h - let passwordfile = [Param $ "--with-password=" ++ fromRawFilePath (fromOsPath 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 @@ -188,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..5db0a9be0f 100644 --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -1,16 +1,106 @@ -{- 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 + +createDirectory :: OsPath -> IO () +createDirectory = X.createDirectory . fromOsPath + +createDirectoryIfMissing :: Bool -> OsPath -> IO () +createDirectoryIfMissing b = X.createDirectoryIfMissing b . fromOsPath + +removeDirectory :: OsPath -> IO () +removeDirectory = X.removeDirectory . fromOsPath + +removeDirectoryRecursive :: OsPath -> IO () +removeDirectoryRecursive = X.removeDirectoryRecursive . fromOsPath + +removePathForcibly :: OsPath -> IO () +removePathForcibly = X.removePathForcibly . fromOsPath + +renameDirectory :: OsPath -> OsPath -> IO () +renameDirectory a b = X.renameDirectory (fromOsPath a) (fromOsPath b) + +listDirectory :: OsPath -> IO [OsPath] +listDirectory p = map toOsPath <$> X.listDirectory (fromOsPath p) + +getDirectoryContents :: OsPath -> IO [OsPath] +getDirectoryContents p = map toOsPath <$> X.getDirectoryContents (fromOsPath p) + +getCurrentDirectory :: IO OsPath +getCurrentDirectory = toOsPath <$> X.getCurrentDirectory + +setCurrentDirectory :: OsPath -> IO () +setCurrentDirectory = X.setCurrentDirectory . fromOsPath + +withCurrentDirectory :: OsPath -> IO a -> IO a +withCurrentDirectory = X.withCurrentDirectory . fromOsPath + +getTemporaryDirectory :: IO OsPath +getTemporaryDirectory = toOsPath <$> X.getTemporaryDirectory + +removeFile :: OsPath -> IO () +removeFile = X.removeFile . fromOsPath + +renameFile :: OsPath -> OsPath -> IO () +renameFile a b = X.renameFile (fromOsPath a) (fromOsPath b) + +renamePath :: OsPath -> OsPath -> IO () +renamePath a b = X.renamePath (fromOsPath a) (fromOsPath b) + +copyFile :: OsPath -> OsPath -> IO () +copyFile a b = X.copyFile (fromOsPath a) (fromOsPath b) + +canonicalizePath :: OsPath -> IO OsPath +canonicalizePath p = toOsPath <$> X.canonicalizePath (fromOsPath p) + +doesPathExist :: OsPath -> IO Bool +doesPathExist = X.doesPathExist . fromOsPath + +doesFileExist :: OsPath -> IO Bool +doesFileExist = X.doesFileExist . fromOsPath + +doesDirectoryExist :: OsPath -> IO Bool +doesDirectoryExist = X.doesDirectoryExist . fromOsPath + +getModificationTime :: OsPath -> IO UTCTime +getModificationTime = X.getModificationTime . fromOsPath +#endif diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 3f01a01919..f8be5b29c0 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -20,12 +20,12 @@ module Utility.Tmp ( ) where import System.IO -import System.Directory import Control.Monad.IO.Class import System.IO.Error +#ifndef mingw32_HOST_OS import Data.Char import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P +#endif import Utility.Exception import Utility.FileSystemEncoding @@ -33,6 +33,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 @@ -59,14 +60,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, @@ -84,8 +85,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. @@ -99,7 +100,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 @@ -137,5 +138,7 @@ relatedTemplate' _ = "t" - of openTempFile, and some extra has been added to make it longer - than any likely implementation. -} +#ifndef mingw32_HOST_OS templateAddedLength :: Int templateAddedLength = 20 +#endif diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs index c359b9d82d..4064e9bfae 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 #ifndef mingw32_HOST_OS + let p = fromOsPath $ topleveltmpdir template -- 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/Touch.hs b/Utility/Touch.hs index 8831f306a3..67005934bd 100644 --- a/Utility/Touch.hs +++ b/Utility/Touch.hs @@ -14,10 +14,11 @@ module Utility.Touch ( #if ! defined(mingw32_HOST_OS) -import System.FilePath.ByteString (RawFilePath) import System.Posix.Files.ByteString import Data.Time.Clock.POSIX +import Utility.RawFilePath + {- Changes the access and modification times of an existing file. Can follow symlinks, or not. -} touchBoth :: RawFilePath -> POSIXTime -> POSIXTime -> Bool -> IO () 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/doc/bugs/How_to_git_union-merge__63__.mdwn b/doc/bugs/How_to_git_union-merge__63__.mdwn index 3272cd2508..d3beff71f2 100644 --- a/doc/bugs/How_to_git_union-merge__63__.mdwn +++ b/doc/bugs/How_to_git_union-merge__63__.mdwn @@ -22,3 +22,5 @@ Tried with (on a Manjaro box): git-annex rules and is a marvelous tool. I wanted to try the union merging to resolve merge conflicts on non-annexed files. It's not ideal, but might be better than repeated `git annex assist|sync` eventually adding the merge conflict markers `<<<<<<<<<` and the like to the files, breaking things like `.gitattributes` syntax which in turn has more devastating lockup consequences... + +> removed it, [[done]] --[[Joey]] diff --git a/doc/git-union-merge.mdwn b/doc/git-union-merge.mdwn deleted file mode 100644 index ca06d2f933..0000000000 --- a/doc/git-union-merge.mdwn +++ /dev/null @@ -1,38 +0,0 @@ -# NAME - -git-union-merge - Join branches together using a union merge - -# SYNOPSIS - -git union-merge ref ref newref - -# DESCRIPTION - -Does a union merge between two refs, storing the result in the -specified newref. - -The union merge will always succeed, but assumes that files can be merged -simply by concatenating together lines from all the oldrefs, in any order. -So, this is useful only for branches containing log-type data. - -Note that this does not touch the checked out working copy. It operates -entirely on git refs and branches. - -# EXAMPLE - - git union-merge git-annex origin/git-annex refs/heads/git-annex - -Merges the current git-annex branch, and a version from origin, -storing the result in the git-annex branch. - -# BUGS - -File modes are not currently merged. - -# AUTHOR - -Joey Hess - - - -Warning: Automatically converted into a man page by mdwn2man. Edit with care diff --git a/doc/internals.mdwn b/doc/internals.mdwn index 06a98e9559..5b9d7fbfb8 100644 --- a/doc/internals.mdwn +++ b/doc/internals.mdwn @@ -68,7 +68,7 @@ internal tracking of information about git-annex repositories and annexed objects. The files stored in this branch are all designed to be auto-merged -using git's [[union merge driver|git-union-merge]]. So each line +by simply concacenating them together. So each line has a timestamp, to allow the most recent information to be identified. ### `uuid.log` diff --git a/doc/todo/RawFilePath_conversion.mdwn b/doc/todo/RawFilePath_conversion.mdwn index 46c9bc3bbe..c10b62cf2e 100644 --- a/doc/todo/RawFilePath_conversion.mdwn +++ b/doc/todo/RawFilePath_conversion.mdwn @@ -1,75 +1,50 @@ For a long time (since 2019) git-annex has been progressively converting from -FilePath to RawFilePath (aka ByteString). +FilePath to RawFilePath. And more recently, to OsPath. + +[[!meta title="OsPath conversion"]] The reason is mostly performance, also a simpler representation of filepaths that doesn't need encoding hacks to support non-UTF8 values. -Some commands like `git-annex find` use RawFilePath end-to-end. -But this conversion is not yet complete. This is a todo to keep track of the -status. +Some commands like `git-annex find` have been converted end-to-end +with good performance results. And OsPath is used very widly now. +But this conversion is not yet complete. This is a todo to keep track +of the status. + +* The OsPath build flag makes git-annex build with OsPath. Otherwise, + it builds with RawFilePath. The plan is to make that build flag the + default where it is not already as time goes on. And then eventually + remove the build flag and simplify code in git-annex to not need to + support two different build methods. * unix has modules that operate on RawFilePath but no OSPath versions yet. See https://github.com/haskell/unix/issues/240 -* filepath-1.4.100 implements support for OSPath. It is bundled with - ghc-9.6.1 and above. Will need to switch from filepath-bytestring to - this, and to avoid a lot of ifdefs, probably only after git-annex no - longers supports building with older ghc versions. This will entail - replacing all the RawFilePath with OsPath, which should be pretty - mechanical, with only some wrapper functions in Utility.FileIO and - Utility.RawFilePath needing to be changed. + However, this is not really a performance problem, because converting + from an OsPath to a RawFilePath in order to use such a function + is the same amount of work as calling a native OsPath version of the + function would be, because passing a ShortByteString into the FFI entails + making a copy of it. - Work on this is underway, in the `ospath` branch. +* filepath-bytestring is used when not building with OsPath. It's also + in Setup-Depends. In order to stop needing to maintain that library, + the goal is to eliminate it from dependencies. This may need to wait + until the OsPath build flag is removed and OsPath is always used. + +* Git.LsFiles has several `pipeNullSplit'` calls that have toOsPath + mapped over the results. That adds an additional copy, so the lazy + ByteString is converted to strict, + and then to ShortByteString, with a copy each time. This is in the + critical path for large git repos, and might be a noticable slowdown. + There is currently no easy way to go direct from a lazy ByteString to a + ShortByteString, although it would certianly be possible to write low + level code to do it efficiently. Alternatively, it would be possible to + read a strict ByteString direct from a handle, like hGetLine does + (although in this case it would need to stop at the terminating 0 byte) + and unsafePerformIO to stream to a list would avoid needing to rewrite + this code to not use a list. + +* OsPath has by now been pushed about as far as it will go, but here and + there use of FilePath remains in odd corners. These are unlikely to cause + any noticiable performance impact. [[!tag confirmed]] - ----- - -The following patch can be useful to find points where conversions are -done. Especially useful to identify cases where a value is converted -`FilePath -> RawFilePath -> FilePath`. - - diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs - index 2a1dc81bc1..03e6986f6e 100644 - --- a/Utility/FileSystemEncoding.hs - +++ b/Utility/FileSystemEncoding.hs - @@ -84,6 +84,9 @@ encodeBL = L.fromStrict . encodeBS - encodeBL = L8.fromString - #endif - - +debugConversions :: String -> IO () - +debugConversions s = hPutStrLn stderr ("conversion: " ++ s) - + - decodeBS :: S.ByteString -> FilePath - #ifndef mingw32_HOST_OS - -- This does the same thing as System.FilePath.ByteString.decodeFilePath, - @@ -92,6 +95,7 @@ decodeBS :: S.ByteString -> FilePath - -- something other than a unix filepath. - {-# NOINLINE decodeBS #-} - decodeBS b = unsafePerformIO $ do - + debugConversions (show b) - enc <- Encoding.getFileSystemEncoding - S.useAsCStringLen b (GHC.peekCStringLen enc) - #else - @@ -106,17 +110,19 @@ encodeBS :: FilePath -> S.ByteString - -- something other than a unix filepath. - {-# NOINLINE encodeBS #-} - encodeBS f = unsafePerformIO $ do - + debugConversions f - enc <- Encoding.getFileSystemEncoding - - GHC.newCStringLen enc f >>= unsafePackMallocCStringLen - + b <- GHC.newCStringLen enc f >>= unsafePackMallocCStringLen - + return b - #else - encodeBS = S8.fromString - #endif - - fromRawFilePath :: RawFilePath -> FilePath - -fromRawFilePath = decodeFilePath - +fromRawFilePath = decodeBS -- decodeFilePath - - toRawFilePath :: FilePath -> RawFilePath - -toRawFilePath = encodeFilePath - +toRawFilePath = encodeBS -- encodeFilePath - - {- Truncates a FilePath to the given number of bytes (or less), - - as represented on disk. diff --git a/git-annex.cabal b/git-annex.cabal index b662fe482e..fae2a3bbb8 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -159,7 +159,7 @@ Flag Production Description: Enable production build (slower build; faster binary) Flag ParallelBuild - Description: Enable production build (slower build; faster binary) + Description: Enable building in parallel Default: False Manual: True @@ -230,7 +230,6 @@ Executable git-annex directory (>= 1.2.7.0), disk-free-space, filepath, - filepath-bytestring (>= 1.4.2.1.1), IfElse, monad-logger (>= 0.3.10), free, @@ -339,6 +338,9 @@ Executable git-annex filepath (>= 1.5.2.0), file-io (>= 0.1.3) CPP-Options: -DWITH_OSPATH + else + Build-Depends: + filepath-bytestring (>= 1.4.2.1.1) if (os(windows)) Build-Depends: @@ -1106,6 +1108,7 @@ Executable git-annex Utility.OptParse Utility.OSX Utility.OsPath + Utility.OsString Utility.PID Utility.PartialPrelude Utility.Path diff --git a/git-union-merge.hs b/git-union-merge.hs deleted file mode 100644 index c499c530df..0000000000 --- a/git-union-merge.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- git-union-merge program - - - - Copyright 2011 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -import System.Environment - -import Common -import qualified Git.UnionMerge -import qualified Git.Config -import qualified Git.CurrentRepo -import qualified Git.Branch -import qualified Git.Index -import qualified Git -import Utility.FileSystemEncoding - -header :: String -header = "Usage: git-union-merge ref ref newref" - -usage :: IO a -usage = error $ "bad parameters\n\n" ++ header - -tmpIndex :: Git.Repo -> FilePath -tmpIndex g = Git.localGitDir g "index.git-union-merge" - -setup :: Git.Repo -> IO () -setup = cleanup -- idempotency - -cleanup :: Git.Repo -> IO () -cleanup g = nukeFile $ tmpIndex g - -parseArgs :: IO [String] -parseArgs = do - args <- getArgs - if length args /= 3 - then usage - else return args - -main :: IO () -main = do - useFileSystemEncoding - [aref, bref, newref] <- map Git.Ref <$> parseArgs - g <- Git.Config.read =<< Git.CurrentRepo.get - _ <- Git.Index.override (tmpIndex g) g - setup g - Git.UnionMerge.merge aref bref g - _ <- Git.Branch.commit Git.Branch.ManualCommit False "union merge" newref [aref, bref] g - cleanup g diff --git a/stack.yaml b/stack.yaml index e062bdde92..5ff6f33d09 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,10 +11,10 @@ flags: benchmark: true crypton: true servant: true - ospath: false + ospath: true packages: - '.' -resolver: lts-23.2 +resolver: nightly-2025-01-20 extra-deps: - filepath-bytestring-1.5.2.0.2 - aws-0.24.4