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 2020-10-29 12:02:46 -04:00
parent b05015f772
commit f45ad178cb
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
31 changed files with 175 additions and 158 deletions

View file

@ -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,10 +51,12 @@ 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
liftIO $ withFile f AppendMode $ \h -> L8.hPutStrLn h c
setAnnexFilePerm f
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
-- | Modifies a log file.
--
@ -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.

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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. -}