diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -221,7 +221,7 @@ , 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 @@ - 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 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -70,6 +70,7 @@ import Logs.AdjustedBranchUpdate import Utility.FileMode import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F import Data.Time.Clock.POSIX import qualified Data.Map as M @@ -160,7 +161,7 @@ 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 @@ -170,13 +171,13 @@ 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, @@ -268,7 +269,7 @@ -- origbranch. _ <- propigateAdjustedCommits' True origbranch adj commitlck - origheadfile <- inRepo $ readFileStrict . Git.Ref.headFile + origheadfile <- inRepo $ F.readFile' . Git.Ref.headFile origheadsha <- inRepo (Git.Ref.sha currbranch) b <- adjustBranch adj origbranch @@ -280,8 +281,8 @@ newheadfile <- case origheadsha of Just s -> do inRepo $ \r -> do - let newheadfile = fromRef s - writeFile (Git.Ref.headFile r) newheadfile + let newheadfile = fromRef' s + F.writeFile' (Git.Ref.headFile r) newheadfile return (Just newheadfile) _ -> return Nothing @@ -295,9 +296,9 @@ unless ok $ case newheadfile of Nothing -> noop Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do - v' <- readFileStrict (Git.Ref.headFile r) + v' <- F.readFile' (Git.Ref.headFile r) when (v == v') $ - writeFile (Git.Ref.headFile r) origheadfile + F.writeFile' (Git.Ref.headFile r) origheadfile return ok | otherwise = preventCommits $ \commitlck -> do @@ -307,16 +308,12 @@ -- adjustment is stable. return True -{- Passed an action that, if it succeeds may get or drop the Key associated - - with the file. When the adjusted branch needs to be refreshed to reflect +{- Passed an action that, if it succeeds may get or drop a key. + - When the adjusted branch needs to be refreshed to reflect - those changes, it's handled here. - - - - Note that the AssociatedFile must be verified by this to point to the - - Key. In some cases, the value was provided by the user and might not - - really be an associated file. -} -adjustedBranchRefresh :: AssociatedFile -> Annex a -> Annex a -adjustedBranchRefresh _af a = do +adjustedBranchRefresh :: Annex a -> Annex a +adjustedBranchRefresh a = do r <- a go return r @@ -450,7 +447,7 @@ 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. @@ -630,7 +627,7 @@ 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 --- a/Annex/AdjustedBranch/Merge.hs +++ b/Annex/AdjustedBranch/Merge.hs @@ -29,9 +29,7 @@ import Utility.Tmp.Dir import Utility.CopyFile import Utility.Directory.Create - -import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P +import qualified Utility.FileIO as F canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool canMergeToAdjustedBranch tomerge (origbranch, adj) = @@ -72,26 +70,26 @@ -} changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do git_dir <- fromRepo Git.localGitDir - let git_dir' = fromRawFilePath git_dir tmpwt <- fromRepo gitAnnexMergeDir - withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ + withTmpDirIn othertmpdir (literalOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $ withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do - 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' "refs" - let refs' = (git_dir' "packed-refs") : refs + git_dir literalOsPath "refs" + let refs' = (git_dir literalOsPath "packed-refs") : refs liftIO $ forM_ refs' $ \src -> do - let src' = toRawFilePath src whenM (doesFileExist src) $ do - dest <- relPathDirToFile git_dir src' - let dest' = toRawFilePath tmpgit P. dest + dest <- relPathDirToFile git_dir src + let dest' = tmpgit dest createDirectoryUnder [git_dir] - (P.takeDirectory dest') - void $ createLinkOrCopy src' dest' + (takeDirectory dest') + void $ createLinkOrCopy src dest' -- This reset makes git merge not care -- that the work tree is empty; otherwise -- it will think that all the files have @@ -107,7 +105,7 @@ if merged then do !mergecommit <- liftIO $ extractSha - <$> S.readFile (tmpgit "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 @@ 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 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -35,10 +35,10 @@ import Utility.InodeCache import Utility.FileMode import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F import qualified Data.Set as S import qualified Data.Map as M -import qualified Data.ByteString.Lazy as L import System.PosixCompat.Files (isSymbolicLink) {- Merges from a branch into the current branch (which may not exist yet), @@ -133,7 +133,7 @@ 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 @@ 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 @@ , 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 @@ -- 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 @@ -- 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,15 +230,15 @@ 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 - l <- calcRepo $ gitAnnexLink (toRawFilePath dest) key + l <- fromOsPath <$> calcRepo (gitAnnexLink dest key) unless inoverlay $ replacewithsymlink dest l - dest' <- toRawFilePath <$> stagefile dest + dest' <- stagefile dest stageSymlink dest' =<< hashSymlink l replacewithsymlink dest link = replaceWorkTreeFile dest $ @@ -247,27 +247,27 @@ 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 item $ \tmp -> do c <- catObject sha - liftIO $ L.writeFile (decodeBS tmp) c + liftIO $ F.writeFile tmp c when isexecutable $ liftIO $ void $ tryIO $ modifyFileMode tmp $ @@ -280,7 +280,7 @@ Nothing -> noop Just sha -> do link <- catSymLinkTarget sha - replacewithsymlink item link + replacewithsymlink item (fromOsPath link) (Just TreeFile, Just TreeSymlink) -> replacefile False (Just TreeExecutable, Just TreeSymlink) -> replacefile True _ -> ifM (liftIO $ doesDirectoryExist item) @@ -304,9 +304,9 @@ , 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) @@ -321,13 +321,13 @@ - 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 @@ -335,19 +335,24 @@ 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 @@ -373,19 +378,18 @@ , 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/Balanced.hs b/Annex/Balanced.hs --- a/Annex/Balanced.hs +++ b/Annex/Balanced.hs @@ -11,11 +11,12 @@ import Types.UUID import Utility.Hash -import Data.List import Data.Maybe import Data.Bits (shiftL) import qualified Data.Set as S import qualified Data.ByteArray as BA +import Data.List +import Prelude -- The Int is how many UUIDs to pick. type BalancedPicker = S.Set UUID -> Key -> Int -> [UUID] diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -54,7 +54,6 @@ 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 @@ -96,6 +95,7 @@ import Utility.Directory.Stream import Utility.Tmp import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F {- Name of the branch that is used to store git-annex's information. -} name :: Git.Ref @@ -312,7 +312,7 @@ - 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 @@ -352,7 +352,7 @@ - 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 @@ -368,12 +368,12 @@ - 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 @@ -383,14 +383,14 @@ 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. @@ -399,7 +399,7 @@ , 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. @@ -407,7 +407,7 @@ - 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. @@ -415,7 +415,7 @@ - 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 @@ -448,7 +448,7 @@ - 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) @@ -480,7 +480,7 @@ 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. @@ -492,11 +492,11 @@ - 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 @@ -504,11 +504,11 @@ 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 @@ -610,7 +610,7 @@ - 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)) @@ -628,10 +628,10 @@ {- 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 [] @@ -639,11 +639,11 @@ {- 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"] @@ -680,7 +680,8 @@ 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 @@ -689,7 +690,7 @@ 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 @@ -711,9 +712,9 @@ {- Checks if the index needs to be updated. -} needUpdateIndex :: Git.Ref -> Annex Bool needUpdateIndex branchref = do - f <- fromRawFilePath <$> fromRepo gitAnnexIndexStatus + f <- fromRepo gitAnnexIndexStatus committedref <- Git.Ref . firstLine' <$> - liftIO (catchDefaultIO mempty $ B.readFile f) + liftIO (catchDefaultIO mempty $ F.readFile' f) return (committedref /= branchref) {- Record that the branch's index has been updated to correspond to a @@ -741,25 +742,26 @@ g <- gitRepo st <- getState let dir = gitAnnexJournalDir st g - (jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir) + (jlogf, jlogh) <- openjlog tmpdir withHashObjectHandle $ \h -> withJournalHandle gitAnnexJournalDir $ \jh -> 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. toRawFilePath 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 - hPutStrLn jlogh file + B.hPutStr jlogh (file <> "\n") streamer $ Git.UpdateIndex.updateIndexLine - sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath 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. @@ -767,10 +769,10 @@ hFlush jlogh hSeek jlogh AbsoluteSeek 0 stagedfs <- lines <$> hGetContents jlogh - mapM_ (removeFile . (dir )) stagedfs + mapM_ (removeFile . (dir ) . toOsPath) stagedfs hClose jlogh - removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf) - openjlog tmpdir = liftIO $ openTmpFileIn tmpdir "jlog" + removeWhenExistsWith removeFile jlogf + openjlog tmpdir = liftIO $ openTmpFileIn tmpdir (literalOsPath "jlog") getLocalTransitions :: Annex Transitions getLocalTransitions = @@ -931,8 +933,8 @@ S.fromList . mapMaybe Git.Sha.extractSha . fileLines' <$> content where content = do - f <- fromRawFilePath <$> fromRepo gitAnnexIgnoredRefs - liftIO $ catchDefaultIO mempty $ B.readFile f + f <- fromRepo gitAnnexIgnoredRefs + liftIO $ catchDefaultIO mempty $ F.readFile' f addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex () addMergedRefs [] = return () @@ -949,8 +951,8 @@ getMergedRefs' :: Annex [(Git.Sha, Git.Branch)] getMergedRefs' = do - f <- fromRawFilePath <$> fromRepo gitAnnexMergedRefs - s <- liftIO $ catchDefaultIO mempty $ B.readFile f + f <- fromRepo gitAnnexMergedRefs + s <- liftIO $ catchDefaultIO mempty $ F.readFile' f return $ map parse $ fileLines' s where parse l = @@ -998,7 +1000,7 @@ = 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, @@ -1021,7 +1023,7 @@ -- 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 @@ -1035,7 +1037,7 @@ else NoUnmergedBranches v overBranchFileContents' - :: (RawFilePath -> Maybe v) + :: (OsPath -> Maybe v) -> (Annex (FileContents v Bool) -> Annex a) -> BranchState -> Annex (a, Git.Sha) @@ -1085,11 +1087,11 @@ - 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 @@ -1097,9 +1099,9 @@ 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 --- a/Annex/BranchState.hs +++ b/Annex/BranchState.hs @@ -118,7 +118,7 @@ , 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 @@ | 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 @@ | 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 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -45,11 +45,11 @@ 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' _ _ = 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 @@ - - 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 --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -23,12 +23,12 @@ 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 Data.ByteString as S -import qualified System.FilePath.ByteString as P newtype ChangedRefs = ChangedRefs [Git.Ref] deriving (Show) @@ -82,7 +82,7 @@ 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 @@ 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 <$> S.readFile 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 --- a/Annex/CheckAttr.hs +++ b/Annex/CheckAttr.hs @@ -29,14 +29,14 @@ , "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 --- a/Annex/CheckIgnore.hs +++ b/Annex/CheckIgnore.hs @@ -22,7 +22,7 @@ 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 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -108,8 +108,8 @@ import Utility.TimeStamp 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 @@ -247,7 +247,7 @@ {- Passed the object content file, and maybe a separate lock file to use, - when the content file itself should not be locked. -} type ContentLocker - = RawFilePath + = OsPath -> Maybe LockFile -> ( Annex (Maybe LockHandle) @@ -259,7 +259,7 @@ -- 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 @@ -277,7 +277,7 @@ 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 @@ -370,24 +370,24 @@ 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 rsp v key af sz action = +getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> Maybe FileSize -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmp rsp v key sz action = checkDiskSpaceToGet key sz False $ - getViaTmpFromDisk rsp v key af action + getViaTmpFromDisk rsp v key action {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk - and not being copied into place. -} -getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool -getViaTmpFromDisk rsp v key af action = checkallowed $ do +getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmpFromDisk rsp v key 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 @@ -400,7 +400,7 @@ else verification if ok then ifM (verifyKeyContentPostRetrieval rsp v verification' key tmpfile) - ( pruneTmpWorkDirBefore tmpfile (moveAnnex key af) + ( pruneTmpWorkDirBefore tmpfile (moveAnnex key) , do verificationOfContentFailed tmpfile return False @@ -433,11 +433,11 @@ - 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. @@ -450,7 +450,7 @@ 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 @@ -462,7 +462,7 @@ , return unabletoget ) -prepTmp :: Key -> Annex RawFilePath +prepTmp :: Key -> Annex OsPath prepTmp key = do tmp <- fromRepo $ gitAnnexTmpObjectLocation key createAnnexDirectory (parentDir tmp) @@ -472,11 +472,11 @@ - 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/ @@ -507,8 +507,8 @@ - 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 af src = ifM (checkSecureHashes' key) +moveAnnex :: Key -> OsPath -> Annex Bool +moveAnnex key src = ifM (checkSecureHashes' key) ( do #ifdef mingw32_HOST_OS {- Windows prevents deletion of files that are not @@ -521,9 +521,9 @@ , return False ) where - storeobject dest = ifM (liftIO $ R.doesPathExist dest) + storeobject dest = ifM (liftIO $ doesPathExist dest) ( alreadyhave - , adjustedBranchRefresh af $ modifyContentDir dest $ do + , adjustedBranchRefresh $ modifyContentDir dest $ do liftIO $ moveFile src dest -- Freeze the object file now that it is in place. -- Waiting until now to freeze it allows for freeze @@ -539,7 +539,7 @@ 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) @@ -562,7 +562,7 @@ {- 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) @@ -579,13 +579,13 @@ - 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) (fromRawFilePath dest) (== LinkAnnexOk) $ \tmp -> + 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) @@ -605,7 +605,7 @@ - - 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 @@ -635,7 +635,7 @@ 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. -} @@ -644,7 +644,7 @@ 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. @@ -653,7 +653,7 @@ - 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 @@ -676,10 +676,10 @@ - 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 ) @@ -704,19 +704,18 @@ 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 @@ -750,7 +749,7 @@ - - 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) @@ -760,14 +759,14 @@ 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 @@ -775,9 +774,9 @@ 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)) $ + ( adjustedBranchRefresh $ depopulatePointerFile key file -- Modified file, so leave it alone. -- If it was a hard link to the annex object, @@ -788,11 +787,11 @@ {- 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 @@ -817,7 +816,7 @@ s <- Annex.getState id r <- Annex.getRead id depth <- gitAnnexLocationDepth <$> Annex.getGitConfig - liftIO $ walk (s, r) depth (fromRawFilePath dir) + liftIO $ walk (s, r) depth dir where walk s depth dir = do contents <- catchDefaultIO [] (dirContents dir) @@ -825,7 +824,7 @@ then do contents' <- filterM present contents keys <- filterM (Annex.eval s . want) $ - mapMaybe (fileKey . P.takeFileName . toRawFilePath) contents' + mapMaybe (fileKey . takeFileName) contents' continue keys [] else do let deeper = walk s (depth - 1) @@ -843,7 +842,7 @@ present _ | inanywhere = pure True present d = presentInAnnex d - presentInAnnex = doesFileExist . contentfile + presentInAnnex = doesPathExist . contentfile contentfile d = d takeFileName d {- Things to do to record changes to content when shutting down. @@ -867,11 +866,11 @@ - 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 @@ -897,18 +896,18 @@ {- 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 @@ -917,15 +916,15 @@ {- 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 [] ) @@ -935,7 +934,7 @@ - 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 @@ -944,8 +943,8 @@ dir <- fromRepo dirspec forM_ dups $ \k -> - pruneTmpWorkDirBefore (dir P. keyFile k) - (liftIO . R.removeLink) + pruneTmpWorkDirBefore (dir keyFile k) + (liftIO . removeFile) if nottransferred then do @@ -960,9 +959,9 @@ - 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 @@ -977,22 +976,21 @@ - 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 @@ -1027,12 +1025,12 @@ 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 @@ -1070,23 +1068,22 @@ - 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) (fromRawFilePath rt) $ \tmp -> - liftIO $ writeFile (fromRawFilePath tmp) $ show t + _ -> replaceFile (const noop) rt $ \tmp -> + 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 <$> readFile (fromRawFilePath rt)) + liftIO $ join <$> tryWhenExists (parsePOSIXTime <$> F.readFile' rt) {- Checks if the retention timestamp is in the future, if so returns - Nothing. @@ -1117,8 +1114,8 @@ {- 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 --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -19,13 +19,12 @@ 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 @@ - 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 @@ - 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 @@ 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 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -30,14 +30,14 @@ - - 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 - let f' = fromRawFilePath f - destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f - liftIO $ removeWhenExistsWith R.removeLink f - (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do + 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 Nothing -> liftIO (writePointerFile tmp k destmode) >> return False @@ -48,23 +48,23 @@ 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 - ic <- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do + 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 --- a/Annex/Content/Presence.hs +++ b/Annex/Content/Presence.hs @@ -33,7 +33,6 @@ 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 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 @@ 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 @@ {- 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 @@ 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 @@ {- 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 @@ - 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 @@ - 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 @@ 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 @@ #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 @@ - 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 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 @@ - 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 --- a/Annex/Content/Presence/LowLevel.hs +++ b/Annex/Content/Presence/LowLevel.hs @@ -12,7 +12,7 @@ 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 --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -15,6 +15,7 @@ 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 @@ - 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 @@ ) ) 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 @@ - (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 @@ 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 --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -23,7 +23,6 @@ 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 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 @@ | 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 @@ 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 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -108,7 +108,7 @@ [ "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/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -11,16 +11,13 @@ import Annex import Annex.CatFile +import Annex.GitShaKey import Types -import Types.Key import qualified Git import qualified Types.Remote as Remote import Git.Quote import Messages -import Data.Maybe -import qualified Data.ByteString.Short as S (fromShort, toShort) - -- From a sha pointing to the content of a file to the key -- to use to export it. When the file is annexed, it's the annexed key. -- When the file is stored in git, it's a special type of key to indicate @@ -30,31 +27,6 @@ where mk (Just k) = k mk Nothing = gitShaKey sha - --- Encodes a git sha as a key. This is used to represent a non-annexed --- file that is stored on a special remote, which necessarily needs a --- key. --- --- This is not the same as a SHA1 key, because the mapping needs to be --- bijective, also because git may not always use SHA1, and because git --- takes a SHA1 of the file size + content, while git-annex SHA1 keys --- only checksum the content. -gitShaKey :: Git.Sha -> Key -gitShaKey (Git.Ref s) = mkKey $ \kd -> kd - { keyName = S.toShort s - , keyVariety = OtherKey "GIT" - } - --- Reverse of gitShaKey -keyGitSha :: Key -> Maybe Git.Sha -keyGitSha k - | fromKey keyVariety k == OtherKey "GIT" = - Just (Git.Ref (S.fromShort (fromKey keyName k))) - | otherwise = Nothing - --- Is a key storing a git sha, and not used for an annexed file? -isGitShaKey :: Key -> Bool -isGitShaKey = isJust . keyGitSha warnExportImportConflict :: Remote -> Annex () warnExportImportConflict r = do diff --git a/Annex/ExternalAddonProcess.hs b/Annex/ExternalAddonProcess.hs --- a/Annex/ExternalAddonProcess.hs +++ b/Annex/ExternalAddonProcess.hs @@ -85,9 +85,9 @@ 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 --- 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 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 @@ 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 @@ 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 @@ , 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 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -18,9 +18,11 @@ 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 @@ -28,8 +30,6 @@ 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 @@ -108,28 +108,29 @@ , 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 @@ -142,7 +143,7 @@ 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 @@ -150,6 +151,6 @@ -- Optimization: Avoid statting .git in the common case; only -- when the gitdir is not in the usual place inside the worktree -- might .git be a file. - | wt ".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 --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -23,7 +23,7 @@ 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 @@ 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 @@ {- 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 @@ - - 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/GitShaKey.hs b/Annex/GitShaKey.hs new file mode 100644 --- /dev/null +++ b/Annex/GitShaKey.hs @@ -0,0 +1,41 @@ +{- Encoding a git sha as a Key + - + - Copyright 2017-2025 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Annex.GitShaKey where + +import Types +import Types.Key +import qualified Git + +import Data.Maybe +import qualified Data.ByteString.Short as S (fromShort, toShort) + +-- Encodes a git sha as a Key. This is used to represent a non-annexed +-- file. For example, when storing a git sha on a special remote. +-- +-- This is not the same as a SHA1 key, because the mapping needs to be +-- bijective, also because git may not always use SHA1, and because git +-- takes a SHA1 of the file size + content, while git-annex SHA1 keys +-- only checksum the content. +gitShaKey :: Git.Sha -> Key +gitShaKey (Git.Ref s) = mkKey $ \kd -> kd + { keyName = S.toShort s + , keyVariety = OtherKey "GIT" + } + +-- Reverse of gitShaKey +keyGitSha :: Key -> Maybe Git.Sha +keyGitSha k + | fromKey keyVariety k == OtherKey "GIT" = + Just (Git.Ref (S.fromShort (fromKey keyName k))) + | otherwise = Nothing + +-- Is a key storing a git sha, and not used for an annexed file? +isGitShaKey :: Key -> Bool +isGitShaKey = isJust . keyGitSha diff --git a/Annex/HashObject.hs b/Annex/HashObject.hs --- a/Annex/HashObject.hs +++ b/Annex/HashObject.hs @@ -28,7 +28,7 @@ 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 --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -9,6 +9,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Hook where import Annex.Common @@ -19,10 +21,11 @@ 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. @@ -32,10 +35,10 @@ ] 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. @@ -43,28 +46,28 @@ 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 @@ -85,7 +88,8 @@ hookWarning h msg = do r <- gitRepo warning $ UnquotedString $ - Git.hookName h ++ " hook (" ++ 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. -} @@ -118,7 +122,7 @@ ( return Nothing , do h <- fromRepo (Git.hookFile hook) - commandfailed h + commandfailed (fromOsPath h) ) runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case Nothing -> return Nothing @@ -129,18 +133,19 @@ ) 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 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Annex.Import ( ImportTreeConfig(..), @@ -37,12 +38,12 @@ import Annex.Link import Annex.LockFile import Annex.Content -import Annex.Export import Annex.RemoteTrackingBranch import Annex.HashObject import Annex.Transfer import Annex.CheckIgnore import Annex.CatFile +import Annex.GitShaKey import Annex.VectorClock import Annex.SpecialRemote.Config import Command @@ -68,9 +69,10 @@ 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 @@ let subtreeref = Ref $ fromRef' finaltree <> ":" - <> getTopFilePath dir + <> fromOsPath (getTopFilePath dir) in fromMaybe emptyTree <$> inRepo (Git.Ref.tree subtreeref) updateexportdb importedtree @@ -349,11 +351,11 @@ 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 @@ -- 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,10 +860,10 @@ 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 + ok <- moveAnnex k tmpfile when ok $ logStatus NoLiveUpdate k InfoPresent return (Just (k, ok)) @@ -871,7 +878,7 @@ 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,12 +901,12 @@ 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 Nothing -> do - ok <- moveAnnex k af tmpfile + ok <- moveAnnex k tmpfile when ok $ do recordcidkey cidmap cid k logStatus NoLiveUpdate k InfoPresent @@ -950,7 +957,7 @@ 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 @@ 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 @@ 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 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -66,7 +66,7 @@ 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 @@ - 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,48 +101,46 @@ 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 (fromRawFilePath tmpdir) $ - relatedTemplate $ "ingest-" ++ takeFileName file + (tmpfile, h) <- openTmpFileIn tmpdir $ + relatedTemplate $ fromOsPath $ + literalOsPath "ingest-" <> takeFileName file hClose h - removeWhenExistsWith R.removeLink (toRawFilePath tmpfile) + removeWhenExistsWith removeFile tmpfile withhardlink' delta tmpfile `catchIO` const (nohardlink' delta) withhardlink' delta tmpfile = do - let tmpfile' = toRawFilePath tmpfile - R.createLink file' tmpfile' - cache <- genInodeCache tmpfile' delta + R.createLink (fromOsPath file) (fromOsPath tmpfile) + cache <- genInodeCache tmpfile delta return $ LockedDown cfg $ KeySource - { keyFilename = file' - , contentLocation = tmpfile' + { 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 @@ -166,7 +164,8 @@ 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) @@ -187,7 +186,7 @@ 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 @@ -199,17 +198,11 @@ | otherwise = gounlocked key mcache golocked key mcache = - tryNonAsync (moveAnnex key naf (contentLocation source)) >>= \case + tryNonAsync (moveAnnex key (contentLocation source)) >>= \case Right True -> success key mcache Right False -> giveup "failed to add content to annex" Left e -> restoreFile (keyFilename source) key e - -- moveAnnex uses the AssociatedFile provided to it to unlock - -- locked files when getting a file in an adjusted branch. - -- That case does not apply here, where we're adding an unlocked - -- file, so provide it nothing. - naf = AssociatedFile Nothing - gounlocked key (Just cache) = do -- Remove temp directory hard link first because -- linkToAnnex falls back to copying if a file @@ -262,12 +255,12 @@ 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) @@ -292,39 +285,38 @@ {- 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 - replaceWorkTreeFile file' $ makeAnnexLink l + 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 - where - file' = fromRawFilePath file {- 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 @@ -369,17 +361,17 @@ - - 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) case mtmp of - Just tmp -> ifM (moveAnnex key af tmp) + Just tmp -> ifM (moveAnnex key tmp) ( linkunlocked mode >> return True , writepointer mode >> return False ) @@ -390,11 +382,10 @@ , do addSymlink file key Nothing case mtmp of - Just tmp -> moveAnnex key af tmp + Just tmp -> moveAnnex key tmp Nothing -> return True ) where - af = AssociatedFile (Just file) mi = case mtmp of Just tmp -> MatchingFile $ FileInfo { contentFile = tmp @@ -412,7 +403,7 @@ {- 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 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -56,6 +56,7 @@ #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 @@ #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 @@ 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 @@ 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 @@ , "" -- 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' :: (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 = 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 @@ 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 @@ -- 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 --- a/Annex/InodeSentinal.hs +++ b/Annex/InodeSentinal.hs @@ -15,7 +15,7 @@ import Utility.InodeCache import Annex.Perms -{- If the sendinal shows the inodes have changed, only the size and mtime +{- If the sentinal shows the inodes have changed, only the size and mtime - are compared. -} compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool compareInodeCaches x y @@ -30,22 +30,22 @@ {- 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 @@ 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 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -26,12 +26,12 @@ 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 @@ -82,7 +82,7 @@ - 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) @@ -91,10 +91,10 @@ ) -- journal file is written atomically let jfile = journalFile file - let tmpfile = tmp P. jfile - liftIO $ withFile (fromRawFilePath 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 @@ -102,20 +102,20 @@ -- 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 ) @@ -133,7 +133,7 @@ -} appendJournalFile :: Journalable content => JournalLocked -> AppendableJournalFile -> content -> Annex () appendJournalFile _jl (AppendableJournalFile (jd, jfile)) content = do - let write = liftIO $ withFile (fromRawFilePath jfile) ReadWriteMode $ \h -> do + let write = liftIO $ F.withFile jfile ReadWriteMode $ \h -> do sz <- hFileSize h when (sz /= 0) $ do hSeek h SeekFromEnd (-1) @@ -160,7 +160,7 @@ -- 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 @@ -178,7 +178,7 @@ - (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 @@ -204,7 +204,7 @@ jfile = journalFile file getfrom d = catchMaybeIO $ discardIncompleteAppend . L.fromStrict - <$> B.readFile (fromRawFilePath (d P. jfile)) + <$> F.readFile' (d jfile) -- Note that this forces read of the whole lazy bytestring. discardIncompleteAppend :: L.ByteString -> L.ByteString @@ -223,18 +223,18 @@ {- 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 @@ -243,17 +243,15 @@ where -- avoid overhead of creating the journal directory when it already -- exists - opendir d = liftIO (openDirectory (fromRawFilePath 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 <- fromRawFilePath <$> fromRepo (getjournaldir st) - liftIO $ - (not <$> isDirectoryEmpty d) - `catchIO` (const $ doesDirectoryExist d) + d <- fromRepo (getjournaldir st) + 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. @@ -262,33 +260,33 @@ - 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 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -38,11 +38,12 @@ 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 @@ -53,7 +54,7 @@ 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. @@ -64,13 +65,13 @@ - 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 @@ -85,9 +86,9 @@ | otherwise -> return Nothing Nothing -> fallback - probesymlink = R.readSymbolicLink file + probesymlink = R.readSymbolicLink (fromOsPath file) - probefilecontent = withFile (fromRawFilePath 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. @@ -102,7 +103,7 @@ then mempty else s -makeAnnexLink :: LinkTarget -> RawFilePath -> Annex () +makeAnnexLink :: LinkTarget -> OsPath -> Annex () makeAnnexLink = makeGitLink {- Creates a link on disk. @@ -112,26 +113,29 @@ - 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 $ S.writeFile (fromRawFilePath 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) @@ -141,7 +145,7 @@ 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) @@ -150,10 +154,10 @@ | maybe False isExecutable mode = TreeExecutable | otherwise = TreeFile -writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO () +writePointerFile :: OsPath -> Key -> Maybe FileMode -> IO () writePointerFile file k mode = do - S.writeFile (fromRawFilePath 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 @@ -186,7 +190,7 @@ - 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 @@ -224,17 +228,18 @@ =<< 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 @@ -245,7 +250,9 @@ when (numfiles > 0) $ bracket lockindex unlockindex go where - withtmpdir = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" + withtmpdir = withTmpDirIn + (Git.localGitDir r) + (literalOsPath "annexindex") isunmodified tsd f orig = genInodeCache f tsd >>= return . \case @@ -322,7 +329,7 @@ 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" @@ -358,7 +365,8 @@ 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 @@ -397,9 +405,9 @@ 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. @@ -431,21 +439,21 @@ - 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) - withFile (fromRawFilePath 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 - , withFile (fromRawFilePath f) ReadMode readhandle + , F.withFile f ReadMode readhandle ) #endif #endif @@ -460,13 +468,14 @@ - 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 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Annex.Locations ( keyFile, @@ -120,7 +121,7 @@ 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 +135,6 @@ import Git.FilePath import Annex.DirHashes import Annex.Fixup -import qualified Utility.RawFilePath as R {- Conventions: - @@ -151,13 +151,13 @@ {- 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 +165,24 @@ - 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 +199,17 @@ - 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 +228,14 @@ 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 +246,19 @@ - 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 +266,23 @@ } {- 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 +292,52 @@ - 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 +346,351 @@ - 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 +742,32 @@ - 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 anyneedesc b + then mconcat $ 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.pack [w] + needesc = map (fromIntegral . ord) ['&', '%', ':', '/'] + +#if MIN_VERSION_bytestring(0,11,3) + anyneedesc = SB.any (`elem` needesc) +#else + anyneedesc = any (`elem` needesc) . SB.unpack +#endif + {- 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 +786,8 @@ - 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 +797,6 @@ - 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 --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -26,11 +26,10 @@ 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 @@ #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 @@ 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 @@ {- 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 @@ {- 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 @@ {- 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 @@ - 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 --- 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 @@ getMagicMimeEncoding, ) where +import Common import Types.Mime import Control.Monad.IO.Class #ifdef WITH_MAGICMIME @@ -23,7 +25,6 @@ import Utility.Env import Control.Concurrent import System.IO.Unsafe (unsafePerformIO) -import Common #else type Magic = () #endif @@ -34,16 +35,18 @@ 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 _ _ = 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 --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -38,7 +38,7 @@ - - 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 @@ 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 --- 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/Notification.hs b/Annex/Notification.hs --- a/Annex/Notification.hs +++ b/Annex/Notification.hs @@ -60,7 +60,7 @@ wanted <- Annex.getRead Annex.desktopnotify when (notifyFinish wanted) $ liftIO $ do client <- DBus.Client.connectSession - void $ Notify.notify client (droppedNote ok (fromRawFilePath f)) + void $ Notify.notify client (droppedNote ok (fromOsPath f)) #else notifyDrop (AssociatedFile (Just _)) _ = noop #endif diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -88,7 +88,7 @@ {- 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 @@ 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 @@ {- 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 @@ - 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 --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -40,20 +40,20 @@ - 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 @@ 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 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 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -49,20 +49,20 @@ 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 @@ 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 @@ - 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 @@ {- 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 @@ 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 @@ - - 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 @@ - 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 @@ - 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 @@ 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 @@ | 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 @@ {- 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 @@ - 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 @@ 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 @@ {- 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 @@ {- 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 @@ <||> (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 --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Annex.Proxy where @@ -30,20 +31,24 @@ import Utility.Metered import Git.Types import qualified Database.Export as Export +import qualified Utility.FileIO as F #ifndef mingw32_HOST_OS 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 as BS import qualified Data.ByteString.Lazy as L -import qualified System.FilePath.ByteString as P import qualified Data.Map as M import qualified Data.Set as S +#ifndef mingw32_HOST_OS +import qualified Data.ByteString as BS import System.IO.Unsafe +#endif proxyRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide proxyRemoteSide clientmaxversion bypass r @@ -173,8 +178,8 @@ -- independently. Also, this key is not getting added into the -- local annex objects. withproxytmpfile k a = withOtherTmp $ \othertmpdir -> - withTmpDirIn (fromRawFilePath othertmpdir) "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) @@ -184,14 +189,14 @@ -- the client, to avoid bad content -- being stored in the special remote. iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k - h <- liftIO $ openFile (fromRawFilePath 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 @@ -258,9 +263,13 @@ storetofile iv h (n - fromIntegral (B.length b)) bs proxyget offset af k = withproxytmpfile k $ \tmpfile -> do - let retrieve = tryNonAsync $ Remote.retrieveKeyFile r k af - (fromRawFilePath tmpfile) nullMeterUpdate vc + let retrieve = tryNonAsync $ Remote.retrieveKeyFile + r k af tmpfile nullMeterUpdate vc +#ifndef mingw32_HOST_OS ordered <- Remote.retrieveKeyFileInOrder r +#else + _ <- Remote.retrieveKeyFileInOrder r +#endif case fromKey keySize k of #ifndef mingw32_HOST_OS Just size | size > 0 && ordered -> do @@ -290,7 +299,7 @@ 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 @@ -342,7 +351,7 @@ 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 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -31,7 +31,7 @@ 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 --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -1,12 +1,10 @@ {- git-annex file replacing - - - Copyright 2013-2021 Joey Hess + - Copyright 2013-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Annex.ReplaceFile ( replaceGitAnnexDirFile, replaceGitDirFile, @@ -19,24 +17,22 @@ import Annex.Tmp import Annex.Perms import Git +import Utility.Tmp import Utility.Tmp.Dir import Utility.Directory.Create -#ifndef mingw32_HOST_OS -import Utility.Path.Max -#endif {- replaceFile on a file located inside the gitAnnexDir. -} -replaceGitAnnexDirFile :: FilePath -> (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 :: FilePath -> (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 :: FilePath -> (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, @@ -54,31 +50,20 @@ - The createdirectory action is only run when moving the file into place - fails, and can create any parent directory structure needed. -} -replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (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 ()) -> FilePath -> (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 othertmpdir' = fromRawFilePath othertmpdir -#ifndef mingw32_HOST_OS - -- Use part of the filename as the template for the temp - -- directory. This does not need to be unique, but it - -- makes it more clear what this temp directory is for. - filemax <- liftIO $ fileNameLengthLimit othertmpdir' - let basetmp = take (filemax `div` 2) (takeFileName file) -#else - -- Windows has limits on the whole path length, so keep - -- it short. - let basetmp = "t" -#endif - withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do - let tmpfile = toRawFilePath (tmpdir basetmp) + let basetmp = relatedTemplate (fromOsPath (takeFileName file)) + withTmpDirIn othertmpdir basetmp $ \tmpdir -> do + let tmpfile = tmpdir basetmp r <- action tmpfile when (checkres r) $ - replaceFileFrom tmpfile (toRawFilePath file) createdirectory + 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 --- a/Annex/RepoSize/LiveUpdate.hs +++ b/Annex/RepoSize/LiveUpdate.hs @@ -23,8 +23,6 @@ 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 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 @@ where go livedir lck pidlockfile now = do void $ tryNonAsync $ do - lockfiles <- liftIO $ filter (not . dirCruft) - <$> 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 @@ 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 @@ ( 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 --- a/Annex/Sim.hs +++ b/Annex/Sim.hs @@ -55,8 +55,6 @@ 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 @@ _ -> 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 @@ <$> 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ ] 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 @@ 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 @@ 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 @@ } 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 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Annex.Ssh ( @@ -38,15 +39,14 @@ import Types.Concurrency import Git.Env import Git.Ssh -import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS import Annex.Perms #ifndef mingw32_HOST_OS import Annex.LockPool #endif import Control.Concurrent.STM -import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P +import qualified Data.ByteString.Short as SBS {- Some ssh commands are fed stdin on a pipe and so should be allowed to - consume it. But ssh commands that are not piped stdin should generally @@ -100,15 +100,16 @@ {- Returns a filename to use for a ssh connection caching socket, and - parameters to enable ssh connection caching. -} -sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [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 -> - let socketfile' = fromRawFilePath socketfile - in (Just socketfile', sshConnectionCachingParams socketfile') + (Just socketfile + , sshConnectionCachingParams (fromOsPath socketfile) + ) -- No connection caching with concurrency is not a good -- combination, so warn the user. go (Left whynocaching) = do @@ -135,10 +136,10 @@ - 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 @@ -165,10 +166,10 @@ - - 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 @@ -189,9 +190,9 @@ 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" @@ -214,7 +215,7 @@ - Locks the socket lock file to prevent other git-annex processes from - stopping the ssh multiplexer on this socket. -} -prepSocket :: FilePath -> 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. @@ -286,13 +287,13 @@ - and this check makes such files be skipped since the corresponding lock - file won't exist. -} -enumSocketFiles :: Annex [FilePath] +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 (fromRawFilePath dir)) + <$> catchDefaultIO [] (dirContents dir) {- Stop any unused ssh connection caching processes. -} sshCleanup :: Annex () @@ -324,45 +325,45 @@ forceSshCleanup :: Annex () forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles -forceStopSsh :: FilePath -> Annex () +forceStopSsh :: OsPath -> Annex () forceStopSsh socketfile = withNullHandle $ \nullh -> do 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 (toRawFilePath 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 :: FilePath -> RawFilePath -socket2lock socket = toRawFilePath (socket ++ lockExt) +socket2lock :: OsPath -> OsPath +socket2lock socket = socket <> lockExt -isLock :: FilePath -> Bool -isLock f = lockExt `isSuffixOf` f +isLock :: OsPath -> Bool +isLock f = lockExt `OS.isSuffixOf` f -lockExt :: String -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. @@ -374,8 +375,9 @@ {- 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. -} @@ -461,7 +463,7 @@ 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 --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -23,7 +23,7 @@ -- directory that is passed to it. However, once the action is done, -- any files left in that directory may be cleaned up by another process at -- any time. -withOtherTmp :: (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 @@ -- 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,17 +58,18 @@ cleanupOtherTmp = do tmplck <- fromRepo gitAnnexTmpOtherLock void $ tryIO $ tryExclusiveLock tmplck $ do - tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir + tmpdir <- fromRepo gitAnnexTmpOtherDir void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir - oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld + oldtmp <- fromRepo gitAnnexTmpOtherDirOld liftIO $ mapM_ cleanold =<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp) - liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty + -- remove when empty + liftIO $ void $ tryIO $ removeDirectory oldtmp where cleanold f = do now <- liftIO getPOSIXTime let oldenough = now - (60 * 60 * 24 * 7) - catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus (toRawFilePath f)) >>= \case + catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus (fromOsPath f)) >>= \case Just mtime | realToFrac mtime <= oldenough -> - void $ tryIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + void $ tryIO $ removeWhenExistsWith removeFile f _ -> return () diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -44,13 +44,11 @@ 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. @@ -80,10 +78,10 @@ Just StallDetectionDisabled -> go Nothing Just sd -> runTransferrer sd r key f d Download witness where - go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f Nothing $ \dest -> + go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key 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 @@ 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 @@ 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 @@ ) #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 @@ 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 @@ -} 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 --- a/Annex/TransferrerPool.hs +++ b/Annex/TransferrerPool.hs @@ -43,7 +43,7 @@ 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 --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -174,13 +174,13 @@ 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 --- 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 @@ - 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/VectorClock.hs b/Annex/VectorClock.hs --- a/Annex/VectorClock.hs +++ b/Annex/VectorClock.hs @@ -21,6 +21,7 @@ import Utility.TimeStamp import Data.ByteString.Builder +import qualified Data.ByteString as B import qualified Data.Attoparsec.ByteString.Lazy as A currentVectorClock :: Annex CandidateVectorClock @@ -76,7 +77,7 @@ buildVectorClock :: VectorClock -> Builder buildVectorClock = string7 . formatVectorClock -parseVectorClock :: String -> Maybe VectorClock +parseVectorClock :: B.ByteString -> Maybe VectorClock parseVectorClock t = VectorClock <$> parsePOSIXTime t vectorClockParser :: A.Parser VectorClock diff --git a/Annex/VectorClock/Utility.hs b/Annex/VectorClock/Utility.hs --- a/Annex/VectorClock/Utility.hs +++ b/Annex/VectorClock/Utility.hs @@ -12,12 +12,13 @@ import Types.VectorClock import Utility.Env import Utility.TimeStamp +import Utility.FileSystemEncoding startVectorClock :: IO (IO CandidateVectorClock) startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK" where go Nothing = timebased - go (Just s) = case parsePOSIXTime s of + go (Just s) = case parsePOSIXTime (encodeBS s) of Just t -> return (pure (CandidateVectorClock t)) Nothing -> timebased -- Avoid using fractional seconds in the CandidateVectorClock. diff --git a/Annex/Verify.hs b/Annex/Verify.hs --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -39,13 +39,13 @@ 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 @@ - 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 @@ -- 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 @@ 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 @@ 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 @@ | 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 @@ 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 @@ -- 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 @@ 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 @@ -- 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 @@ 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 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -40,13 +40,12 @@ 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 @@ - 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ - 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 @@ - 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 - -> (FilePath -> MetaData) + -> (OsPath -> MetaData) -> View -> Maybe Adjustment -> [t] @@ -488,18 +488,18 @@ -- 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 @@ _ -> 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 @@ =<< 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 @@ 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 --- 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 @@ 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 @@ (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 @@ {- 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 @@ 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 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -22,11 +22,11 @@ - 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 @@ - 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 --- 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,6 +31,7 @@ import Utility.Tmp import Messages.Progress import Logs.Transfer +import qualified Utility.FileIO as F import Network.URI import Control.Concurrent.Async @@ -37,7 +39,6 @@ import Data.Either import qualified Data.Aeson as Aeson import GHC.Generics -import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 -- youtube-dl can follow redirects to anywhere, including potentially @@ -71,20 +72,21 @@ -- (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 @@ -99,13 +101,13 @@ 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 = workdirfiles + | otherwise = map fromOsPath <$> workdirfiles workdirfiles = liftIO $ filter (/= filelistfile) - <$> (filterM (doesFileExist) =<< dirContents workdir) + <$> (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) @@ -121,7 +123,7 @@ 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 @@ -144,7 +146,7 @@ , Param progressTemplate , Param "--print-to-file" , Param "after_move:filepath" - , Param filelistfilebase + , Param (fromOsPath filelistfilebase) ] else [] @@ -152,14 +154,14 @@ -- 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 . toRawFilePath) =<< dirContents workdir) + <$> (mapM getFileSize =<< dirContents workdir) reserve <- annexDiskReserve <$> Annex.getGitConfig let maxsize = have - reserve - inprogress + partial if maxsize > 0 @@ -174,12 +176,12 @@ ) -- 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 @@ -224,7 +226,7 @@ -- 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 @@ -235,10 +237,10 @@ -- 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 @@ -268,7 +270,7 @@ 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" @@ -352,7 +354,7 @@ 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 "yt-dlp" $ \tmpfile h -> do +youtubePlaylist' url cmd = withTmpFile (literalOsPath "yt-dlp") $ \tmpfile h -> do hClose h (outerr, ok) <- processTranscript cmd [ "--simulate" @@ -362,14 +364,14 @@ , "--print-to-file" -- Write json with selected fields. , "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j" - , tmpfile + , fromOsPath tmpfile , url ] Nothing if ok then flip catchIO (pure . Left . show) $ do v <- map Aeson.eitherDecodeStrict . B8.lines - <$> B.readFile tmpfile + <$> F.readFile' tmpfile return $ case partitionEithers v of ((parserr:_), _) -> Left $ "yt-dlp json parse error: " ++ parserr @@ -406,5 +408,6 @@ 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 --- a/Assistant.hs +++ b/Assistant.hs @@ -62,40 +62,39 @@ 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 @@ 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 @@ 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 @@ 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 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -395,7 +395,7 @@ 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 --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -15,14 +15,14 @@ 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/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -22,6 +22,7 @@ import qualified Types.Remote as Remote import Config.DynamicConfig import Annex.SpecialRemote.Config +import qualified Utility.FileIO as F import Control.Concurrent.STM import System.Posix.Types @@ -121,9 +122,9 @@ - and parts of it are not relevant. -} writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO () writeDaemonStatusFile file status = - viaTmp writeFile file =<< serialized <$> getPOSIXTime + viaTmp F.writeFile' (toOsPath (toRawFilePath file)) =<< serialized <$> getPOSIXTime where - serialized now = unlines + serialized now = encodeBS $ unlines [ "lastRunning:" ++ show now , "scanComplete:" ++ show (scanComplete status) , "sanityCheckRunning:" ++ show (sanityCheckRunning status) @@ -135,13 +136,13 @@ where parse status = foldr parseline status . lines parseline line status - | key == "lastRunning" = parseval parsePOSIXTime $ \v -> + | key == "lastRunning" = parseval (parsePOSIXTime . encodeBS) $ \v -> status { lastRunning = Just v } | key == "scanComplete" = parseval readish $ \v -> status { scanComplete = v } | key == "sanityCheckRunning" = parseval readish $ \v -> status { sanityCheckRunning = v } - | key == "lastSanityCheck" = parseval parsePOSIXTime $ \v -> + | key == "lastSanityCheck" = parseval (parsePOSIXTime . encodeBS) $ \v -> status { lastSanityCheck = Just v } | otherwise = status -- unparsable line where diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- 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 @@ -17,6 +18,7 @@ import Utility.Tmp import Utility.Env import Utility.SshConfig +import qualified Utility.FileIO as F #ifdef darwin_HOST_OS import Utility.OSX @@ -28,9 +30,10 @@ #endif 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 @@ -49,40 +52,39 @@ , 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 - installAutoStart program autostartfile + installAutoStart (fromOsPath program) autostartfile #else ifM osAndroid ( 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 (sshdir "git-annex-shell") $ unlines + installWrapper (sshdir literalOsPath "git-annex-shell") $ [ shebang , "set -e" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" @@ -91,7 +93,7 @@ , rungitannexshell "$@" , "fi" ] - installWrapper (sshdir "git-annex-wrapper") $ unlines + installWrapper (sshdir literalOsPath "git-annex-wrapper") $ [ shebang , "set -e" , runshell "\"$@\"" @@ -99,45 +101,46 @@ installFileManagerHooks program -installWrapper :: FilePath -> String -> IO () +installWrapper :: OsPath -> [String] -> IO () installWrapper file content = do - curr <- catchDefaultIO "" $ readFileStrict file - when (curr /= content) $ do - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file))) - viaTmp writeFile file content - modifyFileMode (toRawFilePath file) $ - addModes [ownerExecuteMode] + let content' = map encodeBS content + curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' file + when (curr /= content') $ do + 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 (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 f c - modifyFileMode (toRawFilePath f) $ addModes [ownerExecuteMode] + writeFile (fromOsPath f) c + modifyFileMode f $ addModes [ownerExecuteMode] safetoinstallscript f = catchDefaultIO True $ - elem autoaddedcomment . lines <$> readFileStrict f + elem (encodeBS autoaddedcomment) . fileLines' + <$> F.readFile' f autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)" autoaddedmsg = "Automatically added by git-annex, do not edit." @@ -163,7 +166,7 @@ , "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 --- 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.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 --- 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 @@ (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 --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -28,7 +28,7 @@ {- 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 @@ 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 @@ 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 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -22,11 +22,11 @@ {- 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 @@ { 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 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Assistant.Repair where @@ -30,7 +31,7 @@ #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 @@ -95,7 +96,7 @@ 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 @@ -107,7 +108,7 @@ 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. @@ -132,26 +133,26 @@ repairStaleLocks lockfiles return $ not $ null lockfiles where - findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator (fromRawFilePath annexDir)) True . fromRawFilePath . Git.localGitDir + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir islock f - | "gc.pid" `isInfixOf` f = False - | ".lock" `isSuffixOf` f = True - | 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 :: [FilePath] -> Assistant () +repairStaleLocks :: [OsPath] -> Assistant () repairStaleLocks lockfiles = go =<< getsizes where getsize lf = catchMaybeIO $ (\s -> (lf, s)) - <$> getFileSize (toRawFilePath lf) + <$> getFileSize lf getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles go [] = return () - go l = ifM (liftIO $ null <$> Lsof.query ("--" : map 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 . toRawFilePath . 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 --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -18,7 +18,6 @@ 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 @@ 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 @@ 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 @@ - 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 --- 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 @@ -17,6 +19,8 @@ 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 @@ -93,14 +97,14 @@ {- 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 @@ -117,10 +121,10 @@ 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) @@ -148,18 +152,18 @@ 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 = sshdir "authorized_keys" - tryWhenExists (lines <$> readFileStrict keyfile) >>= \case + let keyfile = sshdir literalOsPath "authorized_keys" + tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case Just ls -> viaTmp writeSshConfig keyfile $ unlines $ filter (/= keyline) ls Nothing -> noop @@ -170,7 +174,7 @@ - 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 "; " @@ -201,27 +205,27 @@ ] 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 "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 @@ -244,25 +248,28 @@ 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, @@ -270,8 +277,8 @@ 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 @@ -323,7 +330,7 @@ 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 $ [ "" @@ -331,7 +338,7 @@ , "Host " ++ mangledhost ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) (settings ++ config) - setSshConfigMode (toRawFilePath configfile) + setSshConfigMode (toOsPath configfile) return $ sshdata { sshHostName = T.pack mangledhost @@ -402,7 +409,7 @@ 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 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -67,11 +67,10 @@ 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 @@ - 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 @@ | 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 @@ 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 @@ 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 @@ 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 @@ (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 @@ 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 @@ - 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 @@ - 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 @@ - - 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 @@ 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 @@ 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 @@ <> " 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 @@ 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 @@ 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 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -44,7 +44,7 @@ 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 @@ 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 = 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 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -181,7 +181,7 @@ 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 @@ 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 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -24,8 +24,7 @@ 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 "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 @@ , 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 @@ - 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 @@ - 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 @@ 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 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -138,12 +138,12 @@ 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 @@ - 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 @@ 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 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -121,7 +121,7 @@ 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 --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -28,7 +28,7 @@ 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 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -68,7 +68,7 @@ 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 @@ - 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 @@ 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 @@ {- 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 @@ 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 @@ -} 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 @@ 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/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -47,7 +47,7 @@ | otherwise = do let (f, _, _) = transferFileAndLockFile t g mi <- liftIO $ catchDefaultIO Nothing $ - readTransferInfoFile Nothing (fromRawFilePath f) + readTransferInfoFile Nothing f maybe noop (newsize t info . bytesComplete) mi newsize t info sz diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -38,25 +38,25 @@ , 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 :: Handler OsPath onAdd file = case parseTransferFile file of Nothing -> noop Just t -> go t =<< liftAnnex (checkTransfer t) @@ -72,7 +72,7 @@ - - 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 :: Handler OsPath onModify file = case parseTransferFile file of Nothing -> noop Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) @@ -87,7 +87,7 @@ watchesTransferSize = modifyTracked {- Called when a transfer information file is removed. -} -onDel :: Handler +onDel :: Handler OsPath onDel file = case parseTransferFile file of Nothing -> noop Just t -> do diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -46,7 +46,7 @@ , modifyHook = changed , delDirHook = changed } - let dir = 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 @@ 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 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -42,6 +42,7 @@ 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 @@ 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 @@ 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 @@ {- 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 == literalOsPath ".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 @@ 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 @@ 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 @@ , 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 @@ 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,17 +275,16 @@ -} 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 @@ -315,33 +314,32 @@ 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 @@ - 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 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -62,7 +62,7 @@ -> 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 @@ , return app ) runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex - then withTmpFile "webapp.html" $ \tmpfile h -> do + then withTmpFile (literalOsPath "webapp.html") $ \tmpfile h -> do hClose h 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 @@ 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 @@ 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 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -174,7 +174,7 @@ 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 --- 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 @@ 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 (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 --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -34,7 +34,7 @@ - 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 @@ 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 --- 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 @@ -41,6 +42,8 @@ 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 @@ -87,12 +90,12 @@ 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 @@ -108,7 +111,7 @@ - - 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"] @@ -118,11 +121,11 @@ 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 @@ -140,7 +143,7 @@ - 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 @@ -154,92 +157,92 @@ postUpgrade url where changeprogram program = liftIO $ do - unlessM (boolSystem program [Param "version"]) $ + unlessM (boolSystem (fromOsPath program) [Param "version"]) $ giveup "New git-annex program failed to run! Not using." pf <- programFile - liftIO $ writeFile pf program + liftIO $ writeFile (fromOsPath pf) (fromOsPath program) #ifdef darwin_HOST_OS {- OS X uses a dmg, so mount it, and copy the contents into place. -} unpack = liftIO $ do olddir <- oldVersionLocation - withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) "git-annex.upgrade" $ \tmpdir -> do + withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do void $ boolSystem "hdiutil" - [ Param "attach", File distributionfile - , Param "-mountpoint", File tmpdir + [ Param "attach", File (fromOsPath distributionfile) + , Param "-mountpoint", File (fromOsPath tmpdir) ] void $ boolSystem "cp" [ Param "-R" - , File $ tmpdir installBase "Contents" - , File $ newdir + , File $ fromOsPath $ tmpdir toOsPath installBase literalOsPath "Contents" + , File (fromOsPath newdir) ] void $ boolSystem "hdiutil" [ Param "eject" - , File tmpdir + , File (fromOsPath tmpdir) ] sanitycheck newdir let deleteold = do - deleteFromManifest $ olddir "Contents" "MacOS" + deleteFromManifest $ 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) "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 (toRawFilePath x) (toRawFilePath (dstdir takeFileName x))) + 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. @@ -249,15 +252,15 @@ - - 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)) @@ -275,16 +278,17 @@ #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) + 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 :: FilePath -> IO () +removeEmptyRecursive :: OsPath -> IO () removeEmptyRecursive dir = do mapM_ removeEmptyRecursive =<< dirContents dir void $ tryIO $ removeDirectory dir @@ -292,7 +296,7 @@ {- 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 @@ -307,13 +311,13 @@ 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" @@ -322,13 +326,14 @@ downloadDistributionInfo = do uo <- liftAnnex Url.getUrlOptions gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig - liftIO $ withTmpDir "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 <$> readFileStrict infof + ( parseInfoFile . map decodeBS . fileLines' + <$> F.readFile' infof , return Nothing ) @@ -357,20 +362,20 @@ - 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 "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 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -78,7 +78,7 @@ 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 @@ -90,8 +90,7 @@ mapM_ (\r -> changeSyncable (Just r) False) rs liftAnnex $ prepareRemoveAnnexDir dir - liftIO $ removeDirectoryRecursive . fromRawFilePath - =<< absPath (toRawFilePath 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 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -121,7 +121,7 @@ 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 @@ 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 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -81,24 +81,24 @@ 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 @@ - 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 @@ 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 @@ ((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 = 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 @@ 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 @@ ] 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 = 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 @@ 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 @@ 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 @@ 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 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 @@ - - 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 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -72,7 +72,7 @@ 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 @@ 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 --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -23,7 +23,6 @@ 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 @@ 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 @@ 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 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -76,7 +76,7 @@ , 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 @@ <*> 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 @@ v <- getCachedCred login liftIO $ case v of Nothing -> go [passwordprompts 0] Nothing - Just pass -> withTmpFile "ssh" $ \passfile h -> do + Just pass -> withTmpFile (literalOsPath "ssh") $ \passfile h -> do hClose h - writeFileProtected (toRawFilePath passfile) pass + writeFileProtected passfile pass environ <- getEnvironment let environ' = addEntries - [ ("SSH_ASKPASS", program) - , (sshAskPassEnv, passfile) + [ ("SSH_ASKPASS", fromOsPath program) + , (sshAskPassEnv, fromOsPath passfile) , ("DISPLAY", ":0") ] environ go [passwordprompts 1] (Just environ') @@ -531,7 +531,7 @@ ] , 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 @@ |] 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 --- a/Assistant/WebApp/Configurators/Unused.hs +++ b/Assistant/WebApp/Configurators/Unused.hs @@ -51,7 +51,7 @@ 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 --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -73,6 +73,6 @@ getLogR :: Handler Html getLogR = page "Logs" Nothing $ do logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile - logs <- liftIO $ listLogs (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 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -45,7 +45,7 @@ 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 @@ - 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 --- a/Assistant/WebApp/Documentation.hs +++ b/Assistant/WebApp/Documentation.hs @@ -16,10 +16,10 @@ {- 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 @@ 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 --- a/Assistant/WebApp/OtherRepos.hs +++ b/Assistant/WebApp/OtherRepos.hs @@ -15,7 +15,6 @@ 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 @@ 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 --- a/Backend.hs +++ b/Backend.hs @@ -10,13 +10,14 @@ module Backend ( builtinList, defaultBackend, - defaultHashBackend, + hashBackend, genKey, getBackend, chooseBackend, lookupBackendVariety, lookupBuiltinBackendVariety, maybeLookupBackendVariety, + unknownBackendVarietyMessage, isStableKey, isCryptographicallySecureKey, isCryptographicallySecure, @@ -54,6 +55,15 @@ valid name = not (null name) lookupname = lookupBackendVariety . parseKeyVariety . encodeBS +{- A hashing backend. Takes git config into account, but + - guarantees the backend is cryptographically secure. -} +hashBackend :: Annex Backend +hashBackend = do + db <- defaultBackend + return $ if isCryptographicallySecure db + then db + else defaultHashBackend + {- Generates a key for a file. -} genKey :: KeySource -> MeterUpdate -> Backend -> Annex (Key, Backend) genKey source meterupdate b = case B.genKey b of @@ -63,11 +73,11 @@ 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 +88,7 @@ {- Looks up the backend that should be used for a file. - That can be configured on a per-file basis in the gitattributes file, - or forced with --backend. -} -chooseBackend :: 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 --- a/Backend/External.hs +++ b/Backend/External.hs @@ -96,7 +96,7 @@ 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 @@ 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 --- a/Backend/GitRemoteAnnex.hs +++ b/Backend/GitRemoteAnnex.hs @@ -75,7 +75,7 @@ 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 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -127,7 +127,7 @@ 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 @@ 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 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -14,11 +14,11 @@ 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 @@ -29,12 +29,12 @@ genKeyName :: String -> S.ShortByteString genKeyName s -- Avoid making keys longer than the length of a SHA256 checksum. - | bytelen > sha256len = S.toShort $ encodeBS $ - truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ - show (md5 bl) - | otherwise = S.toShort $ encodeBS s' + | bytelen > sha256len = S.toShort $ + truncateFilePath (sha256len - md5len - 1) s' + <> "-" <> encodeBS (show (md5 bl)) + | otherwise = S.toShort s' where - s' = preSanitizeKeyName s + s' = encodeBS $ preSanitizeKeyName s bl = encodeBL s bytelen = fromIntegral $ L.length bl @@ -55,7 +55,7 @@ , 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 @@ 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 --- a/Backend/VURL/Utilities.hs +++ b/Backend/VURL/Utilities.hs @@ -10,10 +10,8 @@ import Annex.Common import Types.Key import Types.Backend -import Types.KeySource import Logs.EquivilantKeys import qualified Backend.Hash -import Utility.Metered migrateFromURLToVURL :: Key -> Backend -> AssociatedFile -> Bool -> Annex (Maybe Key) migrateFromURLToVURL oldkey newbackend _af inannex @@ -41,18 +39,3 @@ (keyData oldkey) { keyVariety = URLKey } | otherwise = return Nothing - --- The Backend must use a cryptographically secure hash. -generateEquivilantKey :: Backend -> RawFilePath -> Annex (Maybe Key) -generateEquivilantKey b f = - case genKey b of - Just genkey -> do - showSideAction (UnquotedString Backend.Hash.descChecksum) - Just <$> genkey source nullMeterUpdate - Nothing -> return Nothing - where - source = KeySource - { keyFilename = mempty -- avoid adding any extension - , contentLocation = f - , inodeCache = Nothing - } diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -42,9 +42,9 @@ 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 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -11,6 +11,7 @@ import Utility.Env.Basic import qualified Git.Version import Utility.SystemDirectory +import Utility.OsPath import Control.Monad import Control.Applicative @@ -91,11 +92,11 @@ 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 --- 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 System.Environment #ifndef mingw32_HOST_OS import System.Posix.User -import Data.Maybe -import Control.Applicative import Prelude #endif @@ -42,10 +37,10 @@ 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 @@ 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 @@ ( 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/TestConfig.hs b/Build/TestConfig.hs --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -8,9 +8,9 @@ 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 @@ ) 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 --- a/Build/Version.hs +++ b/Build/Version.hs @@ -1,6 +1,6 @@ {- Package version determination. -} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Build.Version where @@ -14,7 +14,9 @@ import Utility.Monad import Utility.Exception -import Utility.Misc +import Utility.OsPath +import Utility.FileSystemEncoding +import qualified Utility.FileIO as F type Version = String @@ -56,11 +58,11 @@ middle = drop 1 . init writeVersion :: Version -> IO () -writeVersion ver = catchMaybeIO (readFileStrict f) >>= \case +writeVersion ver = catchMaybeIO (F.readFile' f) >>= \case Just s | s == body -> return () - _ -> writeFile f body + _ -> F.writeFile' f body where - body = unlines $ concat + body = encodeBS $ unlines $ concat [ header , ["packageversion :: String"] , ["packageversion = \"" ++ ver ++ "\""] @@ -71,4 +73,4 @@ , "" ] footer = [] - f = "Build/Version" + f = literalOsPath "Build/Version" diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,21 @@ +git-annex (10.20250320) upstream; urgency=medium + + * Added the compute special remote. + * addcomputed: New command, adds a file that is generated by a compute + special remote. + * recompute: New command, recomputes computed files. + * findcomputed: New command, displays information about computed files. + * Support help.autocorrect settings "prompt", "never", and "immediate". + * Allow setting remote.foo.annex-tracking-branch to a branch name + that contains "/", as long as it's not a remote tracking branch. + * Added OsPath build flag, which speeds up git-annex's operations on files. + * git-lfs: Added an optional apiurl parameter. + (This needs version 1.2.5 of the haskell git-lfs library to be used.) + * fsck: Remember the files that are checked, so a later run with --more + will skip them, without needing to use --incremental. + + -- Joey Hess Thu, 20 Mar 2025 13:10:48 -0400 + git-annex (10.20250115) upstream; urgency=medium * Improve handing of ssh connection problems during diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -14,6 +14,10 @@ Copyright: © 2013 Joey Hess License: GPL-3+ +Files: doc/special_remotes/compute/git-annex-compute-imageconvert doc/special_remotes/compute/git-annex-compute-wasmedge doc/special_remotes/compute/git-annex-compute-singularity +Copyright: © 2025 Joey Hess +License: GPL-3+ + Files: doc/design/external_backend_protocol/git-annex-backend-XFOO Copyright: © 2020 Joey Hess License: GPL-3+ diff --git a/CmdLine.hs b/CmdLine.hs --- 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.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 () @@ -92,7 +95,7 @@ handleresult (parseCmd progname progdesc correctedargs allcmds getparser) res -> handleresult res where - autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname (NE.fromList cmds) + autocorrect = Git.AutoCorrect.prepare "git-annex" (fromJust subcommandname) cmdname (NE.fromList cmds) name | fuzzy = case cmds of (c:_) -> Just (cmdname c) @@ -159,17 +162,18 @@ 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 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -154,12 +154,12 @@ -- 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 @@ -- 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/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -133,6 +133,9 @@ import qualified Command.UpdateProxy import qualified Command.MaxSize import qualified Command.Sim +import qualified Command.AddComputed +import qualified Command.Recompute +import qualified Command.FindComputed import qualified Command.Version import qualified Command.RemoteDaemon #ifdef WITH_ASSISTANT @@ -265,6 +268,9 @@ , Command.UpdateProxy.cmd , Command.MaxSize.cmd , Command.Sim.cmd + , Command.AddComputed.cmd + , Command.Recompute.cmd + , Command.FindComputed.cmd , Command.Version.cmd , Command.RemoteDaemon.cmd #ifdef WITH_ASSISTANT diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -136,7 +136,7 @@ "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 --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -48,9 +48,9 @@ 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 @@ 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 --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -57,6 +57,8 @@ import Utility.Env import Utility.Metered import Utility.FileMode +import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F import Network.URI import Data.Either @@ -64,8 +66,6 @@ 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 Utility.RawFilePath as R import qualified Data.Set as S run :: [String] -> IO () @@ -145,13 +145,14 @@ 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 @@ -201,7 +202,8 @@ 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 "" @@ -495,13 +497,15 @@ resolveSpecialRemoteWebUrl url | "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl = Url.withUrlOptionsPromptingCreds $ \uo -> - withTmpFile "git-remote-annex" $ \tmp h -> do + withTmpFile (literalOsPath "git-remote-annex") $ \tmp h -> do liftIO $ hClose h Url.download' nullMeterUpdate Nothing url tmp uo >>= \case Left err -> giveup $ url ++ " " ++ err Right () -> liftIO $ - (headMaybe . lines) - <$> readFileStrict tmp + fmap decodeBS + . headMaybe + . fileLines' + <$> F.readFile' tmp | otherwise = return Nothing where lcurl = map toLower url @@ -724,10 +728,10 @@ -- it needs to re-download it fresh every time, and the object -- file should not be stored locally. gettotmp dl = withOtherTmp $ \othertmp -> - withTmpFileIn (fromRawFilePath othertmp) "GITMANIFEST" $ \tmp tmph -> do + withTmpFileIn othertmp (literalOsPath "GITMANIFEST") $ \tmp tmph -> do liftIO $ hClose tmph _ <- dl tmp - b <- liftIO (B.readFile tmp) + b <- liftIO (F.readFile' tmp) case parseManifest b of Right m -> Just <$> verifyManifest rmt m Left err -> giveup err @@ -774,7 +778,7 @@ dropKey' rmt mk put mk - put mk = withTmpFile "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 @@ -785,13 +789,13 @@ -- keys, which it is not. objfile <- calcRepo (gitAnnexLocation mk) modifyContentDir objfile $ - linkOrCopy mk (toRawFilePath 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 @@ -839,9 +843,11 @@ - 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 @@ -857,7 +863,7 @@ f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt)) oldmanifest <- liftIO $ fromRight mempty . parseManifest - <$> B.readFile (fromRawFilePath f) + <$> F.readFile' f `catchNonAsync` (const (pure mempty)) let oldmanifest' = mkManifest [] $ S.fromList (inManifest oldmanifest) @@ -907,7 +913,7 @@ -- 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 @@ -915,15 +921,15 @@ anyM getexport locs where dlwith a = ifM a - ( decodeBS <$> calcRepo (gitAnnexLocation k) + ( calcRepo (gitAnnexLocation k) , giveup $ "Failed to download " ++ serializeKey k ) getexport loc = catchNonAsync (getexport' loc) (const (pure False)) getexport' loc = - getViaTmp rsp vc k (AssociatedFile Nothing) Nothing $ \tmp -> do + getViaTmp rsp vc k 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 @@ -948,7 +954,7 @@ 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) $ @@ -973,14 +979,14 @@ -> Manifest -> Annex (Key, Annex ()) generateGitBundle rmt bs manifest = - withTmpFile "GITBUNDLE" $ \tmp tmph -> do + withTmpFile (literalOsPath "GITBUNDLE") $ \tmp tmph -> do liftIO $ hClose tmph - inRepo $ Git.Bundle.create tmp bs + inRepo $ Git.Bundle.create (fromOsPath tmp) bs bundlekey <- genGitBundleKey (Remote.uuid rmt) - (toRawFilePath tmp) nullMeterUpdate + tmp nullMeterUpdate if (bundlekey `notElem` inManifest manifest) then do - unlessM (moveAnnex bundlekey (AssociatedFile Nothing) (toRawFilePath tmp)) $ + unlessM (moveAnnex bundlekey tmp) $ giveup "Unable to push" return (bundlekey, uploadaction bundlekey) else return (bundlekey, noop) @@ -1020,7 +1026,7 @@ 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 @@ -1089,7 +1095,7 @@ 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. @@ -1122,11 +1128,11 @@ -- 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 "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, @@ -1160,7 +1166,7 @@ -- 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_ removeFile =<< dirContents alternatejournaldir case sab of @@ -1168,7 +1174,7 @@ 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 @@ -1196,7 +1202,7 @@ 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 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -48,6 +48,7 @@ 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,10 +56,9 @@ import Data.IORef import Data.Time.Clock.POSIX import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID) -import qualified System.FilePath.ByteString as P data AnnexedFileSeeker = AnnexedFileSeeker - { startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart + { startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart , checkContentPresent :: Maybe Bool , usesLocationLog :: Bool } @@ -81,7 +81,7 @@ 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 @@ -95,18 +95,18 @@ 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) [] = @@ -120,15 +120,12 @@ -- 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 -> - let f' = toRawFilePath f - in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f')) - <$> dirContentsRecursiveSkipping (".git" `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 @@ 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 @@ 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 @@ -- 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ | 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 --- a/Command.hs +++ b/Command.hs @@ -144,8 +144,7 @@ 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 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -31,7 +31,6 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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/AddComputed.hs b/Command/AddComputed.hs new file mode 100644 --- /dev/null +++ b/Command/AddComputed.hs @@ -0,0 +1,253 @@ +{- git-annex command + - + - Copyright 2025 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Command.AddComputed where + +import Command +import qualified Git +import qualified Git.Types as Git +import qualified Git.Ref as Git +import qualified Annex +import qualified Remote.Compute +import qualified Types.Remote as Remote +import Backend +import Annex.CatFile +import Annex.Content.Presence +import Annex.Ingest +import Annex.UUID +import Annex.GitShaKey +import Types.KeySource +import Types.Key +import Annex.FileMatcher +import Messages.Progress +import Logs.Location +import Logs.EquivilantKeys +import Utility.Metered +import Backend.URL (fromUrl) +import Git.FilePath + +import qualified Data.Map as M +import Data.Time.Clock + +cmd :: Command +cmd = notBareRepo $ withAnnexOptions [backendOption, jsonOptions] $ + command "addcomputed" SectionCommon "add computed files to annex" + (paramRepeating paramExpression) + (seek <$$> optParser) + +data AddComputedOptions = AddComputedOptions + { computeParams :: CmdParams + , computeRemote :: DeferredParse Remote + , reproducible :: Maybe Reproducible + } + +optParser :: CmdParamsDesc -> Parser AddComputedOptions +optParser desc = AddComputedOptions + <$> cmdParams desc + <*> (mkParseRemoteOption <$> parseToOption) + <*> parseReproducible + +newtype Reproducible = Reproducible { isReproducible :: Bool } + deriving (Show, Eq) + +parseReproducible :: Parser (Maybe Reproducible) +parseReproducible = r <|> unr + where + r = flag Nothing (Just (Reproducible True)) + ( long "reproducible" + <> short 'r' + <> help "computation is fully reproducible" + ) + unr = flag Nothing (Just (Reproducible False)) + ( long "unreproducible" + <> short 'u' + <> help "computation is not fully reproducible" + ) + +seek :: AddComputedOptions -> CommandSeek +seek o = startConcurrency commandStages (seek' o) + +seek' :: AddComputedOptions -> CommandSeek +seek' o = do + addunlockedmatcher <- addUnlockedMatcher + r <- getParsed (computeRemote o) + unless (Remote.Compute.isComputeRemote r) $ + giveup "That is not a compute remote." + + commandAction $ start o r addunlockedmatcher + +start :: AddComputedOptions -> Remote -> AddUnlockedMatcher -> CommandStart +start o r = starting "addcomputed" ai si . perform o r + where + ai = ActionItemUUID (Remote.uuid r) (UnquotedString (Remote.name r)) + si = SeekInput (computeParams o) + +perform :: AddComputedOptions -> Remote -> AddUnlockedMatcher -> CommandPerform +perform o r addunlockedmatcher = do + program <- Remote.Compute.getComputeProgram r + repopath <- fromRepo Git.repoPath + subdir <- liftIO $ relPathDirToFile repopath (literalOsPath ".") + let state = Remote.Compute.ComputeState + { Remote.Compute.computeParams = computeParams o ++ + Remote.Compute.defaultComputeParams r + , Remote.Compute.computeInputs = mempty + , Remote.Compute.computeOutputs = mempty + , Remote.Compute.computeSubdir = subdir + } + fast <- Annex.getRead Annex.fast + Remote.Compute.runComputeProgram program state + (Remote.Compute.ImmutableState False) + (getInputContent fast) + Nothing + (go fast) + next $ return True + where + go fast = addComputed (Just "adding") r (reproducible o) + chooseBackend Just fast (Right addunlockedmatcher) + +addComputed + :: Maybe StringContainingQuotedPath + -> Remote + -> Maybe Reproducible + -> (OsPath -> Annex Backend) + -> (OsPath -> Maybe OsPath) + -> Bool + -> Either Bool AddUnlockedMatcher + -> Remote.Compute.ComputeProgramResult + -> OsPath + -> NominalDiffTime + -> Annex () +addComputed maddaction r reproducibleconfig choosebackend destfile fast addunlockedmatcher result tmpdir ts = do + when (M.null outputs) $ + giveup "The computation succeeded, but it did not generate any files." + oks <- forM (M.keys outputs) $ \outputfile -> do + case maddaction of + Just addaction -> showAction $ + addaction <> " " <> QuotedPath outputfile + Nothing -> noop + k <- catchNonAsync (addfile outputfile) + (\err -> giveup $ "Failed to ingest output file " ++ fromOsPath outputfile ++ ": " ++ show err) + return (outputfile, Just k) + let state' = state + { Remote.Compute.computeOutputs = M.fromList oks + } + forM_ (mapMaybe snd oks) $ \k -> do + Remote.Compute.setComputeState + (Remote.remoteStateHandle r) + k ts state' + + let u = Remote.uuid r + unlessM (elem u <$> loggedLocations k) $ + logChange NoLiveUpdate k u InfoPresent + where + state = Remote.Compute.computeState result + + outputs = Remote.Compute.computeOutputs state + + addfile outputfile + | fast = do + case destfile outputfile of + Nothing -> noop + Just f -> addSymlink f stateurlk Nothing + return stateurlk + | isreproducible = do + sz <- liftIO $ getFileSize outputfile' + metered Nothing sz Nothing $ \_ p -> + case destfile outputfile of + Just f -> ingesthelper f p Nothing + Nothing -> genkey outputfile p + | otherwise = case destfile outputfile of + Just f -> ingesthelper f nullMeterUpdate + (Just stateurlk) + Nothing -> return stateurlk + where + stateurl = Remote.Compute.computeStateUrl r state outputfile + stateurlk = fromUrl stateurl Nothing True + outputfile' = tmpdir outputfile + genkey f p = do + backend <- choosebackend outputfile + let ks = KeySource + { keyFilename = f + , contentLocation = outputfile' + , inodeCache = Nothing + } + fst <$> genKey ks p backend + ingesthelper f p mk = ingestwith $ do + k <- maybe (genkey f p) return mk + topf <- inRepo $ toTopFilePath f + let fi = FileInfo + { contentFile = outputfile' + , matchFile = getTopFilePath topf + , matchKey = Just k + } + lockingfile <- case addunlockedmatcher of + Right addunlockedmatcher' -> + not <$> addUnlocked addunlockedmatcher' + (MatchingFile fi) + (not fast) + Left v -> pure v + let ldc = LockDownConfig + { lockingFile = lockingfile + , hardlinkFileTmpDir = Nothing + , checkWritePerms = True + } + liftIO $ createDirectoryIfMissing True $ + takeDirectory f + liftIO $ moveFile outputfile' f + let ks = KeySource + { keyFilename = f + , contentLocation = f + , inodeCache = Nothing + } + let ld = LockedDown ldc ks + ingestAdd' p (Just ld) (Just k) + ingestwith a = a >>= \case + Nothing -> giveup "ingestion failed" + Just k -> do + u <- getUUID + unlessM (elem u <$> loggedLocations k) $ + logStatus NoLiveUpdate k InfoPresent + when (fromKey keyVariety k == VURLKey) $ do + hb <- hashBackend + void $ addEquivilantKey hb k + =<< calcRepo (gitAnnexLocation k) + return k + + isreproducible = case reproducibleconfig of + Just v -> isReproducible v + Nothing -> Remote.Compute.computeReproducible result + +getInputContent :: Bool -> OsPath -> Bool -> Annex (Key, Maybe (Either Git.Sha OsPath)) +getInputContent fast p required = catKeyFile p >>= \case + Just inputkey -> getInputContent' fast inputkey required filedesc + Nothing -> inRepo (Git.fileRef p) >>= \case + Just fileref -> catObjectMetaData fileref >>= \case + Just (sha, _, t) + | t == Git.BlobObject -> + getInputContent' fast (gitShaKey sha) required filedesc + | otherwise -> + badinput $ ", not a git " ++ decodeBS (Git.fmtObjectType t) + Nothing -> notcheckedin + Nothing -> notcheckedin + where + filedesc = fromOsPath p + badinput s = giveup $ "The computation needs an input file " ++ s ++ ": " ++ fromOsPath p + notcheckedin = badinput "that is not checked into the git repository" + +getInputContent' :: Bool -> Key -> Bool -> String -> Annex (Key, Maybe (Either Git.Sha OsPath)) +getInputContent' fast inputkey required filedesc + | fast && not required = return (inputkey, Nothing) + | otherwise = case keyGitSha inputkey of + Nothing -> ifM (inAnnex inputkey) + ( do + obj <- calcRepo (gitAnnexLocation inputkey) + return (inputkey, Just (Right obj)) + , giveup $ "The computation needs the content of an annexed file which is not present: " ++ filedesc + ) + Just sha -> return (inputkey, Just (Left sha)) diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -27,7 +27,7 @@ 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 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -38,7 +38,6 @@ 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 @@ 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 @@ startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart startRemote addunlockedmatcher r o si file uri sz = do pathmax <- liftIO $ fileNameLengthLimit "." - let file' = joinPath $ map (truncateFilePath pathmax) $ - splitDirectories file + let file' = joinPath $ + map (toOsPath . truncateFilePath pathmax . fromOsPath) $ + splitDirectories (toOsPath file) startingAddUrl si uri o $ do showNote $ UnquotedString $ "from " ++ Remote.name r - showDestinationFile (toRawFilePath file') - performRemote addunlockedmatcher r o uri (toRawFilePath file') sz + 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 @@ 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 @@ 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 @@ -279,7 +279,8 @@ return f | otherwise = do pathmax <- liftIO $ fileNameLengthLimit "." - return $ truncateFilePath pathmax $ sanitizeFilePath f + return $ fromRawFilePath $ truncateFilePath pathmax $ + toRawFilePath $ sanitizeFilePath f -- sanitizeFilePath avoids all these security problems -- (and probably others, but at least this catches the most egrarious ones). @@ -293,12 +294,12 @@ 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 @@ -313,7 +314,7 @@ {- 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 @@ -339,21 +340,21 @@ - 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 urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing (verifiableOption o) downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f go Nothing = return Nothing - go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile (fromRawFilePath tmp))) + go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile tmp)) ( tryyoutubedl tmp backend , normalfinish tmp backend ) @@ -365,25 +366,25 @@ -- 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 @@ -444,10 +445,10 @@ 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. @@ -458,7 +459,7 @@ - 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 @@ -467,7 +468,7 @@ {- 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 @@ -476,14 +477,14 @@ 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 @@ -501,14 +502,14 @@ } {- 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 @@ -530,15 +531,15 @@ ( 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 @@ -553,12 +554,12 @@ 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) @@ -567,8 +568,8 @@ url2file :: URI -> Maybe Int -> Int -> FilePath url2file url pathdepth pathmax = case pathdepth of - Nothing -> truncateFilePath pathmax $ sanitizeFilePath fullurl - Just depth + Nothing -> truncatesanitize fullurl + Just depth | depth >= length urlbits -> frombits id | depth > 0 -> frombits $ drop depth | depth < 0 -> frombits $ reverse . take (negate depth) . reverse @@ -580,8 +581,12 @@ , uriQuery url ] frombits a = intercalate "/" $ a urlbits - urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $ + urlbits = map truncatesanitize $ filter (not . null) $ splitc '/' fullurl + truncatesanitize = fromRawFilePath + . truncateFilePath pathmax + . toRawFilePath + . sanitizeFilePath urlString2file :: URLString -> Maybe Int -> Int -> FilePath urlString2file s pathdepth pathmax = case Url.parseURIRelaxed s of @@ -596,8 +601,8 @@ 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 --- a/Command/Assist.hs +++ b/Command/Assist.hs @@ -28,7 +28,8 @@ 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 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -79,11 +79,11 @@ 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 @@ 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 --- a/Command/CalcKey.hs +++ b/Command/CalcKey.hs @@ -32,4 +32,4 @@ 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 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -152,7 +152,7 @@ | 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 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -9,7 +9,6 @@ import Command import Annex.Content -import qualified Utility.RawFilePath as R import qualified Data.ByteString.Char8 as B8 @@ -23,10 +22,13 @@ 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 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -77,7 +77,7 @@ {- 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 @@ 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 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -119,7 +119,7 @@ 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 @@ 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 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -76,7 +76,7 @@ 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 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -17,7 +17,6 @@ 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 @@ 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 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -57,7 +57,7 @@ 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 @@ 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 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -39,7 +39,7 @@ 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 @@ 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 @@ 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 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -26,6 +26,7 @@ import Types.Export import Annex.Export import Annex.Content +import Annex.GitShaKey import Annex.Transfer import Annex.CatFile import Annex.FileMatcher @@ -78,8 +79,8 @@ -- 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 @@ -120,15 +121,21 @@ -- branch. getExportCommit :: Remote -> Git.Ref -> Annex (Maybe (RemoteTrackingBranch, Sha)) getExportCommit r treeish - | '/' `notElem` fromRef baseref = do - let tb = mkRemoteTrackingBranch r baseref - commitsha <- inRepo $ Git.Ref.sha $ Git.Ref.underBase refsheads baseref - return (fmap (tb, ) commitsha) - | otherwise = return Nothing + | '/' `notElem` fromRef baseref = go + | otherwise = ifM isremoteref + ( return Nothing + , go + ) where baseref = Ref $ S8.takeWhile (/= ':') $ fromRef' $ Git.Ref.removeBase refsheads treeish refsheads = "refs/heads" + isremoteref = inRepo $ Git.Ref.exists $ + Git.Ref.underBase "refs/remotes" baseref + go = do + let tb = mkRemoteTrackingBranch r baseref + commitsha <- inRepo $ Git.Ref.sha $ Git.Ref.underBase refsheads baseref + return (fmap (tb, ) commitsha) -- | Changes what's exported to the remote. Does not upload any new -- files, but does delete and rename files already exported to the remote. @@ -306,12 +313,11 @@ sent <- tryNonAsync $ if not (isGitShaKey ek) then tryrenameannexobject $ sendannexobject -- Sending a non-annexed file. - else withTmpFile "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 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 --- a/Command/FilterBranch.hs +++ b/Command/FilterBranch.hs @@ -27,13 +27,11 @@ 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 @@ 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 @@ -- 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 --- a/Command/FilterProcess.hs +++ b/Command/FilterProcess.hs @@ -36,7 +36,7 @@ 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 @@ - 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 @@ -- 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 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -88,9 +88,9 @@ 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 @@ 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/FindComputed.hs b/Command/FindComputed.hs new file mode 100644 --- /dev/null +++ b/Command/FindComputed.hs @@ -0,0 +1,131 @@ +{- git-annex command + - + - Copyright 2025 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, TupleSections #-} + +module Command.FindComputed where + +import Command +import Git.FilePath +import qualified Utility.Format +import Utility.Terminal +import Command.Find (showFormatted, formatVars) +import Remote.Compute (isComputeRemote, getComputeState, ComputeState(..)) +import qualified Remote +import qualified Types.Remote as Remote +import Database.Keys +import Annex.CatFile + +import qualified Data.Map as M + +cmd :: Command +cmd = withAnnexOptions [annexedMatchingOptions] $ noCommit $ noMessages $ + withAnnexOptions [jsonOptions] $ + command "findcomputed" SectionQuery "lists computed files" + paramPaths (seek <$$> optParser) + +data FindComputedOptions = FindComputedOptions + { findThese :: CmdParams + , formatOption :: Maybe Utility.Format.Format + , keyOptions :: Maybe KeyOptions + , inputsOption :: Bool + } + +optParser :: CmdParamsDesc -> Parser FindComputedOptions +optParser desc = FindComputedOptions + <$> cmdParams desc + <*> optional parseFormatOption + <*> optional parseBranchKeysOption + <*> switch + ( long "inputs" + <> help "display input files" + ) + +parseFormatOption :: Parser Utility.Format.Format +parseFormatOption = + option (Utility.Format.gen <$> str) + ( long "format" <> metavar paramFormat + <> help "control format of output" + ) + +seek :: FindComputedOptions -> CommandSeek +seek o = do + unless (isJust (keyOptions o)) $ + checkNotBareRepo + isterminal <- liftIO $ checkIsTerminal stdout + computeremotes <- filter isComputeRemote <$> Remote.remoteList + let seeker = AnnexedFileSeeker + { startAction = const (start o isterminal computeremotes) + , checkContentPresent = Nothing + , usesLocationLog = True + } + withKeyOptions (keyOptions o) False seeker + (commandAction . startKeys o isterminal computeremotes) + (withFilesInGitAnnex ww seeker) + =<< workTreeItems ww (findThese o) + where + ww = WarnUnmatchLsFiles "findcomputed" + +start :: FindComputedOptions -> IsTerminal -> [Remote] -> SeekInput -> OsPath -> Key -> CommandStart +start o isterminal computeremotes _ file key = do + rs <- Remote.remotesWithUUID computeremotes + <$> Remote.keyLocations key + rcs <- catMaybes <$> forM rs get + if null rcs + then stop + else startingCustomOutput key $ do + forM_ rcs display + next $ return True + where + get r = fmap (r, ) + <$> getComputeState (Remote.remoteStateHandle r) key + + showformatted = showFormatted isterminal (formatOption o) + + unformatted r computation = fromOsPath file + <> " (" <> encodeBS (Remote.name r) + <> ") -- " + <> encodeBS computation + + unformattedinputs (Right inputfile) = fromOsPath file + <> " " <> fromOsPath inputfile + unformattedinputs (Left inputkey) = fromOsPath file + <> " " <> serializeKey' inputkey + + display (r, c) = do + let computation = unwords (computeParams c) + let formatvars = + [ ("remote", Remote.name r) + , ("computation", computation) + ] ++ formatVars key (AssociatedFile (Just file)) + if inputsOption o + then forM_ (M.elems $ computeInputs c) $ \inputkey -> do + input <- maybe (Left inputkey) Right + <$> getassociated inputkey + showformatted (unformattedinputs input) $ + [ ("input", either serializeKey fromOsPath input) + , ("inputkey", serializeKey inputkey) + , ("inputfile", either (const "") fromOsPath input) + ] ++ formatvars + else showformatted (unformatted r computation) formatvars + + getassociated inputkey = + getAssociatedFiles inputkey + >>= mapM (fromRepo . fromTopFilePath) + >>= firstM (stillassociated inputkey) + + -- Some associated files that are in the keys database may no + -- longer correspond to files in the repository. + stillassociated k f = catKeyFile f >>= return . \case + Just k' | k' == k -> True + _ -> False + +startKeys :: FindComputedOptions -> IsTerminal -> [Remote] -> (SeekInput, Key, ActionItem) -> CommandStart +startKeys o isterminal computeremotes (si, key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = + start o isterminal computeremotes si (getTopFilePath topf) key +startKeys _ _ _ _ = stop + diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -44,25 +44,27 @@ 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 @@ fixby $ breakHardLink file key obj _ -> stop -breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform +breakHardLink :: OsPath -> Key -> OsPath -> CommandPerform breakHardLink file key obj = do - replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + replaceWorkTreeFile file $ \tmp -> do + 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 @@ modifyContentDir obj $ freezeContent obj next $ return True -makeHardLink :: RawFilePath -> Key -> CommandPerform +makeHardLink :: OsPath -> Key -> CommandPerform makeHardLink file key = do - replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + replaceWorkTreeFile file $ \tmp -> do + 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 (fromRawFilePath file) $ \tmpfile -> do - liftIO $ R.createSymbolicLink link tmpfile + replaceWorkTreeFile file $ \tmpfile -> do + 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 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -59,7 +59,7 @@ 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 @@ 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 @@ 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 @@ 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 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -45,13 +45,13 @@ import Types.CleanupActions import Types.Key import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F import Data.Time.Clock.POSIX 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 @@ -122,8 +122,8 @@ 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 @@ -134,7 +134,7 @@ 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 @@ -193,11 +193,11 @@ 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) @@ -207,9 +207,9 @@ ) , 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 @@ -235,10 +235,10 @@ 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 @@ -246,8 +246,8 @@ | 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 @@ -271,7 +271,7 @@ 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 @@ -290,14 +290,12 @@ -- 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 @@ -309,7 +307,7 @@ 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 @@ -323,7 +321,7 @@ 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 @@ -400,7 +398,7 @@ 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 @@ -409,7 +407,7 @@ 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. -} @@ -417,8 +415,10 @@ case mk of Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" - replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + replaceWorkTreeFile file $ \tmp -> do + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus + (fromOsPath file) ifM (annexThin <$> Annex.getGitConfig) ( void $ linkFromAnnex' key tmp mode , do @@ -439,20 +439,20 @@ 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 @@ -504,7 +504,7 @@ 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 @@ -523,11 +523,11 @@ 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 @@ -551,7 +551,7 @@ - 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 @@ -568,7 +568,7 @@ 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 @@ -589,7 +589,7 @@ ) 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 = @@ -614,25 +614,24 @@ 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 @@ -644,7 +643,7 @@ 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 @@ -677,10 +676,10 @@ recordStartTime u = do f <- fromRepo (gitAnnexFsckState u) createAnnexDirectory $ parentDir f - liftIO $ removeWhenExistsWith R.removeLink f - liftIO $ withFile (fromRawFilePath 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 @@ -691,7 +690,7 @@ 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. -} @@ -699,9 +698,9 @@ 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 <$> readFile (fromRawFilePath f) + fromfile <- parsePOSIXTime <$> F.readFile' f return $ if matchingtimestamp fromfile fromstatus then Just timestamp else Nothing @@ -714,13 +713,12 @@ #endif data Incremental - = NonIncremental + = NonIncremental (Maybe FsckDb.FsckHandle) | ScheduleIncremental Duration UUID Incremental | StartIncremental FsckDb.FsckHandle | ContIncremental FsckDb.FsckHandle prepIncremental :: UUID -> Maybe IncrementalOpt -> Annex Incremental -prepIncremental _ Nothing = pure NonIncremental prepIncremental u (Just StartIncrementalO) = do recordStartTime u ifM (FsckDb.newPass u) @@ -735,6 +733,14 @@ Nothing -> StartIncrementalO Just _ -> MoreIncrementalO return (ScheduleIncremental delta u i) +prepIncremental u Nothing = + ifM (Annex.getRead Annex.fast) + -- Avoid recording fscked files in --fast mode, + -- since that can interfere with a non-fast incremental + -- fsck. + ( pure (NonIncremental Nothing) + , (NonIncremental . Just) <$> openFsckDb u + ) cleanupIncremental :: Incremental -> Annex () cleanupIncremental (ScheduleIncremental delta u i) = do @@ -758,6 +764,6 @@ withFsckDb :: Incremental -> (FsckDb.FsckHandle -> Annex ()) -> Annex () withFsckDb (ContIncremental h) a = a h withFsckDb (StartIncremental h) a = a h -withFsckDb NonIncremental _ = noop +withFsckDb (NonIncremental mh) a = maybe noop a mh withFsckDb (ScheduleIncremental _ _ i) a = withFsckDb i a diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -123,13 +123,14 @@ 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 @@ 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 @@ 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 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 @@ 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 @@ 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 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -55,7 +55,7 @@ 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 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -129,7 +129,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ -- 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 @@ 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 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -24,7 +24,6 @@ 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,10 +157,11 @@ | scrapeOption o = scrape | otherwise = get - get = withTmpFile "feed" $ \tmpf h -> do + get = withTmpFile (literalOsPath "feed") $ \tmpf h -> do + let tmpf' = fromRawFilePath $ fromOsPath tmpf liftIO $ hClose h - ifM (downloadFeed url tmpf) - ( parse tmpf + ifM (downloadFeed url tmpf') + ( parse tmpf' , do recordfail next $ feedProblem url @@ -269,7 +269,7 @@ 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 @@ -314,15 +314,15 @@ 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 @@ -351,16 +351,16 @@ ) 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 } @@ -384,7 +384,7 @@ 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 @@ -396,7 +396,7 @@ -> 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) $ @@ -405,7 +405,7 @@ Nothing -> do recordsuccess next $ return True - Just f -> getter (toRawFilePath f) >>= \case + Just f -> getter f >>= \case Just ks -- Download problem. | null ks -> do @@ -439,7 +439,7 @@ - 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 @@ -448,12 +448,12 @@ ) 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 @@ -608,10 +608,10 @@ - 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 @@ -627,10 +627,9 @@ 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 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -14,7 +14,7 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ 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 = 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 @@ 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 @@ 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 @@ "+ " ++ 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 @@ 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 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -51,14 +51,17 @@ 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 --- a/Command/List.hs +++ b/Command/List.hs @@ -82,7 +82,7 @@ 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 @@ 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 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -39,7 +39,7 @@ , 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 @@ ) 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,15 +70,17 @@ ( 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 (fromRawFilePath obj) $ \tmp -> do + modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do unlessM (checkedCopyFile key obj tmp Nothing) $ giveup "unable to lock file" Database.Keys.storeInodeCaches key [obj] @@ -89,7 +91,7 @@ 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 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -15,7 +15,6 @@ 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 Types.TrustLevel import Utility.DataUnits import Utility.HumanTime +import qualified Utility.FileIO as F data LogChange = Added | Removed @@ -282,15 +282,15 @@ 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 @@ -- 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 @@ 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 @@ 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 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -37,7 +37,7 @@ | 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 @@ -- 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 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -49,22 +49,22 @@ 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 @@ 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 --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -39,7 +39,7 @@ <*> (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 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -99,7 +99,7 @@ ) _ -> 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 @@ 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 @@ (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 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -79,10 +79,10 @@ -- 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 @@ - 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 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -57,7 +57,7 @@ , 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 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -94,7 +94,7 @@ 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 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -28,7 +28,6 @@ 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 @@ (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 @@ -- the names of keys, and would have to be copied, which is too -- expensive. starting "sending files" (ActionItemOther Nothing) (SeekInput []) $ - withTmpFile "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 @@ , 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 t + , Param "-i", File (fromOsPath t) ] ++ ups liftIO (boolSystem "uftp" ps) >>= showEndResult next $ return True @@ -178,9 +176,9 @@ (callback, environ, statush) <- liftIO multicastCallbackEnv tmpobjdir <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory tmpobjdir - withTmpDirIn (fromRawFilePath tmpobjdir) "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 @@ , 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 $ + getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \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 @@ 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,10 +241,10 @@ 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 "authlist" $ \t h -> do + withTmpFile (literalOsPath "authlist") $ \t h -> do liftIO $ hPutStr h (genAuthList m) liftIO $ hClose h a t diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -25,7 +25,7 @@ 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 import Control.Concurrent.Async @@ -193,12 +193,11 @@ serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $ T.unpack ha : map formatP2PAddress addrs -deserializePairData :: String -> Maybe PairData -deserializePairData s = case lines s of - [] -> Nothing - (ha:l) -> do - addrs <- mapM unformatP2PAddress l - return (PairData (HalfAuthToken (T.pack ha)) addrs) +deserializePairData :: [String] -> Maybe PairData +deserializePairData [] = Nothing +deserializePairData (ha:l) = do + addrs <- mapM unformatP2PAddress l + return (PairData (HalfAuthToken (T.pack ha)) addrs) data PairingResult = PairSuccess @@ -220,12 +219,12 @@ -- files. Permissions of received files may allow others -- to read them. So, set up a temp directory that only -- we can read. - withTmpDir "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,23 +234,24 @@ -- 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 $ - readFileStrict recvf + map decodeBS . fileLines' + <$> F.readFile' recvf case r of Left _e -> return ReceiveFailed - Right s -> maybe + Right ls -> maybe (return ReceiveFailed) (finishPairing 100 remotename ourhalf) - (deserializePairData s) + (deserializePairData ls) -- | Allow the peer we're pairing with to authenticate to us, -- using an authtoken constructed from the two HalfAuthTokens. diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -266,8 +266,8 @@ findRepos :: Options -> IO [Git.Repo] findRepos o = do - files <- map toRawFilePath . concat - <$> mapM dirContents (directoryOption o) + files <- concat + <$> 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 --- 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 = 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 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -62,14 +62,14 @@ 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 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -44,7 +44,7 @@ -- 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 @@ 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 @@ (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 @@ 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 @@ {- 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,10 +101,10 @@ - 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 (fromRawFilePath file) $ \tmp -> do + replaceWorkTreeFile file $ \tmp -> do unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ giveup "can't lock old key" thawContent tmp @@ -128,11 +128,11 @@ - and vulnerable to corruption. -} linkKey' :: VerifyConfig -> Key -> Key -> Annex Bool linkKey' v oldkey newkey = - getViaTmpFromDisk RetrievalAllKeysSecure v newkey (AssociatedFile Nothing) $ \tmp -> unVerified $ do + getViaTmpFromDisk RetrievalAllKeysSecure v newkey $ \tmp -> unVerified $ do 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 @@ 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/Recompute.hs b/Command/Recompute.hs new file mode 100644 --- /dev/null +++ b/Command/Recompute.hs @@ -0,0 +1,218 @@ +{- git-annex command + - + - Copyright 2025 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Command.Recompute where + +import Command +import qualified Remote.Compute +import qualified Remote +import qualified Types.Remote as Remote +import qualified Git.Ref as Git +import Annex.Content +import Annex.UUID +import Annex.CatFile +import Annex.GitShaKey +import Git.FilePath +import Logs.Location +import Command.AddComputed (Reproducible(..), parseReproducible, getInputContent, getInputContent', addComputed) +import Backend (maybeLookupBackendVariety, unknownBackendVarietyMessage, chooseBackend) +import Types.Key +import qualified Utility.RawFilePath as R + +import qualified Data.Map as M +import System.PosixCompat.Files (isSymbolicLink) + +cmd :: Command +cmd = notBareRepo $ withAnnexOptions [jsonOptions] $ + command "recompute" SectionCommon "recompute computed files" + paramPaths (seek <$$> optParser) + +data RecomputeOptions = RecomputeOptions + { recomputeThese :: CmdParams + , originalOption :: Bool + , reproducible :: Maybe Reproducible + , computeRemote :: Maybe (DeferredParse Remote) + } + +optParser :: CmdParamsDesc -> Parser RecomputeOptions +optParser desc = RecomputeOptions + <$> cmdParams desc + <*> switch + ( long "original" + <> help "recompute using original content of input files" + ) + <*> parseReproducible + <*> optional (mkParseRemoteOption <$> parseRemoteOption) + +seek :: RecomputeOptions -> CommandSeek +seek o = startConcurrency commandStages (seek' o) + +seek' :: RecomputeOptions -> CommandSeek +seek' o = do + computeremote <- maybe (pure Nothing) (Just <$$> getParsed) + (computeRemote o) + let seeker = AnnexedFileSeeker + { startAction = const $ start o computeremote + , checkContentPresent = Nothing + , usesLocationLog = True + } + withFilesInGitAnnex ww seeker + =<< workTreeItems ww (recomputeThese o) + where + ww = WarnUnmatchLsFiles "recompute" + +start :: RecomputeOptions -> Maybe Remote -> SeekInput -> OsPath -> Key -> CommandStart +start o (Just computeremote) si file key = + stopUnless (elem (Remote.uuid computeremote) <$> loggedLocations key) $ + start' o computeremote si file key +start o Nothing si file key = do + rs <- catMaybes <$> (mapM Remote.byUUID =<< loggedLocations key) + case sortOn Remote.cost $ filter Remote.Compute.isComputeRemote rs of + [] -> stop + (r:_) -> start' o r si file key + +start' :: RecomputeOptions -> Remote -> SeekInput -> OsPath -> Key -> CommandStart +start' o r si file key = + Remote.Compute.getComputeState + (Remote.remoteStateHandle r) key >>= \case + Nothing -> stop + Just state -> shouldrecompute state >>= \case + Nothing -> stop + Just mreason -> starting "recompute" ai si $ do + maybe noop showNote mreason + perform o r file key state + where + ai = mkActionItem (key, file) + + shouldrecompute state + | originalOption o = return (Just Nothing) + | otherwise = firstM (inputchanged state) + (M.toList (Remote.Compute.computeInputs state)) + >>= return . \case + Nothing -> Nothing + Just (inputfile, _) -> Just $ Just $ + QuotedPath inputfile <> " changed" + + inputchanged state (inputfile, inputkey) = do + -- Note that the paths from the remote state are not to be + -- trusted to point to a file in the repository, but using + -- the path with git cat-file will only succeed if it + -- is checked into the repository. + p <- fromRepo $ fromTopFilePath $ asTopFilePath $ + Remote.Compute.computeSubdir state inputfile + case keyGitSha inputkey of + Nothing -> + catKeyFile p >>= return . \case + Just k -> k /= inputkey + Nothing -> inputfilemissing + Just inputgitsha -> inRepo (Git.fileRef p) >>= \case + Just fileref -> catObjectMetaData fileref >>= return . \case + Just (sha, _, _) -> sha /= inputgitsha + Nothing -> inputfilemissing + Nothing -> return inputfilemissing + where + -- When an input file is missing, go ahead and recompute. + -- This way, the user will see the computation fail, + -- with an error message that explains the problem. + -- Or, if the input file is only optionally used by the + -- computation, it might succeed. + inputfilemissing = True + +perform :: RecomputeOptions -> Remote -> OsPath -> Key -> Remote.Compute.ComputeState -> CommandPerform +perform o r file origkey origstate = do + program <- Remote.Compute.getComputeProgram r + reproducibleconfig <- getreproducibleconfig + originallocked <- liftIO $ isSymbolicLink + <$> R.getSymbolicLinkStatus (fromOsPath file) + showOutput + Remote.Compute.runComputeProgram program origstate + (Remote.Compute.ImmutableState False) + (getinputcontent program) + Nothing + (go program reproducibleconfig originallocked) + next cleanup + where + go program reproducibleconfig originallocked result tmpdir ts = do + checkbehaviorchange program + (Remote.Compute.computeState result) + addComputed Nothing r reproducibleconfig + choosebackend destfile False (Left originallocked) + result tmpdir ts + + checkbehaviorchange program state = do + let check s w a b = forM_ (M.keys (w a)) $ \f -> + unless (M.member f (w b)) $ + Remote.Compute.computationBehaviorChangeError program s f + + check "not using input file" + Remote.Compute.computeInputs origstate state + check "outputting" + Remote.Compute.computeOutputs state origstate + check "not outputting" + Remote.Compute.computeOutputs origstate state + + getinputcontent program p required + | originalOption o = + case M.lookup p (Remote.Compute.computeInputs origstate) of + Just inputkey -> getInputContent' False inputkey required + (fromOsPath p ++ "(key " ++ serializeKey inputkey ++ ")") + Nothing -> Remote.Compute.computationBehaviorChangeError program + "requesting a new input file" p + | otherwise = getInputContent False p required + + destfile outputfile + | Just outputfile == origfile = Just file + | otherwise = Nothing + + origfile = headMaybe $ M.keys $ M.filter (== Just origkey) + (Remote.Compute.computeOutputs origstate) + + origbackendvariety = fromKey keyVariety origkey + + recomputingvurl = case origbackendvariety of + VURLKey -> True + _ -> False + + getreproducibleconfig = case reproducible o of + Just (Reproducible True) -> return (Just (Reproducible True)) + -- A VURL key is used when the computation was + -- unreproducible. So recomputing should too, but that + -- will result in the same VURL key. Since moveAnnex + -- will prefer the current annex object to a new one, + -- delete the annex object first, so that if recomputing + -- generates a new version of the file, it replaces + -- the old version. + v -> if recomputingvurl + then do + lockContentForRemoval origkey noop removeAnnex + return (Just (Reproducible False)) + else return v + + cleanup = do + case reproducible o of + Just (Reproducible True) -> noop + -- in case computation failed, update + -- location log for removal done earlier + _ -> when recomputingvurl $ do + u <- getUUID + unlessM (elem u <$> loggedLocations origkey) $ + logStatus NoLiveUpdate origkey InfoMissing + return True + + choosebackend outputfile + -- When converting a VURL to reproducible, can't use + -- the VURL backend. + | recomputingvurl && reproducible o == Just (Reproducible True) = + chooseBackend outputfile + -- Use the same backend as was used to compute it before, + -- so if the computed file is the same, there will be + -- no change. + | otherwise = maybeLookupBackendVariety origbackendvariety >>= \case + Just b -> return b + Nothing -> giveup $ unknownBackendVarietyMessage origbackendvariety diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -28,7 +28,7 @@ start (_, key) = fieldTransfer Download key $ \_p -> do -- This matches the retrievalSecurityPolicy of Remote.Git let rsp = RetrievalAllKeysSecure - ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) Nothing go) + ifM (getViaTmp rsp DefaultVerify key Nothing go) ( do logStatus NoLiveUpdate key InfoPresent _ <- quiesce True @@ -39,4 +39,4 @@ 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 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -57,26 +57,26 @@ 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 @@ 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 @@ 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 @@ Nothing -> a ) -perform :: RawFilePath -> Key -> CommandPerform +perform :: OsPath -> Key -> CommandPerform perform src key = do maybeAddJSONField "key" (serializeKey key) ifM move @@ -129,7 +129,7 @@ ) where move = checkDiskSpaceToGet key Nothing False $ - moveAnnex key (AssociatedFile Nothing) src + moveAnnex key src cleanup :: Key -> CommandCleanup cleanup key = do diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -29,7 +29,7 @@ | 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 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -14,7 +14,6 @@ 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 @@ 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 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.ResolveMerge where import Command @@ -12,8 +14,7 @@ import Git.Sha import qualified Git.Branch import Annex.AutoMerge - -import qualified Data.ByteString as S +import qualified Utility.FileIO as F cmd :: Command cmd = command "resolvemerge" SectionPlumbing @@ -26,10 +27,10 @@ start :: CommandStart start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do us <- fromMaybe nobranch <$> inRepo Git.Branch.current - d <- fromRawFilePath <$> fromRepo Git.localGitDir - let merge_head = d "MERGE_HEAD" + d <- fromRepo Git.localGitDir + let merge_head = d literalOsPath "MERGE_HEAD" them <- fromMaybe (giveup nomergehead) . extractSha - <$> liftIO (S.readFile merge_head) + <$> liftIO (F.readFile' merge_head) ifM (resolveMerge (Just us) them False) ( do void $ commitResolvedMerge Git.Branch.ManualCommit @@ -38,4 +39,4 @@ ) 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 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -32,29 +32,28 @@ 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 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -33,7 +33,9 @@ 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 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -25,18 +25,18 @@ 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 -- checked this way. - ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key (AssociatedFile Nothing) Nothing $ \dest -> unVerified $ + ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key Nothing $ \dest -> unVerified $ if dest /= file then liftIO $ catchBoolIO $ do moveFile file dest diff --git a/Command/Sim.hs b/Command/Sim.hs --- a/Command/Sim.hs +++ b/Command/Sim.hs @@ -61,13 +61,13 @@ 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 @@ 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 @@ 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 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -44,7 +44,7 @@ paramFile (seek <$$> optParser) data SmudgeOptions = UpdateOption | SmudgeOptions - { smudgeFile :: FilePath + { smudgeFile :: OsPath , cleanOption :: Bool } @@ -52,14 +52,14 @@ 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 @@ -- * 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 @@ 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 @@ -- 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 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -66,6 +66,6 @@ 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 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -110,7 +110,7 @@ , pushOption :: Bool , contentOption :: Maybe Bool , noContentOption :: Maybe Bool - , contentOfOption :: [FilePath] + , contentOfOption :: [OsPath] , cleanupOption :: Bool , keyOptions :: Maybe KeyOptions , resolveMergeOverride :: Bool @@ -201,7 +201,7 @@ <> 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 @@ <*> 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 @@ - 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 @@ 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 @@ ) _ -> 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 @@ 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 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -32,6 +32,7 @@ import Remote.Helper.Chunked import Remote.Helper.Encryptable (encryptionField, highRandomQualityField) import Git.Types +import qualified Utility.FileIO as F import Test.Tasty import Test.Tasty.Runners @@ -86,8 +87,7 @@ 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 } @@ -255,24 +255,24 @@ get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ \r k -> do - tmp <- fromRawFilePath <$> prepTmp k - liftIO $ writeFile tmp "" + 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 <- fromRawFilePath <$> 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 $ L.writeFile tmp partial + liftIO $ F.writeFile tmp partial lockContentForRemoval k noop removeAnnex get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from end" $ \r k -> do - loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) - tmp <- fromRawFilePath <$> prepTmp k + loc <- Annex.calcRepo (gitAnnexLocation k) + tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k noop removeAnnex get r k @@ -301,8 +301,8 @@ Just verifier -> do 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 + get r k = logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k Nothing $ \dest -> + 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 @@ -341,8 +341,8 @@ -- 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 @@ -353,17 +353,17 @@ 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 "exported" $ \tmp h -> do + retrieveexport ea k = withTmpFile (literalOsPath "exported") $ \tmp h -> do liftIO $ hClose h tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case Left _ -> return False - Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (toRawFilePath 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] @@ -375,15 +375,15 @@ , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> 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 + logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k Nothing $ \dest -> + 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 -> + Just a -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k Nothing $ \dest -> unVerified $ isRight - <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) + <$> tryNonAsync (a k (AssociatedFile Nothing) dest) ] where check checkval desc a = testCase desc $ @@ -429,24 +429,24 @@ | otherwise = sz > 0 randKey :: Int -> Annex Key -randKey sz = withTmpFile "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 = toRawFilePath f - , contentLocation = toRawFilePath 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) (toRawFilePath f) + _ <- moveAnnex k 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 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -30,7 +30,7 @@ optParser desc = TransferKeyOptions <$> cmdParams desc <*> parseFromToOptions - <*> (AssociatedFile <$> optional (strOption + <*> (AssociatedFile . fmap stringToOsPath <$> optional (strOption ( long "file" <> metavar paramFile <> help "the associated file" ))) @@ -63,8 +63,8 @@ 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 + logStatusAfter NoLiveUpdate key $ getViaTmp (retrievalSecurityPolicy remote) vc key Nothing $ \t -> + 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 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -50,8 +50,8 @@ return True | 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 + logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key Nothing $ \t -> do + 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 @@ 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 --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -55,8 +55,8 @@ -- so caller is responsible for doing notification -- 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)) + let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key Nothing $ \t -> do + 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 = @@ -72,8 +72,8 @@ runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote = 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 + logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key Nothing $ \t -> do + 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 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -39,12 +39,12 @@ , 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 @@ , 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 @@ 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 @@ -- 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 @@ ) 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 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -18,7 +18,6 @@ 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 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 @@ 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 @@ 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 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -73,7 +73,7 @@ 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 @@ {- 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." ] @@ -102,7 +102,7 @@ removeAnnexDir :: CommandCleanup -> CommandStart removeAnnexDir recordok = do Annex.Queue.flush - annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir + annexdir <- fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir starting ("uninit objects") (ActionItemOther Nothing) (SeekInput []) $ do leftovers <- removeUnannexed =<< listKeys InAnnex @@ -113,7 +113,7 @@ 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,15 +134,15 @@ - - Also closes sqlite databases that might be in the directory, - to avoid later failure to write any cached changes to them. -} -prepareRemoveAnnexDir :: FilePath -> Annex () +prepareRemoveAnnexDir :: OsPath -> Annex () prepareRemoveAnnexDir annexdir = do Database.Keys.closeDb liftIO $ prepareRemoveAnnexDir' annexdir -prepareRemoveAnnexDir' :: FilePath -> IO () +prepareRemoveAnnexDir' :: OsPath -> IO () prepareRemoveAnnexDir' annexdir = emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir) - >>= mapM_ (void . tryIO . allowWrite . toRawFilePath) + >>= mapM_ (void . tryIO . allowWrite) {- Keys that were moved out of the annex have a hard link still in the - annex, with > 1 link count, and those can be removed. @@ -159,7 +159,7 @@ , 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 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -40,7 +40,7 @@ , 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,10 +48,10 @@ 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 - destic <- replaceWorkTreeFile (fromRawFilePath dest) $ \tmp -> do + destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath dest) + destic <- replaceWorkTreeFile dest $ \tmp -> do ifM (inAnnex key) ( do r <- linkFromAnnex' key tmp destmode @@ -64,7 +64,7 @@ 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 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -119,7 +119,7 @@ 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 @@ {- 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 @@ 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 @@ 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 @@ 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 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -34,7 +34,7 @@ import Remote import Git.Types (fromConfigKey, fromConfigValue) import Utility.DataUnits -import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F cmd :: Command cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch" @@ -46,27 +46,35 @@ 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 <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f) - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + r <- liftIO $ parseCfg (defCfg curcfg) + . map decodeBS + . fileLines' + <$> 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) @@ -278,8 +286,8 @@ {- If there's a parse error, returns a new version of the file, - with the problem lines noted. -} -parseCfg :: Cfg -> String -> Either String Cfg -parseCfg defcfg = go [] defcfg . lines +parseCfg :: Cfg -> [String] -> Either String Cfg +parseCfg defcfg = go [] defcfg where go c cfg [] | null (mapMaybe fst c) = Right cfg diff --git a/Command/View.hs b/Command/View.hs --- a/Command/View.hs +++ b/Command/View.hs @@ -24,8 +24,6 @@ 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 @@ 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 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -86,15 +86,15 @@ 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 @@ ) 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 = 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 @@ 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 @@ (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 @@ 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 @@ {- 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 @@ 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 --- a/Command/WhereUsed.hs +++ b/Command/WhereUsed.hs @@ -70,9 +70,9 @@ where -- Some associated files that are in the keys database may no -- longer correspond to files in the repository. - stillassociated f = catKeyFile f >>= \case - Just k | k == key -> return True - _ -> return False + stillassociated f = catKeyFile f >>= return . \case + Just k | k == key -> True + _ -> False display :: Key -> StringContainingQuotedPath -> Annex () display key loc = do @@ -124,7 +124,7 @@ 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 @@ -- 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 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -67,7 +67,7 @@ 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 --- a/Common.hs +++ b/Common.hs @@ -10,7 +10,6 @@ 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) @@ -24,6 +23,7 @@ import Utility.Path as X import Utility.Path.AbsRel as X import Utility.Directory as X +import Utility.SystemDirectory as X import Utility.MoveFile as X import Utility.Monad as X import Utility.Data as X @@ -32,5 +32,6 @@ import Utility.Network as X import Utility.Split as X import Utility.FileSystemEncoding as X +import Utility.OsPath as X import Utility.PartialPrelude as X diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -94,7 +94,7 @@ 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 @@ 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 --- 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 --- a/Config/Files/AutoStart.hs +++ b/Config/Files/AutoStart.hs @@ -14,36 +14,36 @@ 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 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 --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -17,8 +17,9 @@ import Config import Utility.Directory.Create import Annex.Version +import qualified Utility.FileIO as F -import qualified System.FilePath.ByteString as P +import qualified Data.ByteString as S configureSmudgeFilter :: Annex () configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do @@ -44,11 +45,12 @@ lfs <- readattr lf gfs <- readattr gf gittop <- Git.localGitDir <$> gitRepo - liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do - createDirectoryUnder [gittop] (P.takeDirectory lf) - writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr) + liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do + createDirectoryUnder [gittop] (takeDirectory lf) + F.writeFile' lf $ + linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr)) where - readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath + readattr = liftIO . catchDefaultIO mempty . F.readFile' configureSmudgeFilterProcess :: Annex () configureSmudgeFilterProcess = @@ -65,9 +67,10 @@ -- git-annex does not commit that. deconfigureSmudgeFilter :: Annex () deconfigureSmudgeFilter = do - lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal - ls <- liftIO $ catchDefaultIO [] $ lines <$> readFileStrict lf - liftIO $ writeFile lf $ unlines $ + lf <- Annex.fromRepo Git.attributesLocal + ls <- liftIO $ catchDefaultIO [] $ + 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 --- a/Creds.hs +++ b/Creds.hs @@ -36,17 +36,16 @@ 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 L -import qualified Data.ByteString.Char8 as S +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 } @@ -99,7 +98,7 @@ storeconfig creds key (Just cipher) = do cmd <- gpgCmd <$> Annex.getGitConfig s <- liftIO $ encrypt cmd (pc, gc) cipher - (feedBytes $ L.pack $ encodeCredPair creds) + (feedBytes $ L8.pack $ encodeCredPair creds) (readBytesStrictly return) storeconfig' key (Accepted (decodeBS (toB64 s))) storeconfig creds key Nothing = @@ -135,8 +134,8 @@ fromenccreds enccreds cipher storablecipher = do cmd <- gpgCmd <$> Annex.getGitConfig mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher - (feedBytes $ L.fromStrict $ fromB64 enccreds) - (readBytesStrictly $ return . S.unpack) + (feedBytes $ L8.fromStrict $ fromB64 enccreds) + (readBytesStrictly $ return . S8.unpack) case mcreds of Just creds -> fromcreds creds Nothing -> do @@ -195,18 +194,21 @@ {- 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 f = liftIO . catchMaybeIO . readFileStrict =<< credsFile f +readCreds :: OsPath -> Annex (Maybe Creds) +readCreds f = do + 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 @@ -217,10 +219,10 @@ 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 --- a/Crypto.hs +++ b/Crypto.hs @@ -211,7 +211,7 @@ Cipher{} -> let passphrase = cipherPassphrase cipher in case statelessOpenPGPCommand c of - Just sopcmd -> withTmpDir "sop" $ \d -> + Just sopcmd -> withTmpDir (literalOsPath "sop") $ \d -> SOP.encryptSymmetric sopcmd passphrase (SOP.EmptyDirectory d) (statelessOpenPGPProfile c) @@ -233,7 +233,7 @@ Cipher{} -> let passphrase = cipherPassphrase cipher in case statelessOpenPGPCommand c of - Just sopcmd -> withTmpDir "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 --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -26,13 +26,12 @@ import qualified Data.ByteString.Char8 as B8 import System.Random import Control.Concurrent -import qualified System.FilePath.ByteString as P #endif benchmarkDbs :: CriterionMode -> Integer -> Annex () #ifdef WITH_BENCHMARK -benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do - db <- benchDb (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 @@ } 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 @@ 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 @@ 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 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -47,11 +47,9 @@ 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 @@ 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 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -58,11 +58,9 @@ 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 @@ 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 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 @@ 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 @@ 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 --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -33,12 +33,10 @@ 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 @@ 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 --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -23,6 +23,7 @@ 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 @@ {- 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 @@ | 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 @@ - 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 @@ 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 @@ , BaseBackend backend ~ SqlBackend , BackendCompatible SqlBackend backend ) - => RawFilePath + => OsPath -> (LogFunc -> IO backend) -> (backend -> m a) -> m a @@ -260,7 +261,7 @@ , BaseBackend backend ~ SqlBackend , BackendCompatible SqlBackend backend ) - => RawFilePath + => OsPath -> backend -> IO () closeRobustly db conn = go maxretries emptyDatabaseInodeCache @@ -294,7 +295,7 @@ => String -> err -> Int - -> RawFilePath + -> OsPath -> Int -> DatabaseInodeCache -> (Int -> DatabaseInodeCache -> IO a) @@ -309,9 +310,9 @@ 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 @@ 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 --- a/Database/ImportFeed.hs +++ b/Database/ImportFeed.hs @@ -40,11 +40,9 @@ 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 @@ 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 --- a/Database/Init.hs +++ b/Database/Init.hs @@ -20,7 +20,6 @@ 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 @@ - 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 @@ - - 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 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -54,11 +54,10 @@ 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 @@ 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 @@ ) {- 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 @@ 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 @@ ( 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 @@ -- 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 @@ 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 @@ 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 @@ 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 --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -22,6 +22,7 @@ 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 @@ (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 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 @@ 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 --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -19,9 +19,9 @@ ) 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 @@ {- 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 --- a/Database/RawFilePath.hs +++ b/Database/RawFilePath.hs @@ -38,7 +38,7 @@ #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 UnliftIO.Resource (ResourceT, runResourceT) openWith' - :: P.RawFilePath + :: RawFilePath -> (SqlBackend -> Sqlite.Connection -> r) -> SqliteConnectionInfo -> LogFunc @@ -58,7 +58,7 @@ 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 @@ withSqliteConn' :: (MonadUnliftIO m, MonadLoggerIO m) - => P.RawFilePath + => RawFilePath -> (SqlBackend -> m a) -> m a withSqliteConn' connstr = withSqliteConnInfo' connstr $ @@ -76,7 +76,7 @@ runSqliteInfo' :: (MonadUnliftIO m) - => P.RawFilePath + => RawFilePath -> SqliteConnectionInfo -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a @@ -87,7 +87,7 @@ withSqliteConnInfo' :: (MonadUnliftIO m, MonadLoggerIO m) - => P.RawFilePath + => RawFilePath -> SqliteConnectionInfo -> (SqlBackend -> m a) -> m a diff --git a/Database/RepoSize.hs b/Database/RepoSize.hs --- a/Database/RepoSize.hs +++ b/Database/RepoSize.hs @@ -42,11 +42,9 @@ 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 @@ 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 --- a/Git.hs +++ b/Git.hs @@ -38,15 +38,14 @@ 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 { 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 @@ | 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 @@ 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/AutoCorrect.hs b/Git/AutoCorrect.hs --- a/Git/AutoCorrect.hs +++ b/Git/AutoCorrect.hs @@ -1,11 +1,11 @@ {- git autocorrection using Damerau-Levenshtein edit distance - - - Copyright 2012 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Git.AutoCorrect where @@ -16,6 +16,7 @@ import Text.EditDistance import Control.Concurrent import qualified Data.List.NonEmpty as NE +import Data.Char {- These are the same cost values as used in git. -} gitEditCosts :: EditCosts @@ -45,30 +46,50 @@ {- Takes action based on git's autocorrect configuration, in preparation for - an autocorrected command being run. -} -prepare :: String -> (c -> String) -> NE.NonEmpty c -> Maybe Repo -> IO () -prepare input showmatch matches r = - case readish . fromConfigValue . Git.Config.get "help.autocorrect" "0" =<< r of +prepare :: String -> String -> (c -> String) -> NE.NonEmpty c -> Maybe Repo -> IO () +prepare cmdname input showmatch matches r = + case readish . getcfg =<< r of Just n | n == 0 -> list | n < 0 -> warn Nothing | otherwise -> sleep n - Nothing -> list + Nothing -> case getcfg <$> r of + Just "prompt" -> prompt + Just "never" -> unknowncommand + Just "immediate" -> warn Nothing + _ -> list where + getcfg = fromConfigValue . Git.Config.get "help.autocorrect" "0" + list = giveup $ unlines $ [ "Unknown command '" ++ input ++ "'" , "" , "Did you mean one of these?" ] ++ map (\m -> "\t" ++ showmatch m) (NE.toList matches) + warn :: Maybe Float -> IO () warn mdelaysec = hPutStr stderr $ unlines - [ "WARNING: You called a git-annex command named '" ++ - input ++ "', which does not exist." + [ warning , case mdelaysec of - Nothing -> "Continuing under the assumption that you meant " ++ match - Just sec -> "Continuing in " ++ show sec ++ " seconds, assuming that you meant " ++ match + Nothing -> "Continuing under the assumption that you meant " ++ match ++ "." + Just sec -> "Continuing in " ++ show sec ++ " seconds, assuming that you meant " ++ match ++ "." ] - where - match = "'" ++ showmatch (NE.head matches) ++ "'." + + match = "'" ++ showmatch (NE.head matches) ++ "'" + + warning = "WARNING: You called a " ++ cmdname ++ " command named '" ++ + input ++ "', which does not exist." + sleep n = do warn (Just (fromIntegral n / 10 :: Float)) threadDelay (n * 100000) -- deciseconds to microseconds + + prompt = do + hPutStrLn stderr warning + hPutStr stderr ("Run " ++ match ++ " instead [y/N]? ") + hFlush stderr + resp <- headMaybe . map toLower <$> getLine + when (resp /= Just 'y') $ + exitWith (ExitFailure 1) + + unknowncommand = giveup $ "Unknown command '" ++ input ++ "'" diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -99,11 +99,11 @@ 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 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -11,12 +11,11 @@ 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 @@ - 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 @@ 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 @@ 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 --- a/Git/CheckIgnore.hs +++ b/Git/CheckIgnore.hs @@ -52,11 +52,11 @@ 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 @@ 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 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -24,10 +24,10 @@ 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 @@ - 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 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -14,7 +14,6 @@ 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 @@ 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 @@ 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 @@ -} 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 @@ 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 @@ -- 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 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -40,15 +40,12 @@ import qualified Git.Url as Url import Utility.UserInfo import Utility.Url.Parse -import qualified Utility.RawFilePath as R - -import qualified Data.ByteString as B -import qualified System.FilePath.ByteString as P +import qualified Utility.OsString as OS {- Finds the git repository used for the cwd, which may be in a parent - directory. -} fromCwd :: IO (Maybe Repo) -fromCwd = R.getCurrentDirectory >>= seekUp +fromCwd = getCurrentDirectory >>= seekUp where seekUp dir = do r <- checkForRepo dir @@ -59,31 +56,32 @@ 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' :: 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 @@ [ s , "//" , auth - , fromRawFilePath (repoPath r) + , fromOsPath (repoPath r) ] in r { location = Url $ fromJust $ parseURIPortable absurl } _ -> r @@ -176,43 +174,43 @@ 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 @@ {- 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 @@ , 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' :: 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 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -16,10 +16,7 @@ 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 @@ 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 @@ 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 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -18,7 +18,6 @@ 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.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 @@ 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 @@ <*> (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 --- a/Git/Env.hs +++ b/Git/Env.hs @@ -30,9 +30,9 @@ - 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 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -32,13 +32,11 @@ 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 @@ 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 @@ - 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 --- a/Git/FilterProcess.hs +++ b/Git/FilterProcess.hs @@ -130,7 +130,7 @@ -- 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 @@ 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 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.HashObject where @@ -14,14 +14,14 @@ 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 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 @@ -- 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 @@ {- 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 "hash" $ \tmp tmph -> do +hashBlob h b = withTmpFile (literalOsPath "hash") $ \tmp tmph -> do hashableBlobToHandle tmph b hClose tmph - hashFile h (toRawFilePath tmp) + hashFile h tmp {- Injects some content into git, returning its Sha. - diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Hook where @@ -14,15 +15,14 @@ import Utility.Tmp import Utility.Shell import Utility.FileMode +import qualified Utility.FileIO as F #ifndef mingw32_HOST_OS import qualified Utility.RawFilePath as R import System.PosixCompat.Files (fileMode) #endif -import qualified Data.ByteString as B - data Hook = Hook - { hookName :: FilePath + { hookName :: OsPath , hookScript :: String , hookOldScripts :: [String] } @@ -31,8 +31,8 @@ instance Eq Hook where a == b = hookName a == hookName b -hookFile :: Hook -> Repo -> FilePath -hookFile h r = fromRawFilePath (localGitDir r) "hooks" 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. @@ -58,15 +58,13 @@ where f = hookFile h r go = do - -- On Windows, using B.writeFile here avoids - -- the newline translation done by writeFile. + -- On Windows, using a ByteString as the file content + -- avoids the newline translation done by writeFile. -- 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 B.writeFile f (encodeBS (hookScript h)) - void $ tryIO $ modifyFileMode - (toRawFilePath f) - (addModes executeModes) + viaTmp F.writeFile' f (encodeBS (hookScript h)) + void $ tryIO $ modifyFileMode f (addModes executeModes) return True {- Removes a hook. Returns False if the hook contained something else, and @@ -91,7 +89,7 @@ -- 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 $ hookFile h r + content <- readFile $ fromOsPath $ hookFile h r return $ if content == hookScript h then ExpectedContent else if any (content ==) (hookOldScripts h) @@ -103,7 +101,7 @@ let f = hookFile h r catchBoolIO $ #ifndef mingw32_HOST_OS - isExecutable . fileMode <$> R.getFileStatus (toRawFilePath f) + isExecutable . fileMode <$> R.getFileStatus (fromOsPath f) #else doesFileExist f #endif diff --git a/Git/Index.hs b/Git/Index.hs --- a/Git/Index.hs +++ b/Git/Index.hs @@ -14,8 +14,6 @@ import Utility.Env import Utility.Env.Set -import qualified System.FilePath.ByteString as P - indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -30,8 +28,8 @@ - - 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 @@ - - 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 @@ 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 --- a/Git/LockFile.hs +++ b/Git/LockFile.hs @@ -21,9 +21,9 @@ #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 @@ - 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 @@ ] 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 @@ -- 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 --- a/Git/Log.hs +++ b/Git/Log.hs @@ -19,7 +19,7 @@ data LoggedFileChange t = LoggedFileChange { changetime :: POSIXTime , changed :: t - , changedfile :: FilePath + , changedfile :: OsPath , oldref :: Ref , newref :: Ref } @@ -34,7 +34,7 @@ -> 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 @@ -- -- 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 @@ _ -> (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 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -39,14 +39,13 @@ 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 @@ {- 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 @@ {- 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 @@ {- 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 @@ - 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 @@ 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 @@ , 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 @@ } 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 @@ - 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 @@ 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 @@ 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 @@ -- 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 @@ - 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 @@ 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. @@ -373,4 +375,4 @@ mkInodeCache <$> (readish =<< M.lookup "ino:" m) <*> (readish =<< M.lookup "size:" m) - <*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m)) + <*> (parsePOSIXTime =<< (encodeBS . replace ":" "." <$> M.lookup "mtime:" m)) diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -137,7 +137,8 @@ -- 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 @@ [ 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 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -12,38 +12,47 @@ 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 -> RawFilePath -objectsDir r = localGitDir r P. "objects" +objectsDir :: Repo -> OsPath +objectsDir r = localGitDir r literalOsPath "objects" -packDir :: Repo -> RawFilePath -packDir r = objectsDir r P. "pack" +packDir :: Repo -> OsPath +packDir r = objectsDir r literalOsPath "pack" -packIdxFile :: RawFilePath -> RawFilePath -packIdxFile = flip P.replaceExtension "idx" +packIdxFile :: OsPath -> OsPath +packIdxFile = flip replaceExtension (literalOsPath "idx") -listPackFiles :: Repo -> IO [FilePath] -listPackFiles r = filter (".pack" `isSuffixOf`) - <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r) +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) - <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (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 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -53,11 +53,11 @@ - 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 @@ {- 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 --- 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 @@ 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 @@ 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 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -15,6 +15,7 @@ import Git.Sha import Git.Types import Git.FilePath +import qualified Utility.FileIO as F import Data.Char (chr, ord) import qualified Data.ByteString as S @@ -23,11 +24,12 @@ headRef :: Ref headRef = Ref "HEAD" -headFile :: Repo -> FilePath -headFile r = fromRawFilePath (localGitDir r) "HEAD" +headFile :: Repo -> OsPath +headFile r = localGitDir r literalOsPath "HEAD" setHeadRef :: Ref -> Repo -> IO () -setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref) +setHeadRef ref r = + F.writeFile' (headFile r) ("ref: " <> fromRef' ref) {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String @@ -67,7 +69,7 @@ - - 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 @@ -77,12 +79,13 @@ -- 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 @@ -93,7 +96,7 @@ - - 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 @@ -110,8 +113,8 @@ {- 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 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -122,8 +122,8 @@ #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 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -43,11 +43,11 @@ 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. -} @@ -57,7 +57,7 @@ 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) $ @@ -78,29 +78,25 @@ explodePacks r = go =<< listPackFiles r where go [] = return False - go packs = withTmpDir "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. - allowRead (toRawFilePath packfile) + allowRead packfile -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> - L.hPut h =<< L.readFile packfile + L.hPut h =<< F.readFile packfile objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir) forM_ objs $ \objfile -> do - f <- relPathDirToFile - (toRawFilePath tmpdir) - (toRawFilePath objfile) - let dest = objectsDir r P. f - createDirectoryIfMissing True - (fromRawFilePath (parentDir dest)) - moveFile (toRawFilePath objfile) dest + f <- relPathDirToFile tmpdir objfile + let dest = objectsDir r f + createDirectoryIfMissing True (parentDir dest) + moveFile objfile dest forM_ packs $ \packfile -> do - let f = toRawFilePath packfile - removeWhenExistsWith R.removeLink f - removeWhenExistsWith R.removeLink (packIdxFile f) + removeWhenExistsWith removeFile packfile + removeWhenExistsWith removeFile (packIdxFile packfile) return True {- Try to retrieve a set of missing objects, from the remotes of a @@ -113,13 +109,13 @@ retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults retrieveMissingObjects missing referencerepo r | not (foundBroken missing) = return missing - | otherwise = withTmpDir "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' = fromRawFilePath (localGitDir r' P. "config") + | 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)) $ - L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr) + F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr) rs <- Construct.fromRemotes r stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) @@ -180,8 +176,8 @@ 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 @@ -248,35 +244,35 @@ - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") +getAllRefs r = getAllRefs' (localGitDir r literalOsPath "refs") -getAllRefs' :: FilePath -> IO [Ref] +getAllRefs' :: OsPath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . toInternalGitPath . encodeBS - . joinPath . drop topsegs . splitPath + let toref = Ref . fromOsPath . toInternalGitPath + . joinPath . drop topsegs . splitPath 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 . lines - <$> catchDefaultIO "" (safeReadFile f') + rs <- mapMaybe parsePacked + . map decodeBS + . fileLines' + <$> 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 @@ -288,7 +284,8 @@ {- 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. @@ -407,7 +404,7 @@ 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) @@ -426,11 +423,11 @@ | 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 @@ -473,14 +470,14 @@ -} preRepair :: Repo -> IO () preRepair g = do - unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do - removeWhenExistsWith R.removeLink headfile - writeFile (fromRawFilePath headfile) "ref: refs/heads/master" + unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do + 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)) @@ -607,7 +604,7 @@ 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 @@ -651,7 +648,7 @@ successfulRepair :: (Bool, [Branch]) -> Bool successfulRepair = fst -safeReadFile :: RawFilePath -> IO String +safeReadFile :: OsPath -> IO B.ByteString safeReadFile f = do allowRead f - readFileStrict (fromRawFilePath f) + F.readFile' f diff --git a/Git/Status.hs b/Git/Status.hs --- a/Git/Status.hs +++ b/Git/Status.hs @@ -57,13 +57,13 @@ 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 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -37,14 +37,13 @@ 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 @@ , " " , fromRef s , "\t" - , takeFileName (fromRawFilePath (getTopFilePath f)) + , fromOsPath (takeFileName (getTopFilePath f)) , "\NUL" ] @@ -181,7 +180,7 @@ 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 @@ _ -> 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 @@ 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 @@ 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 @@ | 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 @@ 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 @@ 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 @@ - 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 --- 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.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 @@ - 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 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 @@ -137,7 +145,7 @@ {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject - deriving (Show) + deriving (Show, Eq) readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -76,14 +76,14 @@ 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 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -81,6 +81,7 @@ 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 @@ <> " 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 @@ "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 @@ - 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 @@ 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 --- a/Key.hs +++ b/Key.hs @@ -18,6 +18,7 @@ keyParser, serializeKey, serializeKey', + serializeKey'', deserializeKey, deserializeKey', nonChunkKey, @@ -31,7 +32,7 @@ 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,8 +64,11 @@ 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 @@ 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 AssociatedFile where arbitrary = AssociatedFile - . fmap (toRawFilePath . fromTestableFilePath) + . fmap (toOsPath . fromTestableFilePath) <$> arbitrary instance Arbitrary Key where diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -48,7 +48,6 @@ 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 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 @@ 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 @@ addMagicLimit :: String - -> (Magic -> FilePath -> Annex (Maybe String)) + -> (Magic -> OsPath -> Annex (Maybe String)) -> (ProvidedInfo -> Maybe String) -> (UserProvidedInfo -> UserInfo String) -> String @@ -228,20 +227,19 @@ 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 @@ 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 @@ 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 @@ 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 @@ } {- 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 @@ , 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 @@ 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 --- a/Logs.hs +++ b/Logs.hs @@ -11,9 +11,7 @@ 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 @@ {- 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 = 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 @@ ] ++ 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 @@ ] {- 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 @@ ] {- Other top-level logs. -} -otherTopLevelLogs :: [RawFilePath] +otherTopLevelLogs :: [OsPath] otherTopLevelLogs = [ numcopiesLog , mincopiesLog @@ -112,188 +110,188 @@ , 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/AdjustedBranchUpdate.hs b/Logs/AdjustedBranchUpdate.hs --- a/Logs/AdjustedBranchUpdate.hs +++ b/Logs/AdjustedBranchUpdate.hs @@ -80,5 +80,5 @@ "1" -> Just True "0" -> Just False _ -> Nothing - t <- parsePOSIXTime ts + t <- parsePOSIXTime (encodeBS ts) return (b, t) diff --git a/Logs/EquivilantKeys.hs b/Logs/EquivilantKeys.hs --- a/Logs/EquivilantKeys.hs +++ b/Logs/EquivilantKeys.hs @@ -1,6 +1,6 @@ {- Logs listing keys that are equivalent to a key. - - - Copyright 2024 Joey Hess + - Copyright 2024-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,6 +10,9 @@ module Logs.EquivilantKeys ( getEquivilantKeys, setEquivilantKey, + updateEquivilantKeys, + addEquivilantKey, + generateEquivilantKey, ) where import Annex.Common @@ -17,6 +20,11 @@ import Logs import Logs.Presence import qualified Annex.Branch +import qualified Backend.Hash +import Types.KeySource +import Types.Backend +import Types.Remote (Verification(..)) +import Utility.Metered getEquivilantKeys :: Key -> Annex [Key] getEquivilantKeys key = do @@ -29,3 +37,34 @@ config <- Annex.getGitConfig addLog (Annex.Branch.RegardingUUID []) (equivilantKeysLogFile config key) InfoPresent (LogInfo (serializeKey' equivkey)) + +-- This returns Verified when when an equivilant key has been added to the +-- log (or was already in the log). This is to avoid hashing the object +-- again later. +updateEquivilantKeys :: Backend -> OsPath -> Key -> [Key] -> Annex (Maybe Verification) +updateEquivilantKeys b obj key eks = generateEquivilantKey b obj >>= \case + Nothing -> return Nothing + Just ek -> do + unless (ek `elem` eks) $ + setEquivilantKey key ek + return (Just Verified) + +addEquivilantKey :: Backend -> Key -> OsPath -> Annex (Maybe Verification) +addEquivilantKey b key obj = + updateEquivilantKeys b obj key + =<< getEquivilantKeys key + +-- The Backend must use a cryptographically secure hash. +generateEquivilantKey :: Backend -> OsPath -> Annex (Maybe Key) +generateEquivilantKey b obj = + case genKey b of + Just genkey -> do + showSideAction (UnquotedString Backend.Hash.descChecksum) + Just <$> genkey source nullMeterUpdate + Nothing -> return Nothing + where + source = KeySource + { keyFilename = mempty -- avoid adding any extension + , contentLocation = obj + , inodeCache = Nothing + } diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -34,6 +34,7 @@ import qualified Git.LsTree import qualified Git.Tree import Annex.UUID +import qualified Utility.FileIO as F import qualified Data.Map as M import qualified Data.ByteString as B @@ -129,7 +130,7 @@ getExportExcluded u = do logf <- fromRepo $ gitAnnexExportExcludeLog u liftIO $ catchDefaultIO [] $ exportExcludedParser - <$> L.readFile (fromRawFilePath logf) + <$> F.readFile logf where exportExcludedParser :: L.ByteString -> [Git.Tree.TreeItem] diff --git a/Logs/File.hs b/Logs/File.hs --- a/Logs/File.hs +++ b/Logs/File.hs @@ -26,46 +26,43 @@ import Annex.LockFile import Annex.ReplaceFile import Utility.Tmp +import qualified Utility.FileIO as F -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L 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 (fromRawFilePath f) c +writeLogFile :: OsPath -> String -> Annex () +writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c where writelog tmp c' = do - liftIO $ writeFile tmp c' - setAnnexFilePerm (toRawFilePath 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 (fromRawFilePath f) $ \tmp -> + replaceGitAnnexDirFile f $ \tmp -> bracket (setup tmp) cleanup a where setup tmp = do setAnnexFilePerm tmp - liftIO $ openFile (fromRawFilePath 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 $ withFile f' AppendMode $ + liftIO $ F.withFile f AppendMode $ \h -> L8.hPutStrLn h c - setAnnexFilePerm (toRawFilePath f') - where - f' = fromRawFilePath f + setAnnexFilePerm f -- | Modifies a log file. -- @@ -75,43 +72,41 @@ -- -- 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 <$> L.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' = fromRawFilePath f writelog lf b = do - liftIO $ L.writeFile lf b - setAnnexFilePerm (toRawFilePath lf) + liftIO $ F.writeFile lf b + 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 $ openFile f' ReadMode + setup = liftIO $ tryWhenExists $ F.openFile f ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = return False go (Just h) = do !r <- liftIO (any matchf . fileLines <$> L.hGetContents h) return r - f' = fromRawFilePath f -- | 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 $ openFile f' ReadMode + setup = liftIO $ tryWhenExists $ F.openFile f ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = return start @@ -120,7 +115,6 @@ go' v (l:ls) = do let !v' = update l v go' v' ls - f' = fromRawFilePath f -- | Streams lines from a log file, passing each line to the processor, -- and then empties the file at the end. @@ -134,19 +128,19 @@ -- -- Locking is used to prevent writes to to the log file while this -- is running. -streamLogFile :: FilePath -> 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 $ writeFile f "" - setAnnexFilePerm (toRawFilePath f) + liftIO $ F.writeFile' f mempty + setAnnexFilePerm f -- Unsafe version that does not do locking, and does not empty the file -- at the end. -streamLogFileUnsafe :: FilePath -> Annex () -> (String -> Annex ()) -> Annex () +streamLogFileUnsafe :: OsPath -> Annex () -> (String -> Annex ()) -> Annex () streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go where - setup = liftIO $ tryWhenExists $ openFile f ReadMode + setup = liftIO $ tryWhenExists $ F.openFile f ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = finalizer @@ -155,38 +149,9 @@ 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. createAnnexDirectory (parentDir f) a - --- On windows, readFile does NewlineMode translation, --- stripping CR before LF. When converting to ByteString, --- use this to emulate that. -fileLines :: L.ByteString -> [L.ByteString] -#ifdef mingw32_HOST_OS -fileLines = map stripCR . L8.lines - where - stripCR b = case L8.unsnoc b of - Nothing -> b - Just (b', e) - | e == '\r' -> b' - | otherwise -> b -#else -fileLines = L8.lines -#endif - -fileLines' :: S.ByteString -> [S.ByteString] -#ifdef mingw32_HOST_OS -fileLines' = map stripCR . S8.lines - where - stripCR b = case S8.unsnoc b of - Nothing -> b - Just (b', e) - | e == '\r' -> b' - | otherwise -> b -#else -fileLines' = S8.lines -#endif diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -15,7 +15,6 @@ 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 @@ 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 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 @@ 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 --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -124,7 +124,7 @@ 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 @@ 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 --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -59,7 +59,7 @@ 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 @@ 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 @@ 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 @@ (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 --- a/Logs/Migrate.hs +++ b/Logs/Migrate.hs @@ -56,11 +56,10 @@ 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. @@ -79,7 +78,7 @@ -- | Commits a migration to the git-annex branch. commitMigration :: Annex () commitMigration = do - logf <- fromRawFilePath <$> fromRepo gitAnnexMigrateLog + logf <- fromRepo gitAnnexMigrateLog lckf <- fromRepo gitAnnexMigrateLock nv <- liftIO $ newTVarIO (0 :: Integer) g <- Annex.gitRepo @@ -95,7 +94,7 @@ 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 @@ 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 @@ (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 @@ 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 @@ 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 --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -32,7 +32,7 @@ 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 --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -32,11 +32,11 @@ 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 @@ - 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 @@ {- 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 @@ - - 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 --- a/Logs/Restage.hs +++ b/Logs/Restage.hs @@ -14,10 +14,10 @@ import Logs.File import Utility.InodeCache import Annex.LockFile +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 @@ -48,26 +48,25 @@ streamRestageLog finalizer processor = do logf <- fromRepo gitAnnexRestageLog oldf <- fromRepo gitAnnexRestageLogOld - let oldf' = fromRawFilePath oldf lckf <- fromRepo gitAnnexRestageLock withExclusiveLock lckf $ liftIO $ - whenM (R.doesPathExist logf) $ - ifM (R.doesPathExist oldf) + whenM (doesPathExist logf) $ + ifM (doesPathExist oldf) ( do - h <- openFile 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 ) - streamLogFileUnsafe oldf' finalizer $ \l -> + streamLogFileUnsafe oldf finalizer $ \l -> case parseRestageLog l of 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 @@ 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 --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -63,7 +63,7 @@ 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 --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -27,13 +27,13 @@ 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 --- a/Logs/Smudge.hs +++ b/Logs/Smudge.hs @@ -21,7 +21,7 @@ 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. -- @@ -34,7 +34,7 @@ streamSmudged a = do logf <- fromRepo gitAnnexSmudgeLog lckf <- fromRepo gitAnnexSmudgeLock - streamLogFile (fromRawFilePath logf) lckf noop $ \l -> + streamLogFile logf lckf noop $ \l -> case parse l of Nothing -> noop Just (k, f) -> a k f @@ -43,4 +43,4 @@ 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 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -21,7 +21,8 @@ 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 @@ -29,8 +30,6 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Control.Concurrent.STM -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 @@ -60,20 +59,21 @@ - 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 @@ -107,9 +107,9 @@ 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 @@ -118,7 +118,7 @@ (Just oldlck, _) -> getLockStatus oldlck case v' of StatusLockedBy pid -> liftIO $ catchDefaultIO Nothing $ - readTransferInfoFile (Just pid) (fromRawFilePath tfile) + readTransferInfoFile (Just pid) tfile _ -> do mode <- annexFileMode -- Ignore failure due to permissions, races, etc. @@ -139,7 +139,7 @@ v <- liftIO $ lockShared lck liftIO $ case v of Nothing -> catchDefaultIO Nothing $ - readTransferInfoFile Nothing (fromRawFilePath tfile) + readTransferInfoFile Nothing tfile Just lockhandle -> do dropLock lockhandle deletestale @@ -157,7 +157,7 @@ infos <- mapM checkTransfer transfers return $ mapMaybe running $ zip transfers infos where - findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath) + findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive) =<< mapM (fromRepo . transferDir) dirs running (t, Just i) = Just (t, i) running (_, Nothing) = Nothing @@ -184,7 +184,7 @@ return $ case (mt, mi) of (Just t, Just i) -> Just (t, i) _ -> Nothing - findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath) + findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive) =<< mapM (fromRepo . failedTransferDir u) [Download, Upload] clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)] @@ -196,7 +196,7 @@ 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 @@ -223,46 +223,47 @@ - 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 :: FilePath -> Maybe Transfer +parseTransferFile :: OsPath -> Maybe Transfer parseTransferFile file - | "lck." `isPrefixOf` 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 (toRawFilePath key)) + <*> fmap (fromKey id) (fileKey key) _ -> Nothing where 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. @@ -281,12 +282,12 @@ #endif -- comes last; arbitrary content , let AssociatedFile afile = associatedFile info - in maybe "" fromRawFilePath afile + in maybe "" fromOsPath afile ] -readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo) +readTransferInfoFile :: Maybe PID -> OsPath -> IO (Maybe TransferInfo) readTransferInfoFile mpid tfile = catchDefaultIO Nothing $ - readTransferInfo mpid <$> readFileStrict tfile + readTransferInfo mpid . decodeBS <$> F.readFile' tfile readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo readTransferInfo mpid s = TransferInfo @@ -299,12 +300,18 @@ <*> 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 - (firstline, otherlines) = separate (== '\n') s - (secondline, rest) = separate (== '\n') otherlines + (firstliner, otherlines) = separate (== '\n') s + (secondliner, rest) = separate (== '\n') otherlines + firstline = dropWhileEnd (== '\r') firstliner + secondline = dropWhileEnd (== '\r') secondliner mpid' = readish secondline #else (firstline, rest) = separate (== '\n') s @@ -315,23 +322,25 @@ bits = splitc ' ' firstline numbits = length bits time = if numbits > 0 - then Just <$> parsePOSIXTime =<< headMaybe bits + then Just <$> parsePOSIXTime . encodeBS =<< headMaybe bits else pure Nothing -- not failure bytes = if numbits > 1 then Just <$> readish =<< headMaybe (drop 1 bits) 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 --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -32,8 +32,8 @@ 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 @@ {- 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/Trust.hs b/Logs/Trust.hs --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -1,6 +1,6 @@ {- git-annex trust log - - - Copyright 2010-2022 Joey Hess + - Copyright 2010-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,17 +18,14 @@ trustMapLoad, ) where -import qualified Data.Map as M -import Data.Default - import Annex.Common import Types.TrustLevel -import qualified Annex import Logs import Remote.List -import qualified Types.Remote import Logs.Trust.Basic as X +import qualified Data.Map as M + {- Returns a list of UUIDs that the trustLog indicates have the - specified trust level. - Note that the list can be incomplete for SemiTrusted, since that's @@ -63,24 +60,8 @@ {- trustLog in a map, overridden with any values from forcetrust or - the git config. The map is cached for speed. -} trustMap :: Annex TrustMap -trustMap = maybe trustMapLoad return =<< Annex.getState Annex.trustmap +trustMap = trustMap' =<< remoteList {- Loads the map, updating the cache, -} trustMapLoad :: Annex TrustMap -trustMapLoad = do - forceoverrides <- Annex.getState Annex.forcetrust - l <- remoteList - let untrustoverrides = M.fromList $ - map (\r -> (Types.Remote.uuid r, UnTrusted)) - (filter Types.Remote.untrustworthy l) - logged <- trustMapRaw - let configured = M.fromList $ mapMaybe configuredtrust l - let m = M.unionWith min untrustoverrides $ - M.union forceoverrides $ - M.union configured logged - Annex.changeState $ \s -> s { Annex.trustmap = Just m } - return m - where - configuredtrust r = (\l -> Just (Types.Remote.uuid r, l)) - =<< readTrustLevel - =<< remoteAnnexTrustLevel (Types.Remote.gitconfig r) +trustMapLoad = trustMapLoad' =<< remoteList diff --git a/Logs/Trust/Basic.hs b/Logs/Trust/Basic.hs --- a/Logs/Trust/Basic.hs +++ b/Logs/Trust/Basic.hs @@ -1,6 +1,6 @@ {- git-annex trust log, basics - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,16 +9,21 @@ module X, trustSet, trustMapRaw, + trustMap', + trustMapLoad', ) where import Annex.Common import Types.TrustLevel import qualified Annex.Branch import qualified Annex +import qualified Types.Remote import Logs import Logs.UUIDBased import Logs.Trust.Pure as X +import qualified Data.Map as M + {- Changes the trust level for a uuid in the trustLog. -} trustSet :: UUID -> TrustLevel -> Annex () trustSet uuid@(UUID _) level = do @@ -34,3 +39,24 @@ - log file. -} trustMapRaw :: Annex TrustMap trustMapRaw = calcTrustMap <$> Annex.Branch.get trustLog + +trustMap' :: [Remote] -> Annex TrustMap +trustMap' l = maybe (trustMapLoad' l) return =<< Annex.getState Annex.trustmap + +trustMapLoad' :: [Remote] -> Annex TrustMap +trustMapLoad' l = do + forceoverrides <- Annex.getState Annex.forcetrust + let untrustoverrides = M.fromList $ + map (\r -> (Types.Remote.uuid r, UnTrusted)) + (filter Types.Remote.untrustworthy l) + logged <- trustMapRaw + let configured = M.fromList $ mapMaybe configuredtrust l + let m = M.unionWith min untrustoverrides $ + M.union forceoverrides $ + M.union configured logged + Annex.changeState $ \s -> s { Annex.trustmap = Just m } + return m + where + configuredtrust r = (\lvl -> Just (Types.Remote.uuid r, lvl)) + =<< readTrustLevel + =<< remoteAnnexTrustLevel (Types.Remote.gitconfig r) diff --git a/Logs/Unused.hs b/Logs/Unused.hs --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -32,6 +32,7 @@ import qualified Data.Set as S import Data.Time.Clock.POSIX import Data.Time +import qualified Utility.FileIO as F import Annex.Common import qualified Annex @@ -57,13 +58,13 @@ 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 @@ -71,16 +72,16 @@ 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 <- fromRawFilePath <$> fromRepo (gitAnnexUnusedLog prefix) + f <- fromRepo (gitAnnexUnusedLog prefix) ifM (liftIO $ doesFileExist f) - ( M.fromList . mapMaybe parse . lines - <$> liftIO (readFileStrict f) + ( M.fromList . mapMaybe (parse . decodeBS) . fileLines' + <$> liftIO (F.readFile' f) , return M.empty ) where - parse line = case (readish sint, deserializeKey skey, parsePOSIXTime ts) of + parse line = case (readish sint, deserializeKey skey, parsePOSIXTime (encodeBS ts)) of (Just int, Just key, mtimestamp) -> Just (key, (int, mtimestamp)) _ -> Nothing where @@ -89,13 +90,13 @@ 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) @@ -103,7 +104,7 @@ =<< 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 --- a/Logs/Upgrade.hs +++ b/Logs/Upgrade.hs @@ -19,6 +19,7 @@ import Utility.TimeStamp import Logs.File import Types.RepoVersion +import qualified Utility.FileIO as F import Data.Time.Clock.POSIX @@ -31,14 +32,14 @@ readUpgradeLog :: Annex [(RepoVersion, POSIXTime)] readUpgradeLog = do - logfile <- fromRawFilePath <$> fromRepo gitAnnexUpgradeLog + logfile <- fromRepo gitAnnexUpgradeLog ifM (liftIO $ doesFileExist logfile) - ( mapMaybe parse . lines - <$> liftIO (readFileStrict logfile) + ( mapMaybe (parse . decodeBS) . fileLines' + <$> liftIO (F.readFile' logfile) , return [] ) where - parse line = case (readish sint, parsePOSIXTime ts) of + parse line = case (readish sint, parsePOSIXTime (encodeBS ts)) of (Just v, Just t) -> Just (RepoVersion v, t) _ -> Nothing where diff --git a/Logs/View.hs b/Logs/View.hs --- a/Logs/View.hs +++ b/Logs/View.hs @@ -54,7 +54,7 @@ recentViews :: Annex [View] recentViews = do - f <- fromRawFilePath <$> fromRepo gitAnnexViewLog + f <- fromOsPath <$> fromRepo gitAnnexViewLog liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f) {- Gets the currently checked out view, if there is one. diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -190,7 +190,7 @@ 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 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -34,6 +34,7 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -55,7 +55,7 @@ - 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 @@ 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 --- 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 @@ 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 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -18,13 +18,14 @@ 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 @@ 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 @@ -80,8 +81,8 @@ iv <- startVerifyKeyContentIncrementally DefaultVerify k 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) + logStatusAfter NoLiveUpdate k $ getViaTmp rsp DefaultVerify k Nothing $ \tmp -> + 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 @@ 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 @@ 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 @@ 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 --- 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 @@ 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 @@ (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 --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -37,6 +37,7 @@ 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 @@ -> Key -> Maybe Offset -> AssociatedFile - -> FilePath + -> OsPath -> FileSize -> Annex Bool -- ^ Called after sending the file to check if it's valid. @@ -358,7 +359,7 @@ 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 --- a/P2P/Http/Types.hs +++ b/P2P/Http/Types.hs @@ -52,7 +52,7 @@ newtype B64Key = B64Key Key deriving (Show) -newtype B64FilePath = B64FilePath RawFilePath +newtype B64FilePath = B64FilePath OsPath deriving (Show) associatedFileToB64FilePath :: AssociatedFile -> Maybe B64FilePath @@ -233,11 +233,11 @@ 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 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -42,7 +42,6 @@ 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 @@ -- 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 @@ -- 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 @@ 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 --- 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.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.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 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 @@ = 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 @@ -- 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 @@ 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 @@ (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.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -319,22 +319,11 @@ remotesChanged findinmap -{- Filters a list of remotes to ones that have the listed uuids. -} -remotesWithUUID :: [Remote] -> [UUID] -> [Remote] -remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs - -{- Filters a list of remotes to ones that do not have the listed uuids. -} -remotesWithoutUUID :: [Remote] -> [UUID] -> [Remote] -remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs - {- List of repository UUIDs that the location log indicates may have a key. - Dead repositories are excluded. -} keyLocations :: Key -> Annex [UUID] keyLocations key = trustExclude DeadTrusted =<< loggedLocations key -{- Whether to include remotes that have annex-ignore set. -} -newtype IncludeIgnored = IncludeIgnored Bool - {- Cost ordered lists of remotes that the location log indicates - may have a key. - @@ -342,33 +331,16 @@ -} keyPossibilities :: IncludeIgnored -> Key -> Annex [Remote] keyPossibilities ii key = do - u <- getUUID - -- uuids of all remotes that are recorded to have the key - locations <- filter (/= u) <$> keyLocations key - speclocations <- map uuid - . filter (remoteAnnexSpeculatePresent . gitconfig) - <$> remoteList - -- there are unlikely to be many speclocations, so building a Set - -- is not worth the expense - let locations' = speclocations ++ filter (`notElem` speclocations) locations - fst <$> remoteLocations ii locations' [] + locations <- keyLocations key + keyPossibilities' ii key locations =<< remoteList {- Given a list of locations of a key, and a list of all - trusted repositories, generates a cost-ordered list of - remotes that contain the key, and a list of trusted locations of the key. -} remoteLocations :: IncludeIgnored -> [UUID] -> [UUID] -> Annex ([Remote], [UUID]) -remoteLocations (IncludeIgnored ii) locations trusted = do - let validtrustedlocations = nub locations `intersect` trusted - - -- remotes that match uuids that have the key - allremotes <- remoteList - >>= if not ii - then filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) - else return - let validremotes = remotesWithUUID allremotes locations - - return (sortBy (comparing cost) validremotes, validtrustedlocations) +remoteLocations ii locations trusted = + remoteLocations' ii locations trusted =<< remoteList {- Displays known locations of a key and helps the user take action - to make them accessible. -} diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -25,6 +25,7 @@ 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 @@ 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 @@ 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 @@ [ Param "pull" , Param "-a" , File $ fromAndroidPath src - , File dest + , File $ fromOsPath dest ] remove :: AndroidSerial -> AndroidPath -> Remover @@ -240,21 +241,22 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ _ -> 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 @@ 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 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -31,14 +31,12 @@ 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 - #ifdef WITH_TORRENTPARSER import Data.Torrent -import qualified Data.ByteString.Lazy as B +import qualified Utility.FileIO as F #endif remote :: RemoteType @@ -100,7 +98,7 @@ , 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, @@ -121,7 +119,7 @@ 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 () @@ -179,7 +177,7 @@ 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 @@ -191,13 +189,13 @@ -} 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" @@ -205,34 +203,31 @@ 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 - (fromRawFilePath metadir) - (fromRawFilePath torrent) - liftIO $ removeDirectoryRecursive - (fromRawFilePath metadir) + ok <- downloadMagnetLink u metadir torrent + liftIO $ removeDirectoryRecursive metadir return ok else withOtherTmp $ \othertmp -> do - withTmpFileIn (fromRawFilePath othertmp) "torrent" $ \f h -> do + withTmpFileIn othertmp (literalOsPath "torrent") $ \f h -> do liftIO $ hClose h - resetAnnexFilePerm (toRawFilePath f) + resetAnnexFilePerm f ok <- Url.withUrlOptions $ Url.download nullMeterUpdate Nothing u f when ok $ - liftIO $ moveFile (toRawFilePath f) torrent + liftIO $ moveFile f torrent return ok ) -downloadMagnetLink :: URLString -> FilePath -> FilePath -> Annex Bool +downloadMagnetLink :: URLString -> OsPath -> OsPath -> Annex Bool downloadMagnetLink u metadir dest = ifM download ( liftIO $ do - ts <- filter (".torrent" `isSuffixOf`) + ts <- filter (literalOsPath ".torrent" `OS.isSuffixOf`) <$> dirContents metadir case ts of (t:[]) -> do - moveFile (toRawFilePath t) (toRawFilePath dest) + moveFile t dest return True _ -> return False , return False @@ -245,22 +240,22 @@ , Param "--seed-time=0" , Param "--summary-interval=0" , Param "-d" - , File 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 @@ -274,9 +269,9 @@ 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" @@ -363,11 +358,11 @@ {- 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 <- B.readFile (fromRawFilePath 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 @@ -383,19 +378,19 @@ 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 (== ')') $ @@ -404,7 +399,7 @@ 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 --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -39,7 +39,6 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- -- 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 @@ 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 @@ 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 @@ , 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 @@ , 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 @@ 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 @@ , 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 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -12,7 +12,6 @@ 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 @@ , 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 @@ (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 "" = 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 @@ 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/Compute.hs b/Remote/Compute.hs new file mode 100644 --- /dev/null +++ b/Remote/Compute.hs @@ -0,0 +1,855 @@ +{- Compute remote. + - + - Copyright 2025 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Remote.Compute ( + remote, + isComputeRemote, + ComputeState(..), + setComputeState, + getComputeState, + computeStateUrl, + ComputeProgram, + getComputeProgram, + runComputeProgram, + ImmutableState(..), + ComputeProgramResult(..), + computationBehaviorChangeError, + defaultComputeParams, +) where + +import Annex.Common +import qualified Annex +import Types.Remote +import Types.ProposedAccepted +import Types.MetaData +import Types.Creds +import Types.TrustLevel +import Types.RemoteState +import Config +import Config.Cost +import Remote.Helper.Special +import Remote.Helper.ExportImport +import Remote.List.Util +import Annex.SpecialRemote.Config +import Annex.UUID +import Annex.Content +import Annex.Tmp +import Annex.GitShaKey +import Annex.CatFile +import Annex.RepoSize.LiveUpdate +import qualified Annex.Transfer +import Logs.MetaData +import Logs.EquivilantKeys +import Logs.Location +import Logs.Trust.Basic +import Logs.Remote +import Messages.Progress +import Utility.Metered +import Utility.TimeStamp +import Utility.Env +import Utility.Tmp.Dir +import Utility.Url +import Utility.MonotonicClock +import Utility.CopyFile +import Types.Key +import Backend +import qualified Git +import qualified Utility.OsString as OS +import qualified Utility.FileIO as F +import qualified Utility.RawFilePath as R +import qualified Utility.SimpleProtocol as Proto + +import Network.HTTP.Types.URI +import Data.Time.Clock +import Text.Read +import Control.Concurrent.STM +import Control.Concurrent.Async +import System.PosixCompat.Files (isRegularFile) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +remote :: RemoteType +remote = RemoteType + { typename = "compute" + , enumerate = const $ findSpecialRemotes "compute" + , generate = gen + , configParser = computeConfigParser + , setup = setupInstance + , exportSupported = exportUnsupported + , importSupported = importUnsupported + , thirdPartyPopulated = False + } + +isComputeRemote :: Remote -> Bool +isComputeRemote r = typename (remotetype r) == typename remote + +isComputeRemote' :: RemoteConfig -> Bool +isComputeRemote' rc = case M.lookup typeField rc of + Nothing -> False + Just t -> fromProposedAccepted t == typename remote + +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = case getComputeProgram' rc of + Left _err -> return Nothing + Right program -> do + c <- parsedRemoteConfig remote rc + cst <- remoteCost gc c veryExpensiveRemoteCost + return $ Just $ mk program c cst + where + mk program c cst = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyUnsupported + , retrieveKeyFile = computeKey rs program + , retrieveKeyFileInOrder = pure True + , retrieveKeyFileCheap = Nothing + , retrievalSecurityPolicy = RetrievalAllKeysSecure + , removeKey = dropKey rs + , lockContent = Nothing + , checkPresent = checkKey rs + , checkPresentCheap = False + , exportActions = exportUnsupported + , importActions = importUnsupported + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , gitconfig = gc + , localpath = Nothing + , getRepo = return r + , readonly = True + , appendonly = False + , untrustworthy = False + , availability = pure LocallyAvailable + , remotetype = remote + , mkUnavailable = return Nothing + , getInfo = return [] + , claimUrl = Nothing + , checkUrl = Nothing + , remoteStateHandle = rs + } + +setupInstance :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) +setupInstance ss mu _ c _ = do + ComputeProgram program <- either giveup return $ getComputeProgram' c + allowedprograms <- maybe [] words . annexAllowedComputePrograms + <$> Annex.getGitConfig + case ss of + Init -> noop + _ -> unless (program `elem` allowedprograms) $ do + let remotename = fromMaybe "(unknown)" (lookupName c) + giveup $ unwords + [ "Unable to enable compute special remote" + , remotename + , "because its compute program" + , program + , "is not listed in annex.security-allowed-compute-programs" + ] + unlessM (liftIO $ inSearchPath program) $ + giveup $ "Cannot find " ++ program ++ " in PATH" + u <- maybe (liftIO genUUID) return mu + gitConfigSpecialRemote u c [("compute", "true")] + return (c, u) + +computeConfigParser :: RemoteConfig -> Annex RemoteConfigParser +computeConfigParser _ = return $ RemoteConfigParser + { remoteConfigFieldParsers = + [ optionalStringParser programField + (FieldDesc $ "compute program (must start with \"" ++ safetyPrefix ++ "\")") + ] + -- Pass through all other params, which git-annex addcomputed adds + -- to the input params. + , remoteConfigRestPassthrough = Just + ( const True + , [("*", FieldDesc "all other parameters are passed to compute program")] + ) + } + +defaultComputeParams :: Remote -> [String] +defaultComputeParams = map mk . M.toList . getRemoteConfigPassedThrough . config + where + mk (f, v) = fromProposedAccepted f ++ '=' : v + +newtype ComputeProgram = ComputeProgram String + deriving (Show) + +getComputeProgram :: Remote -> Annex ComputeProgram +getComputeProgram r = + case getComputeProgram' (unparsedRemoteConfig (config r)) of + Right program -> return program + Left err -> giveup $ + "Problem with the configuration of compute remote " ++ name r ++ ": " ++ err + +getComputeProgram' :: RemoteConfig -> Either String ComputeProgram +getComputeProgram' c = case fromProposedAccepted <$> M.lookup programField c of + Just program + | safetyPrefix `isPrefixOf` program -> + Right (ComputeProgram program) + | otherwise -> Left $ + "The program's name must begin with \"" ++ safetyPrefix ++ "\"" + Nothing -> Left "Specify program=" + +-- Limiting the program to "git-annex-compute-" prefix is important for +-- security, it prevents autoenabled compute remotes from running arbitrary +-- programs. +safetyPrefix :: String +safetyPrefix = "git-annex-compute-" + +programField :: RemoteConfigField +programField = Accepted "program" + +data ProcessCommand + = ProcessInput FilePath + | ProcessOutput FilePath + | ProcessProgress PercentFloat + | ProcessReproducible + | ProcessSandbox + | ProcessInputRequired FilePath + deriving (Show, Eq) + +instance Proto.Receivable ProcessCommand where + parseCommand "INPUT" = Proto.parse1 ProcessInput + parseCommand "OUTPUT" = Proto.parse1 ProcessOutput + parseCommand "PROGRESS" = Proto.parse1 ProcessProgress + parseCommand "REPRODUCIBLE" = Proto.parse0 ProcessReproducible + parseCommand "SANDBOX" = Proto.parse0 ProcessSandbox + parseCommand "INPUT-REQUIRED" = Proto.parse1 ProcessInputRequired + parseCommand _ = Proto.parseFail + +newtype PercentFloat = PercentFloat Float + deriving (Show, Eq) + +instance Proto.Serializable PercentFloat where + serialize (PercentFloat p) = show p ++ "%" + deserialize s = do + s' <- reverse <$> stripPrefix "%" (reverse s) + PercentFloat <$> readMaybe s' + +data ComputeState = ComputeState + { computeParams :: [String] + , computeInputs :: M.Map OsPath Key + , computeOutputs :: M.Map OsPath (Maybe Key) + , computeSubdir :: OsPath + } + deriving (Show, Eq) + +{- Formats a ComputeState as an URL query string. + - + - Prefixes computeParams with 'p', computeInputs with 'i', + - and computeOutputs with 'o'. Uses "d" for computeSubdir. + - + - When the passed Key is an output, rather than duplicate it + - in the query string, that output has no value. + - + - Example: "psomefile&pdestfile&pbaz&isomefile=WORM--foo&odestfile=&d=subdir" + - + - The computeParams are in the order they were given. The computeInputs + - and computeOutputs are sorted in ascending order for stability. + -} +formatComputeState :: Key -> ComputeState -> B.ByteString +formatComputeState k = formatComputeState' (Just k) + +formatComputeState' :: Maybe Key -> ComputeState -> B.ByteString +formatComputeState' mk st = renderQuery False $ concat + [ map formatparam (computeParams st) + , map formatinput (M.toAscList (computeInputs st)) + , mapMaybe formatoutput (M.toAscList (computeOutputs st)) + , [("d", Just (fromOsPath (computeSubdir st)))] + ] + where + formatparam p = ("p" <> encodeBS p, Nothing) + formatinput (file, key) = + ("i" <> fromOsPath file, Just (serializeKey' key)) + formatoutput (file, (Just key)) = Just $ + ("o" <> fromOsPath file, + if Just key == mk + then Nothing + else Just (serializeKey' key) + ) + formatoutput (_, Nothing) = Nothing + +parseComputeState :: Key -> B.ByteString -> Maybe ComputeState +parseComputeState k b = + let st = go emptycomputestate (parseQuery b) + in if st == emptycomputestate || illegalComputeState st + then Nothing + else Just st + where + emptycomputestate = ComputeState + { computeParams = mempty + , computeInputs = mempty + , computeOutputs = mempty + , computeSubdir = literalOsPath "." + } + + go :: ComputeState -> [QueryItem] -> ComputeState + go c [] = c { computeParams = reverse (computeParams c) } + go c ((f, v):rest) = + let c' = fromMaybe c $ case decodeBS f of + ('p':p) -> Just $ c + { computeParams = p : computeParams c + } + ('i':i) -> do + key <- deserializeKey' =<< v + Just $ c + { computeInputs = + M.insert (toOsPath i) key + (computeInputs c) + } + ('o':o) -> case v of + Just kv -> do + key <- deserializeKey' kv + Just $ c + { computeOutputs = + M.insert (toOsPath o) + (Just key) + (computeOutputs c) + } + Nothing -> Just $ c + { computeOutputs = + M.insert (toOsPath o) + (Just k) + (computeOutputs c) + } + ('d':[]) -> do + subdir <- v + Just $ c + { computeSubdir = toOsPath subdir + } + _ -> Nothing + in go c' rest + +{- This is used to avoid ComputeStates that should never happen, + - but which could be injected into a repository by an attacker. -} +illegalComputeState :: ComputeState -> Bool +illegalComputeState st + -- The protocol is line-based, so filenames used in it cannot + -- contain newlines. + | any containsnewline (M.keys (computeInputs st)) = True + | any containsnewline (M.keys (computeOutputs st)) = True + -- Just in case. + | containsnewline (computeSubdir st) = True + | otherwise = False + where + containsnewline p = unsafeFromChar '\n' `OS.elem` p + +{- A compute: url for a given output file of a computation. -} +computeStateUrl :: Remote -> ComputeState -> OsPath -> URLString +computeStateUrl r st p = + "annex-compute:" ++ fromUUID (uuid r) ++ "/" ++ fromOsPath p ++ "?" + ++ decodeBS (formatComputeState' Nothing st') + where + -- Omit computeOutputs, so this gives the same result whether + -- it's called on a ComputeState with the computeOutputs + -- Keys populated or not. + st' = st { computeOutputs = mempty } + +{- The per remote metadata is used to store ComputeState. This allows + - recording multiple ComputeStates that generate the same key. + - + - The metadata fields are numbers (prefixed with "t" to make them legal + - field names), which are estimates of how long it might take to run + - the computation (in seconds). + - + - Avoids redundantly recording a ComputeState when the per remote metadata + - already contains it. + -} +setComputeState :: RemoteStateHandle -> Key -> NominalDiffTime -> ComputeState -> Annex () +setComputeState rs k ts st = do + l <- map snd <$> getComputeStatesUnsorted rs k + unless (st `elem` l) go + where + go = addRemoteMetaData k rs $ MetaData $ M.singleton + (mkMetaFieldUnchecked $ T.pack ('t':show (truncateResolution 1 ts))) + (S.singleton (MetaValue (CurrentlySet True) (formatComputeState k st))) + +{- When multiple ComputeStates have been recorded for the same key, + - this returns one that is probably less expensive to compute, + - based on the original time it took to compute it. -} +getComputeState :: RemoteStateHandle -> Key -> Annex (Maybe ComputeState) +getComputeState rs k = headMaybe . map snd . sortOn fst + <$> getComputeStatesUnsorted rs k + +getComputeStatesUnsorted :: RemoteStateHandle -> Key -> Annex [(NominalDiffTime, ComputeState)] +getComputeStatesUnsorted rs k = do + RemoteMetaData _ (MetaData m) <- getCurrentRemoteMetaData rs k + return $ go [] (M.toList m) + where + go c [] = concat c + go c ((f, s) : rest) = + let sts = mapMaybe (parseComputeState k . fromMetaValue) + (S.toList s) + in case parsePOSIXTime (T.encodeUtf8 (T.drop 1 (fromMetaField f))) of + Just ts -> go (zip (repeat ts) sts : c) rest + Nothing -> go c rest + +computeProgramEnvironment :: ComputeState -> Annex [(String, String)] +computeProgramEnvironment st = do + environ <- filter (caninherit . fst) <$> liftIO getEnvironment + let addenv = mapMaybe go (computeParams st) + return $ environ ++ addenv + where + envprefix = "ANNEX_COMPUTE_" + caninherit v = not (envprefix `isPrefixOf` v) + go p + | '=' `elem` p = + let (f, v) = separate (== '=') p + in Just (envprefix ++ f, v) + | otherwise = Nothing + +newtype ImmutableState = ImmutableState Bool + +data ComputeProgramResult = ComputeProgramResult + { computeState :: ComputeState + , computeInputsUnavailable :: Bool + , computeReproducible :: Bool + , computeSandbox :: Bool + } + +runComputeProgram + :: ComputeProgram + -> ComputeState + -> ImmutableState + -> (OsPath -> Bool -> Annex (Key, Maybe (Either Git.Sha OsPath))) + -- ^ Get input file's content, or Nothing the input file's + -- content is not available. True is passed when the input content + -- is required even for addcomputed --fast. + -> Maybe (Key, MeterUpdate) + -- ^ update meter for this key + -> (ComputeProgramResult -> OsPath -> NominalDiffTime -> Annex v) + -> Annex v +runComputeProgram (ComputeProgram program) state (ImmutableState immutablestate) getinputcontent meterkey cont = + withOtherTmp $ \othertmpdir -> + withTmpDirIn othertmpdir (literalOsPath "compute") go + where + go tmpdir = do + environ <- computeProgramEnvironment state + subdir <- liftIO $ getsubdir tmpdir + let pr = (proc program (computeParams state)) + { cwd = Just (fromOsPath subdir) + , std_in = CreatePipe + , std_out = CreatePipe + , env = Just environ + } + showOutput + starttime <- liftIO currentMonotonicTimestamp + let startresult = ComputeProgramResult state False False False + result <- withmeterfile $ \meterfile -> + bracket + (liftIO $ createProcess pr) + (liftIO . cleanupProcess) $ \p -> + withoutputv p $ + getinput tmpdir subdir startresult meterfile p + endtime <- liftIO currentMonotonicTimestamp + liftIO $ checkoutputs result subdir + cont result subdir (calcduration starttime endtime) + + getsubdir tmpdir = do + let subdir = tmpdir computeSubdir state + ifM (dirContains <$> absPath tmpdir <*> absPath subdir) + ( do + createDirectoryIfMissing True subdir + return subdir + -- Ignore unsafe value in state. + , return tmpdir + ) + + getinput tmpdir subdir result meterfile p outputv = + liftIO (hGetLineUntilExitOrEOF (processHandle p) (stdoutHandle p)) >>= \case + Just l + | null l -> getinput tmpdir subdir result meterfile p outputv + | otherwise -> do + fastDebug "Compute" ("< " ++ l) + result' <- parseoutput outputv tmpdir subdir result meterfile l + getinput tmpdir subdir result' meterfile p outputv + Nothing -> do + liftIO $ hClose (stdoutHandle p) + liftIO $ hClose (stdinHandle p) + unlessM (liftIO $ checkSuccessProcess (processHandle p)) $ + giveup $ program ++ " exited unsuccessfully" + return result + + parseoutput outputv tmpdir subdir result meterfile l = case Proto.parseMessage l of + Just (ProcessInput f) -> handleinput f False outputv tmpdir subdir result + Just (ProcessInputRequired f) -> handleinput f True outputv tmpdir subdir result + Just (ProcessOutput f) -> do + let f' = toOsPath f + checksafefile tmpdir subdir f' "output" + -- Modify filename so eg "-foo" becomes "./-foo" + sendresponse outputv $ toCommand' (File f) + -- If the output file is in a subdirectory, make + -- the directories so the compute program doesn't + -- need to. + liftIO $ createDirectoryIfMissing True $ + takeDirectory (subdir f') + knownoutput <- case M.lookup f' (computeOutputs $ computeState result) of + Nothing -> return False + Just mk -> do + when (mk == fmap fst meterkey) $ + meterfile (subdir f') + return True + checkimmutable knownoutput "outputting" f' $ + return $ if immutablestate + then result + else modresultstate result $ \s -> s + { computeOutputs = + M.insert f' Nothing + (computeOutputs s) + } + Just (ProcessProgress percent) -> do + liftIO $ updatepercent percent + return result + Just ProcessReproducible -> + return $ result { computeReproducible = True } + Just ProcessSandbox -> do + sandboxpath <- liftIO $ fromOsPath <$> + relPathDirToFile subdir tmpdir + sendresponse outputv $ + if null sandboxpath + then "." + else sandboxpath + return $ result { computeSandbox = True } + Nothing -> giveup $ + program ++ " output an unparseable line: \"" ++ l ++ "\"" + + handleinput f required outputv tmpdir subdir result = do + let f' = toOsPath f + let knowninput = M.member f' + (computeInputs (computeState result)) + checksafefile tmpdir subdir f' "input" + checkimmutable knowninput "inputting" f' $ do + (k, inputcontent) <- getinputcontent f' required + let mkrel a = Just <$> + (a >>= liftIO . relPathDirToFile subdir) + mp <- case inputcontent of + Nothing -> pure Nothing + Just (Right obj) + | computeSandbox result -> + mkrel $ populatesandbox obj tmpdir + | otherwise -> + mkrel $ pure obj + Just (Left gitsha) -> + mkrel $ populategitsha gitsha tmpdir + sendresponse outputv $ + maybe "" fromOsPath mp + let result' = result + { computeInputsUnavailable = + isNothing mp || computeInputsUnavailable result + } + return $ if immutablestate + then result' + else modresultstate result' $ \s -> s + { computeInputs = + M.insert f' k + (computeInputs s) + } + + modresultstate result f = + result { computeState = f (computeState result) } + + checksafefile tmpdir subdir f fileaction = do + let err problem = giveup $ + program ++ " tried to " ++ fileaction ++ " a file that is " ++ problem ++ ": " ++ fromOsPath f + unlessM (liftIO $ dirContains <$> absPath tmpdir <*> absPath (subdir f)) $ + err "outside the git repository" + when (any (\p -> dropTrailingPathSeparator p == literalOsPath ".git") (splitPath f)) $ + err "inside the .git directory" + + -- Disallow any output files that are not regular files. + -- This supports compute programs that run code in a sandboxed + -- environment, which might let it eg make a symlink or device + -- file that when read as an output file would expose data that + -- the sandboxed code was not allowed to access itself. + checkoutputs result subdir = + forM_ (M.keys $ computeOutputs $ computeState result) $ \f -> + let f' = subdir f + in tryIO (R.getSymbolicLinkStatus (fromOsPath f')) >>= \case + Right st | not (isRegularFile st) -> + giveup $ program ++ " output file " ++ fromOsPath f ++ " is not a regular file, refusing to use it" + _ -> noop + + checkimmutable True _ _ a = a + checkimmutable False requestdesc p a + | not immutablestate = a + | otherwise = computationBehaviorChangeError (ComputeProgram program) requestdesc p + + calcduration (MonotonicTimestamp starttime) (MonotonicTimestamp endtime) = + fromIntegral (endtime - starttime) :: NominalDiffTime + + -- Writes to a .git/objects/ file in the tmpdir, rather than + -- using the input filename, to avoid exposing the input filename + -- to the program as a parameter, which could parse it as a dashed + -- option or other special parameter. + populategitsha gitsha tmpdir = do + let f = tmpdir literalOsPath ".git" + literalOsPath "objects" + toOsPath (Git.fromRef' gitsha) + liftIO $ createDirectoryIfMissing True $ takeDirectory f + liftIO . F.writeFile f =<< catObject gitsha + return f + + populatesandbox annexobj tmpdir = do + let f = tmpdir literalOsPath ".git" + literalOsPath "annex" + literalOsPath "objects" + takeFileName annexobj + liftIO $ createDirectoryIfMissing True $ takeDirectory f + liftIO $ unlessM (createLinkOrCopy annexobj f) $ + giveup "Unable to populate compute sandbox directory" + return f + + withmeterfile a = case meterkey of + Nothing -> a (const noop) + Just (_, progress) -> do + filev <- liftIO newEmptyTMVarIO + endv <- liftIO $ newEmptyTMVarIO + let meterfile = void . liftIO + . atomically . tryPutTMVar filev + let endmeterfile = atomically $ putTMVar endv () + tid <- liftIO $ async $ do + v <- liftIO $ atomically $ + (Right <$> takeTMVar filev) + `orElse` + (Left <$> takeTMVar endv) + case v of + Right f -> watchFileSize f progress $ \_ -> + void $ liftIO $ atomically $ + takeTMVar endv + Left () -> return () + a meterfile + `finally` liftIO (endmeterfile >> wait tid) + + updatepercent (PercentFloat percent) = case meterkey of + Nothing -> noop + Just (k, progress) -> case fromKey keySize k of + Nothing -> noop + Just sz -> + progress $ BytesProcessed $ floor $ + fromIntegral sz * percent / 100 + + withoutputv p a = do + outputv <- liftIO $ atomically newTQueue + let cleanup pid = do + atomically $ writeTQueue outputv Nothing + wait pid + bracket + (liftIO $ async $ sendoutput' p outputv) + (liftIO . cleanup) + (const $ a outputv) + + sendoutput' p outputv = + atomically (readTQueue outputv) >>= \case + Nothing -> return () + Just s -> do + liftIO $ hPutStrLn (stdinHandle p) s + liftIO $ hFlush (stdinHandle p) + sendoutput' p outputv + + sendresponse outputv s = do + fastDebug "Compute" ("> " ++ s) + liftIO $ atomically $ writeTQueue outputv (Just s) + +computationBehaviorChangeError :: ComputeProgram -> String -> OsPath -> Annex a +computationBehaviorChangeError (ComputeProgram program) requestdesc p = + giveup $ program ++ " is not behaving the same way it used to, now " ++ requestdesc ++ ": " ++ fromOsPath p + +computeKey :: RemoteStateHandle -> ComputeProgram -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification +computeKey rs (ComputeProgram program) k _af dest meterupdate vc = + getComputeState rs k >>= \case + Just state -> + case computeskey state of + Just keyfile -> go state keyfile + Nothing -> missingstate + Nothing -> missingstate + where + missingstate = giveup "Missing compute state" + + go state keyfile = metered (Just meterupdate) k Nothing $ \_ p -> + runComputeProgram (ComputeProgram program) state + (ImmutableState True) + (getinputcontent state) + (Just (k, p)) + (postcompute keyfile) + + getinputcontent state f _required = + case M.lookup f (computeInputs state) of + Just inputkey -> case keyGitSha inputkey of + Nothing -> + let retkey = do + obj <- calcRepo (gitAnnexLocation inputkey) + return (inputkey, Just (Right obj)) + in ifM (inAnnex inputkey) + ( retkey + , ifM (getinputcontent' f inputkey) + ( retkey + , return (inputkey, Nothing) + ) + ) + Just gitsha -> + return (inputkey, Just (Left gitsha)) + Nothing -> error "internal" + + getinputcontent' f inputkey = do + remotes <- avoidCycles [k] inputkey + =<< keyPossibilities inputkey + anyM (getinputcontentfrom f inputkey) remotes + + getinputcontentfrom f inputkey r = do + showAction $ "getting input " <> QuotedPath f + <> " from " <> UnquotedString (name r) + lu <- prepareLiveUpdate Nothing inputkey AddingKey + logStatusAfter lu inputkey $ + Annex.Transfer.download r inputkey (AssociatedFile (Just f)) + Annex.Transfer.stdRetry Annex.Transfer.noNotification + + computeskey state = + case M.keys $ M.filter (== Just k) (computeOutputs state) of + (keyfile : _) -> Just keyfile + [] -> Nothing + + postcompute keyfile result tmpdir _ts + | computeInputsUnavailable result = + giveup "Input file(s) unavailable." + | otherwise = + postcompute' keyfile (computeState result) tmpdir + + postcompute' keyfile state tmpdir = do + hb <- hashBackend + let updatevurl key getobj = + if (fromKey keyVariety key == VURLKey) + then addEquivilantKey hb key =<< getobj + else return Nothing + + let keyfile' = tmpdir keyfile + unlessM (liftIO $ doesFileExist keyfile') $ + giveup $ program ++ " exited sucessfully, but failed to write the computed file" + catchNonAsync (liftIO $ moveFile keyfile' dest) + (\err -> giveup $ "failed to move the computed file: " ++ show err) + mverification <- updatevurl k (pure dest) + + -- Try to move any other computed object files into the annex. + forM_ (M.toList $ computeOutputs state) $ \case + (file, (Just key)) -> + when (k /= key) $ do + let file' = tmpdir file + whenM (liftIO $ doesFileExist file') $ do + whenM (verifyKeyContentPostRetrieval RetrievalAllKeysSecure vc MustVerify key file') $ do + moved <- moveAnnex key file' `catchNonAsync` const (pure False) + when moved $ + void $ updatevurl key (calcRepo (gitAnnexLocation key)) + _ -> noop + + -- The program might not be reproducible, + -- so require strong verification. + return $ fromMaybe MustVerify mverification + +keyPossibilities :: Key -> Annex [Remote] +keyPossibilities key = do + -- This gets populated with a list of all remotes before this + -- remote is used. + remotelist <- Annex.getState Annex.remotes + locs <- loggedLocations key + keyPossibilities' (IncludeIgnored False) key locs remotelist + +{- Filter out any remotes that, in order to compute the inputkey, would + - need to get the outputkey from some remote. + - + - This only finds cycles of compute special remotes, not any other + - similar type of special remote that might have its own input keys. + - There are no other such special remotes in git-annex itself, so this + - is the best that can be done. + - + - Note that, in a case where a compute special remote needs the outputkey + - to compute the inputkey, but could get the outputkey from either this + - remote, or some other, non-compute remote, that is filtered out as a + - cycle because it's not possible to prevent that remote getting from this + - remote. + -} +avoidCycles :: [Key] -> Key -> [Remote] -> Annex [Remote] +avoidCycles outputkeys inputkey = filterM go + where + go r + | iscomputeremote r = + getComputeState (remoteStateHandle r) inputkey >>= \case + Nothing -> return True + Just state + | inputsoutput state -> return False + | otherwise -> checkdeeper state + | otherwise = return True + + iscomputeremote r = remotetype r == remote + + inputsoutput state = not $ M.null $ + M.filter (`elem` outputkeys) + (computeInputs state) + + checkdeeper state = + flip allM (M.elems (computeInputs state)) $ \inputkey' -> do + rs <- keyPossibilities inputkey' + rs' <- avoidCycles (inputkey:outputkeys) inputkey' rs + return (rs' == rs) + +-- Make sure that the compute state exists, and that the input keys are +-- still available (are not dead, and are stored in some repository). +-- +-- When an input key is itself stored in a compute remote, check that +-- its inputs are also still available. +checkKey :: RemoteStateHandle -> Key -> Annex Bool +checkKey rs k = do + deadset <- getdeadset + computeset <- getcomputeset + availablecompute [] deadset computeset k rs + where + getdeadset = do + -- Usually this will already be populated with all remotes, + -- otherwise this compute remote would not be used. Check + -- just in case, to avoid trustMap' caching bad inputs. + remotelist <- Annex.getState Annex.remotes + if null remotelist + then error "internal" + else S.fromList . M.keys . M.filter (== DeadTrusted) + <$> trustMap' remotelist + + getcomputeset = S.fromList . M.keys . M.filter isComputeRemote' + <$> remoteConfigMap + + availablecompute inputkeys deadset computeset k' rs' + | k' `elem` inputkeys = return False -- avoid cycles + | otherwise = + anyM (hasinputs inputkeys deadset computeset . snd) + =<< getComputeStatesUnsorted rs' k' + + hasinputs inputkeys deadset computeset state = do + let ks = M.elems (computeInputs state) + ifM (anyM checkDead ks) + ( return False + , allM (available inputkeys deadset computeset) ks + ) + + available inputkeys deadset computeset k' = do + (repolocs, computelocs) <- + partition (flip S.notMember computeset) + . filter (flip S.notMember deadset) + <$> loggedLocations k' + if not (null repolocs) + then return True + else anyM (availablecompute (k':inputkeys) deadset computeset k' . RemoteStateHandle) computelocs + +-- Unsetting the compute state will prevent computing the key. +dropKey :: RemoteStateHandle -> Maybe SafeDropProof -> Key -> Annex () +dropKey rs _ k = do + RemoteMetaData _ old <- getCurrentRemoteMetaData rs k + addRemoteMetaData k rs (modMeta old DelAllMeta) + +storeKeyUnsupported :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () +storeKeyUnsupported _ _ _ _ = giveup "transfer to compute remote not supported; use git-annex addcomputed instead" diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -97,12 +97,12 @@ , 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 @@ , 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 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -15,10 +15,8 @@ removeDirGeneric, ) where -import qualified Data.ByteString.Lazy as L 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 @@ -52,6 +50,7 @@ import Utility.FileMode import Utility.Directory.Create import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F #ifndef mingw32_HOST_OS import Utility.OpenFd #endif @@ -132,11 +131,11 @@ , 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 @@ , 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 @@ -- 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 @@ 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,63 +219,59 @@ finalizeStoreGeneric d tmpdir destdir in byteStorer go k c m - tmpdir = P.addTrailingPathSeparator $ d P. "tmp" P. kf - tmpf = fromRawFilePath tmpdir fromRawFilePath kf + tmpdir = addTrailingPathSeparator $ d literalOsPath "tmp" kf + tmpf = tmpdir kf kf = keyFile k destdir = storeDir d k -checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool +checkDiskSpaceDirectory :: OsPath -> Key -> Annex Bool checkDiskSpaceDirectory d k = do annexdir <- fromRepo gitAnnexObjectDir samefilesystem <- liftIO $ catchDefaultIO False $ (\a b -> deviceID a == deviceID b) - <$> R.getSymbolicLinkStatus d - <*> R.getSymbolicLinkStatus annexdir + <$> R.getSymbolicLinkStatus (fromOsPath d) + <*> R.getSymbolicLinkStatus (fromOsPath annexdir) checkDiskSpace Nothing (Just d) k 0 samefilesystem {- Passed a temp directory that contains the files that should be placed - in the dest directory, moves it into place. Anything already existing - in the dest directory will be deleted. File permissions will be locked - down. -} -finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO () +finalizeStoreGeneric :: OsPath -> OsPath -> OsPath -> IO () finalizeStoreGeneric d tmp dest = do - removeDirGeneric False (fromRawFilePath d) dest' + removeDirGeneric False d dest createDirectoryUnder [d] (parentDir dest) - renameDirectory (fromRawFilePath tmp) dest' + renameDirectory tmp dest -- may fail on some filesystems void $ tryIO $ do - mapM_ (preventWrite . toRawFilePath) =<< dirContents dest' + 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 (L.readFile . fromRawFilePath =<< getLocation d k) + sink =<< liftIO (F.readFile =<< getLocation d k) -retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) +retrieveKeyFileCheapM :: OsPath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ()) -- no cheap retrieval possible for chunks retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing #ifndef mingw32_HOST_OS retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do - file <- fromRawFilePath <$> (absPath =<< getLocation d k) + file <- absPath =<< getLocation d k ifM (doesFileExist file) - ( R.createSymbolicLink (toRawFilePath file) (toRawFilePath f) + ( R.createSymbolicLink (fromOsPath file) (fromOsPath f) , giveup "content file not present in remote" ) #else retrieveKeyFileCheapM _ _ = Nothing #endif -removeKeyM :: RawFilePath -> Remover -removeKeyM d _proof k = liftIO $ removeDirGeneric True - (fromRawFilePath d) - (fromRawFilePath (storeDir d k)) +removeKeyM :: OsPath -> Remover +removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k) {- Removes the directory, which must be located under the topdir. - @@ -293,13 +287,13 @@ - can also be removed. Failure to remove such a directory is not treated - as an error. -} -removeDirGeneric :: Bool -> FilePath -> FilePath -> IO () +removeDirGeneric :: Bool -> OsPath -> OsPath -> IO () removeDirGeneric removeemptyparents topdir dir = do - void $ tryIO $ allowWrite (toRawFilePath dir) + void $ tryIO $ allowWrite dir #ifdef mingw32_HOST_OS {- Windows needs the files inside the directory to be writable - before it can delete them. -} - void $ tryIO $ mapM_ (allowWrite . toRawFilePath) =<< dirContents dir + void $ tryIO $ mapM_ allowWrite =<< dirContents dir #endif tryNonAsync (removeDirectoryRecursive dir) >>= \case Right () -> return () @@ -307,95 +301,94 @@ unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $ throwM e when removeemptyparents $ do - subdir <- relPathDirToFile (toRawFilePath topdir) (P.takeDirectory (toRawFilePath dir)) - goparents (Just (P.takeDirectory subdir)) (Right ()) + subdir <- relPathDirToFile topdir (takeDirectory dir) + goparents (Just (takeDirectory subdir)) (Right ()) where goparents _ (Left _e) = return () goparents Nothing _ = return () goparents (Just subdir) _ = do - let d = topdir fromRawFilePath subdir + let d = topdir subdir goparents (upFrom subdir) =<< tryIO (removeDirectory d) -checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent +checkPresentM :: OsPath -> ChunkConfig -> CheckPresent checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k checkPresentM d _ k = checkPresentGeneric d (locations' d k) -checkPresentGeneric :: RawFilePath -> [RawFilePath] -> Annex Bool +checkPresentGeneric :: OsPath -> [OsPath] -> Annex Bool checkPresentGeneric d ps = checkPresentGeneric' d $ - liftIO $ anyM (doesFileExist . fromRawFilePath) ps + liftIO $ anyM doesFileExist ps -checkPresentGeneric' :: RawFilePath -> Annex Bool -> Annex Bool +checkPresentGeneric' :: OsPath -> Annex Bool -> Annex Bool checkPresentGeneric' d check = ifM check ( return True - , ifM (liftIO $ doesDirectoryExist (fromRawFilePath d)) + , ifM (liftIO $ doesDirectoryExist d) ( return False - , giveup $ "directory " ++ fromRawFilePath d ++ " is not accessible" + , giveup $ "directory " ++ fromOsPath d ++ " is not accessible" ) ) -storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM :: OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM d cow src _k loc p = do - liftIO $ createDirectoryUnder [d] (P.takeDirectory dest) + liftIO $ createDirectoryUnder [d] (takeDirectory dest) -- Write via temp file so that checkPresentGeneric will not -- see it until it's fully stored. - viaTmp go (fromRawFilePath dest) () + viaTmp go dest () where dest = exportPath d loc - go tmp () = void $ liftIO $ fileCopier cow src 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 <- dirContentsRecursiveSkipping (const False) False (fromRawFilePath dir) - l' <- mapM (go . toRawFilePath) l + 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 @@ -409,7 +402,7 @@ -- 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 @@ -435,25 +428,25 @@ 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 @@ -465,11 +458,11 @@ 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 ) @@ -478,7 +471,7 @@ #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) @@ -487,7 +480,7 @@ 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 @@ -502,7 +495,7 @@ -- 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. @@ -526,7 +519,7 @@ #ifndef mingw32_HOST_OS =<< getFdStatus fd #else - =<< R.getSymbolicLinkStatus f + =<< R.getSymbolicLinkStatus f' #endif guardSameContentIdentifiers cont cids currcid @@ -537,37 +530,37 @@ -- 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] (toRawFilePath destdir) + liftIO $ createDirectoryUnder [dir] destdir withTmpFileIn destdir template $ \tmpf tmph -> do + let tmpf' = fromOsPath tmpf liftIO $ hClose tmph void $ liftIO $ fileCopier cow src tmpf p Nothing - let tmpf' = toRawFilePath tmpf - resetAnnexFilePerm tmpf' - liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case + 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) = splitFileName (fromRawFilePath 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 @@ -591,9 +584,9 @@ -- -- 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 --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -14,7 +14,6 @@ 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,7 @@ 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 withCheckedFiles _ [] _locations _ _ = return False @@ -44,7 +43,7 @@ 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). -} @@ -76,20 +75,20 @@ 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 @@ -97,30 +96,29 @@ - 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' = fromRawFilePath 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 $ - S.appendFile tmp' <=< S.readFile + F.appendFile' tmp <=< S.readFile return True - b <- liftIO $ L.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 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -237,9 +237,10 @@ 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 = 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 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 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -480,12 +480,12 @@ 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 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -20,8 +20,6 @@ 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 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 @@ - 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 @@ 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' 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' repo r rsyncopts accessmethod | not $ Git.repoIsUrl repo = byteRetriever $ \k sink -> guardUsable repo (giveup "cannot access remote") $ - sink =<< liftIO (L.readFile $ gCryptLocation repo k) + sink =<< liftIO (F.readFile $ gCryptLocation repo k) | Git.repoIsSsh repo = if accessShell r then fileRetriever $ \f k p -> do ps <- Ssh.rsyncParamsRemote r Download k - (fromRawFilePath f) + (fromOsPath f) oh <- mkOutputHandler unlessM (Ssh.rsyncHelper oh (Just p) ps) $ giveup "rsync failed" @@ -440,7 +440,7 @@ | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ liftIO $ Remote.Directory.removeDirGeneric True (gCryptTopDir repo) - (fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k)))) + (parentDir (gCryptLocation repo k)) | Git.repoIsSsh repo = shellOrRsync r removeshell removersync | accessmethod == AccessRsyncOverSsh = removersync | otherwise = unsupportedUrl @@ -465,14 +465,14 @@ 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,9 +529,10 @@ let (rsynctransport, rsyncurl, _) = rsyncTransport r gc opts <- rsynctransport liftIO $ do - withTmpFile "tmpconfig" $ \tmpconfig _ -> do + withTmpFile (literalOsPath "tmpconfig") $ \tmpconfig _ -> do + let tmpconfig' = fromOsPath tmpconfig void $ rsync $ opts ++ [ Param $ rsyncurl ++ "/config" - , Param tmpconfig + , Param tmpconfig' ] - Git.Config.fromFile r tmpconfig + Git.Config.fromFile r tmpconfig' diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -49,6 +49,7 @@ 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,7 +325,7 @@ geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do let url = Git.repoLocation r ++ "/config" - v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do + v <- withTmpFile (literalOsPath "git-annex.tmp") $ \tmpfile h -> do liftIO $ hClose h Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case Right () -> @@ -334,7 +335,7 @@ , 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 @@ -469,9 +470,9 @@ | 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 @@ -559,12 +560,12 @@ 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 @@ -602,9 +603,8 @@ <|> 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 @@ -616,16 +616,18 @@ 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 @@ -634,12 +636,12 @@ #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 @@ -680,9 +682,9 @@ let checksuccess = liftIO checkio >>= \case Just err -> giveup err Nothing -> return True - logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest -> + logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key (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 @@ -718,10 +720,12 @@ 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) @@ -815,7 +819,7 @@ -- 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 @@ -828,14 +832,14 @@ 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 @@ -848,7 +852,7 @@ 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 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} module Remote.GitLFS (remote, gen, configKnownUrl) where @@ -20,6 +21,7 @@ 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 +38,12 @@ 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 @@ -65,6 +67,8 @@ , configParser = mkRemoteConfigParser [ optionalStringParser urlField (FieldDesc "url of git-lfs repository") + , optionalStringParser apiUrlField + (FieldDesc "url of LFS API endpoint (when not specified derives from url)") ] , setup = mySetup , exportSupported = exportUnsupported @@ -75,6 +79,9 @@ urlField :: RemoteConfigField urlField = Accepted "url" +apiUrlField :: RemoteConfigField +apiUrlField = Accepted "apiurl" + gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do c <- parsedRemoteConfig remote rc @@ -86,7 +93,7 @@ liftIO $ Git.GCrypt.encryptedRemote g r else pure r sem <- liftIO $ MSemN.new 1 - h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc + h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc c cst <- remoteCost gc c expensiveRemoteCost let specialcfg = (specialRemoteCfg c) -- chunking would not improve git-lfs @@ -218,6 +225,7 @@ , getEndPointLock :: MSemN.MSemN Int , remoteRepo :: Git.Repo , remoteGitConfig :: RemoteGitConfig + , remoteConfigs :: ParsedRemoteConfig } -- Only let one thread at a time do endpoint discovery. @@ -229,10 +237,24 @@ l = getEndPointLock h discoverLFSEndpoint :: LFS.TransferRequestOperation -> LFSHandle -> Annex (Maybe LFS.Endpoint) -discoverLFSEndpoint tro h - | Git.repoIsSsh r = gossh - | Git.repoIsHttp r = gohttp - | otherwise = unsupportedurischeme +discoverLFSEndpoint tro h = + case fmap fromProposedAccepted $ M.lookup apiUrlField (unparsedRemoteConfig (remoteConfigs h)) of + Just apiurl | not (null apiurl) -> case parseURIRelaxed apiurl of + Nothing -> unsupportedurischeme +#if MIN_VERSION_git_lfs(1,2,5) + Just apiuri -> case LFS.mkEndpoint apiuri of + Just endpoint -> checkhttpauth endpoint + Nothing -> unsupportedurischeme +#else +#warning Building with old version of git-lfs, apiurl= will not be supported + Just _ -> do + warning $ "Unable to use configured apiurl because this git-annex is not built with version 1.2.5 of the haskell git-lfs library." + return Nothing +#endif + _ + | Git.repoIsSsh r -> gossh + | Git.repoIsHttp r -> gohttp + | otherwise -> unsupportedurischeme where r = remoteRepo h lfsrepouri = case Git.location r of @@ -277,31 +299,33 @@ warning "unexpected response from git-lfs remote when doing ssh endpoint discovery" return Nothing Just endpoint -> return (Just endpoint) - + + gohttp = case LFS.guessEndpoint lfsrepouri of + Nothing -> unsupportedurischeme + Just endpoint -> checkhttpauth endpoint + -- The endpoint may or may not need http basic authentication, -- which involves using git-credential to prompt for the password. -- -- To determine if it does, make a download or upload request to -- it, not including any objects in the request, and see if -- the server requests authentication. - gohttp = case LFS.guessEndpoint lfsrepouri of - Nothing -> unsupportedurischeme - Just endpoint -> do - let testreq = LFS.startTransferRequest endpoint transfernothing - flip catchNonAsync (const (returnendpoint endpoint)) $ do - resp <- makeSmallAPIRequest testreq - if needauth (responseStatus resp) - then do - cred <- prompt $ inRepo $ Git.getUrlCredential (show lfsrepouri) - let endpoint' = addbasicauth (Git.credentialBasicAuth cred) endpoint - let testreq' = LFS.startTransferRequest endpoint' transfernothing - flip catchNonAsync (const (returnendpoint endpoint')) $ do - resp' <- makeSmallAPIRequest testreq' - inRepo $ if needauth (responseStatus resp') - then Git.rejectUrlCredential cred - else Git.approveUrlCredential cred - returnendpoint endpoint' - else returnendpoint endpoint + checkhttpauth endpoint = do + let testreq = LFS.startTransferRequest endpoint transfernothing + flip catchNonAsync (const (returnendpoint endpoint)) $ do + resp <- makeSmallAPIRequest testreq + if needauth (responseStatus resp) + then do + cred <- prompt $ inRepo $ Git.getUrlCredential (show lfsrepouri) + let endpoint' = addbasicauth (Git.credentialBasicAuth cred) endpoint + let testreq' = LFS.startTransferRequest endpoint' transfernothing + flip catchNonAsync (const (returnendpoint endpoint')) $ do + resp' <- makeSmallAPIRequest testreq' + inRepo $ if needauth (responseStatus resp') + then Git.rejectUrlCredential cred + else Git.approveUrlCredential cred + returnendpoint endpoint' + else returnendpoint endpoint where transfernothing = LFS.TransferRequest { LFS.req_operation = tro @@ -313,10 +337,10 @@ needauth status = status == unauthorized401 - addbasicauth (Just ba) endpoint = - LFS.modifyEndpointRequest endpoint $ + addbasicauth (Just ba) endpoint' = + LFS.modifyEndpointRequest endpoint' $ applyBasicAuth' ba - addbasicauth Nothing endpoint = endpoint + addbasicauth Nothing endpoint' = endpoint' -- The endpoint is cached for later use. getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint) @@ -380,7 +404,7 @@ | 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 +414,11 @@ 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 +521,7 @@ 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 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -178,7 +178,7 @@ 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 --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -23,7 +23,7 @@ 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 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -33,7 +33,7 @@ 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 @@ -> ChunkConfig -> EncKey -> Key - -> FilePath + -> OsPath -> MeterUpdate -> Maybe (Cipher, EncKey) -> encc @@ -135,7 +135,7 @@ -- 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 @@ -> ChunkConfig -> EncKey -> Key - -> FilePath + -> OsPath -> MeterUpdate -> Maybe (Cipher, EncKey) -> encc @@ -276,7 +276,7 @@ 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 @@ -- 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 @@ 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 @@ -} writeRetrievedContent :: LensEncParams encc - => FilePath + => OsPath -> Maybe (Cipher, EncKey) -> encc -> Maybe Handle @@ -409,7 +409,7 @@ 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 @@ 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 @@ 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 @@ 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 --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -72,7 +72,7 @@ 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 --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.Helper.Git where import Annex.Common @@ -25,10 +27,10 @@ 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 @@ -59,9 +61,12 @@ gitRepoInfo :: Remote -> Annex [(String, String)] gitRepoInfo r = do - d <- fromRawFilePath <$> fromRepo Git.localGitDir - mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (toRawFilePath p)) - =<< emptyWhenDoesNotExist (dirContentsRecursive (d "refs" "remotes" Remote.name r)) + d <- fromRepo Git.localGitDir + 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 --- 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 @@ 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 --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -14,6 +14,7 @@ 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 @@ -- 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 @@ -- 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 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -36,9 +36,9 @@ -- 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 @@ 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 --- a/Remote/Helper/Path.hs +++ b/Remote/Helper/Path.hs @@ -10,7 +10,7 @@ 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 --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -44,7 +44,7 @@ } | 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 @@ 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 @@ 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 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -53,6 +53,7 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ - 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 @@ 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 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -66,7 +66,7 @@ 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 --- a/Remote/Helper/ThirdPartyPopulated.hs +++ b/Remote/Helper/ThirdPartyPopulated.hs @@ -14,9 +14,7 @@ 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 @@ -- 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 @@ 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 @@ -- 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 @@ _ -> Just k Nothing -> Nothing where - f = P.takeFileName p + f = takeFileName p diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -118,8 +118,8 @@ ] 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 @@ ) 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 --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -122,14 +122,14 @@ 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 @@ -> (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 @@ ] ] 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/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -40,6 +40,7 @@ import qualified Remote.Rclone import qualified Remote.Hook import qualified Remote.External +import qualified Remote.Compute remoteTypes :: [RemoteType] remoteTypes = map adjustExportImportRemoteType @@ -63,6 +64,7 @@ , Remote.Rclone.remote , Remote.Hook.remote , Remote.External.remote + , Remote.Compute.remote ] {- Builds a list of all Remotes. diff --git a/Remote/List/Util.hs b/Remote/List/Util.hs --- a/Remote/List/Util.hs +++ b/Remote/List/Util.hs @@ -1,6 +1,6 @@ {- git-annex remote list utils - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,7 +10,12 @@ import Annex.Common import qualified Annex import qualified Git.Config +import Annex.UUID +import Types.Remote +import Config.DynamicConfig +import Data.Ord + {- Call when remotes have changed. Re-reads the git config, and - invalidates the cache so the remoteList will be re-generated next time - it's used. -} @@ -22,3 +27,44 @@ , Annex.gitremotes = Nothing , Annex.repo = newg } + +{- Whether to include remotes that have annex-ignore set. -} +newtype IncludeIgnored = IncludeIgnored Bool + +keyPossibilities' + :: IncludeIgnored + -> Key + -> [UUID] + -- ^ uuids of remotes that are recorded to have the key + -> [Remote] + -- ^ all remotes + -> Annex [Remote] +keyPossibilities' ii _key remotelocations rs = do + u <- getUUID + let locations = filter (/= u) remotelocations + let speclocations = map uuid + $ filter (remoteAnnexSpeculatePresent . gitconfig) rs + -- there are unlikely to be many speclocations, so building a Set + -- is not worth the expense + let locations' = speclocations ++ filter (`notElem` speclocations) locations + fst <$> remoteLocations' ii locations' [] rs + +remoteLocations' :: IncludeIgnored -> [UUID] -> [UUID] -> [Remote] -> Annex ([Remote], [UUID]) +remoteLocations' (IncludeIgnored ii) locations trusted rs = do + let validtrustedlocations = nub locations `intersect` trusted + + -- remotes that match uuids that have the key + allremotes <- if not ii + then filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) rs + else return rs + let validremotes = remotesWithUUID allremotes locations + + return (sortBy (comparing cost) validremotes, validtrustedlocations) + +{- Filters a list of remotes to ones that have the listed uuids. -} +remotesWithUUID :: [Remote] -> [UUID] -> [Remote] +remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs + +{- Filters a list of remotes to ones that do not have the listed uuids. -} +remotesWithoutUUID :: [Remote] -> [UUID] -> [Remote] +remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -117,12 +117,13 @@ , 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 @@ - (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 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 @@ [ 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 @@ } 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 @@ {- 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 "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 @@ -- 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 --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -14,14 +14,14 @@ 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 @@ | 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 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -68,6 +68,7 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ | 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 @@ -- -- 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 @@ 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 @@ 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 @@ 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 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -49,7 +49,7 @@ {- 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 @@ 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 @@ , (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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -30,7 +30,6 @@ import Logs.Remote import Logs.EquivilantKeys import Backend -import Backend.VURL.Utilities (generateEquivilantKey) import qualified Data.Map as M @@ -116,7 +115,7 @@ 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 @@ -169,20 +168,10 @@ | otherwise = return (Just v) recordvurlkey eks = do - -- Make sure to pick a backend that is cryptographically - -- secure. - db <- defaultBackend - let b = if isCryptographicallySecure db - then db - else defaultHashBackend - generateEquivilantKey b (toRawFilePath dest) >>= \case - Nothing -> return Nothing - Just ek -> do - unless (ek `elem` eks) $ - setEquivilantKey key ek - return (Just Verified) + b <- hashBackend + updateEquivilantKeys b dest key eks -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 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -176,11 +176,11 @@ 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 @@ 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 @@ 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 @@ 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 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -17,9 +17,9 @@ #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 @@ {- 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 @@ {- 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 @@ -} 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 @@ | 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 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -191,7 +191,7 @@ 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 --- a/Test.hs +++ b/Test.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Test where @@ -37,9 +38,9 @@ import qualified Git.Ref import qualified Git.LsTree import qualified Git.FilePath -import qualified Git.Bundle import qualified Annex.Locations #ifndef mingw32_HOST_OS +import qualified Git.Bundle import qualified Types.GitConfig #endif import qualified Types.TrustLevel @@ -89,6 +90,7 @@ 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 @@ testDirectoryRemote :: TestTree testDirectoryRemote = testRemote True "directory" $ \remotename -> do - createDirectory "remotedir" + createDirectory (literalOsPath "remotedir") git_annex "initremote" [ remotename , "type=directory" @@ -437,7 +439,7 @@ runtest cfg populate = whenM Git.Bundle.versionSupported $ intmpclonerepo $ do let cfg' = ["type=directory", "encryption=none", "directory=dir"] ++ cfg - createDirectory "dir" + createDirectory (literalOsPath "dir") git_annex "initremote" ("foo":("uuid=" ++ diruuid):cfg') "initremote" git_annex "get" [] "get failed" () <- populate @@ -452,7 +454,7 @@ git_annex "get" [annexedfile] "get from origin special remote" diruuid="89ddefa4-a04c-11ef-87b5-e880882a4f98" #else -test_git_remote_annex exporttree = +test_git_remote_annex _exporttree = -- git-remote-annex is not currently installed on Windows return () #endif @@ -461,14 +463,14 @@ test_add_moved = 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 = 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" [] [] @@ -554,27 +556,27 @@ "git-annex add with mimeencoding in largefiles" git_annex "sync" ["--no-content"] "git-annex sync" - (isJust <$> annexeval (Annex.CatFile.catKeyFile (encodeBS "binary"))) + (isJust <$> annexeval (Annex.CatFile.catKeyFile (literalOsPath "binary"))) @? "binary file not added to annex despite mimeencoding config" - (isNothing <$> annexeval (Annex.CatFile.catKeyFile (encodeBS "text"))) + (isNothing <$> annexeval (Annex.CatFile.catKeyFile (literalOsPath "text"))) @? "non-binary file got added to annex despite mimeencoding config" #else return () #endif test_import :: Assertion -test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir "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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ {- --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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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_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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 = 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_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_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_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_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 @@ testscheme "pubkey" where gpgcmd = Utility.Gpg.mkGpgCmd Nothing - testscheme scheme = Utility.Tmp.Dir.withTmpDir "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 @@ (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 @@ 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_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 @@ <$> 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 @@ 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 @@ -- 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 @@ -- 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_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 @@ 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 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Test.Framework where import Test.Tasty @@ -64,6 +66,7 @@ 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. @@ -121,13 +124,14 @@ 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 @@ -157,7 +161,7 @@ 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 @@ -168,7 +172,7 @@ 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 @@ -216,7 +220,7 @@ -- 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 @@ -293,17 +297,18 @@ 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 "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 @@ -311,9 +316,11 @@ -- 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. @@ -330,34 +337,34 @@ -- 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' 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' 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) @@ -415,7 +422,7 @@ 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 @@ -425,12 +432,13 @@ 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 @@ -499,7 +507,7 @@ 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 () @@ -583,10 +591,10 @@ 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 ) @@ -595,7 +603,7 @@ where go n = do let d = "tmprepo" ++ show n - ifM (doesDirectoryExist d) + ifM (doesDirectoryExist (toOsPath d)) ( go $ n + 1 , return d ) @@ -635,9 +643,9 @@ 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 @@ -677,8 +685,8 @@ 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 } @@ -797,7 +805,7 @@ 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 @@ -807,13 +815,13 @@ 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 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -18,14 +18,14 @@ 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 (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 (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 --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -12,6 +12,7 @@ import Types.Key import Types.KeySource import Utility.Metered +import Utility.OsPath import Utility.FileSystemEncoding import Utility.Hash (IncrementalVerifier) @@ -20,7 +21,7 @@ , 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 --- a/Types/BranchState.hs +++ b/Types/BranchState.hs @@ -29,14 +29,14 @@ , 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 --- 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 :: String -> Maybe Direction +parseDirection :: ShortByteString -> Maybe Direction parseDirection "upload" = Just Upload parseDirection "download" = Just Download parseDirection _ = Nothing diff --git a/Types/Distribution.hs b/Types/Distribution.hs --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -40,10 +40,9 @@ formatInfoFile d = replace "keyVariant = " "keyBackendName = " (show d) ++ "\n" ++ formatGitAnnexDistribution d -parseInfoFile :: String -> Maybe GitAnnexDistribution -parseInfoFile s = case lines s of - (_oldformat:rest) -> parseGitAnnexDistribution (unlines rest) - _ -> Nothing +parseInfoFile :: [String] -> Maybe GitAnnexDistribution +parseInfoFile (_oldformat:rest) = parseGitAnnexDistribution (unlines rest) +parseInfoFile _ = Nothing formatGitAnnexDistribution :: GitAnnexDistribution -> String formatGitAnnexDistribution d = unlines diff --git a/Types/Export.hs b/Types/Export.hs --- 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 @@ 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 --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -14,7 +14,7 @@ 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 @@ | 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 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 @@ , 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 @@ -- 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 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -64,7 +64,6 @@ 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 @@ , annexVerify :: Bool , annexPidLock :: Bool , annexPidLockTimeout :: Seconds - , annexDbDir :: Maybe RawFilePath + , annexDbDir :: Maybe OsPath , annexAddUnlocked :: GlobalConfigurable (Maybe String) , annexSecureHashesOnly :: Bool , annexRetry :: Maybe Integer @@ -147,6 +146,7 @@ , annexAllowedUrlSchemes :: S.Set Scheme , annexAllowedIPAddresses :: String , annexAllowUnverifiedDownloads :: Bool + , annexAllowedComputePrograms :: Maybe String , annexMaxExtensionLength :: Maybe Int , annexMaxExtensions :: Maybe Int , annexJobs :: Concurrency @@ -244,7 +244,7 @@ , 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") @@ -262,6 +262,8 @@ getmaybe (annexConfig "security.allowed-http-addresses") -- old name , annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe (annexConfig "security.allow-unverified-downloads") + , annexAllowedComputePrograms = + getmaybe (annexConfig "security.allowed-compute-programs") , annexMaxExtensionLength = getmayberead (annexConfig "maxextensionlength") , annexMaxExtensions = getmayberead (annexConfig "maxextensions") , annexJobs = fromMaybe NonConcurrent $ diff --git a/Types/Import.hs b/Types/Import.hs --- 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 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 @@ - 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 @@ } 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 --- a/Types/Key.hs +++ b/Types/Key.hs @@ -28,6 +28,8 @@ 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.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' 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 --- 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 @@ - 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 --- a/Types/LockCache.hs +++ b/Types/LockCache.hs @@ -13,6 +13,6 @@ 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 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -31,6 +31,7 @@ import Data.Ord +import Common import qualified Git import Types.Key import Types.UUID @@ -47,7 +48,6 @@ import Config.Cost import Utility.Metered import Git.Types (RemoteName) -import Utility.SafeCommand import Utility.Url import Utility.DataUnits @@ -92,18 +92,18 @@ -- 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 @@ -- 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 @@ -- 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 @@ :: 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 @@ -- -- 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 --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -18,7 +18,7 @@ -- A source of a Key's content. data ContentSource - = FileContent FilePath + = FileContent OsPath | ByteContent L.ByteString isByteContent :: ContentSource -> Bool @@ -43,7 +43,7 @@ -- 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 --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -19,7 +19,7 @@ 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 @@ 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 --- a/Types/Transferrer.hs +++ b/Types/Transferrer.hs @@ -153,10 +153,10 @@ -- 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 --- 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 @@ = 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 --- 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 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 @@ -53,6 +56,25 @@ toUUID b | 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 --- a/Types/UrlContents.hs +++ b/Types/UrlContents.hs @@ -10,11 +10,12 @@ ) 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 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -60,7 +60,7 @@ 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 @@ -- 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 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -22,11 +22,10 @@ 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) + moveAnnex k (olddir toOsPath (keyFile0 k)) -- update the symlinks to the key files -- No longer needed here; V1.upgrade does the same thing @@ -39,20 +38,18 @@ 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 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -15,8 +15,6 @@ import Data.ByteString.Builder import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (toShort, fromShort) -import qualified Data.ByteString.Lazy as L -import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (isRegularFile) import Text.Read @@ -35,6 +33,7 @@ import Utility.Tmp import qualified Upgrade.V2 import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F -- v2 adds hashing of filenames of content and location log files. -- Key information is encoded in filenames differently, so @@ -82,20 +81,19 @@ 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 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 @@ 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 @@ 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 @@ 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,68 +194,64 @@ fileKey1 file = readKey1 $ replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file -writeLog1 :: FilePath -> [LogLine] -> IO () -writeLog1 file ls = viaTmp L.writeFile 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 . encodeBL <$> readFileStrict 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 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -20,11 +20,13 @@ 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. - @@ -53,14 +55,14 @@ 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 @@ -68,7 +70,7 @@ return UpgradeSuccess -locationLogs :: Annex [(Key, FilePath)] +locationLogs :: Annex [(Key, OsPath)] locationLogs = do config <- Annex.getGitConfig dir <- fromRepo gitStateDir @@ -80,17 +82,17 @@ where tryDirContents d = catchDefaultIO [] $ dirContents d islogfile config f = maybe Nothing (\k -> Just (k, f)) $ - locationLogFileKey config (toRawFilePath 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 () @@ -129,22 +131,22 @@ {- 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 = fromRawFilePath (Git.attributes repo) + let attributes = Git.attributes repo whenM (doesFileExist attributes) $ do - c <- readFileStrict attributes - liftIO $ viaTmp writeFile attributes $ unlines $ - filter (`notElem` attrLines) $ lines c - Git.Command.run [Param "add", File attributes] repo + c <- map decodeBS . fileLines' + <$> F.readFile' attributes + liftIO $ viaTmp (writeFile . fromOsPath) attributes + (unlines $ filter (`notElem` attrLines) c) + 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 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -33,9 +33,7 @@ import Utility.InodeCache import Utility.DottedVersion import Annex.AdjustedBranch -import qualified Utility.RawFilePath as R - -import qualified Data.ByteString as S +import qualified Utility.FileIO as F upgrade :: Bool -> Annex UpgradeResult upgrade automatic = flip catchNonAsync onexception $ do @@ -130,8 +128,8 @@ Just k -> do stagePointerFile f Nothing =<< hashPointerFile k ifM (isJust <$> getAnnexLinkTarget f) - ( writepointer (fromRawFilePath f) k - , fromdirect (fromRawFilePath f) k + ( writepointer f k + , fromdirect f k ) Database.Keys.addAssociatedFile k =<< inRepo (toTopFilePath f) @@ -139,14 +137,13 @@ 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 @@ -158,8 +155,8 @@ ) writepointer f k = liftIO $ do - removeWhenExistsWith R.removeLink (toRawFilePath f) - S.writeFile 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 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -28,7 +28,7 @@ import Annex.Perms import Utility.InodeCache import Annex.InodeSentinal -import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F setIndirect :: Annex () setIndirect = do @@ -78,27 +78,27 @@ 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 <- fromRawFilePath <$> calcRepo (gitAnnexMapping key) - liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> + mapping <- calcRepo (gitAnnexMapping key) + 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. - @@ -106,10 +106,8 @@ - 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. - @@ -118,27 +116,26 @@ recordedInodeCache :: Key -> Annex [InodeCache] recordedInodeCache key = withInodeCacheFile key $ \f -> liftIO $ catchDefaultIO [] $ - mapMaybe readInodeCache . lines - <$> readFileStrict (fromRawFilePath f) + mapMaybe (readInodeCache . decodeBS) . fileLines' + <$> 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 --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -22,8 +22,8 @@ import Git.FilePath 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 @@ -39,48 +39,52 @@ -- 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. @@ -107,11 +111,11 @@ (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 $ @@ -127,11 +131,12 @@ -- checked into the repository. updateSmudgeFilter :: Annex () updateSmudgeFilter = do - lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal - ls <- liftIO $ lines <$> catchDefaultIO "" (readFileStrict lf) + lf <- Annex.fromRepo Git.attributesLocal + ls <- liftIO $ map decodeBS . fileLines' + <$> catchDefaultIO "" (F.readFile' lf) let ls' = removedotfilter ls when (ls /= ls') $ - liftIO $ writeFile 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 --- a/Upgrade/V9.hs +++ b/Upgrade/V9.hs @@ -55,7 +55,7 @@ - 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 --- 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 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. @@ -59,6 +63,11 @@ -- implementation. 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. -- diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -44,12 +44,12 @@ {- 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 @@ - 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 @@ {- 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 --- 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 @@ #else import System.Win32.Process (terminateProcessById) import Utility.LockFile +import qualified Utility.OsString as OS #endif #ifndef mingw32_HOST_OS @@ -42,7 +44,7 @@ - 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 @@ {- 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 @@ - - 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 @@ _ -> 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 @@ - 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 @@ 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 @@ #endif {- Stops the daemon, safely. -} -stopDaemon :: FilePath -> IO () +stopDaemon :: OsPath -> IO () stopDaemon pidfile = go =<< checkDaemon pidfile where go Nothing = noop @@ -181,14 +183,14 @@ - when eg, restarting the daemon. -} #ifdef mingw32_HOST_OS -winLockFile :: PID -> FilePath -> IO RawFilePath +winLockFile :: PID -> OsPath -> IO OsPath winLockFile pid pidfile = do cleanstale - return $ toRawFilePath $ prefix ++ show pid ++ suffix + return $ prefix <> toOsPath (show pid) <> suffix where - prefix = pidfile ++ "." - suffix = ".lck" + prefix = pidfile <> literalOsPath "." + suffix = literalOsPath ".lck" cleanstale = mapM_ (void . tryIO . removeFile) =<< - (filter iswinlockfile <$> dirContents (fromRawFilePath (parentDir (toRawFilePath pidfile)))) - iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f + (filter iswinlockfile <$> dirContents (parentDir pidfile)) + iswinlockfile f = suffix `OS.isSuffixOf` f && prefix `OS.isPrefixOf` f #endif diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -22,6 +22,7 @@ ) where import Utility.DirWatcher.Types +import Utility.OsPath #if WITH_INOTIFY import qualified Utility.DirWatcher.INotify as INotify @@ -40,7 +41,7 @@ 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 @@ - 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 @@ #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/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs --- a/Utility/DirWatcher/FSEvents.hs +++ b/Utility/DirWatcher/FSEvents.hs @@ -15,15 +15,15 @@ import qualified System.Posix.Files as Files import Data.Bits ((.&.)) -watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO EventStream +watchDir :: OsPath -> (OsPath -> Bool) -> Bool -> WatchHooks -> IO EventStream watchDir dir ignored scanevents hooks = do unlessM fileLevelEventsSupported $ giveup "Need at least OSX 10.7.0 for file-level FSEvents" scan dir - eventStreamCreate [dir] 1.0 True True True dispatch + eventStreamCreate [fromOsPath dir] 1.0 True True True dispatch where dispatch evt - | ignoredPath ignored (eventPath evt) = noop + | ignoredPath ignored (toOsPath (eventPath evt)) = noop | otherwise = do {- More than one flag may be set, if events occurred - close together. @@ -45,8 +45,8 @@ - received for both its old and its new name. -} when (hasflag eventFlagItemRenamed) $ if hasflag eventFlagItemIsDir - then ifM (doesDirectoryExist $ eventPath evt) - ( scan $ eventPath evt + then ifM (doesDirectoryExist $ toOsPath $ eventPath evt) + ( scan $ toOsPath $ eventPath evt , runhook delDirHook Nothing ) else maybe (runhook delHook Nothing) handleadd @@ -61,7 +61,7 @@ runhook modifyHook ms where hasflag f = eventFlags evt .&. f /= 0 - runhook h s = maybe noop (\a -> a (eventPath evt) s) (h hooks) + runhook h s = maybe noop (\a -> a (toOsPath (eventPath evt)) s) (h hooks) handleadd s | Files.isSymbolicLink s = runhook addSymlinkHook $ Just s | Files.isRegularFile s = runhook addHook $ Just s @@ -70,12 +70,13 @@ scan d = unless (ignoredPath ignored d) $ -- Do not follow symlinks when scanning. -- This mirrors the inotify startup scan behavior. - mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d) + mapM_ go =<< emptyWhenDoesNotExist + (dirContentsRecursiveSkipping (const False) False d) where go f | ignoredPath ignored f = noop | otherwise = do - ms <- getstatus f + ms <- getstatus (fromOsPath f) case ms of Nothing -> noop Just s @@ -93,5 +94,5 @@ getstatus = catchMaybeIO . R.getSymbolicLinkStatus . toRawFilePath {- 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/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -47,7 +47,7 @@ - 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 @@ 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) <$> + mapM_ scan =<< filter (`notElem` dirCruft) <$> getDirectoryContents dir where recurse d = watchDir i d ignored scanevents hooks @@ -108,22 +108,21 @@ 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 @@ | 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 @@ 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 @@ 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/Kqueue.hs b/Utility/DirWatcher/Kqueue.hs --- a/Utility/DirWatcher/Kqueue.hs +++ b/Utility/DirWatcher/Kqueue.hs @@ -77,7 +77,7 @@ getDirInfo :: FilePath -> IO DirInfo getDirInfo dir = do - l <- filter (not . dirCruft) <$> getDirectoryContents dir + l <- filter (not . dirCruft . toRawFilePath) <$> getDirectoryContents dir contents <- S.fromList . catMaybes <$> mapM getDirEnt l return $ DirInfo dir contents where diff --git a/Utility/DirWatcher/Types.hs b/Utility/DirWatcher/Types.hs --- a/Utility/DirWatcher/Types.hs +++ b/Utility/DirWatcher/Types.hs @@ -16,12 +16,12 @@ 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 --- a/Utility/DirWatcher/Win32Notify.hs +++ b/Utility/DirWatcher/Win32Notify.hs @@ -14,15 +14,15 @@ 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,10 +40,11 @@ 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 =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d) + mapM_ go =<< emptyWhenDoesNotExist + (dirContentsRecursiveSkipping (const False) False d) where go f | ignoredPath ignored f = noop @@ -60,8 +61,8 @@ 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 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,42 +1,42 @@ {- directory traversal and manipulation - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2025 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Directory ( - module Utility.Directory, - module Utility.SystemDirectory -) where +module Utility.Directory where +#ifdef WITH_OSPATH +import System.Directory.OsPath +#else +import Utility.SystemDirectory +#endif import Control.Monad -import System.FilePath import System.PosixCompat.Files (isDirectory, isSymbolicLink) import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe import Prelude -import Utility.SystemDirectory +import Utility.OsPath import Utility.Exception import Utility.Monad -import Utility.FileSystemEncoding import qualified Utility.RawFilePath as R -dirCruft :: FilePath -> 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 :: FilePath -> IO [FilePath] -dirContents d = map (d ) . filter (not . dirCruft) <$> getDirectoryContents 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. @@ -48,11 +48,11 @@ - be accessed (the use of unsafeInterleaveIO would make it difficult to - trap such exceptions). -} -dirContentsRecursive :: FilePath -> IO [FilePath] +dirContentsRecursive :: OsPath -> IO [OsPath] dirContentsRecursive = dirContentsRecursiveSkipping (const False) True {- Skips directories whose basenames match the skipdir. -} -dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] +dirContentsRecursiveSkipping :: (OsPath -> Bool) -> Bool -> OsPath -> IO [OsPath] dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir | skipdir (takeFileName topdir) = return [] | otherwise = do @@ -72,13 +72,15 @@ =<< catchDefaultIO [] (dirContents dir) files' <- go (dirs' ++ dirs) return (files ++ files') + + 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 (toRawFilePath entry) + ms <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath entry) case ms of (Just s) | isDirectory s -> recurse @@ -98,7 +100,7 @@ - be accessed (the use of unsafeInterleaveIO would make it difficult to - trap such exceptions). -} -dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +dirTreeRecursiveSkipping :: (OsPath -> Bool) -> OsPath -> IO [OsPath] dirTreeRecursiveSkipping skipdir topdir | skipdir (takeFileName topdir) = return [] | otherwise = do @@ -113,7 +115,7 @@ =<< filterM isdir =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs - isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath 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 --- a/Utility/Directory/Create.hs +++ b/Utility/Directory/Create.hs @@ -20,14 +20,12 @@ 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 @@ - 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 @@ 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 --- a/Utility/Directory/Stream.hs +++ b/Utility/Directory/Stream.hs @@ -1,12 +1,13 @@ -{- streaming directory traversal +{- streaming directory reading - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2025 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory.Stream ( @@ -14,11 +15,10 @@ openDirectory, closeDirectory, readDirectory, - isDirectoryEmpty, + isDirectoryPopulated, ) where import Control.Monad -import System.FilePath import Control.Concurrent import Data.Maybe import Prelude @@ -26,11 +26,14 @@ #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 #else -import qualified System.Posix as Posix +import qualified Data.ByteString as B +import qualified System.Posix.Directory.ByteString as Posix #endif import Utility.Directory import Utility.Exception +import Utility.FileSystemEncoding +import Utility.OsPath #ifndef mingw32_HOST_OS data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream @@ -40,14 +43,14 @@ type IsOpen = MVar () -- full when the handle is open -openDirectory :: FilePath -> IO DirectoryHandle +openDirectory :: RawFilePath -> IO DirectoryHandle openDirectory path = do #ifndef mingw32_HOST_OS dirp <- Posix.openDirStream path isopen <- newMVar () return (DirectoryHandle isopen dirp) #else - (h, fdat) <- Win32.findFirstFile (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.) @@ -75,11 +78,11 @@ -- | Reads the next entry from the handle. Once the end of the directory -- is reached, returns Nothing and automatically closes the handle. -readDirectory :: DirectoryHandle -> IO (Maybe FilePath) +readDirectory :: DirectoryHandle -> IO (Maybe RawFilePath) #ifndef mingw32_HOST_OS readDirectory hdl@(DirectoryHandle _ dirp) = do e <- Posix.readDirStream dirp - if null e + if B.null e then do closeDirectory hdl return Nothing @@ -102,18 +105,18 @@ where getfn = do filename <- Win32.getFindDataFileName fdat - return (Just filename) + return (Just (toRawFilePath filename)) #endif --- | True only when directory exists and contains nothing. --- Throws exception if directory does not exist. -isDirectoryEmpty :: FilePath -> IO Bool -isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check +-- | True only when directory exists and is not empty. +isDirectoryPopulated :: RawFilePath -> IO Bool +isDirectoryPopulated d = bracket (openDirectory d) closeDirectory check + `catchIO` const (return False) where check h = do v <- readDirectory h case v of - Nothing -> return True + Nothing -> return False Just f - | not (dirCruft f) -> return False + | not (toOsPath f `elem` dirCruft) -> return True | otherwise -> check h diff --git a/Utility/FileIO.hs b/Utility/FileIO.hs new file mode 100644 --- /dev/null +++ b/Utility/FileIO.hs @@ -0,0 +1,153 @@ +{- File IO on OsPaths. + - + - Since Prelude exports many of these as well, this needs to be imported + - qualified. + - + - Copyright 2025 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Utility.FileIO +( + withFile, + openFile, + withBinaryFile, + openBinaryFile, + readFile, + readFile', + writeFile, + writeFile', + appendFile, + appendFile', + openTempFile, +) where + +#ifdef WITH_OSPATH + +#ifndef mingw32_HOST_OS +import System.File.OsPath +#else +-- On Windows, System.File.OsPath does not handle UNC-style conversion itself, +-- so that has to be done when calling it. See +-- https://github.com/haskell/file-io/issues/39 +import Utility.Path.Windows +import Utility.OsPath +import System.IO (IO, Handle, IOMode) +import Prelude (return) +import qualified System.File.OsPath as O +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Control.Applicative + +withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withFile f m a = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.withFile f' m a + +openFile :: OsPath -> IOMode -> IO Handle +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) + O.readFile f' + +readFile' :: OsPath -> IO B.ByteString +readFile' f = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.readFile' f' + +writeFile :: OsPath -> L.ByteString -> IO () +writeFile f b = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.writeFile f' b + +writeFile' :: OsPath -> B.ByteString -> IO () +writeFile' f b = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.writeFile' f' b + +appendFile :: OsPath -> L.ByteString -> IO () +appendFile f b = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.appendFile f' b + +appendFile' :: OsPath -> B.ByteString -> IO () +appendFile' f b = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.appendFile' f' b + +openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle) +openTempFile p s = do + p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p) + (t, h) <- O.openTempFile p' s + -- Avoid returning mangled path from convertToWindowsNativeNamespace + let t' = p takeFileName t + return (t', h) +#endif + +#else +-- When not building with OsPath, export RawFilePath versions +-- instead. +import Utility.OsPath +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 . fromRawFilePath + +writeFile :: OsPath -> L.ByteString -> IO () +writeFile = L.writeFile . fromRawFilePath + +writeFile' :: OsPath -> B.ByteString -> IO () +writeFile' = B.writeFile . fromRawFilePath + +appendFile :: OsPath -> L.ByteString -> IO () +appendFile = L.appendFile . fromRawFilePath + +appendFile' :: OsPath -> B.ByteString -> IO () +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 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -25,24 +25,27 @@ 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 @@ -75,15 +78,15 @@ ] {- 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. -} @@ -93,7 +96,7 @@ , ownerReadMode, groupReadMode ] -groupWriteRead :: RawFilePath -> IO () +groupWriteRead :: OsPath -> IO () groupWriteRead f = modifyFileMode f $ addModes groupSharedModes checkMode :: FileMode -> FileMode -> Bool @@ -103,13 +106,13 @@ 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 @@ -157,7 +160,7 @@ stickyMode :: FileMode stickyMode = 512 -setSticky :: RawFilePath -> IO () +setSticky :: OsPath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -170,15 +173,15 @@ - 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 $ openFile (fromRawFilePath 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 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -17,12 +17,13 @@ #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO -import Utility.FileSystemEncoding +import qualified Utility.FileIO as F #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 @@ -32,18 +33,18 @@ - 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 (openFile (fromRawFilePath 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 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -23,7 +23,6 @@ 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 @@ -33,8 +32,13 @@ import qualified GHC.Foreign as GHC import System.IO.Unsafe import Data.ByteString.Unsafe (unsafePackMallocCStringLen) +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. @@ -88,9 +92,7 @@ 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 @@ -102,9 +104,7 @@ 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 @@ -114,10 +114,10 @@ #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. @@ -125,26 +125,43 @@ - Avoids returning an invalid part of a unicode byte sequence, at the - cost of efficiency when running on a large FilePath. -} -truncateFilePath :: Int -> FilePath -> FilePath +truncateFilePath :: Int -> RawFilePath -> RawFilePath #ifndef mingw32_HOST_OS -truncateFilePath n = go . reverse +{- On unix, do not assume a unicode locale, but does assume ascii + - characters are a single byte. -} +truncateFilePath n b = + let blen = S.length b + in if blen <= n + then b + else go blen (reverse (fromRawFilePath b)) where - go f = - let b = encodeBS f - in if S.length b <= n - then reverse f - else go (drop 1 f) + go blen f = case uncons f of + Just (c, f') + | isAscii c -> + let blen' = blen - 1 + in if blen' <= n + then toRawFilePath (reverse f') + else go blen' f' + | otherwise -> + let blen' = S.length (toRawFilePath f') + in if blen' <= n + then toRawFilePath (reverse f') + else go blen' f' + Nothing -> toRawFilePath (reverse f) #else {- On Windows, count the number of bytes used by each utf8 character. -} -truncateFilePath n = reverse . go [] n . L8.fromString +truncateFilePath n = toRawFilePath . reverse . go [] n where go coll cnt bs | cnt <= 0 = coll - | otherwise = case L8.decode bs of - Just (c, x) | c /= L8.replacement_char -> - let x' = fromIntegral x - in if cnt - x' < 0 - then coll - else go (c:coll) (cnt - x') (L8.drop 1 bs) + | otherwise = case S8.decode bs of + Just (c, x) + | c /= S8.replacement_char -> + let x' = fromIntegral x + in if cnt - x' < 0 + then coll + else go (c:coll) (cnt - x') (S8.drop 1 bs) + | otherwise -> + go ('_':coll) (cnt - 1) (S8.drop 1 bs) _ -> coll #endif diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs --- 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 @@ 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 @@ 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 @@ 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 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -179,10 +179,10 @@ go (passphrasefd ++ params) #else -- store the passphrase in a temp file for gpg - withTmpFile "gpg" $ \tmpfile h -> do + withTmpFile (literalOsPath "gpg") $ \tmpfile h -> do liftIO $ B.hPutStr h passphrase liftIO $ hClose h - let passphrasefile = [Param "--passphrase-file", File tmpfile] + let passphrasefile = [Param "--passphrase-file", File (fromOsPath tmpfile)] go $ passphrasefile ++ params #endif where @@ -416,9 +416,9 @@ 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 @@ 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 --- a/Utility/HtmlDetect.hs +++ b/Utility/HtmlDetect.hs @@ -13,6 +13,8 @@ ) where import Author +import qualified Utility.FileIO as F +import Utility.OsPath import Text.HTML.TagSoup import System.IO @@ -57,8 +59,8 @@ -- 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 :: FilePath -> IO Bool -isHtmlFile file = withFile 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 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -49,6 +49,7 @@ 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) @@ -185,24 +186,24 @@ (inode:size:mtime:mtimedecimal:_) -> do i <- readish inode sz <- readish size - t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal + t <- parsePOSIXTime $ encodeBS $ mtime ++ '.' : mtimedecimal 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 @@ - 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 @@ 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 @@ 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 @@ 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 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -18,18 +18,19 @@ import Utility.PartialPrelude import Utility.Directory +import Utility.SystemDirectory import Utility.Process 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 @@ -37,42 +38,42 @@ {- 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. @@ -80,21 +81,21 @@ 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 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -27,6 +27,7 @@ import Utility.Exception import Utility.Applicative import Utility.Directory +import Utility.SystemDirectory import Utility.Monad import Utility.Path.AbsRel import Utility.FileMode @@ -38,6 +39,8 @@ import Utility.Env import Utility.Env.Set import Utility.Tmp +import Utility.RawFilePath +import Utility.OsPath import qualified Utility.LockFile.Posix as Posix import System.IO @@ -47,21 +50,19 @@ 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 @@ -76,7 +77,7 @@ 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. @@ -109,25 +110,26 @@ -- 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. -- @@ -147,20 +149,21 @@ _ -> return (Just ParentLocked) where go abslockfile sidelock = do - let abslockfile' = fromRawFilePath abslockfile - (tmp, h) <- openTmpFileIn (takeDirectory abslockfile') "locktmp" - let tmp' = toRawFilePath tmp + (tmp, h) <- openTmpFileIn + (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 @@ -173,7 +176,7 @@ -- 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 @@ -187,36 +190,38 @@ -- -- 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 @@ -239,17 +244,16 @@ -- 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 - let dest' = fromRawFilePath dest - fs <- dirContents (takeDirectory dest') - case length (filter (== dest') fs) of + fs <- dirContents (takeDirectory dest) + case length (filter (== dest) fs) of 1 -> return False -- whew! 0 -> return True -- wtf? _ -> do -- Try to clean up the extra copy we made -- that has the same name. Egads. - _ <- tryIO $ removeFile dest' + _ <- tryIO $ removeFile dest return True -- | Waits as necessary to take a lock. @@ -265,7 +269,7 @@ | 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 @@ -277,15 +281,15 @@ 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 () @@ -293,7 +297,7 @@ -- 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 @@ -309,7 +313,7 @@ -- 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 $ @@ -324,9 +328,9 @@ -- The parent process should keep running as long as the child -- process is running, since the child inherits the environment and will -- not see unsetLockEnv. -pidLockEnv :: 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 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -25,15 +25,15 @@ 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 @@ 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 @@ -- 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 --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -21,11 +21,12 @@ 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 @@ -} 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 @@ -70,14 +71,12 @@ Right h -> Just h #else h <- withTString (fromRawFilePath f') $ \c_f -> - c_CreateFile c_f gENERIC_READ sharemode security_attributes + c_CreateFile c_f gENERIC_READ sharemode (maybePtr Nothing) oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) return $ if h == iNVALID_HANDLE_VALUE then Nothing else Just h #endif - where - security_attributes = maybePtr Nothing dropLock :: LockHandle -> IO () dropLock = closeHandle diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs --- a/Utility/LockPool/STM.hs +++ b/Utility/LockPool/STM.hs @@ -23,14 +23,14 @@ ) 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 --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -35,7 +35,7 @@ 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 @@ {- 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 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -15,6 +15,7 @@ import Common import BuildInfo import Utility.Env.Set +import qualified Utility.OsString as OS import System.Posix.Types @@ -30,12 +31,14 @@ - 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 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -55,6 +55,7 @@ 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 @@ {- 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 @@ 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 @@ -} watchFileSize :: (MonadIO m, MonadMask m) - => RawFilePath + => OsPath -> MeterUpdate -> (MeterUpdate -> m a) -> m a diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -1,20 +1,24 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2025 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Misc ( hGetContentsStrict, - readFileStrict, separate, separate', separateEnd', firstLine, firstLine', + fileLines, + fileLines', + linesFile, + linesFile', segment, segmentDelim, massReplace, @@ -32,6 +36,9 @@ import System.Exit import Control.Applicative import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 import Prelude {- A version of hgetContents that is not lazy. Ensures file is @@ -39,10 +46,6 @@ hGetContentsStrict :: Handle -> IO String hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s -{- A version of readFile that is not lazy. -} -readFileStrict :: FilePath -> IO String -readFileStrict = readFile >=> \s -> length s `seq` return s - {- Like break, but the item matching the condition is not included - in the second result list. - @@ -77,6 +80,51 @@ firstLine' = S.takeWhile (/= nl) where nl = fromIntegral (ord '\n') + +-- On windows, readFile does NewlineMode translation, +-- stripping CR before LF. When converting to ByteString, +-- use this to emulate that. +fileLines :: L.ByteString -> [L.ByteString] +#ifdef mingw32_HOST_OS +fileLines = map stripCR . L8.lines + where + stripCR b = case L8.unsnoc b of + Nothing -> b + Just (b', e) + | e == '\r' -> b' + | otherwise -> b +#else +fileLines = L8.lines +#endif + +fileLines' :: S.ByteString -> [S.ByteString] +#ifdef mingw32_HOST_OS +fileLines' = map stripCR . S8.lines + where + stripCR b = case S8.unsnoc b of + Nothing -> b + Just (b', e) + | e == '\r' -> b' + | otherwise -> b +#else +fileLines' = S8.lines +#endif + +-- One windows, writeFile does NewlineMode translation, +-- adding CR before LF. When converting to ByteString, use this to emulate that. +linesFile :: L.ByteString -> L.ByteString +#ifndef mingw32_HOST_OS +linesFile = id +#else +linesFile = L8.concat . concatMap (\x -> [x, L8.pack "\r\n"]) . fileLines +#endif + +linesFile' :: S.ByteString -> S.ByteString +#ifndef mingw32_HOST_OS +linesFile' = id +#else +linesFile' = S8.concat . concatMap (\x -> [x, S8.pack "\r\n"]) . fileLines' +#endif {- Splits a list into segments that are delimited by items matching - a predicate. (The delimiters are not included in the segments.) diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -21,26 +21,26 @@ 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 qualified Utility.RawFilePath as R +import Utility.OsPath 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 (fromRawFilePath dest) () + | otherwise = viaTmp mv dest () where rethrow = throwM e @@ -56,12 +56,12 @@ 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) @@ -73,11 +73,11 @@ #ifndef mingw32_HOST_OS isdir f = do - r <- tryIO $ R.getSymbolicLinkStatus f + r <- tryIO $ R.getSymbolicLinkStatus (fromOsPath f) case r of (Left _) -> return False (Right s) -> return $ isDirectory s +#endif copyright :: Copyright copyright = author JoeyHess (2022-11) -#endif diff --git a/Utility/OSX.hs b/Utility/OSX.hs --- 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 @@ genOSXAutoStartFile, ) where +import Common import Utility.UserInfo -import System.FilePath - -autoStartBase :: String -> FilePath -autoStartBase label = "Library" "LaunchAgents" label ++ ".plist" +autoStartBase :: String -> OsPath +autoStartBase label = literalOsPath "Library" + literalOsPath "LaunchAgents" + toOsPath label <> literalOsPath ".plist" -systemAutoStart :: String -> FilePath -systemAutoStart label = "/" autoStartBase label +systemAutoStart :: String -> OsPath +systemAutoStart label = literalOsPath "/" 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 --- a/Utility/OpenFd.hs +++ b/Utility/OpenFd.hs @@ -14,7 +14,8 @@ 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 new file mode 100644 --- /dev/null +++ b/Utility/OsPath.hs @@ -0,0 +1,137 @@ +{- OsPath utilities + - + - Copyright 2025 Joey Hess + - + - License: BSD-2-clause + -} + +{-# 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 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 +#else +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 + +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) + toOsPath = bytesToOsPath + fromOsPath = bytesFromOsPath +#else + 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 + 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 = RawFilePath + +type OsString = ByteString + +instance OsPathConv RawFilePath where + toOsPath = id + fromOsPath = id + +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 --- /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 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -27,8 +27,6 @@ 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 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 @@ - 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 @@ 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 @@ - 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 @@ - 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 @@ - 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 @@ - 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 @@ 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 @@ - - 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 @@ - - 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 --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -17,15 +17,14 @@ 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 @@ - 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 @@ - - 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 @@ - 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 --- a/Utility/Path/Tests.hs +++ b/Utility/Path/Tests.hs @@ -17,42 +17,39 @@ 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 @@ - 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 --- a/Utility/Path/Windows.hs +++ b/Utility/Path/Windows.hs @@ -13,12 +13,13 @@ ) 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 @@ | 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 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -22,12 +22,8 @@ readSymbolicLink, createSymbolicLink, createLink, - removeLink, getFileStatus, getSymbolicLinkStatus, - doesPathExist, - getCurrentDirectory, - createDirectory, setFileMode, setOwnerAndGroup, rename, @@ -38,19 +34,7 @@ #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) -- System.PosixCompat does not handle UNC-style conversion itself, @@ -76,11 +60,6 @@ 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 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 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -25,6 +25,7 @@ #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 @@ 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 @@ #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/SafeCommand.hs b/Utility/SafeCommand.hs --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -10,6 +10,7 @@ module Utility.SafeCommand ( CommandParam(..), toCommand, + toCommand', boolSystem, boolSystem', boolSystemEnv, diff --git a/Utility/SafeOutput.hs b/Utility/SafeOutput.hs --- a/Utility/SafeOutput.hs +++ b/Utility/SafeOutput.hs @@ -17,6 +17,11 @@ 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 @@ -25,6 +30,11 @@ 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 diff --git a/Utility/Shell.hs b/Utility/Shell.hs --- a/Utility/Shell.hs +++ b/Utility/Shell.hs @@ -13,6 +13,7 @@ findShellCommand, ) where +import Utility.OsPath import Utility.SafeCommand #ifdef mingw32_HOST_OS import Utility.Path @@ -20,10 +21,6 @@ import Utility.PartialPrelude #endif -#ifdef mingw32_HOST_OS -import System.FilePath -#endif - shellPath :: FilePath shellPath = "/bin/sh" @@ -35,24 +32,24 @@ -- 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 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} + module Utility.SshConfig ( SshConfig(..), Comment(..), @@ -28,11 +30,13 @@ import Utility.UserInfo import Utility.Tmp import Utility.FileMode +import qualified Utility.FileIO as F import Data.Char import Data.Ord import Data.Either import System.PosixCompat.Files (groupWriteMode, otherWriteMode) +import qualified Data.ByteString.Char8 as S8 data SshConfig = GlobalConfig SshSetting @@ -132,9 +136,10 @@ changeUserSshConfig :: (String -> String) -> IO () changeUserSshConfig modifier = do sshdir <- sshDir - let configfile = sshdir "config" + let configfile = sshdir literalOsPath "config" whenM (doesFileExist configfile) $ do - c <- readFileStrict configfile + c <- decodeBS . S8.unlines . fileLines' + <$> F.readFile' configfile let c' = modifier c when (c /= c') $ do -- If it's a symlink, replace the file it @@ -142,10 +147,10 @@ f <- catchDefaultIO configfile (canonicalizePath configfile) viaTmp writeSshConfig f c' -writeSshConfig :: FilePath -> String -> IO () +writeSshConfig :: OsPath -> String -> IO () writeSshConfig f s = do - writeFile f s - setSshConfigMode (toRawFilePath f) + F.writeFile' f (linesFile' (encodeBS s)) + 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 @@ -154,11 +159,11 @@ - 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 --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -70,7 +70,7 @@ - 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 @@ {- 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 "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 @@ go (Just emptydirectory) (passwordfd ++ params) #else -- store the password in a temp file - withTmpFile "sop" $ \tmpfile h -> do + withTmpFile (literalOsPath "sop") $ \tmpfile h -> do liftIO $ B.hPutStr h password liftIO $ hClose h - let passwordfile = [Param $ "--with-password="++tmpfile] + let passwordfile = [Param $ "--with-password=" ++ fromOsPath tmpfile] -- Don't need to pass emptydirectory since @FD is not used, -- and so tmpfile also does not need to be made absolute. case emptydirectory of @@ -188,7 +188,7 @@ , 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 --- a/Utility/Su.hs +++ b/Utility/Su.hs @@ -70,7 +70,7 @@ 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 --- 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/TimeStamp.hs b/Utility/TimeStamp.hs --- a/Utility/TimeStamp.hs +++ b/Utility/TimeStamp.hs @@ -19,7 +19,6 @@ import Data.Ratio import Control.Applicative import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 import qualified Data.Attoparsec.ByteString as A import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8) @@ -41,9 +40,9 @@ A.parseOnly (decimal <* A.endOfInput) b return (d, len) -parsePOSIXTime :: String -> Maybe POSIXTime -parsePOSIXTime s = eitherToMaybe $ - A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s) +parsePOSIXTime :: B.ByteString -> Maybe POSIXTime +parsePOSIXTime b = eitherToMaybe $ + A.parseOnly (parserPOSIXTime <* A.endOfInput) b {- This implementation allows for higher precision in a POSIXTime than - supported by the system's Double, and avoids the complications of diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,10 +1,11 @@ {- Temporary files. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2025 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -13,33 +14,39 @@ viaTmp, withTmpFile, withTmpFileIn, - relatedTemplate, openTmpFileIn, + relatedTemplate, + relatedTemplate', ) where import System.IO -import System.FilePath -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 +#endif import Utility.Exception import Utility.FileSystemEncoding import Utility.FileMode import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F +import Utility.OsPath +import Utility.SystemDirectory -type Template = String +type Template = OsString {- This is the same as openTempFile, except when there is an - error, it displays the template as well as the directory, - to help identify what call was responsible. -} -openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle) -openTmpFileIn dir template = openTempFile dir template +openTmpFileIn :: OsPath -> Template -> IO (OsPath, Handle) +openTmpFileIn dir template = F.openTempFile dir template `catchIO` decoraterrror where decoraterrror e = throwM $ - let loc = ioeGetLocation e ++ " template " ++ template + let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template) in annotateIOError e loc Nothing Nothing {- Runs an action like writeFile, writing to a temp file first and @@ -50,11 +57,11 @@ - mode as it would when using writeFile, unless the writer action changes - it. -} -viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () +viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m () viaTmp a file content = bracketIO setup cleanup use where (dir, base) = splitFileName file - template = relatedTemplate (base ++ ".tmp") + template = relatedTemplate (fromOsPath base <> ".tmp") setup = do createDirectoryIfMissing True dir openTmpFileIn dir template @@ -62,21 +69,23 @@ _ <- tryIO $ hClose h tryIO $ removeFile tmpfile use (tmpfile, h) = do - let tmpfile' = toRawFilePath tmpfile + let tmpfile' = fromOsPath tmpfile -- Make mode the same as if the file were created usually, -- not as a temp file. (This may fail on some filesystems -- that don't support file modes well, so ignore -- exceptions.) - _ <- liftIO $ tryIO $ R.setFileMode tmpfile' =<< defaultFileMode + _ <- liftIO $ tryIO $ + R.setFileMode (fromOsPath tmpfile) + =<< defaultFileMode liftIO $ hClose h a tmpfile content - liftIO $ R.rename tmpfile' (toRawFilePath file) + liftIO $ R.rename tmpfile' (fromOsPath file) {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} -withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a +withTmpFile :: (MonadIO m, MonadMask m) => Template -> (OsPath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ catchDefaultIO (literalOsPath ".") getTemporaryDirectory withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, @@ -85,13 +94,13 @@ - Note that the tmp file will have a file mode that only allows the - current user to access it. -} -withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a +withTmpFileIn :: (MonadIO m, MonadMask m) => OsPath -> Template -> (OsPath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h - catchBoolIO (removeFile name >> return True) + tryIO $ removeFile name use (name, h) = a name h {- It's not safe to use a FilePath of an existing file as the template @@ -99,18 +108,37 @@ - will be longer, and may exceed the maximum filename length. - - This generates a template that is never too long. - - (Well, it allocates 20 characters for use in making a unique temp file, - - anyway, which is enough for the current implementation and any - - likely implementation.) -} -relatedTemplate :: FilePath -> FilePath -relatedTemplate f - | len > 20 = +relatedTemplate :: RawFilePath -> Template +relatedTemplate = toOsPath . relatedTemplate' + +relatedTemplate' :: RawFilePath -> RawFilePath +#ifndef mingw32_HOST_OS +relatedTemplate' f + | len > templateAddedLength = {- Some filesystems like FAT have issues with filenames - ending in ".", so avoid truncating a filename to end - that way. -} - reverse $ dropWhile (== '.') $ reverse $ - truncateFilePath (len - 20) f + B.dropWhileEnd (== dot) $ + truncateFilePath (len - templateAddedLength) f | otherwise = f where - len = length f + len = B.length f + dot = fromIntegral (ord '.') +#else +-- Avoids a test suite failure on windows, reason unknown, but +-- best to keep paths short on windows anyway. +relatedTemplate' _ = "t" +#endif + +{- When a Template is used to create a temporary file, some random bytes + - are appended to it. This is how many such bytes can be added, maximum. + - + - This needs to be as long or longer than the current implementation + - 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 --- 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 @@ ) 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) @@ -23,17 +22,21 @@ import Utility.Exception import Utility.Tmp (Template) +import Utility.OsPath +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 template) + (liftIO $ toOsPath <$> mkdtemp p) removeTmpDir a #else @@ -42,21 +45,21 @@ {- 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 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 --- 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 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ -- 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 @@ -- | 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 --- a/Utility/Touch.hs +++ b/Utility/Touch.hs @@ -14,9 +14,10 @@ #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. -} diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -50,6 +50,7 @@ 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 @@ =<< 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 @@ - - 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 @@ -- 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 @@ 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 @@ - 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 @@ => MeterUpdate -> Maybe IncrementalVerifier -> BytesProcessed - -> FilePath + -> OsPath -> IOMode -> Response (ConduitM () B8.ByteString m ()) -> m () @@ -577,7 +578,7 @@ 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 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -185,9 +185,9 @@ {- 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 . toRawFilePath) file $ genHtmlShim title url + viaTmp (writeFileProtected) file (genHtmlShim title url) genHtmlShim :: String -> String -> String genHtmlShim title url = unlines diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20250115 +Version: 10.20250320 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -159,7 +159,7 @@ 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 @@ -175,6 +175,9 @@ Flag Servant Description: Use the servant library, enabling using annex+http urls and git-annex p2phttp +Flag OsPath + Description: Use the os-string library and related libraries, for faster filename manipulation + Flag Benchmark Description: Enable benchmarking Default: True @@ -227,7 +230,6 @@ directory (>= 1.2.7.0), disk-free-space, filepath, - filepath-bytestring (>= 1.4.2.1.1), IfElse, monad-logger (>= 0.3.10), free, @@ -329,6 +331,17 @@ P2P.Http.Server P2P.Http.State + if flag(OsPath) + Build-Depends: + os-string (>= 2.0.0), + directory (>= 1.3.8.3), + 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: Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0), @@ -549,6 +562,7 @@ Annex.FileMatcher Annex.Fixup Annex.GitOverlay + Annex.GitShaKey Annex.HashObject Annex.Hook Annex.Import @@ -641,6 +655,7 @@ CmdLine.Usage Command Command.Add + Command.AddComputed Command.AddUnused Command.AddUrl Command.Adjust @@ -669,6 +684,7 @@ Command.FilterBranch Command.FilterProcess Command.Find + Command.FindComputed Command.FindKeys Command.FindRef Command.Fix @@ -714,6 +730,7 @@ Command.Proxy Command.Pull Command.Push + Command.Recompute Command.ReKey Command.ReadPresentKey Command.RecvKey @@ -917,6 +934,7 @@ Remote.BitTorrent Remote.Borg Remote.Bup + Remote.Compute Remote.Ddar Remote.Directory Remote.Directory.LegacyChunked @@ -1094,6 +1112,8 @@ Utility.OpenFile Utility.OptParse Utility.OSX + Utility.OsPath + Utility.OsString Utility.PID Utility.PartialPrelude Utility.Path @@ -1123,6 +1143,7 @@ Utility.STM Utility.Su Utility.SystemDirectory + Utility.FileIO Utility.Terminal Utility.TimeStamp Utility.TList diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -11,8 +11,15 @@ benchmark: true crypton: true servant: true + ospath: true packages: - '.' -resolver: lts-23.2 +resolver: nightly-2025-01-20 extra-deps: -- filepath-bytestring-1.4.100.3.2 +- filepath-bytestring-1.5.2.0.2 +- aws-0.24.4 +- git-lfs-1.2.5 +- feed-1.3.2.1 +allow-newer: true +allow-newer-deps: +- feed