finished this stage of the RawFilePath conversion
Finally compiles again, and test suite passes. This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
parent
4bcb4030a5
commit
5a1e73617d
36 changed files with 188 additions and 147 deletions
|
@ -57,10 +57,11 @@ commitThread = namedThread "Committer" $ do
|
|||
liftAnnex $ do
|
||||
-- Clean up anything left behind by a previous process
|
||||
-- on unclean shutdown.
|
||||
void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir
|
||||
void $ liftIO $ tryIO $ removeDirectoryRecursive
|
||||
(fromRawFilePath lockdowndir)
|
||||
void $ createAnnexDirectory lockdowndir
|
||||
waitChangeTime $ \(changes, time) -> do
|
||||
readychanges <- handleAdds lockdowndir havelsof delayadd $
|
||||
readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof delayadd $
|
||||
simplifyChanges changes
|
||||
if shouldCommit False time (length readychanges) readychanges
|
||||
then do
|
||||
|
@ -261,7 +262,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
|
|||
let (pending, inprocess) = partition isPendingAddChange incomplete
|
||||
let lockdownconfig = LockDownConfig
|
||||
{ lockingFile = False
|
||||
, hardlinkFileTmpDir = Just lockdowndir
|
||||
, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
|
||||
}
|
||||
(postponed, toadd) <- partitionEithers
|
||||
<$> safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess
|
||||
|
@ -304,7 +305,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
|
|||
delta <- liftAnnex getTSDelta
|
||||
let cfg = LockDownConfig
|
||||
{ lockingFile = False
|
||||
, hardlinkFileTmpDir = Just lockdowndir
|
||||
, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
|
||||
}
|
||||
if M.null m
|
||||
then forM toadd (add cfg)
|
||||
|
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Assistant.Threads.Merger where
|
||||
|
||||
import Assistant.Common
|
||||
|
@ -13,6 +15,7 @@ import Assistant.BranchChange
|
|||
import Assistant.Sync
|
||||
import Utility.DirWatcher
|
||||
import Utility.DirWatcher.Types
|
||||
import Utility.Directory.Create
|
||||
import Annex.CurrentBranch
|
||||
import qualified Annex
|
||||
import qualified Annex.Branch
|
||||
|
@ -21,13 +24,15 @@ import qualified Git.Branch
|
|||
import qualified Git.Ref
|
||||
import qualified Command.Sync
|
||||
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
{- This thread watches for changes to .git/refs/, and handles incoming
|
||||
- pushes. -}
|
||||
mergeThread :: NamedThread
|
||||
mergeThread = namedThread "Merger" $ do
|
||||
g <- liftAnnex gitRepo
|
||||
let gitd = fromRawFilePath (Git.localGitDir g)
|
||||
let dir = gitd </> "refs"
|
||||
let gitd = Git.localGitDir g
|
||||
let dir = gitd P.</> "refs"
|
||||
liftIO $ createDirectoryUnder gitd dir
|
||||
let hook a = Just <$> asIO2 (runHandler a)
|
||||
changehook <- hook onChange
|
||||
|
@ -37,8 +42,8 @@ mergeThread = namedThread "Merger" $ do
|
|||
, modifyHook = changehook
|
||||
, errHook = errhook
|
||||
}
|
||||
void $ liftIO $ watchDir dir (const False) True hooks id
|
||||
debug ["watching", dir]
|
||||
void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
|
||||
debug ["watching", fromRawFilePath dir]
|
||||
|
||||
type Handler = FilePath -> Assistant ()
|
||||
|
||||
|
|
|
@ -159,7 +159,7 @@ handleMount urlrenderer dir = do
|
|||
-}
|
||||
remotesUnder :: FilePath -> Assistant [Remote]
|
||||
remotesUnder dir = do
|
||||
repotop <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath
|
||||
repotop <- liftAnnex $ fromRepo Git.repoPath
|
||||
rs <- liftAnnex remoteList
|
||||
pairs <- liftAnnex $ mapM (checkremote repotop) rs
|
||||
let (waschanged, rs') = unzip pairs
|
||||
|
@ -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 dir (absPathFrom repotop p) ->
|
||||
Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) ->
|
||||
(,) <$> pure True <*> updateRemote r
|
||||
_ -> return (False, Just r)
|
||||
|
||||
|
|
|
@ -221,7 +221,7 @@ hourlyCheck = do
|
|||
-}
|
||||
checkLogSize :: Int -> Assistant ()
|
||||
checkLogSize n = do
|
||||
f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
|
||||
f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile
|
||||
logs <- liftIO $ listLogs f
|
||||
totalsize <- liftIO $ sum <$> mapM getFileSize logs
|
||||
when (totalsize > 2 * oneMegabyte) $ do
|
||||
|
|
|
@ -37,7 +37,7 @@ transferPollerThread = namedThread "TransferPoller" $ do
|
|||
- temp file being used for the transfer. -}
|
||||
| transferDirection t == Download = do
|
||||
let f = gitAnnexTmpObjectLocation (transferKey t) g
|
||||
sz <- liftIO $ catchMaybeIO $ getFileSize f
|
||||
sz <- liftIO $ catchMaybeIO $ getFileSize (fromRawFilePath f)
|
||||
newsize t info sz
|
||||
{- Uploads don't need to be polled for when the TransferWatcher
|
||||
- thread can track file modifications. -}
|
||||
|
@ -47,7 +47,7 @@ transferPollerThread = namedThread "TransferPoller" $ do
|
|||
| otherwise = do
|
||||
let f = transferFile t g
|
||||
mi <- liftIO $ catchDefaultIO Nothing $
|
||||
readTransferInfoFile Nothing f
|
||||
readTransferInfoFile Nothing (fromRawFilePath f)
|
||||
maybe noop (newsize t info . bytesComplete) mi
|
||||
|
||||
newsize t info sz
|
||||
|
|
|
@ -37,7 +37,7 @@ transferWatcherThread = namedThread "TransferWatcher" $ do
|
|||
, modifyHook = modifyhook
|
||||
, errHook = errhook
|
||||
}
|
||||
void $ liftIO $ watchDir dir (const False) True hooks id
|
||||
void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
|
||||
debug ["watching for transfers"]
|
||||
|
||||
type Handler = FilePath -> Assistant ()
|
||||
|
|
|
@ -46,7 +46,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
|
|||
, modifyHook = changed
|
||||
, delDirHook = changed
|
||||
}
|
||||
let dir = parentDir flagfile
|
||||
let dir = fromRawFilePath (parentDir (toRawFilePath flagfile))
|
||||
let depth = length (splitPath dir) + 1
|
||||
let nosubdirs f = length (splitPath f) == depth
|
||||
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
|
||||
|
|
|
@ -24,6 +24,7 @@ import Assistant.Alert
|
|||
import Utility.DirWatcher
|
||||
import Utility.DirWatcher.Types
|
||||
import Utility.InodeCache
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Annex
|
||||
import qualified Annex.Queue
|
||||
import qualified Git
|
||||
|
@ -169,7 +170,7 @@ ignored = ig . takeFileName
|
|||
ig _ = False
|
||||
|
||||
unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
|
||||
unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file)
|
||||
unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file))
|
||||
( noChange
|
||||
, a
|
||||
)
|
||||
|
@ -194,7 +195,7 @@ runHandler handler file filestatus = void $ do
|
|||
|
||||
{- Small files are added to git as-is, while large ones go into the annex. -}
|
||||
add :: GetFileMatcher -> FilePath -> Assistant (Maybe Change)
|
||||
add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher file)
|
||||
add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher (toRawFilePath file))
|
||||
( pendingAddChange file
|
||||
, do
|
||||
liftAnnex $ Annex.Queue.addCommand "add"
|
||||
|
@ -280,7 +281,7 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
|
|||
Nothing -> noop
|
||||
Just key -> liftAnnex $
|
||||
addassociatedfile key file
|
||||
onAddSymlink' (Just $ fromRawFilePath lt) mk file fs
|
||||
onAddSymlink' (Just lt) mk file fs
|
||||
|
||||
{- A symlink might be an arbitrary symlink, which is just added.
|
||||
- Or, if it is a git-annex symlink, ensure it points to the content
|
||||
|
@ -288,15 +289,17 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
|
|||
-}
|
||||
onAddSymlink :: Handler
|
||||
onAddSymlink file filestatus = unlessIgnored file $ do
|
||||
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
|
||||
kv <- liftAnnex (lookupKey (toRawFilePath file))
|
||||
linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file')
|
||||
kv <- liftAnnex (lookupKey file')
|
||||
onAddSymlink' linktarget kv file filestatus
|
||||
where
|
||||
file' = toRawFilePath file
|
||||
|
||||
onAddSymlink' :: Maybe String -> Maybe Key -> Handler
|
||||
onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler
|
||||
onAddSymlink' linktarget mk file filestatus = go mk
|
||||
where
|
||||
go (Just key) = do
|
||||
link <- liftAnnex $ calcRepo $ gitAnnexLink file key
|
||||
link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key
|
||||
if linktarget == Just link
|
||||
then ensurestaged (Just link) =<< getDaemonStatus
|
||||
else do
|
||||
|
@ -326,17 +329,17 @@ onAddSymlink' linktarget mk file filestatus = go mk
|
|||
ensurestaged Nothing _ = noChange
|
||||
|
||||
{- For speed, tries to reuse the existing blob for symlink target. -}
|
||||
addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)
|
||||
addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
|
||||
addLink file link mk = do
|
||||
debug ["add symlink", file]
|
||||
liftAnnex $ do
|
||||
v <- catObjectDetails $ Ref $ encodeBS' $ ':':file
|
||||
case v of
|
||||
Just (currlink, sha, _type)
|
||||
| s2w8 link == L.unpack currlink ->
|
||||
| L.fromStrict link == currlink ->
|
||||
stageSymlink (toRawFilePath file) sha
|
||||
_ -> stageSymlink (toRawFilePath file)
|
||||
=<< hashSymlink (toRawFilePath link)
|
||||
=<< hashSymlink link
|
||||
madeChange file $ LinkChange mk
|
||||
|
||||
onDel :: Handler
|
||||
|
|
|
@ -91,7 +91,9 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
|
|||
else do
|
||||
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
|
||||
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
|
||||
go tlssettings addr webapp htmlshim (Just urlfile)
|
||||
go tlssettings addr webapp
|
||||
(fromRawFilePath htmlshim)
|
||||
(Just (fromRawFilePath urlfile))
|
||||
where
|
||||
-- The webapp thread does not wait for the startupSanityCheckThread
|
||||
-- to finish, so that the user interface remains responsive while
|
||||
|
@ -100,8 +102,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
|
|||
getreldir
|
||||
| noannex = return Nothing
|
||||
| otherwise = Just <$>
|
||||
(relHome =<< absPath . fromRawFilePath
|
||||
=<< getAnnex' (fromRepo repoPath))
|
||||
(relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath))
|
||||
go tlssettings addr webapp htmlshim urlfile = do
|
||||
let url = myUrl tlssettings webapp addr
|
||||
maybe noop (`writeFileProtected` url) urlfile
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue