more OsPath conversion (749/749)

Builds with and without OsPath build flag.

Unfortunately, the test suite fails.

Sponsored-by: unqueued on Patreon
This commit is contained in:
Joey Hess 2025-02-10 14:57:25 -04:00
parent 20ed039d59
commit c730d00b6e
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
41 changed files with 416 additions and 427 deletions

View file

@ -67,11 +67,10 @@ commitThread = namedThread "Committer" $ do
liftAnnex $ do
-- Clean up anything left behind by a previous process
-- on unclean shutdown.
void $ liftIO $ tryIO $ removeDirectoryRecursive
(fromRawFilePath lockdowndir)
void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir
void $ createAnnexDirectory lockdowndir
waitChangeTime $ \(changes, time) -> do
readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher annexdotfiles delayadd $
readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd $
simplifyChanges changes
if shouldCommit False time (length readychanges) readychanges
then do
@ -276,12 +275,12 @@ commitStaged msg = do
- Any pending adds that are not ready yet are put back into the ChangeChan,
- where they will be retried later.
-}
handleAdds :: FilePath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete
let lockdownconfig = LockDownConfig
{ lockingFile = False
, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
, hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True
}
(postponed, toadd) <- partitionEithers
@ -307,12 +306,13 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
| otherwise = a
checkpointerfile change = do
let file = toRawFilePath $ changeFile change
let file = changeFile change
mk <- liftIO $ isPointerFile file
case mk of
Nothing -> return (Right change)
Just key -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus (fromOsPath file)
liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
return $ Left $ Change
(changeTime change)
@ -328,7 +328,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
else checkmatcher
| otherwise = checkmatcher
where
f = toRawFilePath (changeFile change)
f = changeFile change
checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f)
( return (Left change)
, return (Right change)
@ -336,9 +336,9 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
addsmall [] = noop
addsmall toadd = liftAnnex $ void $ tryIO $
forM (map (toRawFilePath . changeFile) toadd) $ \f ->
forM (map changeFile toadd) $ \f ->
Command.Add.addFile Command.Add.Small f
=<< liftIO (R.getSymbolicLinkStatus f)
=<< liftIO (R.getSymbolicLinkStatus (fromOsPath f))
{- Avoid overhead of re-injesting a renamed unlocked file, by
- examining the other Changes to see if a removed file has the
@ -353,13 +353,13 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
delta <- liftAnnex getTSDelta
let cfg = LockDownConfig
{ lockingFile = False
, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
, hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True
}
if M.null m
then forM toadd (addannexed' cfg)
else forM toadd $ \c -> do
mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta
mcache <- liftIO $ genInodeCache (changeFile c) delta
case mcache of
Nothing -> addannexed' cfg c
Just cache ->
@ -376,19 +376,19 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
(mkey, _mcache) <- liftAnnex $ do
showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput []))
ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing
maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey
maybe (failedingest change) (done change $ keyFilename ks) mkey
addannexed' _ _ = return Nothing
fastadd :: Change -> Key -> Assistant (Maybe Change)
fastadd change key = do
let source = keySource $ lockedDown change
liftAnnex $ finishIngestUnlocked key source
done change (fromRawFilePath $ keyFilename source) key
done change (keyFilename source) key
removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap ct l = do
mks <- forM (filter isRmChange l) $ \c ->
catKeyFile $ toRawFilePath $ changeFile c
catKeyFile $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
@ -401,8 +401,9 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
done change file key = liftAnnex $ do
logStatus NoLiveUpdate key InfoPresent
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file)
stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus (fromOsPath file)
stagePointerFile file mode =<< hashPointerFile key
showEndOk
return $ Just $ finishedChange change key
@ -410,14 +411,14 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
- and is still a hard link to its contentLocation,
- before ingesting it. -}
sanitycheck keysource a = do
fs <- liftIO $ R.getSymbolicLinkStatus $ keyFilename keysource
ks <- liftIO $ R.getSymbolicLinkStatus $ contentLocation keysource
fs <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ keyFilename keysource
ks <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ contentLocation keysource
if deviceID ks == deviceID fs && fileID ks == fileID fs
then a
else do
-- remove the hard link
when (contentLocation keysource /= keyFilename keysource) $
void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation keysource
void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
return Nothing
{- Shown an alert while performing an action to add a file or
@ -430,7 +431,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
- the add succeeded.
-}
addaction [] a = a
addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $
addaction toadd a = alertWhile' (addFileAlert $ map (fromOsPath . changeFile) toadd) $
(,)
<$> pure True
<*> a
@ -440,7 +441,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
-
- Check by running lsof on the repository.
-}
safeToAdd :: FilePath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd :: OsPath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd _ _ _ _ [] [] = return []
safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
maybe noop (liftIO . threadDelaySeconds) delayadd
@ -451,7 +452,8 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
then S.fromList . map fst3 . filter openwrite <$>
findopenfiles (map (keySource . lockedDown) inprocess')
else pure S.empty
let checked = map (check openfiles) inprocess'
let openfiles' = S.map toOsPath openfiles
let checked = map (check openfiles') inprocess'
{- If new events are received when files are closed,
- there's no need to retry any changes that cannot
@ -463,7 +465,7 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
else return checked
where
check openfiles change@(InProcessAddChange { lockedDown = ld })
| S.member (fromRawFilePath (contentLocation (keySource ld))) openfiles = Left change
| S.member (contentLocation (keySource ld)) openfiles = Left change
check _ change = Right change
mkinprocess (c, Just ld) = Just InProcessAddChange
@ -478,7 +480,7 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
<> " still has writers, not adding"
-- remove the hard link
when (contentLocation ks /= keyFilename ks) $
void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks
void $ liftIO $ tryIO $ removeFile $ contentLocation ks
canceladd _ = noop
openwrite (_file, mode, _pid)
@ -498,9 +500,9 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
findopenfiles keysources = ifM crippledFileSystem
( liftIO $ do
let segments = segmentXargsUnordered $
map (fromRawFilePath . keyFilename) keysources
map (fromOsPath . keyFilename) keysources
concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)
, liftIO $ Lsof.queryDir lockdowndir
, liftIO $ Lsof.queryDir (fromOsPath lockdowndir)
)
{- After a Change is committed, queue any necessary transfers or drops
@ -521,5 +523,5 @@ checkChangeContent change@(Change { changeInfo = i }) =
handleDrops "file renamed" present k af []
where
f = changeFile change
af = AssociatedFile (Just (toRawFilePath f))
af = AssociatedFile (Just f)
checkChangeContent _ = noop

View file

@ -44,7 +44,7 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
when (old /= new) $ do
let changedconfigs = new `S.difference` old
debug $ "reloading config" :
map (fromRawFilePath . fst)
map (fromOsPath . fst)
(S.toList changedconfigs)
reloadConfigs new
{- Record a commit to get this config
@ -54,10 +54,10 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
loop new
{- Config files, and their checksums. -}
type Configs = S.Set (RawFilePath, Sha)
type Configs = S.Set (OsPath, Sha)
{- All git-annex's config files, and actions to run when they change. -}
configFilesActions :: [(RawFilePath, Assistant ())]
configFilesActions :: [(OsPath, Assistant ())]
configFilesActions =
[ (uuidLog, void $ liftAnnex uuidDescMapLoad)
, (remoteLog, void $ liftAnnex remotesChanged)
@ -91,5 +91,5 @@ getConfigs :: Assistant Configs
getConfigs = S.fromList . map extract
<$> liftAnnex (inRepo $ LsTree.lsTreeFiles (LsTree.LsTreeLong False) Annex.Branch.fullname files)
where
files = map (fromRawFilePath . fst) configFilesActions
files = map (fromOsPath . fst) configFilesActions
extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)

View file

@ -181,7 +181,7 @@ runActivity urlrenderer activity nowt = do
runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant ()
runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
program <- liftIO programPath
program <- fromOsPath <$> liftIO programPath
g <- liftAnnex gitRepo
fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
void $ batchCommand program (Param "fsck" : annexFsckParams d)
@ -196,7 +196,7 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (r
dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of
Nothing -> go rmt $ do
program <- programPath
program <- fromOsPath <$> programPath
void $ batchCommand program $
[ Param "fsck"
-- avoid downloading files

View file

@ -24,8 +24,7 @@ import qualified Git
import qualified Git.Branch
import qualified Git.Ref
import qualified Command.Sync
import qualified System.FilePath.ByteString as P
import qualified Utility.OsString as OS
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
@ -33,7 +32,7 @@ mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
let gitd = Git.localGitDir g
let dir = gitd P.</> "refs"
let dir = gitd </> literalOsPath "refs"
liftIO $ createDirectoryUnder [gitd] dir
let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange
@ -43,21 +42,21 @@ mergeThread = namedThread "Merger" $ do
, modifyHook = changehook
, errHook = errhook
}
void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
debug ["watching", fromRawFilePath dir]
void $ liftIO $ watchDir dir (const False) True hooks id
debug ["watching", fromOsPath dir]
type Handler = FilePath -> Assistant ()
type Handler t = t -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
onErr :: Handler
onErr :: Handler String
onErr = giveup
{- Called when a new branch ref is written, or a branch ref is modified.
@ -66,9 +65,9 @@ onErr = giveup
- ok; it ensures that any changes pushed since the last time the assistant
- ran are merged in.
-}
onChange :: Handler
onChange :: Handler OsPath
onChange file
| ".lock" `isSuffixOf` file = noop
| literalOsPath ".lock" `OS.isSuffixOf` file = noop
| isAnnexBranch file = do
branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case
@ -112,7 +111,7 @@ onChange file
- to the second branch, which should be merged into it? -}
isRelatedTo :: Git.Ref -> Git.Ref -> Bool
isRelatedTo x y
| basex /= takeDirectory basex ++ "/" ++ basey = False
| basex /= fromOsPath (takeDirectory (toOsPath basex)) ++ "/" ++ basey = False
| "/synced/" `isInfixOf` Git.fromRef x = True
| "refs/remotes/" `isPrefixOf` Git.fromRef x = True
| otherwise = False
@ -120,12 +119,12 @@ isRelatedTo x y
basex = Git.fromRef $ Git.Ref.base x
basey = Git.fromRef $ Git.Ref.base y
isAnnexBranch :: FilePath -> Bool
isAnnexBranch f = n `isSuffixOf` f
isAnnexBranch :: OsPath -> Bool
isAnnexBranch f = n `isSuffixOf` fromOsPath f
where
n = '/' : Git.fromRef Annex.Branch.name
fileToBranch :: FilePath -> Git.Ref
fileToBranch f = Git.Ref $ encodeBS $ "refs" </> base
fileToBranch :: OsPath -> Git.Ref
fileToBranch f = Git.Ref $ fromOsPath $ literalOsPath "refs" </> toOsPath base
where
base = Prelude.last $ split "/refs/" f
base = Prelude.last $ split "/refs/" (fromOsPath f)

View file

@ -138,12 +138,12 @@ pollingThread urlrenderer = go =<< liftIO currentMountPoints
handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant ()
handleMounts urlrenderer wasmounted nowmounted =
mapM_ (handleMount urlrenderer . mnt_dir) $
mapM_ (handleMount urlrenderer . toOsPath . mnt_dir) $
S.toList $ newMountPoints wasmounted nowmounted
handleMount :: UrlRenderer -> FilePath -> Assistant ()
handleMount :: UrlRenderer -> OsPath -> Assistant ()
handleMount urlrenderer dir = do
debug ["detected mount of", dir]
debug ["detected mount of", fromOsPath dir]
rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo)
=<< remotesUnder dir
mapM_ (fsckNudge urlrenderer . Just) rs
@ -157,7 +157,7 @@ handleMount urlrenderer dir = do
- at startup time, or may have changed (it could even be a different
- repository at the same remote location..)
-}
remotesUnder :: FilePath -> Assistant [Remote]
remotesUnder :: OsPath -> Assistant [Remote]
remotesUnder dir = do
repotop <- liftAnnex $ fromRepo Git.repoPath
rs <- liftAnnex remoteList
@ -169,7 +169,7 @@ remotesUnder dir = do
return $ mapMaybe snd $ filter fst pairs
where
checkremote repotop r = case Remote.localpath r of
Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) ->
Just p | dirContains dir (absPathFrom repotop p) ->
(,) <$> pure True <*> updateRemote r
_ -> return (False, Just r)

View file

@ -121,7 +121,7 @@ pairReqReceived False urlrenderer msg = do
pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
pairAckReceived True (Just pip) msg cache = do
stopSending pip
repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo
repodir <- repoPath <$> liftAnnex gitRepo
liftIO $ setupAuthorizedKeys msg repodir
finishedLocalPairing msg (inProgressSshKeyPair pip)
startSending pip PairDone $ multicastPairMsg

View file

@ -28,7 +28,7 @@ import qualified Data.Set as S
remoteControlThread :: NamedThread
remoteControlThread = namedThread "RemoteControl" $ do
program <- liftIO programPath
program <- liftIO $ fromOsPath <$> programPath
(cmd, params) <- liftIO $ toBatchCommand
(program, [Param "remotedaemon", Param "--foreground"])
let p = proc cmd (toCommand params)

View file

@ -68,7 +68,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
ifM (not <$> liftAnnex (inRepo checkIndexFast))
( do
debug ["corrupt index file found at startup; removing and restaging"]
liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile
liftAnnex $ inRepo $ removeWhenExistsWith removeFile . indexFile
{- Normally the startup scan avoids re-staging files,
- but with the index deleted, everything needs to be
- restaged. -}
@ -82,7 +82,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
- will be automatically regenerated. -}
unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do
debug ["corrupt annex/index file found at startup; removing"]
liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex
liftAnnex $ liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexIndex
{- Fix up ssh remotes set up by past versions of the assistant. -}
liftIO $ fixUpSshRemotes
@ -154,13 +154,13 @@ dailyCheck urlrenderer = do
batchmaker <- liftIO getBatchCommandMaker
-- Find old unstaged symlinks, and add them to git.
(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False ["."] g
(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False [literalOsPath "."] g
now <- liftIO getPOSIXTime
forM_ unstaged $ \file -> do
ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file
ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file
case ms of
Just s | toonew (statusChangeTime s) now -> noop
| isSymbolicLink s -> addsymlink (fromRawFilePath file) ms
| isSymbolicLink s -> addsymlink file ms
_ -> noop
liftIO $ void cleanup
@ -182,7 +182,7 @@ dailyCheck urlrenderer = do
{- Run git-annex unused once per day. This is run as a separate
- process to stay out of the annex monad and so it can run as a
- batch job. -}
program <- liftIO programPath
program <- fromOsPath <$> liftIO programPath
let (program', params') = batchmaker (program, [Param "unused"])
void $ liftIO $ boolSystem program' params'
{- Invalidate unused keys cache, and queue transfers of all unused
@ -202,7 +202,7 @@ dailyCheck urlrenderer = do
void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do
Watcher.runHandler Watcher.onAddSymlink file s
insanity $ "found unstaged symlink: " ++ file
insanity $ "found unstaged symlink: " ++ fromOsPath file
hourlyCheck :: Assistant ()
hourlyCheck = do
@ -222,14 +222,14 @@ hourlyCheck = do
-}
checkLogSize :: Int -> Assistant ()
checkLogSize n = do
f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs f
totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs
f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs (fromOsPath f)
totalsize <- liftIO $ sum <$> mapM (getFileSize . toOsPath) logs
when (totalsize > 2 * oneMegabyte) $ do
debug ["Rotated logs due to size:", show totalsize]
liftIO $ openLog f >>= handleToFd >>= redirLog
liftIO $ openLog (fromOsPath f) >>= handleToFd >>= redirLog
when (n < maxLogs + 1) $ do
df <- liftIO $ getDiskFree $ takeDirectory f
df <- liftIO $ getDiskFree $ fromOsPath $ takeDirectory f
case df of
Just free
| free < fromIntegral totalsize ->
@ -270,5 +270,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
checkRepoExists :: Assistant ()
checkRepoExists = do
g <- liftAnnex gitRepo
liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $
liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $
terminateSelf

View file

@ -38,26 +38,26 @@ transferWatcherThread = namedThread "TransferWatcher" $ do
, modifyHook = modifyhook
, errHook = errhook
}
void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
void $ liftIO $ watchDir dir (const False) True hooks id
debug ["watching for transfers"]
type Handler = FilePath -> Assistant ()
type Handler t = t -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
onErr :: Handler
onErr :: Handler String
onErr = giveup
{- Called when a new transfer information file is written. -}
onAdd :: Handler
onAdd file = case parseTransferFile (toRawFilePath file) of
onAdd :: Handler OsPath
onAdd file = case parseTransferFile file of
Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t)
where
@ -72,10 +72,10 @@ onAdd file = case parseTransferFile (toRawFilePath file) of
-
- The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -}
onModify :: Handler
onModify file = case parseTransferFile (toRawFilePath file) of
onModify :: Handler OsPath
onModify file = case parseTransferFile file of
Nothing -> noop
Just t -> go t =<< liftIO (readTransferInfoFile Nothing (toRawFilePath file))
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
where
go _ Nothing = noop
go t (Just newinfo) = alterTransferInfo t $
@ -87,8 +87,8 @@ watchesTransferSize :: Bool
watchesTransferSize = modifyTracked
{- Called when a transfer information file is removed. -}
onDel :: Handler
onDel file = case parseTransferFile (toRawFilePath file) of
onDel :: Handler OsPath
onDel file = case parseTransferFile file of
Nothing -> noop
Just t -> do
debug [ "transfer finishing:", show t]

View file

@ -46,7 +46,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
, modifyHook = changed
, delDirHook = changed
}
let dir = fromRawFilePath (parentDir (toRawFilePath flagfile))
let dir = parentDir flagfile
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
@ -57,7 +57,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
void $ swapMVar mvar Started
return r
changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
changedFile :: UrlRenderer -> MVar WatcherState -> OsPath -> OsPath -> Maybe FileStatus -> Assistant ()
changedFile urlrenderer mvar flagfile file _status
| flagfile /= file = noop
| otherwise = do

