more RawFilePath conversion
At 318/645 after 4k lines of changes This commit was sponsored by Jake Vosloo on Patreon.
This commit is contained in:
Joey Hess
parent
b05015f772
commit
f45ad178cb
31 changed files with 175 additions and 158 deletions
1
Annex.hs
1
Annex.hs
|
|
@ -74,7 +74,6 @@ import qualified Database.Keys.Handle as Keys
|
|||
import Utility.InodeCache
|
||||
import Utility.Url
|
||||
import Utility.ResourcePool
|
||||
import Utility.Path.AbsRel
|
||||
|
||||
import "mtl" Control.Monad.Reader
|
||||
import Control.Concurrent
|
||||
|
|
|
|||
|
|
@ -90,8 +90,8 @@ withWorkTreeRelated :: FilePath -> Annex a -> Annex a
|
|||
withWorkTreeRelated d a = withAltRepo modrepo unmodrepo (const a)
|
||||
where
|
||||
modrepo g = liftIO $ do
|
||||
g' <- addGitEnv g "GIT_COMMON_DIR"
|
||||
=<< absPath (fromRawFilePath (localGitDir g))
|
||||
g' <- addGitEnv g "GIT_COMMON_DIR" . fromRawFilePath
|
||||
=<< absPath (localGitDir g)
|
||||
g'' <- addGitEnv g' "GIT_DIR" d
|
||||
return (g'' { gitEnvOverridesGitDir = True }, ())
|
||||
unmodrepo g g' = g'
|
||||
|
|
|
|||
|
|
@ -50,11 +50,11 @@ setJournalFile :: Journalable content => JournalLocked -> RawFilePath -> content
|
|||
setJournalFile _jl file content = withOtherTmp $ \tmp -> do
|
||||
createAnnexDirectory =<< fromRepo gitAnnexJournalDir
|
||||
-- journal file is written atomically
|
||||
jfile <- fromRawFilePath <$> fromRepo (journalFile file)
|
||||
let tmpfile = tmp </> takeFileName jfile
|
||||
jfile <- fromRepo (journalFile file)
|
||||
let tmpfile = fromRawFilePath (tmp P.</> P.takeFileName jfile)
|
||||
liftIO $ do
|
||||
withFile tmpfile WriteMode $ \h -> writeJournalHandle h content
|
||||
moveFile tmpfile jfile
|
||||
moveFile tmpfile (fromRawFilePath jfile)
|
||||
|
||||
{- Gets any journalled content for a file in the branch. -}
|
||||
getJournalFile :: JournalLocked -> RawFilePath -> Annex (Maybe L.ByteString)
|
||||
|
|
@ -82,19 +82,19 @@ getJournalledFilesStale :: Annex [FilePath]
|
|||
getJournalledFilesStale = do
|
||||
g <- gitRepo
|
||||
fs <- liftIO $ catchDefaultIO [] $
|
||||
getDirectoryContents $ gitAnnexJournalDir g
|
||||
getDirectoryContents $ fromRawFilePath $ gitAnnexJournalDir g
|
||||
return $ filter (`notElem` [".", ".."]) $
|
||||
map (fromRawFilePath . fileJournal . toRawFilePath) fs
|
||||
|
||||
withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a
|
||||
withJournalHandle a = do
|
||||
d <- fromRepo gitAnnexJournalDir
|
||||
d <- fromRawFilePath <$> fromRepo gitAnnexJournalDir
|
||||
bracketIO (openDirectory d) closeDirectory (liftIO . a)
|
||||
|
||||
{- Checks if there are changes in the journal. -}
|
||||
journalDirty :: Annex Bool
|
||||
journalDirty = do
|
||||
d <- fromRepo gitAnnexJournalDir
|
||||
d <- fromRawFilePath <$> fromRepo gitAnnexJournalDir
|
||||
liftIO $
|
||||
(not <$> isDirectoryEmpty d)
|
||||
`catchIO` (const $ doesDirectoryExist d)
|
||||
|
|
|
|||
|
|
@ -108,7 +108,6 @@ import qualified Git.Types as Git
|
|||
import Git.FilePath
|
||||
import Annex.DirHashes
|
||||
import Annex.Fixup
|
||||
import Utility.Path.AbsRel
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
{- Conventions:
|
||||
|
|
@ -240,18 +239,18 @@ gitAnnexContentLock key r config = do
|
|||
|
||||
{- File that maps from a key to the file(s) in the git repository.
|
||||
- Used in direct mode. -}
|
||||
gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath
|
||||
gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
|
||||
gitAnnexMapping key r config = do
|
||||
loc <- gitAnnexLocation key r config
|
||||
return $ fromRawFilePath loc ++ ".map"
|
||||
return $ loc <> ".map"
|
||||
|
||||
{- File that caches information about a key's content, used to determine
|
||||
- if a file has changed.
|
||||
- Used in direct mode. -}
|
||||
gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath
|
||||
gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
|
||||
gitAnnexInodeCache key r config = do
|
||||
loc <- gitAnnexLocation key r config
|
||||
return $ fromRawFilePath loc ++ ".cache"
|
||||
return $ loc <> ".cache"
|
||||
|
||||
gitAnnexInodeSentinal :: Git.Repo -> RawFilePath
|
||||
gitAnnexInodeSentinal r = gitAnnexDir r P.</> "sentinal"
|
||||
|
|
@ -273,22 +272,23 @@ gitAnnexTmpObjectDir :: Git.Repo -> FilePath
|
|||
gitAnnexTmpObjectDir = fromRawFilePath . gitAnnexTmpObjectDir'
|
||||
|
||||
gitAnnexTmpObjectDir' :: Git.Repo -> RawFilePath
|
||||
gitAnnexTmpObjectDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "tmp"
|
||||
gitAnnexTmpObjectDir' r = P.addTrailingPathSeparator $
|
||||
gitAnnexDir r P.</> "tmp"
|
||||
|
||||
{- .git/annex/othertmp/ is used for other temp files -}
|
||||
gitAnnexTmpOtherDir :: Git.Repo -> FilePath
|
||||
gitAnnexTmpOtherDir r = fromRawFilePath $
|
||||
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "othertmp"
|
||||
gitAnnexTmpOtherDir :: Git.Repo -> RawFilePath
|
||||
gitAnnexTmpOtherDir r = P.addTrailingPathSeparator $
|
||||
gitAnnexDir r P.</> "othertmp"
|
||||
|
||||
{- Lock file for gitAnnexTmpOtherDir. -}
|
||||
gitAnnexTmpOtherLock :: Git.Repo -> FilePath
|
||||
gitAnnexTmpOtherLock r = fromRawFilePath $ gitAnnexDir r P.</> "othertmp.lck"
|
||||
gitAnnexTmpOtherLock :: Git.Repo -> RawFilePath
|
||||
gitAnnexTmpOtherLock r = gitAnnexDir r P.</> "othertmp.lck"
|
||||
|
||||
{- .git/annex/misctmp/ was used by old versions of git-annex and is still
|
||||
- used during initialization -}
|
||||
gitAnnexTmpOtherDirOld :: Git.Repo -> FilePath
|
||||
gitAnnexTmpOtherDirOld r = fromRawFilePath $
|
||||
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "misctmp"
|
||||
gitAnnexTmpOtherDirOld :: Git.Repo -> RawFilePath
|
||||
gitAnnexTmpOtherDirOld r = P.addTrailingPathSeparator $
|
||||
gitAnnexDir r P.</> "misctmp"
|
||||
|
||||
{- .git/annex/watchtmp/ is used by the watcher and assistant -}
|
||||
gitAnnexTmpWatcherDir :: Git.Repo -> FilePath
|
||||
|
|
@ -323,9 +323,8 @@ gitAnnexBadLocation :: Key -> Git.Repo -> FilePath
|
|||
gitAnnexBadLocation key r = gitAnnexBadDir r </> fromRawFilePath (keyFile key)
|
||||
|
||||
{- .git/annex/foounused is used to number possibly unused keys -}
|
||||
gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath
|
||||
gitAnnexUnusedLog prefix r =
|
||||
fromRawFilePath (gitAnnexDir r) </> (prefix ++ "unused")
|
||||
gitAnnexUnusedLog :: RawFilePath -> Git.Repo -> RawFilePath
|
||||
gitAnnexUnusedLog prefix r = gitAnnexDir r P.</> (prefix <> "unused")
|
||||
|
||||
{- .git/annex/keysdb/ contains a database of information about keys. -}
|
||||
gitAnnexKeysDb :: Git.Repo -> FilePath
|
||||
|
|
@ -342,29 +341,28 @@ gitAnnexKeysDbIndexCache r = gitAnnexKeysDb r ++ ".cache"
|
|||
|
||||
{- .git/annex/fsck/uuid/ is used to store information about incremental
|
||||
- fscks. -}
|
||||
gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath
|
||||
gitAnnexFsckDir u r = fromRawFilePath $
|
||||
gitAnnexDir r P.</> "fsck" P.</> fromUUID u
|
||||
gitAnnexFsckDir :: UUID -> Git.Repo -> RawFilePath
|
||||
gitAnnexFsckDir u r = gitAnnexDir r P.</> "fsck" P.</> fromUUID u
|
||||
|
||||
{- used to store information about incremental fscks. -}
|
||||
gitAnnexFsckState :: UUID -> Git.Repo -> FilePath
|
||||
gitAnnexFsckState u r = gitAnnexFsckDir u r </> "state"
|
||||
gitAnnexFsckState :: UUID -> Git.Repo -> RawFilePath
|
||||
gitAnnexFsckState u r = gitAnnexFsckDir u r P.</> "state"
|
||||
|
||||
{- Directory containing database used to record fsck info. -}
|
||||
gitAnnexFsckDbDir :: UUID -> Git.Repo -> FilePath
|
||||
gitAnnexFsckDbDir u r = gitAnnexFsckDir u r </> "fsckdb"
|
||||
gitAnnexFsckDbDir :: UUID -> Git.Repo -> RawFilePath
|
||||
gitAnnexFsckDbDir u r = gitAnnexFsckDir u r P.</> "fsckdb"
|
||||
|
||||
{- Directory containing old database used to record fsck info. -}
|
||||
gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> FilePath
|
||||
gitAnnexFsckDbDirOld u r = gitAnnexFsckDir u r </> "db"
|
||||
gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> RawFilePath
|
||||
gitAnnexFsckDbDirOld u r = gitAnnexFsckDir u r P.</> "db"
|
||||
|
||||
{- Lock file for the fsck database. -}
|
||||
gitAnnexFsckDbLock :: UUID -> Git.Repo -> FilePath
|
||||
gitAnnexFsckDbLock u r = gitAnnexFsckDir u r </> "fsck.lck"
|
||||
gitAnnexFsckDbLock :: UUID -> Git.Repo -> RawFilePath
|
||||
gitAnnexFsckDbLock u r = gitAnnexFsckDir u r P.</> "fsck.lck"
|
||||
|
||||
{- .git/annex/fsckresults/uuid is used to store results of git fscks -}
|
||||
gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath
|
||||
gitAnnexFsckResultsLog u r = fromRawFilePath $
|
||||
gitAnnexFsckResultsLog :: UUID -> Git.Repo -> RawFilePath
|
||||
gitAnnexFsckResultsLog u r =
|
||||
gitAnnexDir r P.</> "fsckresults" P.</> fromUUID u
|
||||
|
||||
{- .git/annex/smudge.log is used to log smudges worktree files that need to
|
||||
|
|
@ -372,8 +370,8 @@ gitAnnexFsckResultsLog u r = fromRawFilePath $
|
|||
gitAnnexSmudgeLog :: Git.Repo -> FilePath
|
||||
gitAnnexSmudgeLog r = fromRawFilePath $ gitAnnexDir r P.</> "smudge.log"
|
||||
|
||||
gitAnnexSmudgeLock :: Git.Repo -> FilePath
|
||||
gitAnnexSmudgeLock r = fromRawFilePath $ gitAnnexDir r P.</> "smudge.lck"
|
||||
gitAnnexSmudgeLock :: Git.Repo -> RawFilePath
|
||||
gitAnnexSmudgeLock r = gitAnnexDir r P.</> "smudge.lck"
|
||||
|
||||
{- .git/annex/move.log is used to log moves that are in progress,
|
||||
- to better support resuming an interrupted move. -}
|
||||
|
|
@ -451,27 +449,28 @@ gitAnnexMergeDir r = fromRawFilePath $
|
|||
|
||||
{- .git/annex/transfer/ is used to record keys currently
|
||||
- being transferred, and other transfer bookkeeping info. -}
|
||||
gitAnnexTransferDir :: Git.Repo -> FilePath
|
||||
gitAnnexTransferDir r = fromRawFilePath $
|
||||
gitAnnexTransferDir :: Git.Repo -> RawFilePath
|
||||
gitAnnexTransferDir r =
|
||||
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "transfer"
|
||||
|
||||
{- .git/annex/journal/ is used to journal changes made to the git-annex
|
||||
- branch -}
|
||||
gitAnnexJournalDir :: Git.Repo -> FilePath
|
||||
gitAnnexJournalDir r = fromRawFilePath $
|
||||
gitAnnexJournalDir :: Git.Repo -> RawFilePath
|
||||
gitAnnexJournalDir r =
|
||||
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal"
|
||||
|
||||
gitAnnexJournalDir' :: Git.Repo -> RawFilePath
|
||||
gitAnnexJournalDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal"
|
||||
gitAnnexJournalDir' r =
|
||||
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal"
|
||||
|
||||
{- Lock file for the journal. -}
|
||||
gitAnnexJournalLock :: Git.Repo -> FilePath
|
||||
gitAnnexJournalLock r = fromRawFilePath $ gitAnnexDir r P.</> "journal.lck"
|
||||
gitAnnexJournalLock :: Git.Repo -> RawFilePath
|
||||
gitAnnexJournalLock r = gitAnnexDir r P.</> "journal.lck"
|
||||
|
||||
{- Lock file for flushing a git queue that writes to the git index or
|
||||
- other git state that should only have one writer at a time. -}
|
||||
gitAnnexGitQueueLock :: Git.Repo -> FilePath
|
||||
gitAnnexGitQueueLock r = fromRawFilePath $ gitAnnexDir r P.</> "gitqueue.lck"
|
||||
gitAnnexGitQueueLock :: Git.Repo -> RawFilePath
|
||||
gitAnnexGitQueueLock r = gitAnnexDir r P.</> "gitqueue.lck"
|
||||
|
||||
{- Lock file for direct mode merge. -}
|
||||
gitAnnexMergeLock :: Git.Repo -> FilePath
|
||||
|
|
@ -493,8 +492,8 @@ gitAnnexViewIndex :: Git.Repo -> FilePath
|
|||
gitAnnexViewIndex r = fromRawFilePath $ gitAnnexDir r P.</> "viewindex"
|
||||
|
||||
{- File containing a log of recently accessed views. -}
|
||||
gitAnnexViewLog :: Git.Repo -> FilePath
|
||||
gitAnnexViewLog r = fromRawFilePath $ gitAnnexDir r P.</> "viewlog"
|
||||
gitAnnexViewLog :: Git.Repo -> RawFilePath
|
||||
gitAnnexViewLog r = gitAnnexDir r P.</> "viewlog"
|
||||
|
||||
{- List of refs that have already been merged into the git-annex branch. -}
|
||||
gitAnnexMergedRefs :: Git.Repo -> FilePath
|
||||
|
|
@ -539,9 +538,8 @@ gitAnnexTmpCfgFile :: Git.Repo -> FilePath
|
|||
gitAnnexTmpCfgFile r = fromRawFilePath $ gitAnnexDir r P.</> "config.tmp"
|
||||
|
||||
{- .git/annex/ssh/ is used for ssh connection caching -}
|
||||
gitAnnexSshDir :: Git.Repo -> FilePath
|
||||
gitAnnexSshDir r = fromRawFilePath $
|
||||
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "ssh"
|
||||
gitAnnexSshDir :: Git.Repo -> RawFilePath
|
||||
gitAnnexSshDir r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "ssh"
|
||||
|
||||
{- .git/annex/remotes/ is used for remote-specific state. -}
|
||||
gitAnnexRemotesDir :: Git.Repo -> RawFilePath
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ import Annex.Tmp
|
|||
import Annex.Perms
|
||||
import Git
|
||||
import Utility.Tmp.Dir
|
||||
import Utility.Directory.Create
|
||||
#ifndef mingw32_HOST_OS
|
||||
import Utility.Path.Max
|
||||
#endif
|
||||
|
|
@ -30,7 +31,7 @@ replaceGitAnnexDirFile = replaceFile createAnnexDirectory
|
|||
{- replaceFile on a file located inside the .git directory. -}
|
||||
replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a
|
||||
replaceGitDirFile = replaceFile $ \dir -> do
|
||||
top <- fromRawFilePath <$> fromRepo localGitDir
|
||||
top <- fromRepo localGitDir
|
||||
liftIO $ createDirectoryUnder top dir
|
||||
|
||||
{- replaceFile on a worktree file. -}
|
||||
|
|
@ -52,29 +53,30 @@ replaceWorkTreeFile = replaceFile createWorkTreeDirectory
|
|||
- The createdirectory action is only run when moving the file into place
|
||||
- fails, and can create any parent directory structure needed.
|
||||
-}
|
||||
replaceFile :: (FilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a
|
||||
replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a
|
||||
replaceFile createdirectory file action = withOtherTmp $ \othertmpdir -> do
|
||||
let othertmpdir' = fromRawFilePath othertmpdir
|
||||
#ifndef mingw32_HOST_OS
|
||||
-- Use part of the filename as the template for the temp
|
||||
-- directory. This does not need to be unique, but it
|
||||
-- makes it more clear what this temp directory is for.
|
||||
filemax <- liftIO $ fileNameLengthLimit othertmpdir
|
||||
filemax <- liftIO $ fileNameLengthLimit othertmpdir'
|
||||
let basetmp = take (filemax `div` 2) (takeFileName file)
|
||||
#else
|
||||
-- Windows has limits on the whole path length, so keep
|
||||
-- it short.
|
||||
let basetmp = "t"
|
||||
#endif
|
||||
withTmpDirIn othertmpdir basetmp $ \tmpdir -> do
|
||||
withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do
|
||||
let tmpfile = tmpdir </> basetmp
|
||||
r <- action tmpfile
|
||||
replaceFileFrom tmpfile file createdirectory
|
||||
return r
|
||||
|
||||
replaceFileFrom :: FilePath -> FilePath -> (FilePath -> Annex ()) -> Annex ()
|
||||
replaceFileFrom :: FilePath -> FilePath -> (RawFilePath -> Annex ()) -> Annex ()
|
||||
replaceFileFrom src dest createdirectory = go `catchIO` fallback
|
||||
where
|
||||
go = liftIO $ moveFile src dest
|
||||
fallback _ = do
|
||||
createdirectory (parentDir dest)
|
||||
createdirectory (parentDir (toRawFilePath dest))
|
||||
go
|
||||
|
|
|
|||
42
Annex/Ssh.hs
42
Annex/Ssh.hs
|
|
@ -38,6 +38,7 @@ import Annex.Concurrent.Utility
|
|||
import Types.Concurrency
|
||||
import Git.Env
|
||||
import Git.Ssh
|
||||
import qualified Utility.RawFilePath as R
|
||||
import Annex.Perms
|
||||
#ifndef mingw32_HOST_OS
|
||||
import Annex.LockPool
|
||||
|
|
@ -45,6 +46,7 @@ import Annex.LockPool
|
|||
|
||||
import Control.Concurrent.STM
|
||||
import qualified Data.ByteString as S
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
{- Some ssh commands are fed stdin on a pipe and so should be allowed to
|
||||
- consume it. But ssh commands that are not piped stdin should generally
|
||||
|
|
@ -102,9 +104,11 @@ sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandPar
|
|||
sshCachingInfo (host, port) = go =<< sshCacheDir'
|
||||
where
|
||||
go (Right dir) =
|
||||
liftIO (bestSocketPath $ dir </> hostport2socket host port) >>= return . \case
|
||||
liftIO (bestSocketPath $ dir P.</> hostport2socket host port) >>= return . \case
|
||||
Nothing -> (Nothing, [])
|
||||
Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile)
|
||||
Just socketfile ->
|
||||
let socketfile' = fromRawFilePath socketfile
|
||||
in (Just socketfile', sshConnectionCachingParams socketfile')
|
||||
-- No connection caching with concurrency is not a good
|
||||
-- combination, so warn the user.
|
||||
go (Left whynocaching) = do
|
||||
|
|
@ -130,20 +134,20 @@ sshCachingInfo (host, port) = go =<< sshCacheDir'
|
|||
- file.
|
||||
-
|
||||
- If no path can be constructed that is a valid socket, returns Nothing. -}
|
||||
bestSocketPath :: FilePath -> IO (Maybe FilePath)
|
||||
bestSocketPath :: RawFilePath -> IO (Maybe RawFilePath)
|
||||
bestSocketPath abssocketfile = do
|
||||
relsocketfile <- liftIO $ relPathCwdToFile abssocketfile
|
||||
let socketfile = if length abssocketfile <= length relsocketfile
|
||||
let socketfile = if S.length abssocketfile <= S.length relsocketfile
|
||||
then abssocketfile
|
||||
else relsocketfile
|
||||
return $ if valid_unix_socket_path (socketfile ++ sshgarbage)
|
||||
return $ if valid_unix_socket_path socketfile sshgarbagelen
|
||||
then Just socketfile
|
||||
else Nothing
|
||||
where
|
||||
-- ssh appends a 16 char extension to the socket when setting it
|
||||
-- up, which needs to be taken into account when checking
|
||||
-- that a valid socket was constructed.
|
||||
sshgarbage = replicate (1+16) 'X'
|
||||
sshgarbagelen = 1+16
|
||||
|
||||
sshConnectionCachingParams :: FilePath -> [CommandParam]
|
||||
sshConnectionCachingParams socketfile =
|
||||
|
|
@ -160,10 +164,10 @@ sshSocketDirEnv = "GIT_ANNEX_SSH_SOCKET_DIR"
|
|||
-
|
||||
- The directory will be created if it does not exist.
|
||||
-}
|
||||
sshCacheDir :: Annex (Maybe FilePath)
|
||||
sshCacheDir :: Annex (Maybe RawFilePath)
|
||||
sshCacheDir = eitherToMaybe <$> sshCacheDir'
|
||||
|
||||
sshCacheDir' :: Annex (Either String FilePath)
|
||||
sshCacheDir' :: Annex (Either String RawFilePath)
|
||||
sshCacheDir' =
|
||||
ifM (fromMaybe BuildInfo.sshconnectioncaching . annexSshCaching <$> Annex.getGitConfig)
|
||||
( ifM crippledFileSystem
|
||||
|
|
@ -186,7 +190,7 @@ sshCacheDir' =
|
|||
usetmpdir tmpdir = do
|
||||
let socktmp = tmpdir </> "ssh"
|
||||
createDirectoryIfMissing True socktmp
|
||||
return socktmp
|
||||
return (toRawFilePath socktmp)
|
||||
|
||||
crippledfswarning = unwords
|
||||
[ "This repository is on a crippled filesystem, so unix named"
|
||||
|
|
@ -285,9 +289,9 @@ enumSocketFiles :: Annex [FilePath]
|
|||
enumSocketFiles = liftIO . go =<< sshCacheDir
|
||||
where
|
||||
go Nothing = return []
|
||||
go (Just dir) = filterM (doesFileExist . socket2lock)
|
||||
go (Just dir) = filterM (R.doesPathExist . socket2lock)
|
||||
=<< filter (not . isLock)
|
||||
<$> catchDefaultIO [] (dirContents dir)
|
||||
<$> catchDefaultIO [] (dirContents (fromRawFilePath dir))
|
||||
|
||||
{- Stop any unused ssh connection caching processes. -}
|
||||
sshCleanup :: Annex ()
|
||||
|
|
@ -339,19 +343,19 @@ forceStopSsh socketfile = withNullHandle $ \nullh -> do
|
|||
- of the path to a socket file. At the same time, it needs to be unique
|
||||
- for each host.
|
||||
-}
|
||||
hostport2socket :: SshHost -> Maybe Integer -> FilePath
|
||||
hostport2socket :: SshHost -> Maybe Integer -> RawFilePath
|
||||
hostport2socket host Nothing = hostport2socket' $ fromSshHost host
|
||||
hostport2socket host (Just port) = hostport2socket' $
|
||||
fromSshHost host ++ "!" ++ show port
|
||||
hostport2socket' :: String -> FilePath
|
||||
hostport2socket' :: String -> RawFilePath
|
||||
hostport2socket' s
|
||||
| length s > lengthofmd5s = show $ md5 $ encodeBL s
|
||||
| otherwise = s
|
||||
| length s > lengthofmd5s = toRawFilePath $ show $ md5 $ encodeBL s
|
||||
| otherwise = toRawFilePath s
|
||||
where
|
||||
lengthofmd5s = 32
|
||||
|
||||
socket2lock :: FilePath -> FilePath
|
||||
socket2lock socket = socket ++ lockExt
|
||||
socket2lock :: FilePath -> RawFilePath
|
||||
socket2lock socket = toRawFilePath (socket ++ lockExt)
|
||||
|
||||
isLock :: FilePath -> Bool
|
||||
isLock f = lockExt `isSuffixOf` f
|
||||
|
|
@ -369,8 +373,8 @@ sizeof_sockaddr_un_sun_path = 100
|
|||
|
||||
{- Note that this looks at the true length of the path in bytes, as it will
|
||||
- appear on disk. -}
|
||||
valid_unix_socket_path :: FilePath -> Bool
|
||||
valid_unix_socket_path f = S.length (encodeBS f) < sizeof_sockaddr_un_sun_path
|
||||
valid_unix_socket_path :: RawFilePath -> Int -> Bool
|
||||
valid_unix_socket_path f n = S.length f + n < sizeof_sockaddr_un_sun_path
|
||||
|
||||
{- Parses the SSH port, and returns the other OpenSSH options. If
|
||||
- several ports are found, the last one takes precedence. -}
|
||||
|
|
|
|||
10
Annex/Tmp.hs
10
Annex/Tmp.hs
|
|
@ -21,7 +21,7 @@ import Data.Time.Clock.POSIX
|
|||
-- directory that is passed to it. However, once the action is done,
|
||||
-- any files left in that directory may be cleaned up by another process at
|
||||
-- any time.
|
||||
withOtherTmp :: (FilePath -> Annex a) -> Annex a
|
||||
withOtherTmp :: (RawFilePath -> Annex a) -> Annex a
|
||||
withOtherTmp a = do
|
||||
Annex.addCleanup OtherTmpCleanup cleanupOtherTmp
|
||||
tmpdir <- fromRepo gitAnnexTmpOtherDir
|
||||
|
|
@ -38,14 +38,14 @@ withOtherTmp a = do
|
|||
-- Unlike withOtherTmp, this does not rely on locking working.
|
||||
-- Its main use is in situations where the state of lockfile is not
|
||||
-- determined yet, eg during initialization.
|
||||
withEventuallyCleanedOtherTmp :: (FilePath -> Annex a) -> Annex a
|
||||
withEventuallyCleanedOtherTmp :: (RawFilePath -> Annex a) -> Annex a
|
||||
withEventuallyCleanedOtherTmp = bracket setup cleanup
|
||||
where
|
||||
setup = do
|
||||
tmpdir <- fromRepo gitAnnexTmpOtherDirOld
|
||||
void $ createAnnexDirectory tmpdir
|
||||
return tmpdir
|
||||
cleanup = liftIO . void . tryIO . removeDirectory
|
||||
cleanup = liftIO . void . tryIO . removeDirectory . fromRawFilePath
|
||||
|
||||
-- | Cleans up any tmp files that were left by a previous
|
||||
-- git-annex process that got interrupted or failed to clean up after
|
||||
|
|
@ -56,9 +56,9 @@ cleanupOtherTmp :: Annex ()
|
|||
cleanupOtherTmp = do
|
||||
tmplck <- fromRepo gitAnnexTmpOtherLock
|
||||
void $ tryIO $ tryExclusiveLock (const tmplck) $ do
|
||||
tmpdir <- fromRepo gitAnnexTmpOtherDir
|
||||
tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
|
||||
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
|
||||
oldtmp <- fromRepo gitAnnexTmpOtherDirOld
|
||||
oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld
|
||||
liftIO $ mapM_ cleanold =<< dirContentsRecursive oldtmp
|
||||
liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty
|
||||
where
|
||||
|
|
|
|||
|
|
@ -10,9 +10,13 @@
|
|||
|
||||
module Assistant.Install.Menu where
|
||||
|
||||
import Common
|
||||
|
||||
import Utility.FreeDesktop
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.Path
|
||||
|
||||
import System.IO
|
||||
import Utility.SystemDirectory
|
||||
import System.FilePath
|
||||
|
||||
installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
|
||||
#ifdef darwin_HOST_OS
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ import Utility.DebugLocks as X
|
|||
import Utility.SafeCommand as X
|
||||
import Utility.Process as X
|
||||
import Utility.Path as X
|
||||
import Utility.Path.AbsRel as X
|
||||
import Utility.Directory as X
|
||||
import Utility.Monad as X
|
||||
import Utility.Data as X
|
||||
|
|
|
|||
|
|
@ -9,8 +9,10 @@
|
|||
|
||||
module Config.Files where
|
||||
|
||||
import Common
|
||||
import Utility.FreeDesktop
|
||||
import Utility.Exception
|
||||
|
||||
import System.FilePath
|
||||
|
||||
{- ~/.config/git-annex/file -}
|
||||
userConfigFile :: FilePath -> IO FilePath
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ module Config.Files.AutoStart where
|
|||
import Common
|
||||
import Config.Files
|
||||
import Utility.Tmp
|
||||
import Utility.Path.AbsRel
|
||||
|
||||
{- Returns anything listed in the autostart file (which may not exist). -}
|
||||
readAutoStartFile :: IO [FilePath]
|
||||
|
|
|
|||
|
|
@ -62,13 +62,13 @@ newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go
|
|||
go = do
|
||||
removedb =<< fromRepo (gitAnnexFsckDbDir u)
|
||||
removedb =<< fromRepo (gitAnnexFsckDbDirOld u)
|
||||
removedb = liftIO . void . tryIO . removeDirectoryRecursive
|
||||
removedb = liftIO . void . tryIO . removeDirectoryRecursive . fromRawFilePath
|
||||
|
||||
{- Opens the database, creating it if it doesn't exist yet. -}
|
||||
openDb :: UUID -> Annex FsckHandle
|
||||
openDb u = do
|
||||
dbdir <- fromRepo (gitAnnexFsckDbDir u)
|
||||
let db = dbdir </> "db"
|
||||
let db = fromRawFilePath dbdir </> "db"
|
||||
unlessM (liftIO $ doesFileExist db) $ do
|
||||
initDb db $ void $
|
||||
runMigrationSilent migrateFsck
|
||||
|
|
|
|||
1
Git.hs
1
Git.hs
|
|
@ -47,7 +47,6 @@ import qualified System.FilePath.ByteString as P
|
|||
|
||||
import Common
|
||||
import Git.Types
|
||||
import Utility.Path.AbsRel
|
||||
#ifndef mingw32_HOST_OS
|
||||
import Utility.FileMode
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -10,7 +10,6 @@ module Git.CheckAttr where
|
|||
import Common
|
||||
import Git
|
||||
import Git.Command
|
||||
import Utility.Path.AbsRel
|
||||
import qualified Utility.CoProcess as CoProcess
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
|
|
|
|||
|
|
@ -23,7 +23,6 @@ import qualified Git.Command
|
|||
import qualified Git.Construct
|
||||
import Utility.UserInfo
|
||||
import Utility.ThreadScheduler
|
||||
import Utility.Path.AbsRel
|
||||
|
||||
{- Returns a single git config setting, or a fallback value if not set. -}
|
||||
get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
|
||||
|
|
|
|||
|
|
@ -38,7 +38,6 @@ import Git.Remote
|
|||
import Git.FilePath
|
||||
import qualified Git.Url as Url
|
||||
import Utility.UserInfo
|
||||
import Utility.Path.AbsRel
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ import Git.Construct
|
|||
import qualified Git.Config
|
||||
import Utility.Env
|
||||
import Utility.Env.Set
|
||||
import Utility.Path.AbsRel
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ module Git.FilePath (
|
|||
|
||||
import Common
|
||||
import Git
|
||||
import Utility.Path.AbsRel
|
||||
|
||||
import qualified System.FilePath.ByteString as P
|
||||
import qualified System.FilePath.Posix.ByteString
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ import Git.Command
|
|||
import Git.Types
|
||||
import qualified Utility.CoProcess as CoProcess
|
||||
import Utility.Tmp
|
||||
import Utility.Path.AbsRel
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ import Common
|
|||
import Git
|
||||
import Utility.Env
|
||||
import Utility.Env.Set
|
||||
import Utility.Path.AbsRel
|
||||
|
||||
indexEnv :: String
|
||||
indexEnv = "GIT_INDEX_FILE"
|
||||
|
|
|
|||
|
|
@ -37,7 +37,6 @@ import Git.Sha
|
|||
import Utility.InodeCache
|
||||
import Utility.TimeStamp
|
||||
import Utility.Attoparsec
|
||||
import Utility.Path.AbsRel
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import System.Posix.Types
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ module Git.Version (
|
|||
GitVersion,
|
||||
) where
|
||||
|
||||
import Common
|
||||
import Utility.Process
|
||||
import Utility.DottedVersion
|
||||
|
||||
type GitVersion = DottedVersion
|
||||
|
|
|
|||
24
Logs/File.hs
24
Logs/File.hs
|
|
@ -29,8 +29,8 @@ import qualified Data.ByteString.Lazy.Char8 as L8
|
|||
-- | Writes content to a file, replacing the file atomically, and
|
||||
-- making the new file have whatever permissions the git repository is
|
||||
-- configured to use. Creates the parent directory when necessary.
|
||||
writeLogFile :: FilePath -> String -> Annex ()
|
||||
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c
|
||||
writeLogFile :: RawFilePath -> String -> Annex ()
|
||||
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (fromRawFilePath f) c
|
||||
where
|
||||
writelog f' c' = do
|
||||
liftIO $ writeFile f' c'
|
||||
|
|
@ -38,10 +38,10 @@ writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c
|
|||
|
||||
-- | Runs the action with a handle connected to a temp file.
|
||||
-- The temp file replaces the log file once the action succeeds.
|
||||
withLogHandle :: FilePath -> (Handle -> Annex a) -> Annex a
|
||||
withLogHandle :: RawFilePath -> (Handle -> Annex a) -> Annex a
|
||||
withLogHandle f a = do
|
||||
createAnnexDirectory (parentDir f)
|
||||
replaceGitAnnexDirFile f $ \tmp ->
|
||||
replaceGitAnnexDirFile (fromRawFilePath f) $ \tmp ->
|
||||
bracket (setup tmp) cleanup a
|
||||
where
|
||||
setup tmp = do
|
||||
|
|
@ -51,8 +51,10 @@ withLogHandle f a = do
|
|||
|
||||
-- | Appends a line to a log file, first locking it to prevent
|
||||
-- concurrent writers.
|
||||
appendLogFile :: FilePath -> (Git.Repo -> FilePath) -> L.ByteString -> Annex ()
|
||||
appendLogFile f lck c = createDirWhenNeeded f $ withExclusiveLock lck $ do
|
||||
appendLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> L.ByteString -> Annex ()
|
||||
appendLogFile f lck c =
|
||||
createDirWhenNeeded (toRawFilePath f) $
|
||||
withExclusiveLock lck $ do
|
||||
liftIO $ withFile f AppendMode $ \h -> L8.hPutStrLn h c
|
||||
setAnnexFilePerm f
|
||||
|
||||
|
|
@ -64,13 +66,13 @@ appendLogFile f lck c = createDirWhenNeeded f $ withExclusiveLock lck $ do
|
|||
--
|
||||
-- The file is locked to prevent concurrent writers, and it is written
|
||||
-- atomically.
|
||||
modifyLogFile :: FilePath -> (Git.Repo -> FilePath) -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
|
||||
modifyLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
|
||||
modifyLogFile f lck modf = withExclusiveLock lck $ do
|
||||
ls <- liftIO $ fromMaybe []
|
||||
<$> tryWhenExists (L8.lines <$> L.readFile f)
|
||||
let ls' = modf ls
|
||||
when (ls' /= ls) $
|
||||
createDirWhenNeeded f $
|
||||
createDirWhenNeeded (toRawFilePath f) $
|
||||
viaTmp writelog f (L8.unlines ls')
|
||||
where
|
||||
writelog f' b = do
|
||||
|
|
@ -83,7 +85,7 @@ modifyLogFile f lck modf = withExclusiveLock lck $ do
|
|||
-- action is concurrently modifying the file. It does not lock the file,
|
||||
-- for speed, but instead relies on the fact that a log file usually
|
||||
-- ends in a newline.
|
||||
checkLogFile :: FilePath -> (Git.Repo -> FilePath) -> (L.ByteString -> Bool) -> Annex Bool
|
||||
checkLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> (L.ByteString -> Bool) -> Annex Bool
|
||||
checkLogFile f lck matchf = withExclusiveLock lck $ bracket setup cleanup go
|
||||
where
|
||||
setup = liftIO $ tryWhenExists $ openFile f ReadMode
|
||||
|
|
@ -117,7 +119,7 @@ fullLines = go []
|
|||
--
|
||||
-- Locking is used to prevent writes to to the log file while this
|
||||
-- is running.
|
||||
streamLogFile :: FilePath -> (Git.Repo -> FilePath) -> (String -> Annex ()) -> Annex ()
|
||||
streamLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> (String -> Annex ()) -> Annex ()
|
||||
streamLogFile f lck a = withExclusiveLock lck $ bracketOnError setup cleanup go
|
||||
where
|
||||
setup = liftIO $ tryWhenExists $ openFile f ReadMode
|
||||
|
|
@ -130,7 +132,7 @@ streamLogFile f lck a = withExclusiveLock lck $ bracketOnError setup cleanup go
|
|||
liftIO $ writeFile f ""
|
||||
setAnnexFilePerm f
|
||||
|
||||
createDirWhenNeeded :: FilePath -> Annex () -> Annex ()
|
||||
createDirWhenNeeded :: RawFilePath -> Annex () -> Annex ()
|
||||
createDirWhenNeeded f a = a `catchNonAsync` \_e -> do
|
||||
-- Most of the time, the directory will exist, so this is only
|
||||
-- done if writing the file fails.
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ import Annex.Common
|
|||
import Git.Fsck
|
||||
import Git.Types
|
||||
import Logs.File
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import qualified Data.Set as S
|
||||
|
||||
|
|
@ -24,7 +25,8 @@ writeFsckResults u fsckresults = do
|
|||
case fsckresults of
|
||||
FsckFailed -> store S.empty False logfile
|
||||
FsckFoundMissing s t
|
||||
| S.null s -> liftIO $ removeWhenExistsWith removeLink logfile
|
||||
| S.null s -> liftIO $
|
||||
removeWhenExistsWith R.removeLink logfile
|
||||
| otherwise -> store s t logfile
|
||||
where
|
||||
store s t logfile = writeLogFile logfile $ serialize s t
|
||||
|
|
@ -38,7 +40,7 @@ readFsckResults :: UUID -> Annex FsckResults
|
|||
readFsckResults u = do
|
||||
logfile <- fromRepo $ gitAnnexFsckResultsLog u
|
||||
liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $
|
||||
deserialize . lines <$> readFile logfile
|
||||
deserialize . lines <$> readFile (fromRawFilePath logfile)
|
||||
where
|
||||
deserialize ("truncated":ls) = deserialize' ls True
|
||||
deserialize ls = deserialize' ls False
|
||||
|
|
@ -47,6 +49,6 @@ readFsckResults u = do
|
|||
in if S.null s then FsckFailed else FsckFoundMissing s t
|
||||
|
||||
clearFsckResults :: UUID -> Annex ()
|
||||
clearFsckResults = liftIO . removeWhenExistsWith removeLink
|
||||
clearFsckResults = liftIO . removeWhenExistsWith R.removeLink
|
||||
<=< fromRepo . gitAnnexFsckResultsLog
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Logs.Transfer where
|
||||
|
|
@ -19,6 +20,7 @@ import Utility.PID
|
|||
import Annex.LockPool
|
||||
import Utility.TimeStamp
|
||||
import Logs.File
|
||||
import qualified Utility.RawFilePath as R
|
||||
#ifndef mingw32_HOST_OS
|
||||
import Annex.Perms
|
||||
#endif
|
||||
|
|
@ -26,6 +28,8 @@ import Annex.Perms
|
|||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
import Control.Concurrent
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
describeTransfer :: Transfer -> TransferInfo -> String
|
||||
describeTransfer t info = unwords
|
||||
|
|
@ -56,12 +60,12 @@ percentComplete t info =
|
|||
- which should be run after locking the transfer lock file, but
|
||||
- before using the callback, and a MVar that can be used to read
|
||||
- the number of bytesComplete. -}
|
||||
mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath, Annex (), MVar Integer)
|
||||
mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, RawFilePath, Annex (), MVar Integer)
|
||||
mkProgressUpdater t info = do
|
||||
tfile <- fromRepo $ transferFile t
|
||||
let createtfile = void $ tryNonAsync $ writeTransferInfoFile info tfile
|
||||
mvar <- liftIO $ newMVar 0
|
||||
return (liftIO . updater tfile mvar, tfile, createtfile, mvar)
|
||||
return (liftIO . updater (fromRawFilePath tfile) mvar, tfile, createtfile, mvar)
|
||||
where
|
||||
updater tfile mvar b = modifyMVar_ mvar $ \oldbytes -> do
|
||||
let newbytes = fromBytesProcessed b
|
||||
|
|
@ -103,13 +107,13 @@ checkTransfer t = debugLocks $ do
|
|||
tfile <- fromRepo $ transferFile t
|
||||
let lck = transferLockFile tfile
|
||||
let cleanstale = do
|
||||
void $ tryIO $ removeFile tfile
|
||||
void $ tryIO $ removeFile lck
|
||||
void $ tryIO $ R.removeLink tfile
|
||||
void $ tryIO $ R.removeLink lck
|
||||
#ifndef mingw32_HOST_OS
|
||||
v <- getLockStatus lck
|
||||
case v of
|
||||
StatusLockedBy pid -> liftIO $ catchDefaultIO Nothing $
|
||||
readTransferInfoFile (Just pid) tfile
|
||||
readTransferInfoFile (Just pid) (fromRawFilePath tfile)
|
||||
_ -> do
|
||||
-- Take a non-blocking lock while deleting
|
||||
-- the stale lock file. Ignore failure
|
||||
|
|
@ -145,7 +149,7 @@ getTransfers' dirs wanted = do
|
|||
infos <- mapM checkTransfer transfers
|
||||
return $ mapMaybe running $ zip transfers infos
|
||||
where
|
||||
findfiles = liftIO . mapM dirContentsRecursive
|
||||
findfiles = liftIO . mapM (dirContentsRecursive . fromRawFilePath)
|
||||
=<< mapM (fromRepo . transferDir) dirs
|
||||
running (t, Just i) = Just (t, i)
|
||||
running (_, Nothing) = Nothing
|
||||
|
|
@ -172,7 +176,7 @@ getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles
|
|||
return $ case (mt, mi) of
|
||||
(Just t, Just i) -> Just (t, i)
|
||||
_ -> Nothing
|
||||
findfiles = liftIO . mapM dirContentsRecursive
|
||||
findfiles = liftIO . mapM (dirContentsRecursive . fromRawFilePath)
|
||||
=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]
|
||||
|
||||
clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
|
||||
|
|
@ -184,7 +188,7 @@ clearFailedTransfers u = do
|
|||
removeFailedTransfer :: Transfer -> Annex ()
|
||||
removeFailedTransfer t = do
|
||||
f <- fromRepo $ failedTransferFile t
|
||||
liftIO $ void $ tryIO $ removeFile f
|
||||
liftIO $ void $ tryIO $ R.removeLink f
|
||||
|
||||
recordFailedTransfer :: Transfer -> TransferInfo -> Annex ()
|
||||
recordFailedTransfer t info = do
|
||||
|
|
@ -192,20 +196,23 @@ recordFailedTransfer t info = do
|
|||
writeTransferInfoFile info failedtfile
|
||||
|
||||
{- The transfer information file to use for a given Transfer. -}
|
||||
transferFile :: Transfer -> Git.Repo -> FilePath
|
||||
transferFile (Transfer direction u kd) r = transferDir direction r
|
||||
</> filter (/= '/') (fromUUID u)
|
||||
</> fromRawFilePath (keyFile (mkKey (const kd)))
|
||||
transferFile :: Transfer -> Git.Repo -> RawFilePath
|
||||
transferFile (Transfer direction u kd) r =
|
||||
transferDir direction r
|
||||
P.</> B8.filter (/= '/') (fromUUID u)
|
||||
P.</> keyFile (mkKey (const kd))
|
||||
|
||||
{- The transfer information file to use to record a failed Transfer -}
|
||||
failedTransferFile :: Transfer -> Git.Repo -> FilePath
|
||||
failedTransferFile (Transfer direction u kd) r = failedTransferDir u direction r
|
||||
</> fromRawFilePath (keyFile (mkKey (const kd)))
|
||||
failedTransferFile :: Transfer -> Git.Repo -> RawFilePath
|
||||
failedTransferFile (Transfer direction u kd) r =
|
||||
failedTransferDir u direction r
|
||||
P.</> keyFile (mkKey (const kd))
|
||||
|
||||
{- The transfer lock file corresponding to a given transfer info file. -}
|
||||
transferLockFile :: FilePath -> FilePath
|
||||
transferLockFile infofile = let (d,f) = splitFileName infofile in
|
||||
combine d ("lck." ++ f)
|
||||
transferLockFile :: RawFilePath -> RawFilePath
|
||||
transferLockFile infofile =
|
||||
let (d, f) = P.splitFileName infofile
|
||||
in P.combine d ("lck." <> f)
|
||||
|
||||
{- Parses a transfer information filename to a Transfer. -}
|
||||
parseTransferFile :: FilePath -> Maybe Transfer
|
||||
|
|
@ -220,7 +227,7 @@ parseTransferFile file
|
|||
where
|
||||
bits = splitDirectories file
|
||||
|
||||
writeTransferInfoFile :: TransferInfo -> FilePath -> Annex ()
|
||||
writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex ()
|
||||
writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
|
||||
|
||||
-- The file keeps whatever permissions it has, so should be used only
|
||||
|
|
@ -286,16 +293,16 @@ readTransferInfo mpid s = TransferInfo
|
|||
else pure Nothing -- not failure
|
||||
|
||||
{- The directory holding transfer information files for a given Direction. -}
|
||||
transferDir :: Direction -> Git.Repo -> FilePath
|
||||
transferDir direction r = gitAnnexTransferDir r </> formatDirection direction
|
||||
transferDir :: Direction -> Git.Repo -> RawFilePath
|
||||
transferDir direction r = gitAnnexTransferDir r P.</> formatDirection direction
|
||||
|
||||
{- The directory holding failed transfer information files for a given
|
||||
- Direction and UUID -}
|
||||
failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath
|
||||
failedTransferDir :: UUID -> Direction -> Git.Repo -> RawFilePath
|
||||
failedTransferDir u direction r = gitAnnexTransferDir r
|
||||
</> "failed"
|
||||
</> formatDirection direction
|
||||
</> filter (/= '/') (fromUUID u)
|
||||
P.</> "failed"
|
||||
P.</> formatDirection direction
|
||||
P.</> B8.filter (/= '/') (fromUUID u)
|
||||
|
||||
prop_read_write_transferinfo :: TransferInfo -> Bool
|
||||
prop_read_write_transferinfo info
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Logs.Unused (
|
||||
UnusedMap,
|
||||
updateUnusedLog,
|
||||
|
|
@ -55,13 +57,13 @@ preserveTimestamps oldl newl = M.intersection (M.unionWith oldts oldl newl) newl
|
|||
where
|
||||
oldts _old@(_, ts) _new@(int, _) = (int, ts)
|
||||
|
||||
updateUnusedLog :: FilePath -> UnusedMap -> Annex ()
|
||||
updateUnusedLog :: RawFilePath -> UnusedMap -> Annex ()
|
||||
updateUnusedLog prefix m = do
|
||||
oldl <- readUnusedLog prefix
|
||||
newl <- preserveTimestamps oldl . flip map2log m <$> liftIO getPOSIXTime
|
||||
writeUnusedLog prefix newl
|
||||
|
||||
writeUnusedLog :: FilePath -> UnusedLog -> Annex ()
|
||||
writeUnusedLog :: RawFilePath -> UnusedLog -> Annex ()
|
||||
writeUnusedLog prefix l = do
|
||||
logfile <- fromRepo $ gitAnnexUnusedLog prefix
|
||||
writeLogFile logfile $ unlines $ map format $ M.toList l
|
||||
|
|
@ -69,9 +71,9 @@ writeUnusedLog prefix l = do
|
|||
format (k, (i, Just t)) = show i ++ " " ++ serializeKey k ++ " " ++ show t
|
||||
format (k, (i, Nothing)) = show i ++ " " ++ serializeKey k
|
||||
|
||||
readUnusedLog :: FilePath -> Annex UnusedLog
|
||||
readUnusedLog :: RawFilePath -> Annex UnusedLog
|
||||
readUnusedLog prefix = do
|
||||
f <- fromRepo $ gitAnnexUnusedLog prefix
|
||||
f <- fromRawFilePath <$> fromRepo (gitAnnexUnusedLog prefix)
|
||||
ifM (liftIO $ doesFileExist f)
|
||||
( M.fromList . mapMaybe parse . lines
|
||||
<$> liftIO (readFileStrict f)
|
||||
|
|
@ -87,13 +89,13 @@ readUnusedLog prefix = do
|
|||
skey = reverse rskey
|
||||
ts = reverse rts
|
||||
|
||||
readUnusedMap :: FilePath -> Annex UnusedMap
|
||||
readUnusedMap :: RawFilePath -> Annex UnusedMap
|
||||
readUnusedMap = log2map <$$> readUnusedLog
|
||||
|
||||
dateUnusedLog :: FilePath -> Annex (Maybe UTCTime)
|
||||
dateUnusedLog :: RawFilePath -> Annex (Maybe UTCTime)
|
||||
dateUnusedLog prefix = do
|
||||
f <- fromRepo $ gitAnnexUnusedLog prefix
|
||||
liftIO $ catchMaybeIO $ getModificationTime f
|
||||
liftIO $ catchMaybeIO $ getModificationTime $ fromRawFilePath f
|
||||
|
||||
{- Set of unused keys. This is cached for speed. -}
|
||||
unusedKeys :: Annex (S.Set Key)
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ removeView v = writeViews =<< filter (/= v) <$> recentViews
|
|||
|
||||
recentViews :: Annex [View]
|
||||
recentViews = do
|
||||
f <- fromRepo gitAnnexViewLog
|
||||
f <- fromRawFilePath <$> fromRepo gitAnnexViewLog
|
||||
liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f)
|
||||
|
||||
{- Gets the currently checked out view, if there is one. -}
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Types.Transfer where
|
||||
|
|
@ -17,6 +18,7 @@ import Utility.QuickCheck
|
|||
import Utility.Url
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Time.Clock.POSIX
|
||||
import Control.Concurrent
|
||||
import Control.Applicative
|
||||
|
|
@ -56,7 +58,7 @@ stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (Associa
|
|||
data Direction = Upload | Download
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
|
||||
formatDirection :: Direction -> String
|
||||
formatDirection :: Direction -> B.ByteString
|
||||
formatDirection Upload = "upload"
|
||||
formatDirection Download = "download"
|
||||
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ import Config
|
|||
import Annex.Perms
|
||||
import Utility.InodeCache
|
||||
import Annex.InodeSentinal
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
setIndirect :: Annex ()
|
||||
setIndirect = do
|
||||
|
|
@ -86,7 +87,7 @@ associatedFiles key = do
|
|||
- the top of the repo. -}
|
||||
associatedFilesRelative :: Key -> Annex [FilePath]
|
||||
associatedFilesRelative key = do
|
||||
mapping <- calcRepo $ gitAnnexMapping key
|
||||
mapping <- fromRawFilePath <$> calcRepo (gitAnnexMapping key)
|
||||
liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h ->
|
||||
-- Read strictly to ensure the file is closed promptly
|
||||
lines <$> hGetContentsStrict h
|
||||
|
|
@ -96,7 +97,7 @@ removeAssociatedFiles :: Key -> Annex ()
|
|||
removeAssociatedFiles key = do
|
||||
mapping <- calcRepo $ gitAnnexMapping key
|
||||
modifyContent mapping $
|
||||
liftIO $ removeWhenExistsWith removeLink mapping
|
||||
liftIO $ removeWhenExistsWith R.removeLink mapping
|
||||
|
||||
{- Checks if a file in the tree, associated with a key, has not been modified.
|
||||
-
|
||||
|
|
@ -116,13 +117,14 @@ goodContent key file =
|
|||
recordedInodeCache :: Key -> Annex [InodeCache]
|
||||
recordedInodeCache key = withInodeCacheFile key $ \f ->
|
||||
liftIO $ catchDefaultIO [] $
|
||||
mapMaybe readInodeCache . lines <$> readFileStrict f
|
||||
mapMaybe readInodeCache . lines
|
||||
<$> readFileStrict (fromRawFilePath f)
|
||||
|
||||
{- Removes an inode cache. -}
|
||||
removeInodeCache :: Key -> Annex ()
|
||||
removeInodeCache key = withInodeCacheFile key $ \f ->
|
||||
modifyContent f $
|
||||
liftIO $ removeWhenExistsWith removeLink f
|
||||
liftIO $ removeWhenExistsWith R.removeLink f
|
||||
|
||||
withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
|
||||
withInodeCacheFile :: Key -> (RawFilePath -> Annex a) -> Annex a
|
||||
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ module Utility.DottedVersion (
|
|||
normalize,
|
||||
) where
|
||||
|
||||
import Common
|
||||
import Utility.Split
|
||||
|
||||
data DottedVersion = DottedVersion String Integer
|
||||
deriving (Eq)
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ import Utility.FileSystemEncoding (RawFilePath)
|
|||
import System.Posix.Files.ByteString
|
||||
import qualified System.Posix.Directory.ByteString as D
|
||||
|
||||
-- | Checks if a file or directoy exists. Note that a dangling symlink
|
||||
-- | Checks if a file or directory exists. Note that a dangling symlink
|
||||
-- will be false.
|
||||
doesPathExist :: RawFilePath -> IO Bool
|
||||
doesPathExist = fileExist
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue