more OsPath conversion
Sponsored-by: Jack Hill
This commit is contained in:
parent
a03c609268
commit
c69e57aede
17 changed files with 83 additions and 91 deletions
|
@ -795,6 +795,3 @@ keyPath key hasher = hasher key </> f </> f
|
|||
keyPaths :: Key -> NE.NonEmpty OsPath
|
||||
keyPaths key = NE.map (\h -> keyPath key (h def)) dirHashes
|
||||
|
||||
uuidPath :: UUID -> OsPath
|
||||
uuidPath u = toOsPath (fromUUID u :: SB.ShortByteString)
|
||||
|
||||
|
|
|
@ -26,11 +26,10 @@ import Annex.Perms
|
|||
import Annex.LockPool
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
{- Create a specified lock file, and takes a shared lock, which is retained
|
||||
- in the cache. -}
|
||||
lockFileCached :: RawFilePath -> Annex ()
|
||||
lockFileCached :: OsPath -> Annex ()
|
||||
lockFileCached file = go =<< fromLockCache file
|
||||
where
|
||||
go (Just _) = noop -- already locked
|
||||
|
@ -43,7 +42,7 @@ lockFileCached file = go =<< fromLockCache file
|
|||
#endif
|
||||
changeLockCache $ M.insert file lockhandle
|
||||
|
||||
unlockFile :: RawFilePath -> Annex ()
|
||||
unlockFile :: OsPath -> Annex ()
|
||||
unlockFile file = maybe noop go =<< fromLockCache file
|
||||
where
|
||||
go lockhandle = do
|
||||
|
@ -53,7 +52,7 @@ unlockFile file = maybe noop go =<< fromLockCache file
|
|||
getLockCache :: Annex LockCache
|
||||
getLockCache = getState lockcache
|
||||
|
||||
fromLockCache :: RawFilePath -> Annex (Maybe LockHandle)
|
||||
fromLockCache :: OsPath -> Annex (Maybe LockHandle)
|
||||
fromLockCache file = M.lookup file <$> getLockCache
|
||||
|
||||
changeLockCache :: (LockCache -> LockCache) -> Annex ()
|
||||
|
@ -63,9 +62,9 @@ changeLockCache a = do
|
|||
|
||||
{- Runs an action with a shared lock held. If an exclusive lock is held,
|
||||
- blocks until it becomes free. -}
|
||||
withSharedLock :: RawFilePath -> Annex a -> Annex a
|
||||
withSharedLock :: OsPath -> Annex a -> Annex a
|
||||
withSharedLock lockfile a = debugLocks $ do
|
||||
createAnnexDirectory $ P.takeDirectory lockfile
|
||||
createAnnexDirectory $ takeDirectory lockfile
|
||||
mode <- annexFileMode
|
||||
bracket (lock mode lockfile) (liftIO . dropLock) (const a)
|
||||
where
|
||||
|
@ -77,16 +76,16 @@ withSharedLock lockfile a = debugLocks $ do
|
|||
|
||||
{- Runs an action with an exclusive lock held. If the lock is already
|
||||
- held, blocks until it becomes free. -}
|
||||
withExclusiveLock :: RawFilePath -> Annex a -> Annex a
|
||||
withExclusiveLock :: OsPath -> Annex a -> Annex a
|
||||
withExclusiveLock lockfile a = bracket
|
||||
(takeExclusiveLock lockfile)
|
||||
(liftIO . dropLock)
|
||||
(const a)
|
||||
|
||||
{- Takes an exclusive lock, blocking until it's free. -}
|
||||
takeExclusiveLock :: RawFilePath -> Annex LockHandle
|
||||
takeExclusiveLock :: OsPath -> Annex LockHandle
|
||||
takeExclusiveLock lockfile = debugLocks $ do
|
||||
createAnnexDirectory $ P.takeDirectory lockfile
|
||||
createAnnexDirectory $ takeDirectory lockfile
|
||||
mode <- annexFileMode
|
||||
lock mode lockfile
|
||||
where
|
||||
|
@ -98,9 +97,9 @@ takeExclusiveLock lockfile = debugLocks $ do
|
|||
|
||||
{- Tries to take an exclusive lock and run an action. If the lock is
|
||||
- already held, returns Nothing. -}
|
||||
tryExclusiveLock :: RawFilePath -> Annex a -> Annex (Maybe a)
|
||||
tryExclusiveLock :: OsPath -> Annex a -> Annex (Maybe a)
|
||||
tryExclusiveLock lockfile a = debugLocks $ do
|
||||
createAnnexDirectory $ P.takeDirectory lockfile
|
||||
createAnnexDirectory $ takeDirectory lockfile
|
||||
mode <- annexFileMode
|
||||
bracket (lock mode lockfile) (liftIO . unlock) go
|
||||
where
|
||||
|
@ -118,7 +117,7 @@ tryExclusiveLock lockfile a = debugLocks $ do
|
|||
- Does not create the lock directory or lock file if it does not exist,
|
||||
- taking an exclusive lock will create them.
|
||||
-}
|
||||
trySharedLock :: RawFilePath -> Annex (Maybe LockHandle)
|
||||
trySharedLock :: OsPath -> Annex (Maybe LockHandle)
|
||||
trySharedLock lockfile = debugLocks $
|
||||
#ifndef mingw32_HOST_OS
|
||||
tryLockShared Nothing lockfile
|
||||
|
|
|
@ -24,17 +24,17 @@ import Utility.Directory.Create
|
|||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
{- replaceFile on a file located inside the gitAnnexDir. -}
|
||||
replaceGitAnnexDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceGitAnnexDirFile :: OsPath -> (OsPath -> Annex a) -> Annex a
|
||||
replaceGitAnnexDirFile = replaceFile createAnnexDirectory
|
||||
|
||||
{- replaceFile on a file located inside the .git directory. -}
|
||||
replaceGitDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceGitDirFile :: OsPath -> (OsPath -> Annex a) -> Annex a
|
||||
replaceGitDirFile = replaceFile $ \dir -> do
|
||||
top <- fromRepo localGitDir
|
||||
liftIO $ createDirectoryUnder [top] dir
|
||||
|
||||
{- replaceFile on a worktree file. -}
|
||||
replaceWorkTreeFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceWorkTreeFile :: OsPath -> (OsPath -> Annex a) -> Annex a
|
||||
replaceWorkTreeFile = replaceFile createWorkTreeDirectory
|
||||
|
||||
{- Replaces a possibly already existing file with a new version,
|
||||
|
@ -52,20 +52,20 @@ 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 :: (RawFilePath -> Annex ()) -> RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceFile :: (OsPath -> Annex ()) -> OsPath -> (OsPath -> Annex a) -> Annex a
|
||||
replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action
|
||||
|
||||
replaceFile' :: (RawFilePath -> Annex ()) -> RawFilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceFile' :: (OsPath -> Annex ()) -> OsPath -> (a -> Bool) -> (OsPath -> Annex a) -> Annex a
|
||||
replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do
|
||||
let basetmp = relatedTemplate' (P.takeFileName file)
|
||||
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath basetmp) $ \tmpdir -> do
|
||||
let tmpfile = toRawFilePath tmpdir P.</> basetmp
|
||||
let basetmp = relatedTemplate (fromOsPath (takeFileName file))
|
||||
withTmpDirIn othertmpdir basetmp $ \tmpdir -> do
|
||||
let tmpfile = tmpdir </> basetmp
|
||||
r <- action tmpfile
|
||||
when (checkres r) $
|
||||
replaceFileFrom tmpfile file createdirectory
|
||||
return r
|
||||
|
||||
replaceFileFrom :: RawFilePath -> RawFilePath -> (RawFilePath -> Annex ()) -> Annex ()
|
||||
replaceFileFrom :: OsPath -> OsPath -> (OsPath -> Annex ()) -> Annex ()
|
||||
replaceFileFrom src dest createdirectory = go `catchIO` fallback
|
||||
where
|
||||
go = liftIO $ moveFile src dest
|
||||
|
|
13
Annex/Tmp.hs
13
Annex/Tmp.hs
|
@ -23,7 +23,7 @@ import System.PosixCompat.Files (modificationTime)
|
|||
-- 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 :: (RawFilePath -> Annex a) -> Annex a
|
||||
withOtherTmp :: (OsPath -> Annex a) -> Annex a
|
||||
withOtherTmp a = do
|
||||
Annex.addCleanupAction OtherTmpCleanup cleanupOtherTmp
|
||||
tmpdir <- fromRepo gitAnnexTmpOtherDir
|
||||
|
@ -40,14 +40,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 :: (RawFilePath -> Annex a) -> Annex a
|
||||
withEventuallyCleanedOtherTmp :: (OsPath -> Annex a) -> Annex a
|
||||
withEventuallyCleanedOtherTmp = bracket setup cleanup
|
||||
where
|
||||
setup = do
|
||||
tmpdir <- fromRepo gitAnnexTmpOtherDirOld
|
||||
void $ createAnnexDirectory tmpdir
|
||||
return tmpdir
|
||||
cleanup = liftIO . void . tryIO . removeDirectory . fromRawFilePath
|
||||
cleanup = liftIO . void . tryIO . removeDirectory
|
||||
|
||||
-- | Cleans up any tmp files that were left by a previous
|
||||
-- git-annex process that got interrupted or failed to clean up after
|
||||
|
@ -58,14 +58,13 @@ cleanupOtherTmp :: Annex ()
|
|||
cleanupOtherTmp = do
|
||||
tmplck <- fromRepo gitAnnexTmpOtherLock
|
||||
void $ tryIO $ tryExclusiveLock tmplck $ do
|
||||
tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
|
||||
tmpdir <- fromRepo gitAnnexTmpOtherDir
|
||||
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
|
||||
oldtmp <- fromRepo gitAnnexTmpOtherDirOld
|
||||
liftIO $ mapM_ cleanold
|
||||
liftIO $ mapM_ (cleanold . fromOsPath)
|
||||
=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
|
||||
-- remove when empty
|
||||
liftIO $ void $ tryIO $
|
||||
removeDirectory (fromRawFilePath oldtmp)
|
||||
liftIO $ void $ tryIO $ removeDirectory oldtmp
|
||||
where
|
||||
cleanold f = do
|
||||
now <- liftIO getPOSIXTime
|
||||
|
|
|
@ -98,8 +98,8 @@ AnnexBranch
|
|||
openDb :: Annex ContentIdentifierHandle
|
||||
openDb = do
|
||||
dbdir <- calcRepo' gitAnnexContentIdentifierDbDir
|
||||
let db = dbdir P.</> "db"
|
||||
isnew <- liftIO $ not <$> R.doesPathExist db
|
||||
let db = dbdir </> literalOsPath "db"
|
||||
isnew <- liftIO $ not <$> doesDirectoryPathExist db
|
||||
if isnew
|
||||
then initDb db $ void $
|
||||
runMigrationSilent migrateContentIdentifier
|
||||
|
|
|
@ -33,12 +33,10 @@ import Annex.Locations
|
|||
import Utility.Exception
|
||||
import Annex.Common
|
||||
import Annex.LockFile
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import Database.Persist.Sql hiding (Key)
|
||||
import Database.Persist.TH
|
||||
import Data.Time.Clock
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
data FsckHandle = FsckHandle H.DbQueue UUID
|
||||
|
||||
|
@ -66,14 +64,14 @@ newPass u = do
|
|||
go = do
|
||||
removedb =<< calcRepo' (gitAnnexFsckDbDir u)
|
||||
removedb =<< calcRepo' (gitAnnexFsckDbDirOld u)
|
||||
removedb = liftIO . void . tryIO . removeDirectoryRecursive . fromRawFilePath
|
||||
removedb = liftIO . void . tryIO . removeDirectoryRecursive
|
||||
|
||||
{- Opens the database, creating it if it doesn't exist yet. -}
|
||||
openDb :: UUID -> Annex FsckHandle
|
||||
openDb u = do
|
||||
dbdir <- calcRepo' (gitAnnexFsckDbDir u)
|
||||
let db = dbdir P.</> "db"
|
||||
unlessM (liftIO $ R.doesPathExist db) $ do
|
||||
let db = dbdir </> literalOsPath "db"
|
||||
unlessM (liftIO $ doesDirectoryExist db) $ do
|
||||
initDb db $ void $
|
||||
runMigrationSilent migrateFsck
|
||||
lockFileCached =<< calcRepo' (gitAnnexFsckDbLock u)
|
||||
|
|
|
@ -42,11 +42,9 @@ import Database.Utility
|
|||
import Database.Types
|
||||
import Annex.LockFile
|
||||
import Git.Types
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import Database.Persist.Sql hiding (Key)
|
||||
import Database.Persist.TH
|
||||
import qualified System.FilePath.ByteString as P
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Set as S
|
||||
import Control.Exception
|
||||
|
@ -107,8 +105,8 @@ getRepoSizeHandle = Annex.getState Annex.reposizehandle >>= \case
|
|||
openDb :: Annex RepoSizeHandle
|
||||
openDb = lockDbWhile permerr $ do
|
||||
dbdir <- calcRepo' gitAnnexRepoSizeDbDir
|
||||
let db = dbdir P.</> "db"
|
||||
unlessM (liftIO $ R.doesPathExist db) $ do
|
||||
let db = dbdir </> literalOsPath "db"
|
||||
unlessM (liftIO $ doesDirectoryExist db) $ do
|
||||
initDb db $ void $
|
||||
runMigrationSilent migrateRepoSizes
|
||||
h <- liftIO $ H.openDb db "repo_sizes"
|
||||
|
|
|
@ -95,7 +95,7 @@ explodePacks r = go =<< listPackFiles r
|
|||
f <- relPathDirToFile tmpdir objfile
|
||||
let dest = objectsDir r </> f
|
||||
createDirectoryIfMissing True (parentDir dest)
|
||||
moveFile (fromOsPath objfile) (fromOsPath dest)
|
||||
moveFile objfile dest
|
||||
forM_ packs $ \packfile -> do
|
||||
removeWhenExistsWith R.removeLink (fromOsPath packfile)
|
||||
removeWhenExistsWith R.removeLink (fromOsPath (packIdxFile packfile))
|
||||
|
|
45
Logs/File.hs
45
Logs/File.hs
|
@ -34,16 +34,16 @@ 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 :: RawFilePath -> String -> Annex ()
|
||||
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (toOsPath f) c
|
||||
writeLogFile :: OsPath -> String -> Annex ()
|
||||
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c
|
||||
where
|
||||
writelog tmp c' = do
|
||||
liftIO $ writeFile (fromRawFilePath (fromOsPath tmp)) c'
|
||||
setAnnexFilePerm (fromOsPath tmp)
|
||||
liftIO $ writeFile (fromOsPath tmp) c'
|
||||
setAnnexFilePerm tmp
|
||||
|
||||
-- | Runs the action with a handle connected to a temp file.
|
||||
-- The temp file replaces the log file once the action succeeds.
|
||||
withLogHandle :: RawFilePath -> (Handle -> Annex a) -> Annex a
|
||||
withLogHandle :: OsPath -> (Handle -> Annex a) -> Annex a
|
||||
withLogHandle f a = do
|
||||
createAnnexDirectory (parentDir f)
|
||||
replaceGitAnnexDirFile f $ \tmp ->
|
||||
|
@ -51,16 +51,16 @@ withLogHandle f a = do
|
|||
where
|
||||
setup tmp = do
|
||||
setAnnexFilePerm tmp
|
||||
liftIO $ F.openFile (toOsPath tmp) WriteMode
|
||||
liftIO $ F.openFile tmp WriteMode
|
||||
cleanup h = liftIO $ hClose h
|
||||
|
||||
-- | Appends a line to a log file, first locking it to prevent
|
||||
-- concurrent writers.
|
||||
appendLogFile :: RawFilePath -> RawFilePath -> L.ByteString -> Annex ()
|
||||
appendLogFile :: OsPath -> OsPath -> L.ByteString -> Annex ()
|
||||
appendLogFile f lck c =
|
||||
createDirWhenNeeded f $
|
||||
withExclusiveLock lck $ do
|
||||
liftIO $ F.withFile (toOsPath f) AppendMode $
|
||||
liftIO $ F.withFile f AppendMode $
|
||||
\h -> L8.hPutStrLn h c
|
||||
setAnnexFilePerm f
|
||||
|
||||
|
@ -72,25 +72,24 @@ appendLogFile f lck c =
|
|||
--
|
||||
-- The file is locked to prevent concurrent writers, and it is written
|
||||
-- atomically.
|
||||
modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
|
||||
modifyLogFile :: OsPath -> OsPath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
|
||||
modifyLogFile f lck modf = withExclusiveLock lck $ do
|
||||
ls <- liftIO $ fromMaybe []
|
||||
<$> tryWhenExists (fileLines <$> F.readFile f')
|
||||
<$> tryWhenExists (fileLines <$> F.readFile f)
|
||||
let ls' = modf ls
|
||||
when (ls' /= ls) $
|
||||
createDirWhenNeeded f $
|
||||
viaTmp writelog f' (L8.unlines ls')
|
||||
viaTmp writelog f (L8.unlines ls')
|
||||
where
|
||||
f' = toOsPath f
|
||||
writelog lf b = do
|
||||
liftIO $ F.writeFile lf b
|
||||
setAnnexFilePerm (fromOsPath lf)
|
||||
setAnnexFilePerm lf
|
||||
|
||||
-- | Checks the content of a log file to see if any line matches.
|
||||
checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool
|
||||
checkLogFile :: OsPath -> OsPath -> (L.ByteString -> Bool) -> Annex Bool
|
||||
checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go
|
||||
where
|
||||
setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
|
||||
setup = liftIO $ tryWhenExists $ F.openFile f ReadMode
|
||||
cleanup Nothing = noop
|
||||
cleanup (Just h) = liftIO $ hClose h
|
||||
go Nothing = return False
|
||||
|
@ -99,15 +98,15 @@ checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go
|
|||
return r
|
||||
|
||||
-- | Folds a function over lines of a log file to calculate a value.
|
||||
calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
|
||||
calcLogFile :: OsPath -> OsPath -> t -> (L.ByteString -> t -> t) -> Annex t
|
||||
calcLogFile f lck start update =
|
||||
withSharedLock lck $ calcLogFileUnsafe f start update
|
||||
|
||||
-- | Unsafe version that does not do locking.
|
||||
calcLogFileUnsafe :: RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
|
||||
calcLogFileUnsafe :: OsPath -> t -> (L.ByteString -> t -> t) -> Annex t
|
||||
calcLogFileUnsafe f start update = bracket setup cleanup go
|
||||
where
|
||||
setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
|
||||
setup = liftIO $ tryWhenExists $ F.openFile f ReadMode
|
||||
cleanup Nothing = noop
|
||||
cleanup (Just h) = liftIO $ hClose h
|
||||
go Nothing = return start
|
||||
|
@ -129,19 +128,19 @@ calcLogFileUnsafe f start update = bracket setup cleanup go
|
|||
--
|
||||
-- Locking is used to prevent writes to to the log file while this
|
||||
-- is running.
|
||||
streamLogFile :: RawFilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
|
||||
streamLogFile :: OsPath -> OsPath -> Annex () -> (String -> Annex ()) -> Annex ()
|
||||
streamLogFile f lck finalizer processor =
|
||||
withExclusiveLock lck $ do
|
||||
streamLogFileUnsafe f finalizer processor
|
||||
liftIO $ F.writeFile' (toOsPath f) mempty
|
||||
liftIO $ F.writeFile' f mempty
|
||||
setAnnexFilePerm f
|
||||
|
||||
-- Unsafe version that does not do locking, and does not empty the file
|
||||
-- at the end.
|
||||
streamLogFileUnsafe :: RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
|
||||
streamLogFileUnsafe :: OsPath -> Annex () -> (String -> Annex ()) -> Annex ()
|
||||
streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go
|
||||
where
|
||||
setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
|
||||
setup = liftIO $ tryWhenExists $ F.openFile f ReadMode
|
||||
cleanup Nothing = noop
|
||||
cleanup (Just h) = liftIO $ hClose h
|
||||
go Nothing = finalizer
|
||||
|
@ -150,7 +149,7 @@ streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go
|
|||
liftIO $ hClose h
|
||||
finalizer
|
||||
|
||||
createDirWhenNeeded :: RawFilePath -> Annex () -> Annex ()
|
||||
createDirWhenNeeded :: OsPath -> 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.
|
||||
|
|
|
@ -58,13 +58,13 @@ preserveTimestamps oldl newl = M.intersection (M.unionWith oldts oldl newl) newl
|
|||
where
|
||||
oldts _old@(_, ts) _new@(int, _) = (int, ts)
|
||||
|
||||
updateUnusedLog :: RawFilePath -> UnusedMap -> Annex ()
|
||||
updateUnusedLog :: OsPath -> UnusedMap -> Annex ()
|
||||
updateUnusedLog prefix m = do
|
||||
oldl <- readUnusedLog prefix
|
||||
newl <- preserveTimestamps oldl . flip map2log m <$> liftIO getPOSIXTime
|
||||
writeUnusedLog prefix newl
|
||||
|
||||
writeUnusedLog :: RawFilePath -> UnusedLog -> Annex ()
|
||||
writeUnusedLog :: OsPath -> UnusedLog -> Annex ()
|
||||
writeUnusedLog prefix l = do
|
||||
logfile <- fromRepo $ gitAnnexUnusedLog prefix
|
||||
writeLogFile logfile $ unlines $ map format $ M.toList l
|
||||
|
@ -72,12 +72,12 @@ writeUnusedLog prefix l = do
|
|||
format (k, (i, Just t)) = show i ++ " " ++ serializeKey k ++ " " ++ show t
|
||||
format (k, (i, Nothing)) = show i ++ " " ++ serializeKey k
|
||||
|
||||
readUnusedLog :: RawFilePath -> Annex UnusedLog
|
||||
readUnusedLog :: OsPath -> Annex UnusedLog
|
||||
readUnusedLog prefix = do
|
||||
f <- fromRepo (gitAnnexUnusedLog prefix)
|
||||
ifM (liftIO $ doesFileExist (fromRawFilePath f))
|
||||
ifM (liftIO $ doesFileExist f)
|
||||
( M.fromList . mapMaybe (parse . decodeBS) . fileLines'
|
||||
<$> liftIO (F.readFile' (toOsPath f))
|
||||
<$> liftIO (F.readFile' f)
|
||||
, return M.empty
|
||||
)
|
||||
where
|
||||
|
@ -90,13 +90,13 @@ readUnusedLog prefix = do
|
|||
skey = reverse rskey
|
||||
ts = reverse rts
|
||||
|
||||
readUnusedMap :: RawFilePath -> Annex UnusedMap
|
||||
readUnusedMap :: OsPath -> Annex UnusedMap
|
||||
readUnusedMap = log2map <$$> readUnusedLog
|
||||
|
||||
dateUnusedLog :: RawFilePath -> Annex (Maybe UTCTime)
|
||||
dateUnusedLog :: OsPath -> Annex (Maybe UTCTime)
|
||||
dateUnusedLog prefix = do
|
||||
f <- fromRepo $ gitAnnexUnusedLog prefix
|
||||
liftIO $ catchMaybeIO $ getModificationTime $ fromRawFilePath f
|
||||
liftIO $ catchMaybeIO $ getModificationTime f
|
||||
|
||||
{- Set of unused keys. This is cached for speed. -}
|
||||
unusedKeys :: Annex (S.Set Key)
|
||||
|
@ -104,7 +104,7 @@ unusedKeys = maybe (setUnusedKeys =<< unusedKeys') return
|
|||
=<< Annex.getState Annex.unusedkeys
|
||||
|
||||
unusedKeys' :: Annex [Key]
|
||||
unusedKeys' = M.keys <$> readUnusedLog ""
|
||||
unusedKeys' = M.keys <$> readUnusedLog (literalOsPath "")
|
||||
|
||||
setUnusedKeys :: [Key] -> Annex (S.Set Key)
|
||||
setUnusedKeys ks = do
|
||||
|
|
|
@ -33,9 +33,9 @@ writeUpgradeLog v t = do
|
|||
readUpgradeLog :: Annex [(RepoVersion, POSIXTime)]
|
||||
readUpgradeLog = do
|
||||
logfile <- fromRepo gitAnnexUpgradeLog
|
||||
ifM (liftIO $ doesFileExist (fromRawFilePath logfile))
|
||||
ifM (liftIO $ doesFileExist logfile)
|
||||
( mapMaybe (parse . decodeBS) . fileLines'
|
||||
<$> liftIO (F.readFile' (toOsPath logfile))
|
||||
<$> liftIO (F.readFile' logfile)
|
||||
, return []
|
||||
)
|
||||
where
|
||||
|
|
|
@ -54,7 +54,7 @@ removeView v = writeViews =<< filter (/= v) <$> recentViews
|
|||
|
||||
recentViews :: Annex [View]
|
||||
recentViews = do
|
||||
f <- fromRawFilePath <$> fromRepo gitAnnexViewLog
|
||||
f <- fromOsPath <$> fromRepo gitAnnexViewLog
|
||||
liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f)
|
||||
|
||||
{- Gets the currently checked out view, if there is one.
|
||||
|
|
|
@ -11,7 +11,6 @@
|
|||
module Remote.Helper.Hooks (addHooks) where
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
import Annex.Common
|
||||
import Types.Remote
|
||||
|
@ -51,13 +50,13 @@ addHooks' r starthook stophook = r'
|
|||
runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a
|
||||
runHooks r starthook stophook a = do
|
||||
dir <- fromRepo gitAnnexRemotesDir
|
||||
let lck = dir P.</> remoteid <> ".lck"
|
||||
let lck = dir </> remoteid <> literalOsPath ".lck"
|
||||
whenM (notElem lck . M.keys <$> getLockCache) $ do
|
||||
createAnnexDirectory dir
|
||||
firstrun lck
|
||||
a
|
||||
where
|
||||
remoteid = fromUUID (uuid r)
|
||||
remoteid = uuidPath (uuid r)
|
||||
run Nothing = noop
|
||||
run (Just command) = void $ liftIO $
|
||||
boolSystem "sh" [Param "-c", Param command]
|
||||
|
|
|
@ -13,6 +13,6 @@ module Types.LockCache (
|
|||
import Utility.LockPool (LockHandle)
|
||||
|
||||
import qualified Data.Map as M
|
||||
import System.FilePath.ByteString (RawFilePath)
|
||||
import Utility.OsPath
|
||||
|
||||
type LockCache = M.Map RawFilePath LockHandle
|
||||
type LockCache = M.Map OsPath LockHandle
|
||||
|
|
|
@ -24,6 +24,7 @@ import Git.Types (ConfigValue(..))
|
|||
import Utility.FileSystemEncoding
|
||||
import Utility.QuickCheck
|
||||
import Utility.Aeson
|
||||
import Utility.OsPath
|
||||
import qualified Utility.SimpleProtocol as Proto
|
||||
|
||||
-- A UUID is either an arbitrary opaque string, or UUID info may be missing.
|
||||
|
@ -101,6 +102,9 @@ buildUUID NoUUID = mempty
|
|||
isUUID :: String -> Bool
|
||||
isUUID = isJust . U.fromString
|
||||
|
||||
uuidPath :: UUID -> OsPath
|
||||
uuidPath u = toOsPath (fromUUID u :: SB.ShortByteString)
|
||||
|
||||
-- A description of a UUID.
|
||||
newtype UUIDDesc = UUIDDesc B.ByteString
|
||||
deriving (Eq, Sem.Semigroup, Monoid, IsString)
|
||||
|
|
|
@ -27,21 +27,20 @@ import Utility.SystemDirectory
|
|||
import Utility.Tmp
|
||||
import Utility.Exception
|
||||
import Utility.Monad
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.OsPath
|
||||
import qualified Utility.RawFilePath as R
|
||||
import Author
|
||||
|
||||
{- Moves one filename to another.
|
||||
- First tries a rename, but falls back to moving across devices if needed. -}
|
||||
moveFile :: RawFilePath -> RawFilePath -> IO ()
|
||||
moveFile src dest = tryIO (R.rename src dest) >>= onrename
|
||||
moveFile :: OsPath -> OsPath -> IO ()
|
||||
moveFile src dest = tryIO (renamePath src dest) >>= onrename
|
||||
where
|
||||
onrename (Right _) = noop
|
||||
onrename (Left e)
|
||||
| isPermissionError e = rethrow
|
||||
| isDoesNotExistError e = rethrow
|
||||
| otherwise = viaTmp mv (toOsPath dest) ()
|
||||
| otherwise = viaTmp mv dest ()
|
||||
where
|
||||
rethrow = throwM e
|
||||
|
||||
|
@ -57,8 +56,8 @@ moveFile src dest = tryIO (R.rename src dest) >>= onrename
|
|||
whenM (isdir dest) rethrow
|
||||
ok <- copyright =<< boolSystem "mv"
|
||||
[ Param "-f"
|
||||
, Param (fromRawFilePath src)
|
||||
, Param (fromRawFilePath (fromOsPath tmp))
|
||||
, Param (fromOsPath src)
|
||||
, Param (fromOsPath tmp)
|
||||
]
|
||||
let e' = e
|
||||
#else
|
||||
|
@ -74,7 +73,7 @@ moveFile src dest = tryIO (R.rename src dest) >>= onrename
|
|||
|
||||
#ifndef mingw32_HOST_OS
|
||||
isdir f = do
|
||||
r <- tryIO $ R.getSymbolicLinkStatus f
|
||||
r <- tryIO $ R.getSymbolicLinkStatus (fromOsPath f)
|
||||
case r of
|
||||
(Left _) -> return False
|
||||
(Right s) -> return $ isDirectory s
|
||||
|
|
|
@ -104,7 +104,7 @@ setFileMode p m = do
|
|||
P.setFileMode p' m
|
||||
|
||||
{- Using renamePath rather than the rename provided in unix-compat
|
||||
- because of this bug https://github.com/jacobstanley/unix-compat/issues/56-}
|
||||
- because of this bug https://github.com/jacobstanley/unix-compat/issues/56 -}
|
||||
rename :: RawFilePath -> RawFilePath -> IO ()
|
||||
rename a b = D.renamePath (fromRawFilePath a) (fromRawFilePath b)
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue