From 0811531b5921e24b54674dcaf6967b7829fd4e77 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 6 Feb 2025 11:38:14 -0400 Subject: [PATCH] more OsPath conversion (542/749) Sponsored-by: Luke T. Shumaker --- Command.hs | 3 +- Command/Unannex.hs | 23 +++++++------- Command/Undo.hs | 18 +++++------ Command/Uninit.hs | 16 +++++----- Command/Unlock.hs | 8 ++--- Command/Unused.hs | 16 +++++----- Command/Vicfg.hs | 24 ++++++++------- Command/View.hs | 7 ++--- Command/WhereUsed.hs | 4 +-- Git/Types.hs | 3 ++ Test/Framework.hs | 71 ++++++++++++++++++++++++-------------------- Upgrade/V9.hs | 2 +- Utility/Daemon.hs | 48 ++++++++++++++++-------------- 13 files changed, 127 insertions(+), 116 deletions(-) diff --git a/Command.hs b/Command.hs index 6dc20a2cc6..1b683b2994 100644 --- a/Command.hs +++ b/Command.hs @@ -144,8 +144,7 @@ noDaemonRunning :: Command -> Command noDaemonRunning = addCheck NoDaemonRunning $ whenM (isJust <$> daemonpid) $ giveup "You cannot run this command while git-annex watch or git-annex assistant is running." where - daemonpid = liftIO . checkDaemon . fromRawFilePath - =<< fromRepo gitAnnexPidFile + daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile dontCheck :: CommandCheck -> Command -> Command dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 8eeae06d28..31ae53c6ff 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -39,12 +39,12 @@ seeker fast = AnnexedFileSeeker , usesLocationLog = False } -start :: Bool -> SeekInput -> RawFilePath -> Key -> CommandStart +start :: Bool -> SeekInput -> OsPath -> Key -> CommandStart start fast si file key = starting "unannex" (mkActionItem (key, file)) si $ perform fast file key -perform :: Bool -> RawFilePath -> Key -> CommandPerform +perform :: Bool -> OsPath -> Key -> CommandPerform perform fast file key = do Annex.Queue.addCommand [] "rm" [ Param "--cached" @@ -52,7 +52,7 @@ perform fast file key = do , Param "--quiet" , Param "--" ] - [fromRawFilePath file] + [fromOsPath file] isAnnexLink file >>= \case -- If the file is locked, it needs to be replaced with -- the content from the annex. Note that it's possible @@ -73,9 +73,9 @@ perform fast file key = do maybe noop Database.Keys.removeInodeCache =<< withTSDelta (liftIO . genInodeCache file) -cleanup :: Bool -> RawFilePath -> Key -> CommandCleanup +cleanup :: Bool -> OsPath -> Key -> CommandCleanup cleanup fast file key = do - liftIO $ removeFile (fromRawFilePath file) + liftIO $ removeFile file src <- calcRepo (gitAnnexLocation key) ifM (pure fast <||> Annex.getRead Annex.fast) ( do @@ -83,7 +83,7 @@ cleanup fast file key = do -- already have other hard links pointing at it. This -- avoids unannexing (and uninit) ending up hard -- linking files together, which would be surprising. - s <- liftIO $ R.getFileStatus src + s <- liftIO $ R.getFileStatus (fromOsPath src) if linkCount s > 1 then copyfrom src else hardlinkfrom src @@ -91,13 +91,14 @@ cleanup fast file key = do ) where copyfrom src = - thawContent file `after` liftIO - (copyFileExternal CopyAllMetaData - (fromRawFilePath src) - (fromRawFilePath file)) + thawContent file `after` + liftIO (copyFileExternal CopyAllMetaData src file) hardlinkfrom src = -- creating a hard link could fall; fall back to copying - ifM (liftIO $ catchBoolIO $ R.createLink src file >> return True) + ifM (liftIO $ tryhardlink src file) ( return True , copyfrom src ) + tryhardlink src dest = catchBoolIO $ do + R.createLink (fromOsPath src) (fromOsPath dest) + return True diff --git a/Command/Undo.hs b/Command/Undo.hs index 000cc1c313..289d4c35d2 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -18,7 +18,6 @@ import qualified Annex import qualified Git.LsFiles as LsFiles import qualified Git.Command as Git import qualified Git.Branch -import qualified Utility.RawFilePath as R cmd :: Command cmd = notBareRepo $ withAnnexOptions [jsonOptions] $ @@ -30,7 +29,7 @@ seek :: CmdParams -> CommandSeek seek ps = do -- Safety first; avoid any undo that would touch files that are not -- in the index. - (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toRawFilePath ps) + (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toOsPath ps) unless (null fs) $ do qp <- coreQuotePath <$> Annex.getGitConfig giveup $ decodeBS $ quote qp $ @@ -48,19 +47,20 @@ seek ps = do start :: FilePath -> CommandStart start p = starting "undo" ai si $ - perform p + perform p' where - ai = ActionItemOther (Just (QuotedPath (toRawFilePath p))) + p' = toOsPath p + ai = ActionItemOther (Just (QuotedPath p')) si = SeekInput [p] -perform :: FilePath -> CommandPerform +perform :: OsPath -> CommandPerform perform p = do g <- gitRepo -- Get the reversed diff that needs to be applied to undo. (diff, cleanup) <- inRepo $ - diffLog [Param "-R", Param "--", Param p] - top <- inRepo $ toTopFilePath $ toRawFilePath p + diffLog [Param "-R", Param "--", Param (fromOsPath p)] + top <- inRepo $ toTopFilePath p let diff' = filter (`isDiffOf` top) diff liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff') @@ -73,10 +73,10 @@ perform p = do forM_ removals $ \di -> do f <- mkrel di - liftIO $ removeWhenExistsWith R.removeLink f + liftIO $ removeWhenExistsWith removeFile f forM_ adds $ \di -> do - f <- fromRawFilePath <$> mkrel di + f <- fromOsPath <$> mkrel di inRepo $ Git.run [Param "checkout", Param "--", File f] next $ liftIO cleanup diff --git a/Command/Uninit.hs b/Command/Uninit.hs index d883467787..0c95774c14 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -73,7 +73,7 @@ checkCanUninit recordok = when (b == Just Annex.Branch.name) $ giveup $ "cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out" top <- fromRepo Git.repoPath - currdir <- liftIO R.getCurrentDirectory + currdir <- liftIO getCurrentDirectory whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" @@ -87,14 +87,14 @@ checkCanUninit recordok = {- git annex symlinks that are not checked into git could be left by an - interrupted add. -} -startCheckIncomplete :: Annex () -> RawFilePath -> Key -> CommandStart +startCheckIncomplete :: Annex () -> OsPath -> Key -> CommandStart startCheckIncomplete recordnotok file key = starting "uninit check" (mkActionItem (file, key)) (SeekInput []) $ do recordnotok giveup $ unlines err where err = - [ fromRawFilePath file ++ " points to annexed content, but is not checked into git." + [ fromOsPath file ++ " points to annexed content, but is not checked into git." , "Perhaps this was left behind by an interrupted git annex add?" , "Not continuing with uninit; either delete or git annex add the file and retry." ] @@ -109,11 +109,11 @@ removeAnnexDir recordok = do prepareRemoveAnnexDir annexdir if null leftovers then do - liftIO $ removeDirectoryRecursive (fromRawFilePath annexdir) + liftIO $ removeDirectoryRecursive annexdir next recordok else giveup $ unlines [ "Not fully uninitialized" - , "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir + , "Some annexed data is still left in " ++ fromOsPath annexobjectdir , "This may include deleted files, or old versions of modified files." , "" , "If you don't care about preserving the data, just delete the" @@ -134,12 +134,12 @@ removeAnnexDir recordok = do - - Also closes sqlite databases that might be in the directory, - to avoid later failure to write any cached changes to them. -} -prepareRemoveAnnexDir :: RawFilePath -> Annex () +prepareRemoveAnnexDir :: OsPath -> Annex () prepareRemoveAnnexDir annexdir = do Database.Keys.closeDb liftIO $ prepareRemoveAnnexDir' annexdir -prepareRemoveAnnexDir' :: RawFilePath -> IO () +prepareRemoveAnnexDir' :: OsPath -> IO () prepareRemoveAnnexDir' annexdir = emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir) >>= mapM_ (void . tryIO . allowWrite) @@ -159,7 +159,7 @@ removeUnannexed = go [] , go (k:c) ks ) enoughlinks f = catchBoolIO $ do - s <- R.getFileStatus f + s <- R.getFileStatus (fromOsPath f) return $ linkCount s > 1 completeUnitialize :: CommandStart diff --git a/Command/Unlock.hs b/Command/Unlock.hs index e0f7ccb29a..ac8520f0f4 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -40,7 +40,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps , usesLocationLog = False } -start :: SeekInput -> RawFilePath -> Key -> CommandStart +start :: SeekInput -> OsPath -> Key -> CommandStart start si file key = ifM (isJust <$> isAnnexLink file) ( starting "unlock" ai si $ perform file key , stop @@ -48,9 +48,9 @@ start si file key = ifM (isJust <$> isAnnexLink file) where ai = mkActionItem (key, AssociatedFile (Just file)) -perform :: RawFilePath -> Key -> CommandPerform +perform :: OsPath -> Key -> CommandPerform perform dest key = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest + destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath dest) destic <- replaceWorkTreeFile dest $ \tmp -> do ifM (inAnnex key) ( do @@ -64,7 +64,7 @@ perform dest key = do withTSDelta (liftIO . genInodeCache tmp) next $ cleanup dest destic key destmode -cleanup :: RawFilePath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup +cleanup :: OsPath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup cleanup dest destic key destmode = do stagePointerFile dest destmode =<< hashPointerFile key maybe noop (restagePointerFile (Restage True) dest) destic diff --git a/Command/Unused.hs b/Command/Unused.hs index 85913a5782..22edacdc35 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -119,7 +119,7 @@ check fileprefix msg a c = do maybeAddJSONField ((if null fileprefix then "unused" else fileprefix) ++ "-list") (M.fromList $ map (\(n, k) -> (T.pack (show n), serializeKey k)) unusedlist) - updateUnusedLog (toRawFilePath fileprefix) (M.fromList unusedlist) + updateUnusedLog (toOsPath fileprefix) (M.fromList unusedlist) return $ c + length l number :: Int -> [a] -> [(Int, a)] @@ -194,7 +194,7 @@ excludeReferenced refspec ks = runbloomfilter withKeysReferencedM ks {- Given an initial value, accumulates the value over each key - referenced by files in the working tree. -} -withKeysReferenced :: v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v +withKeysReferenced :: v -> (Key -> OsPath -> v -> Annex v) -> Annex v withKeysReferenced initial = withKeysReferenced' Nothing initial {- Runs an action on each referenced key in the working tree. -} @@ -204,10 +204,10 @@ withKeysReferencedM a = withKeysReferenced' Nothing () calla calla k _ _ = a k {- Folds an action over keys and files referenced in a particular directory. -} -withKeysFilesReferencedIn :: FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v +withKeysFilesReferencedIn :: OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v withKeysFilesReferencedIn = withKeysReferenced' . Just -withKeysReferenced' :: Maybe FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v +withKeysReferenced' :: Maybe OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v withKeysReferenced' mdir initial a = do (files, clean) <- getfiles r <- go initial files @@ -221,7 +221,7 @@ withKeysReferenced' mdir initial a = do top <- fromRepo Git.repoPath inRepo $ LsFiles.allFiles [] [top] ) - Just dir -> inRepo $ LsFiles.inRepo [] [toRawFilePath dir] + Just dir -> inRepo $ LsFiles.inRepo [] [dir] go v [] = return v go v (f:fs) = do mk <- lookupKey f @@ -308,9 +308,9 @@ data UnusedMaps = UnusedMaps withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CmdParams -> CommandSeek withUnusedMaps a params = do - unused <- readUnusedMap "" - unusedbad <- readUnusedMap "bad" - unusedtmp <- readUnusedMap "tmp" + unused <- readUnusedMap (literalOsPath "") + unusedbad <- readUnusedMap (literalOsPath "bad") + unusedtmp <- readUnusedMap (literalOsPath "tmp") let m = unused `M.union` unusedbad `M.union` unusedtmp let unusedmaps = UnusedMaps unused unusedbad unusedtmp commandActions $ map (a unusedmaps) $ concatMap (unusedSpec m) params diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 426177ec69..4679c598e5 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -34,7 +34,6 @@ import Types.NumCopies import Remote import Git.Types (fromConfigKey, fromConfigValue) import Utility.DataUnits -import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F cmd :: Command @@ -47,30 +46,35 @@ seek = withNothing (commandAction start) start :: CommandStart start = do f <- fromRepo gitAnnexTmpCfgFile - let f' = fromRawFilePath f createAnnexDirectory $ parentDir f cfg <- getCfg descs <- uuidDescriptions - liftIO $ writeFile f' $ genCfg cfg descs - vicfg cfg f' + liftIO $ writeFile (fromOsPath f) $ genCfg cfg descs + vicfg cfg f stop -vicfg :: Cfg -> FilePath -> Annex () +vicfg :: Cfg -> OsPath -> Annex () vicfg curcfg f = do vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR" - -- Allow EDITOR to be processed by the shell, so it can contain options. - unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ + unlessM (liftIO $ boolSystem "sh" (shparams vi)) $ giveup $ vi ++ " exited nonzero; aborting" r <- liftIO $ parseCfg (defCfg curcfg) . map decodeBS . fileLines' - <$> F.readFile' (toOsPath (toRawFilePath f)) - liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) + <$> F.readFile' f + liftIO $ removeWhenExistsWith removeFile f case r of Left s -> do - liftIO $ writeFile f s + liftIO $ writeFile (fromOsPath f) s vicfg curcfg f Right newcfg -> setCfg curcfg newcfg + where + -- Allow EDITOR to be processed by the shell, + -- so it can contain options. + shparams editor = + [ Param "-c" + , Param $ unwords [editor, shellEscape (fromOsPath f)] + ] data Cfg = Cfg { cfgTrustMap :: M.Map UUID (Down TrustLevel) diff --git a/Command/View.hs b/Command/View.hs index c510d3671b..9873d91b1d 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -24,8 +24,6 @@ import Logs.View import Types.AdjustedBranch import Annex.AdjustedBranch.Name -import qualified System.FilePath.ByteString as P - cmd :: Command cmd = notBareRepo $ command "view" SectionMetaData "enter a view branch" @@ -120,13 +118,12 @@ checkoutViewBranch view madj mkbranch = do forM_ l (removeemptydir top) liftIO $ void cleanup unlessM (liftIO $ doesDirectoryExist here) $ do - showLongNote $ UnquotedString $ cwdmissing (fromRawFilePath top) + showLongNote $ UnquotedString $ cwdmissing (fromOsPath top) return ok where removeemptydir top d = do p <- inRepo $ toTopFilePath d - liftIO $ tryIO $ removeDirectory $ - fromRawFilePath $ (top P. getTopFilePath p) + liftIO $ tryIO $ removeDirectory $ top getTopFilePath p cwdmissing top = unlines [ "This view does not include the subdirectory you are currently in." , "Perhaps you should: cd " ++ top diff --git a/Command/WhereUsed.hs b/Command/WhereUsed.hs index 2119c02a66..bfe49d1a73 100644 --- a/Command/WhereUsed.hs +++ b/Command/WhereUsed.hs @@ -124,7 +124,7 @@ findHistorical key = do display key (descBranchFilePath (BranchFilePath r tf)) return True -searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Annex Bool) -> Annex Bool +searchLog :: Key -> [CommandParam] -> (S.ByteString -> [OsPath] -> Annex Bool) -> Annex Bool searchLog key ps a = do (output, cleanup) <- Annex.inRepo $ Git.Command.pipeNullSplit ps' found <- case output of @@ -154,7 +154,7 @@ searchLog key ps a = do -- so a regexp is used. Since annex pointer files -- may contain a newline followed by perhaps something -- else, that is also matched. - , Param ("-G" ++ escapeRegexp (fromRawFilePath (keyFile key)) ++ "($|\n)") + , Param ("-G" ++ escapeRegexp (fromOsPath (keyFile key)) ++ "($|\n)") -- Skip commits where the file was deleted, -- only find those where it was added or modified. , Param "--diff-filter=ACMRTUX" diff --git a/Git/Types.hs b/Git/Types.hs index 0a0ff44d68..980d259a5e 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -107,6 +107,9 @@ instance FromConfigValue S.ByteString where instance FromConfigValue String where fromConfigValue = decodeBS . fromConfigValue +instance FromConfigValue OsPath where + fromConfigValue v = toOsPath (fromConfigValue v :: S.ByteString) + instance Show ConfigValue where show = fromConfigValue diff --git a/Test/Framework.hs b/Test/Framework.hs index 94354eb521..d063731ec1 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -66,6 +66,7 @@ import qualified Utility.Tmp.Dir import qualified Utility.Metered import qualified Utility.HumanTime import qualified Command.Uninit +import qualified Utility.OsString as OS -- Run a process. The output and stderr is captured, and is only -- displayed if the process does not return the expected value. @@ -123,13 +124,14 @@ git_annex'' expectedret expectedtranscript command params environ faildesc = do let params' = if debug then "--debug":params else params - testProcess pp (command:params') environ expectedret expectedtranscript faildesc + testProcess (fromOsPath pp) (command:params') environ + expectedret expectedtranscript faildesc {- Runs git-annex and returns its standard output. -} git_annex_output :: String -> [String] -> IO String git_annex_output command params = do pp <- Annex.Path.programPath - Utility.Process.readProcess pp (command:params) + Utility.Process.readProcess (fromOsPath pp) (command:params) git_annex_expectoutput :: String -> [String] -> [String] -> Assertion git_annex_expectoutput command params expected = do @@ -159,7 +161,7 @@ with_ssh_origin cloner a = cloner $ do let v = Git.Types.ConfigValue (toRawFilePath "/dev/null") origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) - let originurl = "localhost:" ++ fromRawFilePath origindir + let originurl = "localhost:" ++ fromOsPath origindir git "config" [config, originurl] "git config failed" a where @@ -170,7 +172,7 @@ intmpclonerepo a = withtmpclonerepo $ \r -> intopdir r a checkRepo :: Types.Annex a -> FilePath -> IO a checkRepo getval d = do - s <- Annex.new =<< Git.Construct.fromPath (toRawFilePath d) + s <- Annex.new =<< Git.Construct.fromPath (toOsPath d) Annex.eval s $ getval `finally` Annex.Action.stopCoProcesses @@ -218,7 +220,7 @@ inpath path a = do -- any type of error and change back to currdir before -- rethrowing. r <- bracket_ - (setCurrentDirectory path) + (setCurrentDirectory (toOsPath path)) (setCurrentDirectory currdir) (tryNonAsync a) case r of @@ -295,17 +297,18 @@ configrepo dir = intopdir dir $ do ensuredir :: FilePath -> IO () ensuredir d = do - e <- doesDirectoryExist d + let d' = toOsPath d + e <- doesDirectoryExist d' unless e $ - createDirectory d + createDirectory d' {- This is the only place in the test suite that can use setEnv. - Using it elsewhere can conflict with tasty's use of getEnv, which can - happen concurrently with a test case running, and would be a problem - since setEnv is not thread safe. This is run before tasty. -} setTestEnv :: IO a -> IO a -setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do - tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome) +setTestEnv a = Utility.Tmp.Dir.withTmpDir (literalOsPath "testhome") $ \tmphome -> do + tmphomeabs <- fromOsPath <$> absPath tmphome {- Prevent global git configs from affecting the test suite. -} Utility.Env.Set.setEnv "HOME" tmphomeabs True Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True @@ -313,9 +316,11 @@ setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do -- Ensure that the same git-annex binary that is running -- git-annex test is at the front of the PATH. - p <- Utility.Env.getEnvDefault "PATH" "" pp <- Annex.Path.programPath - Utility.Env.Set.setEnv "PATH" (takeDirectory pp ++ [searchPathSeparator] ++ p) True + p <- Utility.Env.getEnvDefault "PATH" "" + let p' = fromOsPath $ + takeDirectory pp <> OS.singleton searchPathSeparator <> toOsPath p + Utility.Env.Set.setEnv "PATH" p' True -- Avoid git complaining if it cannot determine the user's -- email address, or exploding if it doesn't know the user's name. @@ -332,34 +337,34 @@ setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do -- Record top directory. currdir <- getCurrentDirectory - Utility.Env.Set.setEnv "TOPDIR" currdir True + Utility.Env.Set.setEnv "TOPDIR" (fromOsPath currdir) True a removeDirectoryForCleanup :: FilePath -> IO () -removeDirectoryForCleanup = removePathForcibly +removeDirectoryForCleanup = removePathForcibly . toOsPath cleanup :: FilePath -> IO () -cleanup dir = whenM (doesDirectoryExist dir) $ do - Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath dir) +cleanup dir = whenM (doesDirectoryExist (toOsPath dir)) $ do + Command.Uninit.prepareRemoveAnnexDir' (toOsPath dir) -- This can fail if files in the directory are still open by a -- subprocess. void $ tryIO $ removeDirectoryForCleanup dir finalCleanup :: IO () -finalCleanup = whenM (doesDirectoryExist tmpdir) $ do - Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir) +finalCleanup = whenM (doesDirectoryExist (toOsPath tmpdir)) $ do + Command.Uninit.prepareRemoveAnnexDir' (toOsPath tmpdir) catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do print e putStrLn "sleeping 10 seconds and will retry directory cleanup" Utility.ThreadScheduler.threadDelaySeconds $ Utility.ThreadScheduler.Seconds 10 - whenM (doesDirectoryExist tmpdir) $ + whenM (doesDirectoryExist (toOsPath tmpdir)) $ removeDirectoryForCleanup tmpdir checklink :: FilePath -> Assertion checklink f = ifM (annexeval Config.crippledFileSystem) - ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f))) + ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toOsPath f))) @? f ++ " is not a (crippled) symlink" , do s <- R.getSymbolicLinkStatus (toRawFilePath f) @@ -417,7 +422,7 @@ checkdangling f = ifM (annexeval Config.crippledFileSystem) checklocationlog :: FilePath -> Bool -> Assertion checklocationlog f expected = do thisuuid <- annexeval Annex.UUID.getUUID - r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f) + r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f) case r of Just k -> do uuids <- annexeval $ Remote.keyLocations k @@ -428,11 +433,11 @@ checklocationlog f expected = do checkbackend :: FilePath -> Types.Backend -> Assertion checkbackend file expected = do b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) - =<< Annex.WorkTree.lookupKey (toRawFilePath file) + =<< Annex.WorkTree.lookupKey (toOsPath file) assertEqual ("backend for " ++ file) (Just expected) b checkispointerfile :: FilePath -> Assertion -checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toRawFilePath f)) $ +checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toOsPath f)) $ assertFailure $ f ++ " is not a pointer file" inlocationlog :: FilePath -> Assertion @@ -501,7 +506,7 @@ unannexed = runchecks [checkregularfile, checkcontent, checkwritable] unannexed_in_git :: FilePath -> Assertion unannexed_in_git f = do unannexed f - r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f) + r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f) case r of Just _k -> assertFailure $ f ++ " is annexed in git" Nothing -> return () @@ -585,10 +590,10 @@ newmainrepodir = go (0 :: Int) where go n = do let d = "main" ++ show n - ifM (doesDirectoryExist d) + ifM (doesDirectoryExist (toOsPath d)) ( go $ n + 1 , do - createDirectory d + createDirectory (toOsPath d) return d ) @@ -597,7 +602,7 @@ tmprepodir = go (0 :: Int) where go n = do let d = "tmprepo" ++ show n - ifM (doesDirectoryExist d) + ifM (doesDirectoryExist (toOsPath d)) ( go $ n + 1 , return d ) @@ -637,9 +642,9 @@ writecontent :: FilePath -> String -> IO () writecontent f c = go (10000000 :: Integer) where go ticsleft = do - oldmtime <- catchMaybeIO $ getModificationTime f + oldmtime <- catchMaybeIO $ getModificationTime (toOsPath f) writeFile f c - newmtime <- getModificationTime f + newmtime <- getModificationTime (toOsPath f) if Just newmtime == oldmtime then do threadDelay 100000 @@ -679,8 +684,8 @@ getKey b f = case Types.Backend.genKey b of Nothing -> error "internal" where ks = Types.KeySource.KeySource - { Types.KeySource.keyFilename = toRawFilePath f - , Types.KeySource.contentLocation = toRawFilePath f + { Types.KeySource.keyFilename = toOsPath f + , Types.KeySource.contentLocation = toOsPath f , Types.KeySource.inodeCache = Nothing } @@ -799,7 +804,7 @@ parallelTestRunner' numjobs opts mkts go Nothing = summarizeresults $ withConcurrentOutput $ do ensuredir tmpdir crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' - (toRawFilePath tmpdir) + (toOsPath tmpdir) Nothing Nothing False adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported let ts = mkts numparts crippledfilesystem adjustedbranchok opts @@ -809,13 +814,13 @@ parallelTestRunner' numjobs opts mkts mapM_ (hPutStrLn stderr) warnings environ <- Utility.Env.getEnvironment args <- getArgs - pp <- Annex.Path.programPath + pp <- fromOsPath <$> Annex.Path.programPath termcolor <- hSupportsANSIColor stdout let ps = if useColor (lookupOption tastyopts) termcolor then "--color=always":args else "--color=never":args let runone n = do - let subdir = tmpdir show n + let subdir = fromOsPath $ toOsPath tmpdir toOsPath (show n) ensuredir subdir let p = (proc pp ps) { env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ) diff --git a/Upgrade/V9.hs b/Upgrade/V9.hs index 32af018f36..52f94092b4 100644 --- a/Upgrade/V9.hs +++ b/Upgrade/V9.hs @@ -55,7 +55,7 @@ upgrade automatic - run for an entire year and so predate the v9 upgrade. -} assistantrunning = do pidfile <- fromRepo gitAnnexPidFile - isJust <$> liftIO (checkDaemon (fromOsPath pidfile)) + isJust <$> liftIO (checkDaemon pidfile) unsafeupgrade = [ "Not upgrading from v9 to v10, because there may be git-annex" diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index 38f8d09aee..8fd142da36 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -5,6 +5,7 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Utility.Daemon ( @@ -25,6 +26,7 @@ import Utility.OpenFd #else import System.Win32.Process (terminateProcessById) import Utility.LockFile +import qualified Utility.OsString as OS #endif #ifndef mingw32_HOST_OS @@ -42,7 +44,7 @@ import System.Posix hiding (getEnv, getEnvironment) - Instead, it runs the cmd with provided params, in the background, - which the caller should arrange to run this again. -} -daemonize :: String -> [CommandParam] -> IO Fd -> Maybe FilePath -> Bool -> IO () -> IO () +daemonize :: String -> [CommandParam] -> IO Fd -> Maybe OsPath -> Bool -> IO () -> IO () daemonize cmd params openlogfd pidfile changedirectory a = do maybe noop checkalreadyrunning pidfile getEnv envvar >>= \case @@ -70,10 +72,10 @@ daemonize cmd params openlogfd pidfile changedirectory a = do {- To run an action that is normally daemonized in the foreground. -} #ifndef mingw32_HOST_OS -foreground :: IO Fd -> Maybe FilePath -> IO () -> IO () +foreground :: IO Fd -> Maybe OsPath -> IO () -> IO () foreground openlogfd pidfile a = do #else -foreground :: Maybe FilePath -> IO () -> IO () +foreground :: Maybe OsPath -> IO () -> IO () foreground pidfile a = do #endif maybe noop lockPidFile pidfile @@ -93,12 +95,12 @@ foreground pidfile a = do - - Writes the pid to the file, fully atomically. - Fails if the pid file is already locked by another process. -} -lockPidFile :: FilePath -> IO () +lockPidFile :: OsPath -> IO () lockPidFile pidfile = do #ifndef mingw32_HOST_OS - fd <- openFdWithMode (toRawFilePath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags + fd <- openFdWithMode (fromOsPath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) - fd' <- openFdWithMode (toRawFilePath newfile) ReadWrite (Just stdFileMode) defaultFileFlags + fd' <- openFdWithMode (fromOsPath newfile) ReadWrite (Just stdFileMode) defaultFileFlags { trunc = True } locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0) case (locked, locked') of @@ -107,17 +109,17 @@ lockPidFile pidfile = do _ -> do _ <- fdWrite fd' =<< show <$> getPID closeFd fd - rename newfile pidfile + renameFile newfile pidfile where - newfile = pidfile ++ ".new" + newfile = pidfile <> literalOsPath ".new" #else {- Not atomic on Windows, oh well. -} unlessM (isNothing <$> checkDaemon pidfile) alreadyRunning pid <- getPID - writeFile pidfile (show pid) + writeFile (fromOsPath pidfile) (show pid) lckfile <- winLockFile pid pidfile - writeFile (fromRawFilePath lckfile) "" + writeFile (fromOsPath lckfile) "" void $ lockExclusive lckfile #endif @@ -128,17 +130,17 @@ alreadyRunning = giveup "Daemon is already running." - is locked by the same process that is listed in the pid file. - - If it's running, returns its pid. -} -checkDaemon :: FilePath -> IO (Maybe PID) +checkDaemon :: OsPath -> IO (Maybe PID) #ifndef mingw32_HOST_OS checkDaemon pidfile = bracket setup cleanup go where setup = catchMaybeIO $ - openFdWithMode (toRawFilePath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags + openFdWithMode (fromOsPath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags cleanup (Just fd) = closeFd fd cleanup Nothing = return () go (Just fd) = catchDefaultIO Nothing $ do locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) - p <- readish <$> readFile pidfile + p <- readish <$> readFile (fromOsPath pidfile) return (check locked p) go Nothing = return Nothing @@ -147,16 +149,16 @@ checkDaemon pidfile = bracket setup cleanup go check (Just (pid, _)) (Just pid') | pid == pid' = Just pid | otherwise = giveup $ - "stale pid in " ++ pidfile ++ + "stale pid in " ++ fromOsPath pidfile ++ " (got " ++ show pid' ++ "; expected " ++ show pid ++ " )" #else checkDaemon pidfile = maybe (return Nothing) (check . readish) - =<< catchMaybeIO (readFile pidfile) + =<< catchMaybeIO (readFile (fromOsPath pidfile)) where check Nothing = return Nothing check (Just pid) = do - v <- lockShared =<< winLockFile pid pidfile + v <- lockShared =<< winLockFile pid (fromOsPath pidfile) case v of Just h -> do dropLock h @@ -165,7 +167,7 @@ checkDaemon pidfile = maybe (return Nothing) (check . readish) #endif {- Stops the daemon, safely. -} -stopDaemon :: FilePath -> IO () +stopDaemon :: OsPath -> IO () stopDaemon pidfile = go =<< checkDaemon pidfile where go Nothing = noop @@ -181,14 +183,14 @@ stopDaemon pidfile = go =<< checkDaemon pidfile - when eg, restarting the daemon. -} #ifdef mingw32_HOST_OS -winLockFile :: PID -> FilePath -> IO RawFilePath +winLockFile :: PID -> OsPath -> IO OsPath winLockFile pid pidfile = do cleanstale - return $ toRawFilePath $ prefix ++ show pid ++ suffix + return $ prefix <> toOsPath (show pid) <> suffix where - prefix = pidfile ++ "." - suffix = ".lck" + prefix = pidfile <> literalOsPath "." + suffix = literalOsPath ".lck" cleanstale = mapM_ (void . tryIO . removeFile) =<< - (filter iswinlockfile . map fromRawFilePath <$> dirContents (parentDir (toRawFilePath pidfile))) - iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f + (filter iswinlockfile <$> dirContents (parentDir pidfile)) + iswinlockfile f = suffix `OS.isSuffixOf` f && prefix `OS.isPrefixOf` f #endif