Merge branch 'master' into relativepaths

Conflicts:
	Locations.hs
	debian/changelog
This commit is contained in:
Joey Hess 2015-01-06 19:00:01 -04:00
commit 858d776352
61 changed files with 238 additions and 122 deletions

View file

@ -261,7 +261,7 @@ finishGetViaTmp check key action = do
prepTmp :: Key -> Annex FilePath prepTmp :: Key -> Annex FilePath
prepTmp key = do prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpObjectLocation key tmp <- fromRepo $ gitAnnexTmpObjectLocation key
createAnnexDirectory (parentDir tmp) createAnnexDirectory (takeDirectory tmp)
return tmp return tmp
{- Creates a temp file for a key, runs an action on it, and cleans up {- Creates a temp file for a key, runs an action on it, and cleans up
@ -425,7 +425,7 @@ cleanObjectLoc key cleaner = do
where where
removeparents _ 0 = noop removeparents _ 0 = noop
removeparents file n = do removeparents file n = do
let dir = parentDir file let dir = takeDirectory file
maybe noop (const $ removeparents dir (n-1)) maybe noop (const $ removeparents dir (n-1))
<=< catchMaybeIO $ removeDirectory dir <=< catchMaybeIO $ removeDirectory dir
@ -474,7 +474,7 @@ moveBad key = do
src <- calcRepo $ gitAnnexLocation key src <- calcRepo $ gitAnnexLocation key
bad <- fromRepo gitAnnexBadDir bad <- fromRepo gitAnnexBadDir
let dest = bad </> takeFileName src let dest = bad </> takeFileName src
createAnnexDirectory (parentDir dest) createAnnexDirectory (takeDirectory dest)
cleanObjectLoc key $ cleanObjectLoc key $
liftIO $ moveFile src dest liftIO $ moveFile src dest
logStatus key InfoMissing logStatus key InfoMissing

View file

@ -247,7 +247,7 @@ sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus
createInodeSentinalFile :: Annex () createInodeSentinalFile :: Annex ()
createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do
s <- annexSentinalFile s <- annexSentinalFile
createAnnexDirectory (parentDir (sentinalFile s)) createAnnexDirectory (takeDirectory (sentinalFile s))
liftIO $ writeSentinalFile s liftIO $ writeSentinalFile s
where where
alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile

View file

@ -270,7 +270,7 @@ updateWorkTree d oldref = do
- Empty work tree directories are removed, per git behavior. -} - Empty work tree directories are removed, per git behavior. -}
moveout_raw _ _ f = liftIO $ do moveout_raw _ _ f = liftIO $ do
nukeFile f nukeFile f
void $ tryIO $ removeDirectory $ parentDir f void $ tryIO $ removeDirectory $ takeDirectory f
{- If the file is already present, with the right content for the {- If the file is already present, with the right content for the
- key, it's left alone. - key, it's left alone.
@ -291,7 +291,7 @@ updateWorkTree d oldref = do
movein_raw item makeabs f = do movein_raw item makeabs f = do
preserveUnannexed item makeabs f oldref preserveUnannexed item makeabs f oldref
liftIO $ do liftIO $ do
createDirectoryIfMissing True $ parentDir f createDirectoryIfMissing True $ takeDirectory f
void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
{- If the file that's being moved in is already present in the work {- If the file that's being moved in is already present in the work
@ -309,13 +309,14 @@ preserveUnannexed item makeabs absf oldref = do
checkdirs (DiffTree.file item) checkdirs (DiffTree.file item)
where where
checkdirs from = do checkdirs from = do
let p = parentDir (getTopFilePath from) case parentDir (getTopFilePath from) of
let d = asTopFilePath p Nothing -> noop
unless (null p) $ do Just p -> do
let absd = makeabs d let d = asTopFilePath p
whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $ let absd = makeabs d
liftIO $ findnewname absd 0 whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
checkdirs d liftIO $ findnewname absd 0
checkdirs d
collidingitem f = isJust collidingitem f = isJust
<$> catchMaybeIO (getSymbolicLinkStatus f) <$> catchMaybeIO (getSymbolicLinkStatus f)
@ -382,7 +383,7 @@ removeDirect k f = do
) )
liftIO $ do liftIO $ do
nukeFile f nukeFile f
void $ tryIO $ removeDirectory $ parentDir f void $ tryIO $ removeDirectory $ takeDirectory f
{- Called when a direct mode file has been changed. Its old content may be {- Called when a direct mode file has been changed. Its old content may be
- lost. -} - lost. -}

View file

@ -71,12 +71,12 @@ annexFileMode = withShared $ return . go
createAnnexDirectory :: FilePath -> Annex () createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = traverse dir [] =<< top createAnnexDirectory dir = traverse dir [] =<< top
where where
top = parentDir <$> fromRepo gitAnnexDir top = takeDirectory <$> fromRepo gitAnnexDir
traverse d below stop traverse d below stop
| d `equalFilePath` stop = done | d `equalFilePath` stop = done
| otherwise = ifM (liftIO $ doesDirectoryExist d) | otherwise = ifM (liftIO $ doesDirectoryExist d)
( done ( done
, traverse (parentDir d) (d:below) stop , traverse (takeDirectory d) (d:below) stop
) )
where where
done = forM_ below $ \p -> do done = forM_ below $ \p -> do
@ -92,14 +92,14 @@ freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = unlessM crippledFileSystem $ freezeContentDir file = unlessM crippledFileSystem $
liftIO . go =<< fromRepo getSharedRepository liftIO . go =<< fromRepo getSharedRepository
where where
dir = parentDir file dir = takeDirectory file
go GroupShared = groupWriteRead dir go GroupShared = groupWriteRead dir
go AllShared = groupWriteRead dir go AllShared = groupWriteRead dir
go _ = preventWrite dir go _ = preventWrite dir
thawContentDir :: FilePath -> Annex () thawContentDir :: FilePath -> Annex ()
thawContentDir file = unlessM crippledFileSystem $ thawContentDir file = unlessM crippledFileSystem $
liftIO $ allowWrite $ parentDir file liftIO $ allowWrite $ takeDirectory file
{- Makes the directory tree to store an annexed file's content, {- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -} - with appropriate permissions on each level. -}
@ -111,7 +111,7 @@ createContentDir dest = do
unlessM crippledFileSystem $ unlessM crippledFileSystem $
liftIO $ allowWrite dir liftIO $ allowWrite dir
where where
dir = parentDir dest dir = takeDirectory dest
{- Creates the content directory for a file if it doesn't already exist, {- Creates the content directory for a file if it doesn't already exist,
- or thaws it if it does, then runs an action to modify the file, and - or thaws it if it does, then runs an action to modify the file, and

View file

@ -46,5 +46,5 @@ replaceFileFrom src dest = go `catchIO` fallback
where where
go = moveFile src dest go = moveFile src dest
fallback _ = do fallback _ = do
createDirectoryIfMissing True $ parentDir dest createDirectoryIfMissing True $ takeDirectory dest
go go

View file

@ -125,7 +125,7 @@ prepSocket socketfile = do
-- Cleanup at end of this run. -- Cleanup at end of this run.
Annex.addCleanup SshCachingCleanup sshCleanup Annex.addCleanup SshCachingCleanup sshCleanup
liftIO $ createDirectoryIfMissing True $ parentDir socketfile liftIO $ createDirectoryIfMissing True $ takeDirectory socketfile
lockFileShared $ socket2lock socketfile lockFileShared $ socket2lock socketfile
enumSocketFiles :: Annex [FilePath] enumSocketFiles :: Annex [FilePath]

View file

@ -78,7 +78,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
logfile <- fromRepo gitAnnexLogFile logfile <- fromRepo gitAnnexLogFile
liftIO $ debugM desc $ "logging to " ++ logfile liftIO $ debugM desc $ "logging to " ++ logfile
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
createAnnexDirectory (parentDir logfile) createAnnexDirectory (takeDirectory logfile)
logfd <- liftIO $ handleToFd =<< openLog logfile logfd <- liftIO $ handleToFd =<< openLog logfile
if foreground if foreground
then do then do
@ -98,7 +98,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
-- log file. The only way to do so is to restart the program. -- log file. The only way to do so is to restart the program.
when (foreground || not foreground) $ do when (foreground || not foreground) $ do
let flag = "GIT_ANNEX_OUTPUT_REDIR" let flag = "GIT_ANNEX_OUTPUT_REDIR"
createAnnexDirectory (parentDir logfile) createAnnexDirectory (takeDirectory logfile)
ifM (liftIO $ isNothing <$> getEnv flag) ifM (liftIO $ isNothing <$> getEnv flag)
( liftIO $ withFile devNull WriteMode $ \nullh -> do ( liftIO $ withFile devNull WriteMode $ \nullh -> do
loghandle <- openLog logfile loghandle <- openLog logfile

View file

@ -49,7 +49,7 @@ ensureInstalled = go =<< standaloneAppBase
go (Just base) = do go (Just base) = do
let program = base </> "git-annex" let program = base </> "git-annex"
programfile <- programFile programfile <- programFile
createDirectoryIfMissing True (parentDir programfile) createDirectoryIfMissing True (takeDirectory programfile)
writeFile programfile program writeFile programfile program
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
@ -87,7 +87,7 @@ installWrapper :: FilePath -> String -> IO ()
installWrapper file content = do installWrapper file content = do
curr <- catchDefaultIO "" $ readFileStrict file curr <- catchDefaultIO "" $ readFileStrict file
when (curr /= content) $ do when (curr /= content) $ do
createDirectoryIfMissing True (parentDir file) createDirectoryIfMissing True (takeDirectory file)
viaTmp writeFile file content viaTmp writeFile file content
modifyFileMode file $ addModes [ownerExecuteMode] modifyFileMode file $ addModes [ownerExecuteMode]

View file

@ -19,7 +19,7 @@ import System.Directory
installAutoStart :: FilePath -> FilePath -> IO () installAutoStart :: FilePath -> FilePath -> IO ()
installAutoStart command file = do installAutoStart command file = do
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
createDirectoryIfMissing True (parentDir file) createDirectoryIfMissing True (takeDirectory file)
writeFile file $ genOSXAutoStartFile osxAutoStartLabel command writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
["assistant", "--autostart"] ["assistant", "--autostart"]
#else #else

View file

@ -38,7 +38,7 @@ fdoDesktopMenu command = genDesktopEntry
installIcon :: FilePath -> FilePath -> IO () installIcon :: FilePath -> FilePath -> IO ()
installIcon src dest = do installIcon src dest = do
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (takeDirectory dest)
withBinaryFile src ReadMode $ \hin -> withBinaryFile src ReadMode $ \hin ->
withBinaryFile dest WriteMode $ \hout -> withBinaryFile dest WriteMode $ \hout ->
hGetContents hin >>= hPutStr hout hGetContents hin >>= hPutStr hout

View file

@ -233,7 +233,8 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
setupSshKeyPair sshkeypair sshdata = do setupSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir sshdir <- sshDir
createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile createDirectoryIfMissing True $
takeDirectory $ sshdir </> sshprivkeyfile
unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair) writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)

View file

@ -47,7 +47,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
, modifyHook = changed , modifyHook = changed
, delDirHook = changed , delDirHook = changed
} }
let dir = parentDir flagfile let dir = takeDirectory flagfile
let depth = length (splitPath dir) + 1 let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)

View file

@ -161,7 +161,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
{- OS X uses a dmg, so mount it, and copy the contents into place. -} {- OS X uses a dmg, so mount it, and copy the contents into place. -}
unpack = liftIO $ do unpack = liftIO $ do
olddir <- oldVersionLocation olddir <- oldVersionLocation
withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do withTmpDirIn (takeDirectory newdir) "git-annex.upgrade" $ \tmpdir -> do
void $ boolSystem "hdiutil" void $ boolSystem "hdiutil"
[ Param "attach", File distributionfile [ Param "attach", File distributionfile
, Param "-mountpoint", File tmpdir , Param "-mountpoint", File tmpdir
@ -186,7 +186,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
- into place. -} - into place. -}
unpack = liftIO $ do unpack = liftIO $ do
olddir <- oldVersionLocation olddir <- oldVersionLocation
withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do withTmpDirIn (takeDirectory newdir) "git-annex.upgrade" $ \tmpdir -> do
let tarball = tmpdir </> "tar" let tarball = tmpdir </> "tar"
-- Cannot rely on filename extension, and this also -- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent -- avoids problems if tar doesn't support transparent
@ -217,14 +217,14 @@ upgradeToDistribution newdir cleanup distributionfile = do
unlessM (doesDirectoryExist dir) $ unlessM (doesDirectoryExist dir) $
error $ "did not find " ++ dir ++ " in " ++ distributionfile error $ "did not find " ++ dir ++ " in " ++ distributionfile
makeorigsymlink olddir = do makeorigsymlink olddir = do
let origdir = parentDir olddir </> installBase let origdir = takeDirectory olddir </> installBase
nukeFile origdir nukeFile origdir
createSymbolicLink newdir origdir createSymbolicLink newdir origdir
{- Finds where the old version was installed. -} {- Finds where the old version was installed. -}
oldVersionLocation :: IO FilePath oldVersionLocation :: IO FilePath
oldVersionLocation = do oldVersionLocation = do
pdir <- parentDir <$> readProgramFile pdir <- takeDirectory <$> readProgramFile
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
let dirs = splitDirectories pdir let dirs = splitDirectories pdir
{- It will probably be deep inside a git-annex.app directory. -} {- It will probably be deep inside a git-annex.app directory. -}
@ -253,7 +253,7 @@ newVersionLocation d olddir =
return Nothing return Nothing
where where
s = installBase ++ "." ++ distributionVersion d s = installBase ++ "." ++ distributionVersion d
topdir = parentDir olddir topdir = takeDirectory olddir
newloc = topdir </> s newloc = topdir </> s
trymkdir dir fallback = trymkdir dir fallback =
(createDirectory dir >> return (Just dir)) (createDirectory dir >> return (Just dir))

View file

@ -83,7 +83,7 @@ checkRepositoryPath p = do
home <- myHomeDir home <- myHomeDir
let basepath = expandTilde home $ T.unpack p let basepath = expandTilde home $ T.unpack p
path <- absPath basepath path <- absPath basepath
let parent = parentDir path let parent = takeDirectory path
problems <- catMaybes <$> mapM runcheck problems <- catMaybes <$> mapM runcheck
[ (return $ path == "/", "Enter the full path to use for the repository.") [ (return $ path == "/", "Enter the full path to use for the repository.")
, (return $ all isSpace basepath, "A blank path? Seems unlikely.") , (return $ all isSpace basepath, "A blank path? Seems unlikely.")
@ -416,7 +416,7 @@ startFullAssistant path repogroup setup = do
canWrite :: FilePath -> IO Bool canWrite :: FilePath -> IO Bool
canWrite dir = do canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir) tocheck <- ifM (doesDirectoryExist dir)
(return dir, return $ parentDir dir) (return dir, return $ takeDirectory dir)
catchBoolIO $ fileAccess tocheck False True False catchBoolIO $ fileAccess tocheck False True False
{- Gets the UUID of the git repo at a location, which may not exist, or {- Gets the UUID of the git repo at a location, which may not exist, or

View file

@ -32,10 +32,8 @@ backend = Backend
{- Every unique url has a corresponding key. -} {- Every unique url has a corresponding key. -}
fromUrl :: String -> Maybe Integer -> Annex Key fromUrl :: String -> Maybe Integer -> Annex Key
fromUrl url size = do fromUrl url size = return $ stubKey
n <- genKeyName url { keyName = genKeyName url
return $ stubKey , keyBackendName = "URL"
{ keyName = n , keySize = size
, keyBackendName = "URL" }
, keySize = size
}

View file

@ -13,13 +13,18 @@ import Common.Annex
{- Generates a keyName from an input string. Takes care of sanitizing it. {- Generates a keyName from an input string. Takes care of sanitizing it.
- If it's not too long, the full string is used as the keyName. - If it's not too long, the full string is used as the keyName.
- Otherwise, it's truncated at half the filename length limit, and its - Otherwise, it's truncated, and its md5 is prepended to ensure a unique
- md5 is prepended to ensure a unique key. -} - key. -}
genKeyName :: String -> Annex String genKeyName :: String -> String
genKeyName s = do genKeyName s
limit <- liftIO . fileNameLengthLimit =<< fromRepo gitAnnexDir -- Avoid making keys longer than the length of a SHA256 checksum.
let s' = preSanitizeKeyName s | bytelen > sha256len =
let truncs = truncateFilePath (limit `div` 2) s' truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ md5s (Str s)
return $ if s' == truncs | otherwise = s'
then s' where
else truncs ++ "-" ++ md5s (Str s) s' = preSanitizeKeyName s
bytelen = length (decodeW8 s')
sha256len = 64
md5len = 32

View file

@ -34,9 +34,8 @@ keyValue :: KeySource -> Annex (Maybe Key)
keyValue source = do keyValue source = do
stat <- liftIO $ getFileStatus $ contentLocation source stat <- liftIO $ getFileStatus $ contentLocation source
relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source)
n <- genKeyName relf
return $ Just $ stubKey return $ Just $ stubKey
{ keyName = n { keyName = genKeyName relf
, keyBackendName = name backend , keyBackendName = name backend
, keySize = Just $ fromIntegral $ fileSize stat , keySize = Just $ fromIntegral $ fileSize stat
, keyMtime = Just $ modificationTime stat , keyMtime = Just $ modificationTime stat

View file

@ -22,6 +22,7 @@ import Assistant.Install.Menu
import Control.Applicative import Control.Applicative
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.FilePath
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix.User import System.Posix.User
#endif #endif
@ -75,6 +76,6 @@ install command = do
( return () ( return ()
, do , do
programfile <- inDestDir =<< programFile programfile <- inDestDir =<< programFile
createDirectoryIfMissing True (parentDir programfile) createDirectoryIfMissing True (takeDirectory programfile)
writeFile programfile command writeFile programfile command
) )

View file

@ -64,7 +64,7 @@ getbuild repodir (url, f) = do
let dest = repodir </> f let dest = repodir </> f
let tmp = dest ++ ".tmp" let tmp = dest ++ ".tmp"
nukeFile tmp nukeFile tmp
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (takeDirectory dest)
let oops s = do let oops s = do
nukeFile tmp nukeFile tmp
putStrLn $ "*** " ++ s putStrLn $ "*** " ++ s

View file

@ -204,7 +204,7 @@ applySplices destdir imports splices@(first:_) = do
let f = splicedFile first let f = splicedFile first
let dest = (destdir </> f) let dest = (destdir </> f)
lls <- map (++ "\n") . lines <$> readFileStrictAnyEncoding f lls <- map (++ "\n") . lines <$> readFileStrictAnyEncoding f
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (takeDirectory dest)
let newcontent = concat $ addimports $ expand lls splices let newcontent = concat $ addimports $ expand lls splices
oldcontent <- catchMaybeIO $ readFileStrictAnyEncoding dest oldcontent <- catchMaybeIO $ readFileStrictAnyEncoding dest
when (oldcontent /= Just newcontent) $ do when (oldcontent /= Just newcontent) $ do

View file

@ -47,7 +47,7 @@ mklibs top = do
writeFile (top </> "linker") writeFile (top </> "linker")
(Prelude.head $ filter ("ld-linux" `isInfixOf`) libs') (Prelude.head $ filter ("ld-linux" `isInfixOf`) libs')
writeFile (top </> "gconvdir") writeFile (top </> "gconvdir")
(parentDir $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs) (takeDirectory $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs)
mapM_ (installLinkerShim top) exes mapM_ (installLinkerShim top) exes
@ -75,7 +75,7 @@ installLinkerShim top exe = do
symToHardLink :: FilePath -> IO () symToHardLink :: FilePath -> IO ()
symToHardLink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus f) $ do symToHardLink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus f) $ do
l <- readSymbolicLink f l <- readSymbolicLink f
let absl = absPathFrom (parentDir f) l let absl = absPathFrom (takeDirectory f) l
nukeFile f nukeFile f
createLink absl f createLink absl f
@ -84,7 +84,7 @@ installFile top f = do
createDirectoryIfMissing True destdir createDirectoryIfMissing True destdir
void $ copyFileExternal CopyTimeStamps f destdir void $ copyFileExternal CopyTimeStamps f destdir
where where
destdir = inTop top $ parentDir f destdir = inTop top $ takeDirectory f
checkExe :: FilePath -> IO Bool checkExe :: FilePath -> IO Bool
checkExe f checkExe f

View file

@ -50,7 +50,7 @@ installLibs appbase replacement_libs libmap = do
ifM (doesFileExist dest) ifM (doesFileExist dest)
( return Nothing ( return Nothing
, do , do
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (takeDirectory dest)
putStrLn $ "installing " ++ pathlib ++ " as " ++ shortlib putStrLn $ "installing " ++ pathlib ++ " as " ++ shortlib
_ <- boolSystem "cp" [File pathlib, File dest] _ <- boolSystem "cp" [File pathlib, File dest]
_ <- boolSystem "chmod" [Param "644", File dest] _ <- boolSystem "chmod" [Param "644", File dest]

View file

@ -70,7 +70,7 @@ withPathContents a params = seekActions $
map a . concat <$> liftIO (mapM get params) map a . concat <$> liftIO (mapM get params)
where where
get p = ifM (isDirectory <$> getFileStatus p) get p = ifM (isDirectory <$> getFileStatus p)
( map (\f -> (f, makeRelative (parentDir p) f)) ( map (\f -> (f, makeRelative (takeDirectory p) f))
<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p <$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p
, return [(p, takeFileName p)] , return [(p, takeFileName p)]
) )

View file

@ -101,7 +101,7 @@ performRemote r relaxed uri file sz = ifAnnexed file adduri geturi
downloadRemoteFile :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) downloadRemoteFile :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)
downloadRemoteFile r relaxed uri file sz = do downloadRemoteFile r relaxed uri file sz = do
urlkey <- Backend.URL.fromUrl uri sz urlkey <- Backend.URL.fromUrl uri sz
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (takeDirectory file)
ifM (Annex.getState Annex.fast <||> pure relaxed) ifM (Annex.getState Annex.fast <||> pure relaxed)
( do ( do
cleanup (Remote.uuid r) loguri file urlkey Nothing cleanup (Remote.uuid r) loguri file urlkey Nothing
@ -195,7 +195,7 @@ addUrlFileQuvi relaxed quviurl videourl file = do
showOutput showOutput
ok <- Transfer.notifyTransfer Transfer.Download (Just file) $ ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do
liftIO $ createDirectoryIfMissing True (parentDir tmp) liftIO $ createDirectoryIfMissing True (takeDirectory tmp)
downloadUrl [videourl] tmp downloadUrl [videourl] tmp
if ok if ok
then do then do
@ -227,7 +227,7 @@ addUrlChecked relaxed url u checkexistssize key
addUrlFile :: Bool -> URLString -> FilePath -> Annex (Maybe Key) addUrlFile :: Bool -> URLString -> FilePath -> Annex (Maybe Key)
addUrlFile relaxed url file = do addUrlFile relaxed url file = do
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (takeDirectory file)
ifM (Annex.getState Annex.fast <||> pure relaxed) ifM (Annex.getState Annex.fast <||> pure relaxed)
( nodownload relaxed url file ( nodownload relaxed url file
, downloadWeb url file , downloadWeb url file
@ -269,7 +269,7 @@ downloadWith downloader dummykey u url file =
where where
runtransfer tmp = Transfer.notifyTransfer Transfer.Download (Just file) $ runtransfer tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do
liftIO $ createDirectoryIfMissing True (parentDir tmp) liftIO $ createDirectoryIfMissing True (takeDirectory tmp)
downloader tmp p downloader tmp p
{- Hits the url to get the size, if available. {- Hits the url to get the size, if available.

View file

@ -43,7 +43,7 @@ perform file link = do
<$> getSymbolicLinkStatus file <$> getSymbolicLinkStatus file
#endif #endif
#endif #endif
createDirectoryIfMissing True (parentDir file) createDirectoryIfMissing True (takeDirectory file)
removeFile file removeFile file
createSymbolicLink link file createSymbolicLink link file
#ifdef WITH_CLIBS #ifdef WITH_CLIBS

View file

@ -34,7 +34,7 @@ start _ = error "specify a key and a dest file"
perform :: Key -> FilePath -> CommandPerform perform :: Key -> FilePath -> CommandPerform
perform key file = do perform key file = do
link <- inRepo $ gitAnnexLink file key link <- inRepo $ gitAnnexLink file key
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (takeDirectory file)
liftIO $ createSymbolicLink link file liftIO $ createSymbolicLink link file
next $ cleanup file next $ cleanup file

View file

@ -200,7 +200,7 @@ fixLink key file = do
go want have go want have
| want /= fromInternalGitPath have = do | want /= fromInternalGitPath have = do
showNote "fixing link" showNote "fixing link"
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (takeDirectory file)
liftIO $ removeFile file liftIO $ removeFile file
addAnnexLink want file addAnnexLink want file
| otherwise = noop | otherwise = noop
@ -218,7 +218,7 @@ verifyLocationLog key desc = do
file <- calcRepo $ gitAnnexLocation key file <- calcRepo $ gitAnnexLocation key
when (present && not direct) $ when (present && not direct) $
freezeContent file freezeContent file
whenM (liftIO $ doesDirectoryExist $ parentDir file) $ whenM (liftIO $ doesDirectoryExist $ takeDirectory file) $
freezeContentDir file freezeContentDir file
{- In direct mode, modified files will show up as not present, {- In direct mode, modified files will show up as not present,
@ -450,7 +450,7 @@ needFsck _ _ = return True
-} -}
recordFsckTime :: Key -> Annex () recordFsckTime :: Key -> Annex ()
recordFsckTime key = do recordFsckTime key = do
parent <- parentDir <$> calcRepo (gitAnnexLocation key) parent <- takeDirectory <$> calcRepo (gitAnnexLocation key)
liftIO $ void $ tryIO $ do liftIO $ void $ tryIO $ do
touchFile parent touchFile parent
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
@ -459,7 +459,7 @@ recordFsckTime key = do
getFsckTime :: Key -> Annex (Maybe EpochTime) getFsckTime :: Key -> Annex (Maybe EpochTime)
getFsckTime key = do getFsckTime key = do
parent <- parentDir <$> calcRepo (gitAnnexLocation key) parent <- takeDirectory <$> calcRepo (gitAnnexLocation key)
liftIO $ catchDefaultIO Nothing $ do liftIO $ catchDefaultIO Nothing $ do
s <- getFileStatus parent s <- getFileStatus parent
return $ if isSticky $ fileMode s return $ if isSticky $ fileMode s
@ -477,7 +477,7 @@ getFsckTime key = do
recordStartTime :: Annex () recordStartTime :: Annex ()
recordStartTime = do recordStartTime = do
f <- fromRepo gitAnnexFsckState f <- fromRepo gitAnnexFsckState
createAnnexDirectory $ parentDir f createAnnexDirectory $ takeDirectory f
liftIO $ do liftIO $ do
nukeFile f nukeFile f
withFile f WriteMode $ \h -> do withFile f WriteMode $ \h -> do

View file

@ -173,7 +173,7 @@ instance Arbitrary FuzzAction where
runFuzzAction :: FuzzAction -> Annex () runFuzzAction :: FuzzAction -> Annex ()
runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do
createDirectoryIfMissing True $ parentDir f createDirectoryIfMissing True $ takeDirectory f
n <- getStdRandom random :: IO Int n <- getStdRandom random :: IO Int
writeFile f $ show n ++ "\n" writeFile f $ show n ++ "\n"
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f
@ -210,7 +210,7 @@ genFuzzAction = do
case md of case md of
Nothing -> genFuzzAction Nothing -> genFuzzAction
Just d -> do Just d -> do
newd <- liftIO $ newDir (parentDir $ toFilePath d) newd <- liftIO $ newDir (takeDirectory $ toFilePath d)
maybe genFuzzAction (return . FuzzMoveDir d) newd maybe genFuzzAction (return . FuzzMoveDir d) newd
FuzzDeleteDir _ -> do FuzzDeleteDir _ -> do
d <- liftIO existingDir d <- liftIO existingDir

View file

@ -88,7 +88,7 @@ start mode (srcfile, destfile) =
next $ return True next $ return True
importfile = do importfile = do
handleexisting =<< liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile) handleexisting =<< liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
liftIO $ createDirectoryIfMissing True (parentDir destfile) liftIO $ createDirectoryIfMissing True (takeDirectory destfile)
liftIO $ if mode == Duplicate || mode == SkipDuplicates liftIO $ if mode == Duplicate || mode == SkipDuplicates
then void $ copyFileExternal CopyAllMetaData srcfile destfile then void $ copyFileExternal CopyAllMetaData srcfile destfile
else moveFile srcfile destfile else moveFile srcfile destfile

View file

@ -311,7 +311,7 @@ checkFeedBroken' url f = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
case prev of case prev of
Nothing -> do Nothing -> do
createAnnexDirectory (parentDir f) createAnnexDirectory (takeDirectory f)
liftIO $ writeFile f $ show now liftIO $ writeFile f $ show now
return False return False
Just prevtime -> do Just prevtime -> do

View file

@ -46,7 +46,7 @@ perform dest key = ifM (checkDiskSpace Nothing key 0)
( do ( do
src <- calcRepo $ gitAnnexLocation key src <- calcRepo $ gitAnnexLocation key
tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key
liftIO $ createDirectoryIfMissing True (parentDir tmpdest) liftIO $ createDirectoryIfMissing True (takeDirectory tmpdest)
showAction "copying" showAction "copying"
ifM (liftIO $ copyFileExternal CopyAllMetaData src tmpdest) ifM (liftIO $ copyFileExternal CopyAllMetaData src tmpdest)
( do ( do

View file

@ -39,7 +39,7 @@ seek = withNothing start
start :: CommandStart start :: CommandStart
start = do start = do
f <- fromRepo gitAnnexTmpCfgFile f <- fromRepo gitAnnexTmpCfgFile
createAnnexDirectory $ parentDir f createAnnexDirectory $ takeDirectory f
cfg <- getCfg cfg <- getCfg
descs <- uuidDescriptions descs <- uuidDescriptions
liftIO $ writeFileAnyEncoding f $ genCfg cfg descs liftIO $ writeFileAnyEncoding f $ genCfg cfg descs

View file

@ -33,7 +33,7 @@ modifyAutoStartFile func = do
let dirs' = nubBy equalFilePath $ func dirs let dirs' = nubBy equalFilePath $ func dirs
when (dirs' /= dirs) $ do when (dirs' /= dirs) $ do
f <- autoStartFile f <- autoStartFile
createDirectoryIfMissing True (parentDir f) createDirectoryIfMissing True (takeDirectory f)
viaTmp writeFile f $ unlines dirs' viaTmp writeFile f $ unlines dirs'
{- Adds a directory to the autostart file. If the directory is already {- Adds a directory to the autostart file. If the directory is already

View file

@ -46,8 +46,8 @@ fromCwd = getCurrentDirectory >>= seekUp
r <- checkForRepo dir r <- checkForRepo dir
case r of case r of
Nothing -> case parentDir dir of Nothing -> case parentDir dir of
"" -> return Nothing Nothing -> return Nothing
d -> seekUp d Just d -> seekUp d
Just loc -> Just <$> newFrom loc Just loc -> Just <$> newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -} {- Local Repo constructor, accepts a relative or absolute path. -}

View file

@ -244,7 +244,7 @@ explodePackedRefsFile r = do
where where
makeref (sha, ref) = do makeref (sha, ref) = do
let dest = localGitDir r </> fromRef ref let dest = localGitDir r </> fromRef ref
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (takeDirectory dest)
unlessM (doesFileExist dest) $ unlessM (doesFileExist dest) $
writeFile dest (fromRef sha) writeFile dest (fromRef sha)

View file

@ -146,7 +146,7 @@ gitAnnexLink file key r = do
currdir <- getCurrentDirectory currdir <- getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPathUnix currdir file let absfile = fromMaybe whoops $ absNormPathUnix currdir file
loc <- gitAnnexLocation' key r False loc <- gitAnnexLocation' key r False
relPathDirToFile (parentDir absfile) loc relPathDirToFile (takeDirectory absfile) loc
where where
whoops = error $ "unable to normalize " ++ file whoops = error $ "unable to normalize " ++ file

View file

@ -29,7 +29,7 @@ writeFsckResults u fsckresults = do
| otherwise -> store s t logfile | otherwise -> store s t logfile
where where
store s t logfile = do store s t logfile = do
createDirectoryIfMissing True (parentDir logfile) createDirectoryIfMissing True (takeDirectory logfile)
liftIO $ viaTmp writeFile logfile $ serialize s t liftIO $ viaTmp writeFile logfile $ serialize s t
serialize s t = serialize s t =
let ls = map fromRef (S.toList s) let ls = map fromRef (S.toList s)

View file

@ -189,7 +189,7 @@ downloadTorrentFile u = do
, do , do
showAction "downloading torrent file" showAction "downloading torrent file"
showOutput showOutput
createAnnexDirectory (parentDir torrent) createAnnexDirectory (takeDirectory torrent)
if isTorrentMagnetUrl u if isTorrentMagnetUrl u
then do then do
tmpdir <- tmpTorrentDir u tmpdir <- tmpTorrentDir u

View file

@ -143,7 +143,7 @@ finalizeStoreGeneric :: FilePath -> FilePath -> IO ()
finalizeStoreGeneric tmp dest = do finalizeStoreGeneric tmp dest = do
void $ tryIO $ allowWrite dest -- may already exist void $ tryIO $ allowWrite dest -- may already exist
void $ tryIO $ removeDirectoryRecursive dest -- or not exist void $ tryIO $ removeDirectoryRecursive dest -- or not exist
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (takeDirectory dest)
renameDirectory tmp dest renameDirectory tmp dest
-- may fail on some filesystems -- may fail on some filesystems
void $ tryIO $ do void $ tryIO $ do

View file

@ -315,7 +315,7 @@ store r rsyncopts
void $ tryIO $ createDirectoryIfMissing True tmpdir void $ tryIO $ createDirectoryIfMissing True tmpdir
let tmpf = tmpdir </> keyFile k let tmpf = tmpdir </> keyFile k
meteredWriteFile p tmpf b meteredWriteFile p tmpf b
let destdir = parentDir $ gCryptLocation r k let destdir = takeDirectory $ gCryptLocation r k
Remote.Directory.finalizeStoreGeneric tmpdir destdir Remote.Directory.finalizeStoreGeneric tmpdir destdir
return True return True
| Git.repoIsSsh (repo r) = if isShell r | Git.repoIsSsh (repo r) = if isShell r
@ -340,7 +340,7 @@ retrieve r rsyncopts
remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover
remove r rsyncopts k remove r rsyncopts k
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $
liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k)) liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (takeDirectory (gCryptLocation r k))
| Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync | Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
| otherwise = unsupportedUrl | otherwise = unsupportedUrl
where where

View file

@ -556,7 +556,7 @@ rsyncOrCopyFile rsyncparams src dest p =
ifM (sameDeviceIds src dest) (docopy, dorsync) ifM (sameDeviceIds src dest) (docopy, dorsync)
where where
sameDeviceIds a b = (==) <$> getDeviceId a <*> getDeviceId b sameDeviceIds a b = (==) <$> getDeviceId a <*> getDeviceId b
getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f) getDeviceId f = deviceID <$> liftIO (getFileStatus $ takeDirectory f)
docopy = liftIO $ bracket docopy = liftIO $ bracket
(forkIO $ watchfilesize zeroBytesProcessed) (forkIO $ watchfilesize zeroBytesProcessed)
(void . tryIO . killThread) (void . tryIO . killThread)

View file

@ -161,7 +161,7 @@ rsyncSetup mu _ c = do
store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool
store o k src meterupdate = withRsyncScratchDir $ \tmp -> do store o k src meterupdate = withRsyncScratchDir $ \tmp -> do
let dest = tmp </> Prelude.head (keyPaths k) let dest = tmp </> Prelude.head (keyPaths k)
liftIO $ createDirectoryIfMissing True $ parentDir dest liftIO $ createDirectoryIfMissing True $ takeDirectory dest
ok <- liftIO $ if canrename ok <- liftIO $ if canrename
then do then do
rename src dest rename src dest
@ -214,7 +214,7 @@ remove o k = do
- traverses directories. -} - traverses directories. -}
includes = concatMap use annexHashes includes = concatMap use annexHashes
use h = let dir = h k in use h = let dir = h k in
[ parentDir dir [ takeDirectory dir
, dir , dir
-- match content directory and anything in it -- match content directory and anything in it
, dir </> keyFile k </> "***" , dir </> keyFile k </> "***"

View file

@ -153,7 +153,7 @@ tahoeConfigure configdir furl mscs = do
createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool
createClient configdir furl = do createClient configdir furl = do
createDirectoryIfMissing True (parentDir configdir) createDirectoryIfMissing True (takeDirectory configdir)
boolTahoe configdir "create-client" boolTahoe configdir "create-client"
[ Param "--nickname", Param "git-annex" [ Param "--nickname", Param "git-annex"
, Param "--introducer", Param furl , Param "--introducer", Param furl

View file

@ -1071,7 +1071,7 @@ test_uncommitted_conflict_resolution = do
withtmpclonerepo False $ \r2 -> do withtmpclonerepo False $ \r2 -> do
indir r1 $ do indir r1 $ do
disconnectOrigin disconnectOrigin
createDirectoryIfMissing True (parentDir remoteconflictor) createDirectoryIfMissing True (takeDirectory remoteconflictor)
writeFile remoteconflictor annexedcontent writeFile remoteconflictor annexedcontent
git_annex "add" [conflictor] @? "add remoteconflicter failed" git_annex "add" [conflictor] @? "add remoteconflicter failed"
git_annex "sync" [] @? "sync failed in r1" git_annex "sync" [] @? "sync failed in r1"

View file

@ -73,7 +73,7 @@ moveContent = do
where where
move f = do move f = do
let k = fileKey1 (takeFileName f) let k = fileKey1 (takeFileName f)
let d = parentDir f let d = takeDirectory f
liftIO $ allowWrite d liftIO $ allowWrite d
liftIO $ allowWrite f liftIO $ allowWrite f
moveAnnex k f moveAnnex k f
@ -114,7 +114,7 @@ moveLocationLogs = do
dest <- fromRepo $ logFile2 k dest <- fromRepo $ logFile2 k
dir <- fromRepo Upgrade.V2.gitStateDir dir <- fromRepo Upgrade.V2.gitStateDir
let f = dir </> l let f = dir </> l
liftIO $ createDirectoryIfMissing True (parentDir dest) liftIO $ createDirectoryIfMissing True (takeDirectory dest)
-- could just git mv, but this way deals with -- could just git mv, but this way deals with
-- log files that are not checked into git, -- log files that are not checked into git,
-- as well as merging with already upgraded -- as well as merging with already upgraded

View file

@ -83,7 +83,7 @@ foreground pidfile a = do
- Fails if the pid file is already locked by another process. -} - Fails if the pid file is already locked by another process. -}
lockPidFile :: FilePath -> IO () lockPidFile :: FilePath -> IO ()
lockPidFile pidfile = do lockPidFile pidfile = do
createDirectoryIfMissing True (parentDir pidfile) createDirectoryIfMissing True (takeDirectory pidfile)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags
locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
@ -176,6 +176,6 @@ winLockFile pid pidfile = do
prefix = pidfile ++ "." prefix = pidfile ++ "."
suffix = ".lck" suffix = ".lck"
cleanstale = mapM_ (void . tryIO . removeFile) =<< cleanstale = mapM_ (void . tryIO . removeFile) =<<
(filter iswinlockfile <$> dirContents (parentDir pidfile)) (filter iswinlockfile <$> dirContents (takeDirectory pidfile))
iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
#endif #endif

View file

@ -27,7 +27,6 @@ module Utility.FreeDesktop (
) where ) where
import Utility.Exception import Utility.Exception
import Utility.Path
import Utility.UserInfo import Utility.UserInfo
import Utility.Process import Utility.Process
import Utility.PartialPrelude import Utility.PartialPrelude
@ -79,7 +78,7 @@ buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"
writeDesktopMenuFile :: DesktopEntry -> String -> IO () writeDesktopMenuFile :: DesktopEntry -> String -> IO ()
writeDesktopMenuFile d file = do writeDesktopMenuFile d file = do
createDirectoryIfMissing True (parentDir file) createDirectoryIfMissing True (takeDirectory file)
writeFile file $ buildDesktopMenuFile d writeFile file $ buildDesktopMenuFile d
{- Path to use for a desktop menu file, in either the systemDataDir or {- Path to use for a desktop menu file, in either the systemDataDir or

View file

@ -10,6 +10,7 @@ module Utility.LinuxMkLibs where
import Control.Applicative import Control.Applicative
import Data.Maybe import Data.Maybe
import System.Directory import System.Directory
import System.FilePath
import Data.List.Utils import Data.List.Utils
import System.Posix.Files import System.Posix.Files
import Data.Char import Data.Char
@ -28,14 +29,14 @@ installLib installfile top lib = ifM (doesFileExist lib)
( do ( do
installfile top lib installfile top lib
checksymlink lib checksymlink lib
return $ Just $ parentDir lib return $ Just $ takeDirectory lib
, return Nothing , return Nothing
) )
where where
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
l <- readSymbolicLink (inTop top f) l <- readSymbolicLink (inTop top f)
let absl = absPathFrom (parentDir f) l let absl = absPathFrom (takeDirectory f) l
let target = relPathDirToFile (parentDir f) absl let target = relPathDirToFile (takeDirectory f) absl
installfile top absl installfile top absl
nukeFile (top ++ f) nukeFile (top ++ f)
createSymbolicLink target (inTop top f) createSymbolicLink target (inTop top f)

View file

@ -77,14 +77,12 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
todos = replace "/" "\\" todos = replace "/" "\\"
#endif #endif
{- Returns the parent directory of a path. {- Just the parent directory of a path, or Nothing if the path has no
- - parent (ie for "/") -}
- To allow this to be easily used in loops, which terminate upon reaching the parentDir :: FilePath -> Maybe FilePath
- top, the parent of / is "" -}
parentDir :: FilePath -> FilePath
parentDir dir parentDir dir
| null dirs = "" | null dirs = Nothing
| otherwise = joinDrive drive (join s $ init dirs) | otherwise = Just $ joinDrive drive (join s $ init dirs)
where where
-- on Unix, the drive will be "/" when the dir is absolute, otherwise "" -- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
(drive, path) = splitDrive dir (drive, path) = splitDrive dir
@ -94,8 +92,8 @@ parentDir dir
prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir prop_parentDir_basics dir
| null dir = True | null dir = True
| dir == "/" = parentDir dir == "" | dir == "/" = parentDir dir == Nothing
| otherwise = p /= dir | otherwise = p /= Just dir
where where
p = parentDir dir p = parentDir dir

3
debian/changelog vendored
View file

@ -18,6 +18,9 @@ git-annex (5.20141232) UNRELEASED; urgency=medium
- On Windows, this avoids some of the problems with the absurdly small - On Windows, this avoids some of the problems with the absurdly small
MAX_PATH of 260 bytes. In particular, git-annex repositories should MAX_PATH of 260 bytes. In particular, git-annex repositories should
work in deeper/longer directory structures than before. work in deeper/longer directory structures than before.
* Generate shorter keys for WORM and URL, avoiding keys that are longer
than used for SHA256, so as to not break on systems like Windows that
have very small maximum path length limits.
-- Joey Hess <id@joeyh.name> Fri, 02 Jan 2015 13:35:13 -0400 -- Joey Hess <id@joeyh.name> Fri, 02 Jan 2015 13:35:13 -0400

View file

@ -0,0 +1,13 @@
[[!comment format=mdwn
username="http://joeyh.name/"
subject="comment 1"
date="2015-01-06T17:41:45Z"
content="""
The encrypted content size is not constant, and not known to git-annex.
The only git-annex remote that checks the size in its checkpresent implementation is the web special remote, precisely because it's never encrypted. Also because files on the web change content from time to time and so that needs to be detected.
What would make sense is to extend the reply to `CHECKPRESENT-SUCCESS Key [size]` or perhaps `CHECKPRESENT-SIZE Key size`. git-annex can then compare the value with the key's known size, if any. If the key is encrypted, it would need to skip this check.
Note that chunk keys currently have their keySize inherited from the parent key, and the keyChunkSize of each chunk key is set to the key size. The last chunk of a key will typically be shorter than its keyChunkSize. That would need to be cleaned up.
"""]]

View file

@ -0,0 +1,25 @@
[[!comment format=mdwn
username="http://joeyh.name/"
subject="comment 2"
date="2015-01-06T19:18:26Z"
content="""
On Linux and OSX, there is a maximum filename size, typically 255 bytes. git-annex always ensures that keys it generates are a maximum of 255 bytes long, no matter the platform. But, in dir/subdir/file, each of the 3 segments of the path is allowed to be that long. The limit on the total path size on Linux is a more reasonable 4096 bytes; OSX has only 1024 bytes.
I don't know what to do about Windows having such an absurdly small `MAX_PATH` compared to more modern systems.
The length of just a SHA512 checksum is 128 bytes; that means SHA512 backend cannot be used on windows, at all, since the paths git-annex generates will be at least twice that long, and will easily overflow `PATH_MAX`. I've confirmed this; just adding a file with --backend=SHA512 fails with a \"No such file or directory\" error when it tries to use the path.
A SHA256 is a more manageable 64 bytes long. So a typical path to such an object will end with eg \".git\annex\objects\566\a33\SHA256E--d728a4c4727febe1c28509482ae1b7b2215798218e544eed7cb7b4dc988f838b\SHA256E--d728a4c4727febe1c28509482ae1b7b2215798218e544eed7cb7b4dc988f838b\" -- 174 bytes long (or a bit longer when there are also extension and size in the key) and leaving only 86 bytes or so for `c:\path\to\repo`.
Perhaps git-annex should reduce its maximum key size from 255 to 64 bytes, the same as SHA256. Then url keys would work on Windows, except for in deep paths, where git-annex cannot work at all. This would be an easy change.
git-annex could also avoid using absolute paths, which it currently uses extensively for simplicity (and possiibly robustness against renames of repositories and changes of working directory?), and use relative paths instead. This would probably solve the two examples given in the bug report, and it would make git-annex work better when in a deep path in Windows. It would not make SHA512 work though; with keys that long, the relative path is still too long. (And, it's still possible to get a relative path that has so many '../../' and subdirectories etc that it overflows `PATH_MAX`. It would probably take a really crazy repository directory structure though.)
The MSDN article has one very interesting bit:
> The Windows API has many functions that also have Unicode versions to permit an extended-length path for a maximum total path length of 32,767 characters. This type of path is composed of components separated by backslashes, each up to the value returned in the lpMaximumComponentLength parameter of the GetVolumeInformation function (this value is commonly 255 characters). To specify an extended-length path, use the \"\\?\\" prefix. For example, \"\\?\D:\very long path\".
(It seems that, when using that prefix, `/` is not converted to `\` .. I think git-annex is quite good about getting the slashes the right way round these days.)
So it might be possible for git-annex to use that prefix and avoid this issue entirely. Haskell's FilePath library does understand that prefix (treats it as part of the drive). Since git-annex always uses the path to the top of the Repo when constructing the problimatic FilePaths, I might be able to just change the Repo constructor to add that prefix, and everything follow from that. I tried doing that, unfortunately this makes *git* fail, with \"fatal: relative path syntax cannot be used outside working tree\" when operating on such a repo. Cause git doesn't understand that prefix.
"""]]

View file

@ -0,0 +1,9 @@
[[!comment format=mdwn
username="http://joeyh.name/"
subject="comment 3"
date="2015-01-06T20:51:20Z"
content="""
I've started a `relativepaths` branch that uses all relative paths to the git repo. After working on it for several hours, there are still 16 test suite failures (update: 10) (update: 1). The potential for uncaught breakage is much higher than I am happy with. (Amoung other problems, git-annex does call setCurrentDirectory in several places, and this utterly breaks the relative paths).
Using that branch on windows, I am still unable to add files with --backend=SHA512; even relative paths don't make it short enough for such keys.
"""]]

View file

@ -0,0 +1,9 @@
[[!comment format=mdwn
username="http://joeyh.name/"
subject="comment 4"
date="2015-01-06T21:59:15Z"
content="""
Even with relative paths, Edward's example would use a path of 253 characters, and so a slightly longer url would still break it, even with relative paths.
So, I think reducing url key length needs to be done anyway, and I've done that. Which hardly closes this bug.
"""]]

View file

@ -0,0 +1,13 @@
[[!comment format=mdwn
username="http://joeyh.name/"
subject="comment 7"
date="2015-01-06T17:43:45Z"
content="""
I verified with `eu-readelf --file-header` that the git-annex binary is DYN; ie linked PIE.
It might be that I also need to tell the C compiler to build it with PIE options. I have now updated the build to include that. Please test the new build.
It occurs to me that the problem might be not git-annex, but one of the other binaries, like busybox. Does the android app install to the point that there is a working terminal app with a shell?
It also seems possible that the entire haskell library stack might need to be built with PIE options. If so, that will be a massive pain; I'd need an entire separate autobuilder instance.
"""]]

View file

@ -0,0 +1,7 @@
[[!comment format=mdwn
username="etset"
subject="Still not working"
date="2015-01-06T22:48:18Z"
content="""
The terminal opens, showing the error message at start and at every new opened tab, without a working shell ever appearing.
"""]]

View file

@ -0,0 +1,14 @@
git-annex internally uses all absolute paths all the time.
For a couple of reasons, I'd like it to use relative paths.
The best reason is, it would let a repository be moved while git-annex was
running, without breaking. A lesser reason is that Windows has some
crazy small limit on the length of a path (260 bytes?!), and using relative
paths would avoid hitting it so often.
I tried to do this today, in a `relativepaths` branch. I eventually got the
test suite to pass, but I am very unsure about this change. A lot of random
assumptions broke, and the test suite won't catch them all. In a few
places, git-annex commands do change the current directory, and that
will break with relative paths.
A frustrating day.

View file

@ -0,0 +1,10 @@
[[!comment format=mdwn
username="https://www.google.com/accounts/o8/id?id=AItOawmwjQzWgiD7_I3zw-_91rMRf_6qoThupis"
nickname="Mike"
subject="comment 7"
date="2015-01-06T18:01:40Z"
content="""
Unfortunately, that is not useful for this at all. We are talking about millions of files here, and the issue is leaving behind old hard links, so that program just won't work at all.
Furthermore, this questions has all ready been answered in previous comments.
"""]]

View file

@ -0,0 +1,13 @@
[[!comment format=mdwn
username="https://www.google.com/accounts/o8/id?id=AItOawlcfH7xkyz1kyG_neK4GcFFfFWuIY7l_6A"
nickname="Primiano"
subject="large scale rewrite tips"
date="2015-01-06T22:55:20Z"
content="""
I recently had the need of re-kind-of-annexing an unusually large repo (one of the largest?).
With some tricks and the right code I managed to get it down to 170000 commits in 19 minutes and extracing ~8GB of blobs.
Attaching the link here as I feel it might be helpful for very large projects (where git-filter-branch can become prohibitively slow)
[https://www.primianotucci.com/blog/large-scale-git-history-rewrites](https://www.primianotucci.com/blog/large-scale-git-history-rewrites)
"""]]

View file

@ -1,9 +0,0 @@
[[!comment format=mdwn
username="edward"
subject="URL backend file paths hit the 260 character file path limit on Windows"
date="2014-12-08T19:13:39Z"
content="""
It isn't possible to checkout a git annex repository on Windows that includes quvi videos because the file path is often greater than 260 characters.
See [[bugs/\"git-annex: direct: 1 failed\" on Windows]].
"""]]

View file

@ -3,6 +3,12 @@ usable!
## status ## status
* There can be problems when the git-annex repository is in a deep
or long path. Ie, `C:\loooooooooooooooooongdir\`.
[Details here](http://git-annex.branchable.com/bugs/__34__git-annex:_direct:_1_failed__34___on_Windows)
Workaround: Put your git-annex repo in `C:\annex` or some similar short
path if possible.
* XMPP library not yet built. (See below.) * XMPP library not yet built. (See below.)
* Local pairing seems to fail, after acking on Linux box, it stalls. * Local pairing seems to fail, after acking on Linux box, it stalls.