View file

@ -42,6 +42,7 @@ import Git.FilePath
import Config.GitConfig
import Utility.ThreadScheduler
import Logs.Location
import qualified Utility.OsString as OS
import qualified Database.Keys
#ifndef mingw32_HOST_OS
import qualified Utility.Lsof as Lsof
@ -94,16 +95,16 @@ runWatcher = do
delhook <- hook onDel
addsymlinkhook <- hook onAddSymlink
deldirhook <- hook onDelDir
errhook <- hook onErr
errhook <- asIO2 onErr
let hooks = mkWatchHooks
{ addHook = addhook
, delHook = delhook
, addSymlinkHook = addsymlinkhook
, delDirHook = deldirhook
, errHook = errhook
, errHook = Just errhook
}
scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig
h <- liftIO $ watchDir "." ignored scanevents hooks startup
h <- liftIO $ watchDir (literalOsPath ".") ignored scanevents hooks startup
debug [ "watching", "."]
{- Let the DirWatcher thread run until signalled to pause it,
@ -138,9 +139,8 @@ startupScan scanner = do
top <- liftAnnex $ fromRepo Git.repoPath
(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top]
forM_ fs $ \f -> do
let f' = fromRawFilePath f
liftAnnex $ onDel' f'
maybe noop recordChange =<< madeChange f' RmChange
liftAnnex $ onDel' f
maybe noop recordChange =<< madeChange f RmChange
void $ liftIO cleanup
liftAnnex $ showAction "started"
@ -157,30 +157,31 @@ startupScan scanner = do
{- Hardcoded ignores, passed to the DirWatcher so it can avoid looking
- at the entire .git directory. Does not include .gitignores. -}
ignored :: FilePath -> Bool
ignored :: OsPath -> Bool
ignored = ig . takeFileName
where
ig ".git" = True
ig ".gitignore" = True
ig ".gitattributes" = True
ig f
| f == literalOsPath ".git" = True
| f == literalOsPath ".gitignore" = True
| f == literalOsPath ".gitattributes" = True
#ifdef darwin_HOST_OS
ig ".DS_Store" = True
| f == literlosPath ".DS_Store" = True
#endif
ig _ = False
| otherwise = False
unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file))
unlessIgnored :: OsPath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file)
( noChange
, a
)
type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change)
type Handler = OsPath -> Maybe FileStatus -> Assistant (Maybe Change)
{- Runs an action handler, and if there was a change, adds it to the ChangeChan.
-
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
-}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler :: Handler -> OsPath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus
case r of
@ -189,7 +190,7 @@ runHandler handler file filestatus = void $ do
Right (Just change) -> recordChange change
where
normalize f
| "./" `isPrefixOf` file = drop 2 f
| literalOsPath "./" `OS.isPrefixOf` file = OS.drop 2 f
| otherwise = f
shouldRestage :: DaemonStatus -> Bool
@ -201,34 +202,34 @@ onAddFile symlinkssupported f fs =
where
addassociatedfile key file =
Database.Keys.addAssociatedFile key
=<< inRepo (toTopFilePath (toRawFilePath file))
=<< inRepo (toTopFilePath file)
samefilestatus key file status = do
cache <- Database.Keys.getInodeCaches key
curr <- withTSDelta $ \delta ->
liftIO $ toInodeCache delta (toRawFilePath file) status
liftIO $ toInodeCache delta file status
case (cache, curr) of
(_, Just c) -> elemInodeCaches c cache
([], Nothing) -> return True
_ -> return False
contentchanged oldkey file = do
Database.Keys.removeAssociatedFile oldkey
=<< inRepo (toTopFilePath (toRawFilePath file))
=<< inRepo (toTopFilePath file)
unlessM (inAnnex oldkey) $
logStatus NoLiveUpdate oldkey InfoMissing
addlink file key = do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file)
liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file)
liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
madeChange file $ LinkChange (Just key)
onAddFile'
:: (Key -> FilePath -> Annex ())
-> (Key -> FilePath -> Annex ())
-> (FilePath -> Key -> Assistant (Maybe Change))
-> (Key -> FilePath -> FileStatus -> Annex Bool)
:: (Key -> OsPath -> Annex ())
-> (Key -> OsPath -> Annex ())
-> (OsPath -> Key -> Assistant (Maybe Change))
-> (Key -> OsPath -> FileStatus -> Annex Bool)
-> Bool
-> Handler
onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do
v <- liftAnnex $ catKeyFile (toRawFilePath file)
v <- liftAnnex $ catKeyFile file
case (v, fs) of
(Just key, Just filestatus) ->
ifM (liftAnnex $ samefilestatus key file filestatus)
@ -242,13 +243,13 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo
, noChange
)
, guardSymlinkStandin (Just key) $ do
debug ["changed", file]
debug ["changed", fromOsPath file]
liftAnnex $ contentchanged key file
pendingAddChange file
)
_ -> unlessIgnored file $
guardSymlinkStandin Nothing $ do
debug ["add", file]
debug ["add", fromOsPath file]
pendingAddChange file
where
{- On a filesystem without symlinks, we'll get changes for regular
@ -258,8 +259,7 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo
guardSymlinkStandin mk a
| symlinkssupported = a
| otherwise = do
linktarget <- liftAnnex $ getAnnexLinkTarget $
toRawFilePath file
linktarget <- liftAnnex $ getAnnexLinkTarget file
case linktarget of
Nothing -> a
Just lt -> do
@ -275,21 +275,20 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo
-}
onAddSymlink :: Handler
onAddSymlink file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file')
kv <- liftAnnex (lookupKey file')
linktarget <- liftIO $ catchMaybeIO $
R.readSymbolicLink (fromOsPath file)
kv <- liftAnnex (lookupKey file)
onAddSymlink' linktarget kv file filestatus
where
file' = toRawFilePath file
onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler
onAddSymlink' linktarget mk file filestatus = go mk
where
go (Just key) = do
link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key
link <- liftAnnex $ fromOsPath <$> calcRepo (gitAnnexLink file key)
if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus
else do
liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $
liftAnnex $ replaceWorkTreeFile file $
makeAnnexLink link
addLink file link (Just key)
-- other symlink, not git-annex
@ -315,33 +314,32 @@ onAddSymlink' linktarget mk file filestatus = go mk
ensurestaged Nothing _ = noChange
{- For speed, tries to reuse the existing blob for symlink target. -}
addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
addLink :: OsPath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do
debug ["add symlink", file]
debug ["add symlink", fromOsPath file]
liftAnnex $ do
v <- catObjectDetails $ Ref $ encodeBS $ ':':file
v <- catObjectDetails $ Ref $ encodeBS $ ':':fromOsPath file
case v of
Just (currlink, sha, _type)
| L.fromStrict link == currlink ->
stageSymlink (toRawFilePath file) sha
_ -> stageSymlink (toRawFilePath file)
=<< hashSymlink link
stageSymlink file sha
_ -> stageSymlink file =<< hashSymlink link
madeChange file $ LinkChange mk
onDel :: Handler
onDel file _ = do
debug ["file deleted", file]
debug ["file deleted", fromOsPath file]
liftAnnex $ onDel' file
madeChange file RmChange
onDel' :: FilePath -> Annex ()
onDel' :: OsPath -> Annex ()
onDel' file = do
topfile <- inRepo (toTopFilePath (toRawFilePath file))
topfile <- inRepo (toTopFilePath file)
withkey $ flip Database.Keys.removeAssociatedFile topfile
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile (toRawFilePath file))
inRepo (Git.UpdateIndex.unstageFile file)
where
withkey a = maybe noop a =<< catKeyFile (toRawFilePath file)
withkey a = maybe noop a =<< catKeyFile file
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,
@ -351,23 +349,21 @@ onDel' file = do
- pairing up renamed files when the directory was renamed. -}
onDelDir :: Handler
onDelDir dir _ = do
debug ["directory deleted", dir]
(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [toRawFilePath dir]
let fs' = map fromRawFilePath fs
debug ["directory deleted", fromOsPath dir]
(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [dir]
liftAnnex $ mapM_ onDel' fs'
liftAnnex $ mapM_ onDel' fs
-- Get the events queued up as fast as possible, so the
-- committer sees them all in one block.
now <- liftIO getCurrentTime
recordChanges $ map (\f -> Change now f RmChange) fs'
recordChanges $ map (\f -> Change now f RmChange) fs
void $ liftIO clean
noChange
{- Called when there's an error with inotify or kqueue. -}
onErr :: Handler
onErr :: String -> Maybe FileStatus -> Assistant ()
onErr msg _ = do
liftAnnex $ warning (UnquotedString msg)
void $ addAlert $ warningAlert "watcher" msg
noChange

View file

@ -62,7 +62,7 @@ webAppThread
-> Maybe (IO Url)
-> Maybe HostName
-> Maybe PortNumber
-> Maybe (Url -> FilePath -> IO ())
-> Maybe (Url -> OsPath -> IO ())
-> NamedThread
webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do
listenhost' <- if isJust listenhost
@ -89,15 +89,13 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
, return app
)
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do
then withTmpFile (literalOsPath "webapp.html") $ \tmpfile h -> do
hClose h
go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing
go tlssettings addr webapp tmpfile Nothing
else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
go tlssettings addr webapp
(fromRawFilePath htmlshim)
(Just urlfile)
go tlssettings addr webapp htmlshim (Just urlfile)
where
-- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while
@ -105,8 +103,8 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
thread = namedThreadUnchecked "WebApp"
getreldir
| noannex = return Nothing
| otherwise = Just <$>
(relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath))
| otherwise = Just . fromOsPath <$>
(relHome =<< absPath =<< getAnnex' (fromRepo repoPath))
go tlssettings addr webapp htmlshim urlfile = do
let url = myUrl tlssettings webapp addr
maybe noop (`writeFileProtected` url) urlfile
@ -131,6 +129,8 @@ getTlsSettings = do
cert <- fromRepo gitAnnexWebCertificate
privkey <- fromRepo gitAnnexWebPrivKey
ifM (liftIO $ allM doesFileExist [cert, privkey])
( return $ Just $ TLS.tlsSettings cert privkey
( return $ Just $ TLS.tlsSettings
(fromOsPath cert)
(fromOsPath privkey)
, return Nothing
)