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:
parent
b05015f772
commit
f45ad178cb
31 changed files with 175 additions and 158 deletions
28
Logs/File.hs
28
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,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.
|
||||
|
|
|
@ -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. -}
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue