more OsPath conversion (542/749)
Sponsored-by: Luke T. Shumaker
This commit is contained in:
Joey Hess
parent
0d2b805806
commit
0811531b59
13 changed files with 127 additions and 116 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue