mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

more OsPath conversion (658/749)

Browse source 
At this point the test suite builds, and mostly the assistant is left.

Sponsored-by: unqueued
This commit is contained in:
Joey Hess 2025-02-08 15:17:33 -04:00
parent 5eef09a3cc
commit 2d224e0d28
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
7 changed files with 163 additions and 138 deletions
Download patch file Download diff file Expand all files Collapse all files

4
Annex/Init.hs
View file

@ -111,8 +111,8 @@ genDescription Nothing = do
let at = if null hostname then "" else "@" let at = if null hostname then "" else "@"
v <- liftIO myUserName v <- liftIO myUserName
return $ UUIDDesc $ encodeBS $ concat $ case v of return $ UUIDDesc $ encodeBS $ concat $ case v of
Right username -> [username, at, hostname, ":", reldir] Right username -> [username, at, hostname, ":", fromOsPath reldir]
Left _ -> [hostname, ":", reldir] Left _ -> [hostname, ":", fromOsPath reldir]
initialize :: Annex () -> Maybe String -> Maybe RepoVersion -> Annex () initialize :: Annex () -> Maybe String -> Maybe RepoVersion -> Annex ()
initialize startupannex mdescription mversion = checkInitializeAllowed $ \initallowed -> do initialize startupannex mdescription mversion = checkInitializeAllowed $ \initallowed -> do

47
Annex/Sim.hs
View file

@ -55,8 +55,6 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.UUID as U import qualified Data.UUID as U
import qualified Data.UUID.V5 as U5 import qualified Data.UUID.V5 as U5
import qualified Utility.RawFilePath as R
import qualified System.FilePath.ByteString as P
data SimState t = SimState data SimState t = SimState
{ simRepos :: M.Map RepoName UUID { simRepos :: M.Map RepoName UUID
@ -342,7 +340,7 @@ applySimCommand c@(CommandVisit repo cmdparams) st _ =
_ -> return ("sh", ["-c", unwords cmdparams]) _ -> return ("sh", ["-c", unwords cmdparams])
exitcode <- liftIO $ exitcode <- liftIO $
safeSystem' cmd (map Param params) safeSystem' cmd (map Param params)
(\p -> p { cwd = Just dir }) (\p -> p { cwd = Just (fromOsPath dir) })
when (null cmdparams) $ when (null cmdparams) $
showLongNote "Finished visit to simulated repository." showLongNote "Finished visit to simulated repository."
if null cmdparams if null cmdparams
@ -431,7 +429,7 @@ applySimCommand' (CommandAddTree repo expr) st _ =
<$> inRepo (toTopFilePath f) <$> inRepo (toTopFilePath f)
ifM (checkMatcher matcher (Just k) afile NoLiveUpdate mempty (pure False) (pure False)) ifM (checkMatcher matcher (Just k) afile NoLiveUpdate mempty (pure False) (pure False))
( let st'' = setPresentKey True (u, repo) k u $ st' ( 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 in go matcher u st'' fs
, go matcher u st' fs , go matcher u st' fs
@ -758,7 +756,7 @@ overFilesRemote r u remote remotepred localpred checkwant handlewanted st =
Right (Left (st, map (go remoteu) $ M.toList $ simFiles st)) Right (Left (st, map (go remoteu) $ M.toList $ simFiles st))
where where
go remoteu (f, k) st' = go remoteu (f, k) st' =
let af = AssociatedFile $ Just f let af = AssociatedFile $ Just $ toOsPath f
in liftIO $ runSimRepo u st' $ \st'' rst -> in liftIO $ runSimRepo u st' $ \st'' rst ->
case M.lookup remoteu (simRepoState st'') of case M.lookup remoteu (simRepoState st'') of
Nothing -> return (st'', False) Nothing -> return (st'', False)
@ -814,7 +812,7 @@ simulateDropUnwanted st u dropfromname dropfrom =
Right $ Left (st, map go $ M.toList $ simFiles st) Right $ Left (st, map go $ M.toList $ simFiles st)
where where
go (f, k) st' = liftIO $ runSimRepo u st' $ \st'' rst -> 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 in if present dropfrom rst k
then updateLiveSizeChanges rst $ then updateLiveSizeChanges rst $
ifM (wantDrop NoLiveUpdate False (Just dropfrom) (Just k) af Nothing) ifM (wantDrop NoLiveUpdate False (Just dropfrom) (Just k) af Nothing)
@ -1104,7 +1102,7 @@ initNewSimRepos = \st -> go st (M.toList $ simRepoState st)
go st ((u, rst):rest) = go st ((u, rst):rest) =
case simRepo rst of case simRepo rst of
Nothing -> do Nothing -> do
let d = simRepoDirectory st u let d = fromOsPath $ simRepoDirectory st u
sr <- initSimRepo (simRepoName rst) u d st sr <- initSimRepo (simRepoName rst) u d st
let rst' = rst { simRepo = Just sr } let rst' = rst { simRepo = Just sr }
let st' = st let st' = st
@ -1114,8 +1112,8 @@ initNewSimRepos = \st -> go st (M.toList $ simRepoState st)
go st' rest go st' rest
_ -> go st rest _ -> go st rest
simRepoDirectory :: SimState t -> UUID -> FilePath simRepoDirectory :: SimState t -> UUID -> OsPath
simRepoDirectory st u = simRootDirectory st </> fromUUID u simRepoDirectory st u = toOsPath (simRootDirectory st) </> fromUUID u
initSimRepo :: RepoName -> UUID -> FilePath -> SimState SimRepo -> IO SimRepo initSimRepo :: RepoName -> UUID -> FilePath -> SimState SimRepo -> IO SimRepo
initSimRepo simreponame u dest st = do initSimRepo simreponame u dest st = do
@ -1126,7 +1124,7 @@ initSimRepo simreponame u dest st = do
] ]
unless inited $ unless inited $
giveup "git init failed" giveup "git init failed"
simrepo <- Git.Construct.fromPath (toRawFilePath dest) simrepo <- Git.Construct.fromPath (toOsPath dest)
ast <- Annex.new simrepo ast <- Annex.new simrepo
((), ast') <- Annex.run ast $ doQuietAction $ do ((), ast') <- Annex.run ast $ doQuietAction $ do
storeUUID u storeUUID u
@ -1301,15 +1299,14 @@ updateSimRepoState newst sr = do
setdesc r u = describeUUID u $ toUUIDDesc $ setdesc r u = describeUUID u $ toUUIDDesc $
simulatedRepositoryDescription r simulatedRepositoryDescription r
stageannexedfile f k = do stageannexedfile f k = do
let f' = annexedfilepath f let f' = annexedfilepath (toOsPath f)
l <- calcRepo $ gitAnnexLink f' k l <- calcRepo $ gitAnnexLink f' k
liftIO $ createDirectoryIfMissing True $ liftIO $ createDirectoryIfMissing True $ takeDirectory f'
takeDirectory $ fromRawFilePath f' addAnnexLink (fromOsPath l) f'
addAnnexLink l f' unstageannexedfile f =
unstageannexedfile f = do liftIO $ removeWhenExistsWith removeFile $
liftIO $ removeWhenExistsWith R.removeLink $ annexedfilepath (toOsPath f)
annexedfilepath f annexedfilepath f = repoPath (simRepoGitRepo sr) </> f
annexedfilepath f = repoPath (simRepoGitRepo sr) P.</> f
getlocations = maybe mempty simLocations getlocations = maybe mempty simLocations
. M.lookup (simRepoUUID sr) . M.lookup (simRepoUUID sr)
. simRepoState . simRepoState
@ -1359,19 +1356,21 @@ suspendSim st = do
let st'' = st' let st'' = st'
{ simRepoState = M.map freeze (simRepoState 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 where
freeze :: SimRepoState SimRepo -> SimRepoState () freeze :: SimRepoState SimRepo -> SimRepoState ()
freeze rst = rst { simRepo = Nothing } freeze rst = rst { simRepo = Nothing }
restoreSim :: RawFilePath -> IO (Either String (SimState SimRepo)) restoreSim :: OsPath -> IO (Either String (SimState SimRepo))
restoreSim rootdir = restoreSim rootdir =
tryIO (readFile (fromRawFilePath rootdir </> "state")) >>= \case tryIO (readFile statefile) >>= \case
Left err -> return (Left (show err)) Left err -> return (Left (show err))
Right c -> case readMaybe c :: Maybe (SimState ()) of Right c -> case readMaybe c :: Maybe (SimState ()) of
Nothing -> return (Left "unable to parse sim state file") Nothing -> return (Left "unable to parse sim state file")
Just st -> do Just st -> do
let st' = st { simRootDirectory = fromRawFilePath rootdir } let st' = st { simRootDirectory = fromOsPath rootdir }
repostate <- M.fromList repostate <- M.fromList
<$> mapM (thaw st') (M.toList (simRepoState st)) <$> mapM (thaw st') (M.toList (simRepoState st))
let st'' = st' let st'' = st'
@ -1380,12 +1379,12 @@ restoreSim rootdir =
} }
return (Right st'') return (Right st'')
where where
statefile = fromOsPath $ rootdir </> literalOsPath "state"
thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case
Left _ -> (u, rst { simRepo = Nothing }) Left _ -> (u, rst { simRepo = Nothing })
Right r -> (u, rst { simRepo = Just r }) Right r -> (u, rst { simRepo = Just r })
thaw' st u = do thaw' st u = do
simrepo <- Git.Construct.fromPath $ toRawFilePath $ simrepo <- Git.Construct.fromPath $ simRepoDirectory st u
simRepoDirectory st u
ast <- Annex.new simrepo ast <- Annex.new simrepo
return $ SimRepo return $ SimRepo
{ simRepoGitRepo = simrepo { simRepoGitRepo = simrepo

2
CmdLine/GitAnnexShell.hs
View file

@ -136,7 +136,7 @@ builtin cmd dir params = do
"Restricted login shell for git-annex only SSH access" "Restricted login shell for git-annex only SSH access"
where where
mkrepo = do mkrepo = do
r <- Git.Construct.repoAbsPath (toRawFilePath dir) r <- Git.Construct.repoAbsPath (toOsPath dir)
>>= Git.Construct.fromAbsPath >>= Git.Construct.fromAbsPath
let r' = r { repoPathSpecifiedExplicitly = True } let r' = r { repoPathSpecifiedExplicitly = True }
Git.Config.read r' Git.Config.read r'

20
CmdLine/GitAnnexShell/Checks.hs
View file

@ -48,9 +48,9 @@ checkDirectory mdir = do
v <- getEnv "GIT_ANNEX_SHELL_DIRECTORY" v <- getEnv "GIT_ANNEX_SHELL_DIRECTORY"
case (v, mdir) of case (v, mdir) of
(Nothing, _) -> noop (Nothing, _) -> noop
(Just d, Nothing) -> req d Nothing (Just d, Nothing) -> req (toOsPath d) Nothing
(Just d, Just dir) (Just d, Just dir)
| d `equalFilePath` dir -> noop | toOsPath d `equalFilePath` toOsPath dir -> noop
| otherwise -> do | otherwise -> do
home <- myHomeDir home <- myHomeDir
d' <- canondir home d d' <- canondir home d
@ -61,19 +61,21 @@ checkDirectory mdir = do
where where
req d mdir' = giveup $ unwords req d mdir' = giveup $ unwords
[ "Only allowed to access" [ "Only allowed to access"
, d , fromOsPath d
, maybe "and could not determine directory from command line" ("not " ++) mdir' , maybe "and could not determine directory from command line"
(("not " ++) . fromOsPath)
mdir'
] ]
{- A directory may start with ~/ or in some cases, even /~/, {- A directory may start with ~/ or in some cases, even /~/,
- or could just be relative to home, or of course could - or could just be relative to home, or of course could
- be absolute. -} - be absolute. -}
canondir home d canondir home d
| "~/" `isPrefixOf` d = return d | "~/" `isPrefixOf` d = return $ toOsPath d
| "/~/" `isPrefixOf` d = return $ drop 1 d | "/~/" `isPrefixOf` d = return $ toOsPath $ drop 1 d
| otherwise = relHome $ fromRawFilePath $ absPathFrom | otherwise = relHome $ absPathFrom
(toRawFilePath home) (toOsPath home)
(toRawFilePath d) (toOsPath d)
{- Modifies a Command to check that it is run in either a git-annex {- Modifies a Command to check that it is run in either a git-annex
- repository, or a repository with a gcrypt-id set. -} - repository, or a repository with a gcrypt-id set. -}

8
Command/Sim.hs
View file

@ -61,13 +61,13 @@ startsim simfile = startsim' simfile >>= cleanup
startsim' :: Maybe FilePath -> Annex (SimState SimRepo) startsim' :: Maybe FilePath -> Annex (SimState SimRepo)
startsim' simfile = do startsim' simfile = do
simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir simdir <- fromRepo gitAnnexSimDir
whenM (liftIO $ doesDirectoryExist simdir) $ whenM (liftIO $ doesDirectoryExist simdir) $
giveup "A sim was previously started. Use `git-annex sim end` to stop it before starting a new one." giveup "A sim was previously started. Use `git-annex sim end` to stop it before starting a new one."
showLongNote $ UnquotedString "Sim started." showLongNote $ UnquotedString "Sim started."
rng <- liftIO $ fst . random <$> getStdGen rng <- liftIO $ fst . random <$> getStdGen
let st = emptySimState rng simdir let st = emptySimState rng (fromOsPath simdir)
case simfile of case simfile of
Nothing -> startup simdir st [] Nothing -> startup simdir st []
Just f -> liftIO (readFile f) >>= \c -> Just f -> liftIO (readFile f) >>= \c ->
@ -77,7 +77,7 @@ startsim' simfile = do
where where
startup simdir st cs = do startup simdir st cs = do
repobyname <- mkGetExistingRepoByName repobyname <- mkGetExistingRepoByName
createAnnexDirectory (toRawFilePath simdir) createAnnexDirectory simdir
let st' = recordSeed st cs let st' = recordSeed st cs
go st' repobyname cs go st' repobyname cs
@ -88,7 +88,7 @@ startsim' simfile = do
endsim :: CommandSeek endsim :: CommandSeek
endsim = do endsim = do
simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir simdir <- fromRepo gitAnnexSimDir
whenM (liftIO $ doesDirectoryExist simdir) $ do whenM (liftIO $ doesDirectoryExist simdir) $ do
liftIO $ removeDirectoryRecursive simdir liftIO $ removeDirectoryRecursive simdir
showLongNote $ UnquotedString "Sim ended." showLongNote $ UnquotedString "Sim ended."

214
Test.hs
View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Test where module Test where
@ -87,6 +88,7 @@ import qualified Utility.Aeson
import qualified Utility.CopyFile import qualified Utility.CopyFile
import qualified Utility.MoveFile import qualified Utility.MoveFile
import qualified Utility.StatelessOpenPGP import qualified Utility.StatelessOpenPGP
import qualified Utility.OsString as OS
import qualified Types.Remote import qualified Types.Remote
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import qualified Remote.Helper.Encryptable import qualified Remote.Helper.Encryptable
@ -216,7 +218,7 @@ testGitRemote = testRemote False "git" $ \remotename -> do
testDirectoryRemote :: TestTree testDirectoryRemote :: TestTree
testDirectoryRemote = testRemote True "directory" $ \remotename -> do testDirectoryRemote = testRemote True "directory" $ \remotename -> do
createDirectory "remotedir" createDirectory (literalOsPath "remotedir")
git_annex "initremote" git_annex "initremote"
[ remotename [ remotename
, "type=directory" , "type=directory"
@ -437,7 +439,7 @@ test_git_remote_annex exporttree
runtest cfg populate = whenM Git.Bundle.versionSupported $ runtest cfg populate = whenM Git.Bundle.versionSupported $
intmpclonerepo $ do intmpclonerepo $ do
let cfg' = ["type=directory", "encryption=none", "directory=dir"] ++ cfg let cfg' = ["type=directory", "encryption=none", "directory=dir"] ++ cfg
createDirectory "dir" createDirectory (literalOsPath "dir")
git_annex "initremote" ("foo":("uuid=" ++ diruuid):cfg') "initremote" git_annex "initremote" ("foo":("uuid=" ++ diruuid):cfg') "initremote"
git_annex "get" [] "get failed" git_annex "get" [] "get failed"
() <- populate () <- populate
@ -461,14 +463,14 @@ test_add_moved :: Assertion
test_add_moved = intmpclonerepo $ do test_add_moved = intmpclonerepo $ do
git_annex "get" [annexedfile] "get failed" git_annex "get" [annexedfile] "get failed"
annexed_present annexedfile annexed_present annexedfile
createDirectory subdir createDirectory (toOsPath subdir)
Utility.MoveFile.moveFile (toRawFilePath annexedfile) (toRawFilePath subfile) Utility.MoveFile.moveFile (toOsPath annexedfile) subfile
git_annex "add" [subdir] "add of moved annexed file" git_annex "add" [subdir] "add of moved annexed file"
git "mv" [sha1annexedfile, sha1annexedfile ++ ".renamed"] "git mv" git "mv" [sha1annexedfile, sha1annexedfile ++ ".renamed"] "git mv"
git_annex "add" [] "add does not fail on deleted file after move" git_annex "add" [] "add does not fail on deleted file after move"
where where
subdir = "subdir" subdir = "subdir"
subfile = subdir </> "file" subfile = toOsPath subdir </> literalOsPath "file"
test_readonly_remote :: Assertion test_readonly_remote :: Assertion
test_readonly_remote = test_readonly_remote =
@ -494,7 +496,7 @@ test_ignore_deleted_files :: Assertion
test_ignore_deleted_files = intmpclonerepo $ do test_ignore_deleted_files = intmpclonerepo $ do
git_annex "get" [annexedfile] "get" git_annex "get" [annexedfile] "get"
git_annex_expectoutput "find" [] [annexedfile] 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, -- A file that has been deleted, but the deletion not staged,
-- is a special case; make sure git-annex skips these. -- is a special case; make sure git-annex skips these.
git_annex_expectoutput "find" [] [] git_annex_expectoutput "find" [] []
@ -563,18 +565,18 @@ test_magic = intmpclonerepo $ do
#endif #endif
test_import :: Assertion test_import :: Assertion
test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "importtest")) $ \importdir -> do test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (literalOsPath "importtest") $ \importdir -> do
(toimport1, importf1, imported1) <- mktoimport importdir "import1" (toimport1, importf1, imported1) <- mktoimport importdir (literalOsPath "import1")
git_annex "import" [toimport1] "import" git_annex "import" [toimport1] "import"
annexed_present_imported imported1 annexed_present_imported imported1
checkdoesnotexist importf1 checkdoesnotexist importf1
(toimport2, importf2, imported2) <- mktoimport importdir "import2" (toimport2, importf2, imported2) <- mktoimport importdir (literalOsPath "import2")
git_annex "import" [toimport2] "import of duplicate" git_annex "import" [toimport2] "import of duplicate"
annexed_present_imported imported2 annexed_present_imported imported2
checkdoesnotexist importf2 checkdoesnotexist importf2
(toimport3, importf3, imported3) <- mktoimport importdir "import3" (toimport3, importf3, imported3) <- mktoimport importdir (literalOsPath "import3")
git_annex "import" ["--skip-duplicates", toimport3] git_annex "import" ["--skip-duplicates", toimport3]
"import of duplicate with --skip-duplicates" "import of duplicate with --skip-duplicates"
checkdoesnotexist imported3 checkdoesnotexist imported3
@ -584,19 +586,19 @@ test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePa
checkdoesnotexist imported3 checkdoesnotexist imported3
checkdoesnotexist importf3 checkdoesnotexist importf3
(toimport4, importf4, imported4) <- mktoimport importdir "import4" (toimport4, importf4, imported4) <- mktoimport importdir (literalOsPath "import4")
git_annex "import" ["--deduplicate", toimport4] "import --deduplicate" git_annex "import" ["--deduplicate", toimport4] "import --deduplicate"
checkdoesnotexist imported4 checkdoesnotexist imported4
checkdoesnotexist importf4 checkdoesnotexist importf4
(toimport5, importf5, imported5) <- mktoimport importdir "import5" (toimport5, importf5, imported5) <- mktoimport importdir (literalOsPath "import5")
git_annex "import" ["--duplicate", toimport5] "import --duplicate" git_annex "import" ["--duplicate", toimport5] "import --duplicate"
annexed_present_imported imported5 annexed_present_imported imported5
checkexists importf5 checkexists importf5
git_annex "drop" ["--force", imported1, imported2, imported5] "drop" git_annex "drop" ["--force", imported1, imported2, imported5] "drop"
annexed_notpresent_imported imported2 annexed_notpresent_imported imported2
(toimportdup, importfdup, importeddup) <- mktoimport importdir "importdup" (toimportdup, importfdup, importeddup) <- mktoimport importdir (literalOsPath "importdup")
git_annex_shouldfail "import" ["--clean-duplicates", toimportdup] git_annex_shouldfail "import" ["--clean-duplicates", toimportdup]
"import of missing duplicate with --clean-duplicates not allowed" "import of missing duplicate with --clean-duplicates not allowed"
checkdoesnotexist importeddup checkdoesnotexist importeddup
@ -604,9 +606,14 @@ test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePa
where where
mktoimport importdir subdir = do mktoimport importdir subdir = do
createDirectory (importdir </> subdir) createDirectory (importdir </> subdir)
let importf = subdir </> "f" let importf = subdir </> literalOsPath "f"
writecontent (importdir </> importf) (content importf) writecontent (fromOsPath (importdir </> importf))
return (importdir </> subdir, importdir </> importf, importf) (content (fromOsPath importf))
return
( fromOsPath (importdir </> subdir)
, fromOsPath (importdir </> importf)
, fromOsPath importf
)
test_reinject :: Assertion test_reinject :: Assertion
test_reinject = intmpclonerepo $ do test_reinject = intmpclonerepo $ do
@ -880,10 +887,10 @@ test_lock_force = intmpclonerepo $ do
git_annex "get" [annexedfile] "get of file" git_annex "get" [annexedfile] "get of file"
git_annex "unlock" [annexedfile] "unlock" git_annex "unlock" [annexedfile] "unlock"
annexeval $ do annexeval $ do
Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile)
Database.Keys.removeInodeCaches k Database.Keys.removeInodeCaches k
Database.Keys.closeDb Database.Keys.closeDb
liftIO . removeWhenExistsWith R.removeLink liftIO . removeWhenExistsWith removeFile
=<< Annex.calcRepo' Annex.Locations.gitAnnexKeysDbIndexCache =<< Annex.calcRepo' Annex.Locations.gitAnnexKeysDbIndexCache
writecontent annexedfile "test_lock_force content" writecontent annexedfile "test_lock_force content"
git_annex_shouldfail "lock" [annexedfile] "lock of modified file should not be allowed" git_annex_shouldfail "lock" [annexedfile] "lock of modified file should not be allowed"
@ -930,7 +937,7 @@ test_fix = intmpclonerepo $ unlessM (hasUnlockedFiles <$> getTestMode) $ do
annexed_present annexedfile annexed_present annexedfile
git_annex "fix" [annexedfile] "fix of present file" git_annex "fix" [annexedfile] "fix of present file"
annexed_present annexedfile annexed_present annexedfile
createDirectory subdir createDirectory (toOsPath subdir)
git "mv" [annexedfile, subdir] "git mv" git "mv" [annexedfile, subdir] "git mv"
git_annex "fix" [newfile] "fix of moved file" git_annex "fix" [newfile] "fix of moved file"
runchecks [checklink, checkunwritable] newfile runchecks [checklink, checkunwritable] newfile
@ -978,7 +985,7 @@ test_fsck_basic = intmpclonerepo $ do
where where
corrupt f = do corrupt f = do
git_annex "get" [f] "get of file" git_annex "get" [f] "get of file"
Utility.FileMode.allowWrite (toRawFilePath f) Utility.FileMode.allowWrite (toOsPath f)
writecontent f (changedcontent f) writecontent f (changedcontent f)
ifM (hasUnlockedFiles <$> getTestMode) ifM (hasUnlockedFiles <$> getTestMode)
( git_annex "fsck" []"fsck on unlocked file with changed file content" ( git_annex "fsck" []"fsck on unlocked file with changed file content"
@ -1119,10 +1126,12 @@ test_unused = intmpclonerepo $ do
writecontent "unusedfile" "unusedcontent" writecontent "unusedfile" "unusedcontent"
git_annex "add" ["unusedfile"] "add of unusedfile" git_annex "add" ["unusedfile"] "add of unusedfile"
unusedfilekey <- getKey backendSHA256E "unusedfile" unusedfilekey <- getKey backendSHA256E "unusedfile"
renameFile "unusedfile" "unusedunstagedfile" renameFile
(literalOsPath "unusedfile")
(literalOsPath "unusedunstagedfile")
git "rm" ["-qf", "unusedfile"] "git rm" git "rm" ["-qf", "unusedfile"] "git rm"
checkunused [] "with unstaged link" checkunused [] "with unstaged link"
removeFile "unusedunstagedfile" removeFile (literalOsPath "unusedunstagedfile")
checkunused [unusedfilekey] "with renamed link deleted" checkunused [unusedfilekey] "with renamed link deleted"
-- unused used to miss symlinks that were deleted or modified -- unused used to miss symlinks that were deleted or modified
@ -1141,7 +1150,7 @@ test_unused = intmpclonerepo $ do
git_annex "add" ["unusedfile"] "add of unusedfile" git_annex "add" ["unusedfile"] "add of unusedfile"
git "add" ["unusedfile"] "git add" git "add" ["unusedfile"] "git add"
checkunused [] "with staged file" checkunused [] "with staged file"
removeFile "unusedfile" removeFile (literalOsPath "unusedfile")
checkunused [] "with staged deleted file" checkunused [] "with staged deleted file"
-- When an unlocked file is modified, git diff will cause git-annex -- When an unlocked file is modified, git diff will cause git-annex
@ -1190,7 +1199,7 @@ test_find = intmpclonerepo $ do
{- --include=* should match files in subdirectories too, {- --include=* should match files in subdirectories too,
- and --exclude=* should exclude them. -} - and --exclude=* should exclude them. -}
createDirectory "dir" createDirectory (literalOsPath "dir")
writecontent "dir/subfile" "subfile" writecontent "dir/subfile" "subfile"
git_annex "add" ["dir"] "add of subdir" git_annex "add" ["dir"] "add of subdir"
git_annex_expectoutput "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] git_annex_expectoutput "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"]
@ -1258,8 +1267,11 @@ test_concurrent_get_of_dup_key_regression = intmpclonerepo $ do
dupfile = annexedfile ++ "2" dupfile = annexedfile ++ "2"
dupfile2 = annexedfile ++ "3" dupfile2 = annexedfile ++ "3"
makedup f = do makedup f = do
Utility.CopyFile.copyFileExternal Utility.CopyFile.CopyAllMetaData annexedfile f Utility.CopyFile.copyFileExternal
@? "copying annexed file failed" Utility.CopyFile.CopyAllMetaData
(toOsPath annexedfile)
(toOsPath f)
@? "copying annexed file failed"
git "add" [f] "git add" git "add" [f] "git add"
{- Regression test for union merge bug fixed in {- Regression test for union merge bug fixed in
@ -1345,7 +1357,7 @@ test_conflict_resolution =
conflictor = "conflictor" conflictor = "conflictor"
variantprefix = conflictor ++ ".variant" variantprefix = conflictor ++ ".variant"
checkmerge what d = do checkmerge what d = do
l <- getDirectoryContents d l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l let v = filter (variantprefix `isPrefixOf`) l
length v == 2 length v == 2
@? (what ++ " not exactly 2 variant files in: " ++ show l) @? (what ++ " not exactly 2 variant files in: " ++ show l)
@ -1382,7 +1394,7 @@ test_conflict_resolution_adjusted_branch =
conflictor = "conflictor" conflictor = "conflictor"
variantprefix = conflictor ++ ".variant" variantprefix = conflictor ++ ".variant"
checkmerge what d = do checkmerge what d = do
l <- getDirectoryContents d l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l let v = filter (variantprefix `isPrefixOf`) l
length v == 2 length v == 2
@? (what ++ " not exactly 2 variant files in: " ++ show l) @? (what ++ " not exactly 2 variant files in: " ++ show l)
@ -1407,7 +1419,7 @@ test_mixed_conflict_resolution = do
git_annex "sync" ["--no-content"] "sync in r1" git_annex "sync" ["--no-content"] "sync in r1"
intopdir r2 $ do intopdir r2 $ do
disconnectOrigin disconnectOrigin
createDirectory conflictor createDirectory (toOsPath conflictor)
writecontent subfile "subfile" writecontent subfile "subfile"
add_annex conflictor "add conflicter" add_annex conflictor "add conflicter"
git_annex "sync" ["--no-content"] "sync in r2" git_annex "sync" ["--no-content"] "sync in r2"
@ -1418,19 +1430,19 @@ test_mixed_conflict_resolution = do
checkmerge "r1" r1 checkmerge "r1" r1
checkmerge "r2" r2 checkmerge "r2" r2
conflictor = "conflictor" conflictor = "conflictor"
subfile = conflictor </> "subfile" subfile = fromOsPath (toOsPath conflictor </> literalOsPath "subfile")
checkmerge what d = do checkmerge what d = do
doesDirectoryExist (d </> conflictor) doesDirectoryExist (toOsPath d </> toOsPath conflictor)
@? (d ++ " conflictor directory missing") @? (d ++ " conflictor directory missing")
l <- getDirectoryContents d l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (Annex.VariantFile.variantMarker `isInfixOf`) l let v = filter (fromOsPath Annex.VariantFile.variantMarker `isInfixOf`) l
not (null v) not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l ) @? (what ++ " conflictor variant file missing in: " ++ show l )
length v == 1 length v == 1
@? (what ++ " too many variant files in: " ++ show v) @? (what ++ " too many variant files in: " ++ show v)
intopdir d $ do intopdir d $ do
git_annex "get" (conflictor:v) ("get in " ++ what) 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 git_annex_expectoutput "find" v v
{- Check merge conflict resolution when both repos start with an annexed {- Check merge conflict resolution when both repos start with an annexed
@ -1456,7 +1468,7 @@ test_remove_conflict_resolution = do
git_annex "unlock" [conflictor] "unlock conflictor" git_annex "unlock" [conflictor] "unlock conflictor"
writecontent conflictor "newconflictor" writecontent conflictor "newconflictor"
intopdir r1 $ intopdir r1 $
removeWhenExistsWith R.removeLink (toRawFilePath conflictor) removeWhenExistsWith removeFile (toOsPath conflictor)
let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] let l = if inr1 then [r1, r2, r1] else [r2, r1, r2]
forM_ l $ \r -> intopdir r $ forM_ l $ \r -> intopdir r $
git_annex "sync" ["--no-content"] "sync" git_annex "sync" ["--no-content"] "sync"
@ -1465,7 +1477,7 @@ test_remove_conflict_resolution = do
conflictor = "conflictor" conflictor = "conflictor"
variantprefix = conflictor ++ ".variant" variantprefix = conflictor ++ ".variant"
checkmerge what d = do checkmerge what d = do
l <- getDirectoryContents d l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l let v = filter (variantprefix `isPrefixOf`) l
not (null v) not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l ) @? (what ++ " conflictor variant file missing in: " ++ show l )
@ -1506,14 +1518,15 @@ test_nonannexed_file_conflict_resolution = do
nonannexed_content = "nonannexed" nonannexed_content = "nonannexed"
variantprefix = conflictor ++ ".variant" variantprefix = conflictor ++ ".variant"
checkmerge what d = do checkmerge what d = do
l <- getDirectoryContents d l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l let v = filter (variantprefix `isPrefixOf`) l
not (null v) not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l ) @? (what ++ " conflictor variant file missing in: " ++ show l )
length v == 1 length v == 1
@? (what ++ " too many variant files in: " ++ show v) @? (what ++ " too many variant files in: " ++ show v)
conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l) 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 s == Just nonannexed_content
@? (what ++ " wrong content for nonannexed file: " ++ show s) @? (what ++ " wrong content for nonannexed file: " ++ show s)
@ -1552,14 +1565,15 @@ test_nonannexed_symlink_conflict_resolution = do
symlinktarget = "dummy-target" symlinktarget = "dummy-target"
variantprefix = conflictor ++ ".variant" variantprefix = conflictor ++ ".variant"
checkmerge what d = do checkmerge what d = do
l <- getDirectoryContents d l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l let v = filter (variantprefix `isPrefixOf`) l
not (null v) not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l ) @? (what ++ " conflictor variant file missing in: " ++ show l )
length v == 1 length v == 1
@? (what ++ " too many variant files in: " ++ show v) @? (what ++ " too many variant files in: " ++ show v)
conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l) 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) s == Just (toRawFilePath symlinktarget)
@? (what ++ " wrong target for nonannexed symlink: " ++ show s) @? (what ++ " wrong target for nonannexed symlink: " ++ show s)
@ -1575,13 +1589,13 @@ test_nonannexed_symlink_conflict_resolution = do
test_uncommitted_conflict_resolution :: Assertion test_uncommitted_conflict_resolution :: Assertion
test_uncommitted_conflict_resolution = do test_uncommitted_conflict_resolution = do
check conflictor check conflictor
check (conflictor </> "file") check (fromOsPath (toOsPath conflictor </> literalOsPath "file"))
where where
check remoteconflictor = withtmpclonerepo $ \r1 -> check remoteconflictor = withtmpclonerepo $ \r1 ->
withtmpclonerepo $ \r2 -> do withtmpclonerepo $ \r2 -> do
intopdir r1 $ do intopdir r1 $ do
disconnectOrigin disconnectOrigin
createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor))) createDirectoryIfMissing True (parentDir (toOsPath remoteconflictor))
writecontent remoteconflictor annexedcontent writecontent remoteconflictor annexedcontent
add_annex conflictor "add remoteconflicter" add_annex conflictor "add remoteconflicter"
git_annex "sync" ["--no-content"] "sync in r1" git_annex "sync" ["--no-content"] "sync in r1"
@ -1610,20 +1624,22 @@ test_conflict_resolution_symlink_bit = unlessM (hasUnlockedFiles <$> getTestMode
git_annex "sync" ["--no-content"] "sync in r1" git_annex "sync" ["--no-content"] "sync in r1"
check_is_link conflictor "r1" check_is_link conflictor "r1"
intopdir r2 $ do intopdir r2 $ do
createDirectory conflictor createDirectory (toOsPath conflictor)
writecontent (conflictor </> "subfile") "subfile" writecontent conflictorsubfile "subfile"
git_annex "add" [conflictor] "add conflicter" git_annex "add" [conflictor] "add conflicter"
git_annex "sync" ["--no-content"] "sync in r2" git_annex "sync" ["--no-content"] "sync in r2"
check_is_link (conflictor </> "subfile") "r2" check_is_link conflictorsubfile "r2"
intopdir r3 $ do intopdir r3 $ do
writecontent conflictor "conflictor" writecontent conflictor "conflictor"
git_annex "add" [conflictor] "add conflicter" git_annex "add" [conflictor] "add conflicter"
git_annex "sync" ["--no-content"] "sync in r1" git_annex "sync" ["--no-content"] "sync in r1"
check_is_link (conflictor </> "subfile") "r3" check_is_link conflictorsubfile "r3"
where where
conflictor = "conflictor" conflictor = "conflictor"
conflictorsubfile = fromOsPath $
toOsPath conflictor </> literalOsPath "subfile"
check_is_link f what = do 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] 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 all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l
@? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l) @? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l)
@ -1655,7 +1671,7 @@ test_mixed_lock_conflict_resolution =
conflictor = "conflictor" conflictor = "conflictor"
variantprefix = conflictor ++ ".variant" variantprefix = conflictor ++ ".variant"
checkmerge what d = intopdir d $ do checkmerge what d = intopdir d $ do
l <- getDirectoryContents "." l <- map fromOsPath <$> getDirectoryContents (literalOsPath ".")
let v = filter (variantprefix `isPrefixOf`) l let v = filter (variantprefix `isPrefixOf`) l
length v == 0 length v == 0
@? (what ++ " not exactly 0 variant files in: " ++ show l) @? (what ++ " not exactly 0 variant files in: " ++ show l)
@ -1688,7 +1704,7 @@ test_adjusted_branch_merge_regression = do
git_annex "sync" ["--no-content"] "sync" git_annex "sync" ["--no-content"] "sync"
checkmerge what d = intopdir d $ whensupported $ do checkmerge what d = intopdir d $ whensupported $ do
git_annex "sync" ["--no-content"] ("sync should not work in " ++ what) git_annex "sync" ["--no-content"] ("sync should not work in " ++ what)
l <- getDirectoryContents "." l <- map fromOsPath <$> getDirectoryContents (literalOsPath ".")
conflictor `elem` l conflictor `elem` l
@? ("conflictor not present after merge in " ++ what) @? ("conflictor not present after merge in " ++ what)
-- Currently this fails on FAT, for unknown reasons not to -- Currently this fails on FAT, for unknown reasons not to
@ -1705,16 +1721,17 @@ test_adjusted_branch_subtree_regression =
origbranch <- annexeval origBranch origbranch <- annexeval origBranch
git_annex "upgrade" [] "upgrade" git_annex "upgrade" [] "upgrade"
git_annex "adjust" ["--unlock", "--force"] "adjust" git_annex "adjust" ["--unlock", "--force"] "adjust"
createDirectoryIfMissing True "a/b/c" createDirectoryIfMissing True (literalOsPath "a/b/c")
writecontent "a/b/c/d" "foo" writecontent "a/b/c/d" "foo"
git_annex "add" ["a/b/c"] "add a/b/c" git_annex "add" ["a/b/c"] "add a/b/c"
git_annex "sync" ["--no-content"] "sync" git_annex "sync" ["--no-content"] "sync"
createDirectoryIfMissing True "a/b/x" createDirectoryIfMissing True (literalOsPath "a/b/x")
writecontent "a/b/x/y" "foo" writecontent "a/b/x/y" "foo"
git_annex "add" ["a/b/x"] "add a/b/x" git_annex "add" ["a/b/x"] "add a/b/x"
git_annex "sync" ["--no-content"] "sync" git_annex "sync" ["--no-content"] "sync"
git "checkout" [origbranch] "git checkout" 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 :: Assertion
test_map = intmpclonerepo $ do test_map = intmpclonerepo $ do
@ -1731,7 +1748,7 @@ test_uninit = intmpclonerepo $ do
-- any exit status is accepted; does abnormal exit -- any exit status is accepted; does abnormal exit
git_annex'' (const True) (const True) "uninit" [] Nothing "uninit" git_annex'' (const True) (const True) "uninit" [] Nothing "uninit"
checkregularfile annexedfile checkregularfile annexedfile
doesDirectoryExist ".git" @? ".git vanished in uninit" doesDirectoryExist (literalOsPath ".git") @? ".git vanished in uninit"
test_uninit_inbranch :: Assertion test_uninit_inbranch :: Assertion
test_uninit_inbranch = intmpclonerepo $ do test_uninit_inbranch = intmpclonerepo $ do
@ -1760,7 +1777,7 @@ test_hook_remote :: Assertion
test_hook_remote = intmpclonerepo $ do test_hook_remote = intmpclonerepo $ do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
git_annex "initremote" (words "foo type=hook encryption=none hooktype=foo") "initremote" git_annex "initremote" (words "foo type=hook encryption=none hooktype=foo") "initremote"
createDirectory dir createDirectory (toOsPath dir)
git_config "annex.foo-store-hook" $ git_config "annex.foo-store-hook" $
"cp $ANNEX_FILE " ++ loc "cp $ANNEX_FILE " ++ loc
git_config "annex.foo-retrieve-hook" $ git_config "annex.foo-retrieve-hook" $
@ -1790,7 +1807,7 @@ test_hook_remote = intmpclonerepo $ do
test_directory_remote :: Assertion test_directory_remote :: Assertion
test_directory_remote = intmpclonerepo $ do test_directory_remote = intmpclonerepo $ do
createDirectory "dir" createDirectory (literalOsPath "dir")
git_annex "initremote" (words "foo type=directory encryption=none directory=dir") "initremote" git_annex "initremote" (words "foo type=directory encryption=none directory=dir") "initremote"
git_annex "get" [annexedfile] "get of file" git_annex "get" [annexedfile] "get of file"
annexed_present annexedfile annexed_present annexedfile
@ -1806,7 +1823,7 @@ test_directory_remote = intmpclonerepo $ do
test_rsync_remote :: Assertion test_rsync_remote :: Assertion
test_rsync_remote = intmpclonerepo $ do test_rsync_remote = intmpclonerepo $ do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
createDirectory "dir" createDirectory (literalOsPath "dir")
git_annex "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") "initremote" git_annex "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") "initremote"
git_annex "get" [annexedfile] "get of file" git_annex "get" [annexedfile] "get of file"
annexed_present annexedfile annexed_present annexedfile
@ -1825,9 +1842,9 @@ test_rsync_remote = intmpclonerepo $ do
test_bup_remote :: Assertion test_bup_remote :: Assertion
test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do
-- bup special remote needs an absolute path -- bup special remote needs an absolute path
dir <- fromRawFilePath <$> absPath (toRawFilePath "dir") dir <- absPath (literalOsPath "dir")
createDirectory 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" git_annex "get" [annexedfile] "get of file"
annexed_present annexedfile annexed_present annexedfile
git_annex "copy" [annexedfile, "--to", "foo"] "copy --to bup remote" git_annex "copy" [annexedfile, "--to", "foo"] "copy --to bup remote"
@ -1841,8 +1858,8 @@ test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do
test_borg_remote :: Assertion test_borg_remote :: Assertion
test_borg_remote = when BuildInfo.borg $ do test_borg_remote = when BuildInfo.borg $ do
borgdirparent <- fromRawFilePath <$> (absPath . toRawFilePath =<< tmprepodir) borgdirparent <- absPath . toOsPath =<< tmprepodir
let borgdir = borgdirparent </> "borgrepo" let borgdir = fromOsPath (borgdirparent </> literalOsPath "borgrepo")
intmpclonerepo $ do intmpclonerepo $ do
testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) (const True) "borg init" testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) (const True) "borg init"
testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) (const True) "borg create" testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) (const True) "borg create"
@ -1894,27 +1911,27 @@ test_gpg_crypto = do
testscheme "pubkey" testscheme "pubkey"
where where
gpgcmd = Utility.Gpg.mkGpgCmd Nothing gpgcmd = Utility.Gpg.mkGpgCmd Nothing
testscheme scheme = Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "gpgtmp")) $ \gpgtmp -> do testscheme scheme = Utility.Tmp.Dir.withTmpDir (literalOsPath "gpgtmp") $ \gpgtmp -> do
-- Use the system temp directory as gpg temp directory because -- Use the system temp directory as gpg temp directory because
-- it needs to be able to store the agent socket there, -- it needs to be able to store the agent socket there,
-- which can be problematic when testing some filesystems. -- which can be problematic when testing some filesystems.
absgpgtmp <- fromRawFilePath <$> absPath (toRawFilePath gpgtmp) absgpgtmp <- absPath gpgtmp
res <- testscheme' scheme absgpgtmp res <- testscheme' scheme absgpgtmp
-- gpg may still be running and would prevent -- gpg may still be running and would prevent
-- removeDirectoryRecursive from succeeding, so -- removeDirectoryRecursive from succeeding, so
-- force removal of the temp directory. -- force removal of the temp directory.
liftIO $ removeDirectoryForCleanup gpgtmp liftIO $ removeDirectoryForCleanup (fromOsPath gpgtmp)
return res return res
testscheme' scheme absgpgtmp = intmpclonerepo $ do testscheme' scheme absgpgtmp = intmpclonerepo $ do
-- Since gpg uses a unix socket, which is limited to a -- Since gpg uses a unix socket, which is limited to a
-- short path, use whichever is shorter of absolute -- short path, use whichever is shorter of absolute
-- or relative path. -- or relative path.
relgpgtmp <- fromRawFilePath <$> relPathCwdToFile (toRawFilePath absgpgtmp) relgpgtmp <- relPathCwdToFile absgpgtmp
let gpgtmp = if length relgpgtmp < length absgpgtmp let gpgtmp = if OS.length relgpgtmp < OS.length absgpgtmp
then relgpgtmp then relgpgtmp
else absgpgtmp else absgpgtmp
void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ \environ -> do void $ Utility.Gpg.testHarness (fromOsPath gpgtmp) gpgcmd $ \environ -> do
createDirectory "dir" createDirectory (literalOsPath "dir")
let initps = let initps =
[ "foo" [ "foo"
, "type=directory" , "type=directory"
@ -1934,7 +1951,7 @@ test_gpg_crypto = do
(c,k) <- annexeval $ do (c,k) <- annexeval $ do
uuid <- Remote.nameToUUID "foo" uuid <- Remote.nameToUUID "foo"
rs <- Logs.Remote.readRemoteLog 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) return (fromJust $ M.lookup uuid rs, k)
let key = if scheme `elem` ["hybrid","pubkey"] let key = if scheme `elem` ["hybrid","pubkey"]
then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId] then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]
@ -1971,12 +1988,12 @@ test_gpg_crypto = do
let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg) let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg)
cipher <- Crypto.decryptCipher' gpgcmd (Just environ) encparams cip cipher <- Crypto.decryptCipher' gpgcmd (Just environ) encparams cip
files <- filterM doesFileExist $ files <- filterM doesFileExist $
map ("dir" </>) $ concatMap (serializeKeys cipher) keys map (literalOsPath "dir" </>) $ concatMap (serializeKeys cipher) keys
return (not $ null files) <&&> allM (checkFile mvariant) files return (not $ null files) <&&> allM (checkFile mvariant) files
checkFile mvariant filename = 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 if mvariant == Just Types.Crypto.PubKey then ks else Nothing
serializeKeys cipher = map fromRawFilePath . NE.toList serializeKeys cipher = NE.toList
. Annex.Locations.keyPaths . Annex.Locations.keyPaths
. Crypto.encryptKey Types.Crypto.HmacSha1 cipher . Crypto.encryptKey Types.Crypto.HmacSha1 cipher
#else #else
@ -1985,8 +2002,9 @@ test_gpg_crypto = putStrLn "gpg testing not implemented on Windows"
test_add_subdirs :: Assertion test_add_subdirs :: Assertion
test_add_subdirs = intmpclonerepo $ do test_add_subdirs = intmpclonerepo $ do
createDirectory "dir" createDirectory (literalOsPath "dir")
writecontent ("dir" </> "foo") $ "dir/" ++ content annexedfile writecontent (fromOsPath (literalOsPath "dir" </> literalOsPath "foo"))
("dir/" ++ content annexedfile)
git_annex "add" ["dir"] "add of subdir" git_annex "add" ["dir"] "add of subdir"
{- Regression test for Windows bug where symlinks were not {- Regression test for Windows bug where symlinks were not
@ -1997,27 +2015,30 @@ test_add_subdirs = intmpclonerepo $ do
<$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo")) <$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo"))
"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)
createDirectory "dir2" createDirectory (literalOsPath "dir2")
writecontent ("dir2" </> "foo") $ content annexedfile writecontent (fromOsPath (literalOsPath "dir2" </> literalOsPath "foo"))
setCurrentDirectory "dir" (content annexedfile)
git_annex "add" [".." </> "dir2"] "add of ../subdir" setCurrentDirectory (literalOsPath "dir")
git_annex "add" [fromOsPath (literalOsPath ".." </> literalOsPath "dir2")]
"add of ../subdir"
test_addurl :: Assertion test_addurl :: Assertion
test_addurl = intmpclonerepo $ do test_addurl = intmpclonerepo $ do
-- file:// only; this test suite should not hit the network -- file:// only; this test suite should not hit the network
let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps) let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps)
f <- fromRawFilePath <$> absPath (toRawFilePath "myurl") f <- absPath (literalOsPath "myurl")
let url = replace "\\" "/" ("file:///" ++ dropDrive f) let url = replace "\\" "/" ("file:///" ++ fromOsPath (dropDrive f))
writecontent f "foo" writecontent (fromOsPath f) "foo"
git_annex_shouldfail "addurl" [url] "addurl should not work on file url" git_annex_shouldfail "addurl" [url] "addurl should not work on file url"
filecmd "addurl" [url] ("addurl on " ++ url) filecmd "addurl" [url] ("addurl on " ++ url)
let dest = "addurlurldest" let dest = "addurlurldest"
filecmd "addurl" ["--file", dest, url] ("addurl on " ++ url ++ " with --file") 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 :: Assertion
test_export_import = intmpclonerepo $ do 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 "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote"
git_annex "get" [] "get of files" git_annex "get" [] "get of files"
annexed_present annexedfile annexed_present annexedfile
@ -2035,7 +2056,7 @@ test_export_import = intmpclonerepo $ do
git_annex "merge" ["foo/" ++ origbranch] "git annex merge" git_annex "merge" ["foo/" ++ origbranch] "git annex merge"
annexed_present_imported "import" annexed_present_imported "import"
removeWhenExistsWith R.removeLink (toRawFilePath "import") removeWhenExistsWith removeFile (literalOsPath "import")
writecontent "import" (content "newimport1") writecontent "import" (content "newimport1")
git_annex "add" ["import"] "add of import" git_annex "add" ["import"] "add of import"
commitchanges commitchanges
@ -2044,7 +2065,7 @@ test_export_import = intmpclonerepo $ do
-- verify that export refuses to overwrite modified file -- verify that export refuses to overwrite modified file
writedir "import" (content "newimport2") writedir "import" (content "newimport2")
removeWhenExistsWith R.removeLink (toRawFilePath "import") removeWhenExistsWith removeFile (literalOsPath "import")
writecontent "import" (content "newimport3") writecontent "import" (content "newimport3")
git_annex "add" ["import"] "add of import" git_annex "add" ["import"] "add of import"
commitchanges commitchanges
@ -2054,17 +2075,18 @@ test_export_import = intmpclonerepo $ do
-- resolving import conflict -- resolving import conflict
git_annex "import" [origbranch, "--from", "foo"] "import from dir" git_annex "import" [origbranch, "--from", "foo"] "import from dir"
git_shouldfail "merge" ["foo/master", "-mmerge"] "git merge of conflict should exit nonzero" 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") writecontent "import" (content "newimport3")
git_annex "add" ["import"] "add of import" git_annex "add" ["import"] "add of import"
commitchanges commitchanges
git_annex "export" [origbranch, "--to", "foo"] "export after import conflict" git_annex "export" [origbranch, "--to", "foo"] "export after import conflict"
dircontains "import" (content "newimport3") dircontains "import" (content "newimport3")
where where
dircontains f v = dircontains f v = do
((v==) <$> readFile ("dir" </> f)) let df = fromOsPath (literalOsPath "dir" </> stringToOsPath f)
@? ("did not find expected content of " ++ "dir" </> f) ((v==) <$> readFile df)
writedir f = writecontent ("dir" </> f) @? ("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 -- When on an adjusted branch, this updates the master branch
-- to match it, which is necessary since the master branch is going -- to match it, which is necessary since the master branch is going
-- to be exported. -- to be exported.
@ -2072,12 +2094,12 @@ test_export_import = intmpclonerepo $ do
test_export_import_subdir :: Assertion test_export_import_subdir :: Assertion
test_export_import_subdir = intmpclonerepo $ do 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 "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote"
git_annex "get" [] "get of files" git_annex "get" [] "get of files"
annexed_present annexedfile annexed_present annexedfile
createDirectory subdir createDirectory (toOsPath subdir)
git "mv" [annexedfile, subannexedfile] "git mv" git "mv" [annexedfile, subannexedfile] "git mv"
git "commit" ["-m", "moved"] "git commit" git "commit" ["-m", "moved"] "git commit"
@ -2096,12 +2118,14 @@ test_export_import_subdir = intmpclonerepo $ do
testimport testimport
testexport testexport
where where
dircontains f v = dircontains f v = do
((v==) <$> readFile ("dir" </> f)) let df = fromOsPath (literalOsPath "dir" </> toOsPath f)
@? ("did not find expected content of " ++ "dir" </> f) ((v==) <$> readFile df)
@? ("did not find expected content of " ++ df)
subdir = "subdir" subdir = "subdir"
subannexedfile = "subdir" </> annexedfile subannexedfile = fromOsPath $
literalOsPath "subdir" </> toOsPath annexedfile
testexport = do testexport = do
origbranch <- annexeval origBranch origbranch <- annexeval origBranch

6
Utility/Path/AbsRel.hs
View file

@ -76,9 +76,9 @@ relPathDirToFile :: OsPath -> OsPath -> IO OsPath
relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
{- Converts paths in the home directory to use ~/ -} {- Converts paths in the home directory to use ~/ -}
relHome :: OsPath -> IO String relHome :: OsPath -> IO OsPath
relHome path = do relHome path = do
home <- toOsPath <$> myHomeDir home <- toOsPath <$> myHomeDir
return $ if dirContains home path return $ if dirContains home path
then fromOsPath (literalOsPath "~/" <> relPathDirToFileAbs home path) then literalOsPath "~/" <> relPathDirToFileAbs home path
else fromOsPath path else path