git-annex 6.20171109 → 6.20171124
raw patch · 34 files changed
+211/−274 lines, 34 filesdep −Win32-extrasdep ~Win32dep ~basedep ~process
Dependencies removed: Win32-extras
Dependency ranges changed: Win32, base, process, unix-compat
Files
- Annex/AdjustedBranch.hs +40/−53
- Annex/AutoMerge.hs +2/−3
- Annex/Branch.hs +10/−12
- Annex/ChangedRefs.hs +8/−13
- Annex/Content.hs +24/−33
- Annex/Direct.hs +9/−13
- Annex/FileMatcher.hs +4/−6
- Annex/Fixup.hs +1/−1
- Annex/Ingest.hs +14/−21
- Annex/Init.hs +1/−2
- Annex/LockPool/PosixOrPid.hs +4/−6
- Annex/MetaData.hs +1/−2
- CHANGELOG +8/−0
- Command/EnableTor.hs +2/−0
- Command/Export.hs +9/−9
- Common.hs +1/−1
- Messages/Progress.hs +23/−9
- Remote/Git.hs +15/−18
- Remote/Helper/Special.hs +4/−4
- Remote/P2P.hs +7/−4
- Remote/WebDAV.hs +2/−0
- Utility/DirWatcher/Win32Notify.hs +1/−1
- Utility/Directory.hs +1/−1
- Utility/FileMode.hs +1/−1
- Utility/PID.hs +1/−2
- Utility/PosixFiles.hs +0/−42
- Utility/SRV.hs +1/−1
- Utility/Shell.hs +0/−3
- Utility/Su.hs +1/−1
- Utility/Tmp.hs +1/−1
- Utility/UserInfo.hs +6/−3
- Utility/WebApp.hs +1/−1
- git-annex.cabal +8/−6
- stack.yaml +0/−1
Annex/AdjustedBranch.hs view
@@ -80,9 +80,8 @@ adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust-adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) -> do- mk <- catKey s- case mk of+adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) ->+ catKey s >>= \case Just k -> ifM (inAnnex k) ( return (Just ti) , return Nothing@@ -99,29 +98,25 @@ noAdjust = return . Just adjustToPointer :: TreeItem -> Annex (Maybe TreeItem)-adjustToPointer ti@(TreeItem f _m s) = do- mk <- catKey s- case mk of- Just k -> do- Database.Keys.addAssociatedFile k f- Just . TreeItem f (fromBlobType FileBlob)- <$> hashPointerFile k- Nothing -> return (Just ti)+adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case+ Just k -> do+ Database.Keys.addAssociatedFile k f+ Just . TreeItem f (fromBlobType FileBlob)+ <$> hashPointerFile k+ Nothing -> return (Just ti) adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem) adjustToSymlink = adjustToSymlink' gitAnnexLink adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem)-adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = do- mk <- catKey s- case mk of- Just k -> do- absf <- inRepo $ \r -> absPath $- fromTopFilePath f r- linktarget <- calcRepo $ gitannexlink absf k- Just . TreeItem f (fromBlobType SymlinkBlob)- <$> hashSymlink linktarget- Nothing -> return (Just ti)+adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case+ Just k -> do+ absf <- inRepo $ \r -> absPath $+ fromTopFilePath f r+ linktarget <- calcRepo $ gitannexlink absf k+ Just . TreeItem f (fromBlobType SymlinkBlob)+ <$> hashSymlink linktarget+ Nothing -> return (Just ti) type OrigBranch = Branch newtype AdjBranch = AdjBranch { adjBranch :: Branch }@@ -438,11 +433,9 @@ return True reparent _ _ Nothing = return False - getcurrentcommit = do- v <- inRepo Git.Branch.currentUnsafe- case v of- Nothing -> return Nothing- Just c -> catCommit c+ getcurrentcommit = inRepo Git.Branch.currentUnsafe >>= \case+ Nothing -> return Nothing+ Just c -> catCommit c {- Check for any commits present on the adjusted branch that have not yet - been propigated to the basis branch, and propigate them to the basis@@ -463,23 +456,19 @@ -> Adjustment -> CommitsPrevented -> Annex (Maybe Sha, Annex ())-propigateAdjustedCommits' origbranch adj _commitsprevented = do- ov <- inRepo $ Git.Ref.sha basis- case ov of- Just origsha -> do- cv <- catCommit currbranch- case cv of- Just currcommit -> do- v <- newcommits >>= go origsha False- case v of- Left e -> do- warning e- return (Nothing, return ())- Right newparent -> return- ( Just newparent- , rebase currcommit newparent- )- Nothing -> return (Nothing, return ())+propigateAdjustedCommits' origbranch adj _commitsprevented =+ inRepo (Git.Ref.sha basis) >>= \case+ Just origsha -> catCommit currbranch >>= \case+ Just currcommit ->+ newcommits >>= go origsha False >>= \case+ Left e -> do+ warning e+ return (Nothing, return ())+ Right newparent -> return+ ( Just newparent+ , rebase currcommit newparent+ )+ Nothing -> return (Nothing, return ()) Nothing -> return (Nothing, return ()) where (BasisBranch basis) = basisBranch adjbranch@@ -492,18 +481,16 @@ setBasisBranch (BasisBranch basis) parent inRepo $ Git.Branch.update' origbranch parent return (Right parent)- go parent pastadjcommit (sha:l) = do- mc <- catCommit sha- case mc of- Just c- | commitMessage c == adjustedBranchCommitMessage ->- go parent True l- | pastadjcommit -> do- v <- reverseAdjustedCommit parent adj (sha, c) origbranch- case v of+ go parent pastadjcommit (sha:l) = catCommit sha >>= \case+ Just c+ | commitMessage c == adjustedBranchCommitMessage ->+ go parent True l+ | pastadjcommit ->+ reverseAdjustedCommit parent adj (sha, c) origbranch+ >>= \case Left e -> return (Left e) Right commit -> go commit pastadjcommit l- _ -> go parent pastadjcommit l+ _ -> go parent pastadjcommit l rebase currcommit newparent = do -- Reuse the current adjusted tree, and reparent it -- on top of the newparent.
Annex/AutoMerge.hs view
@@ -217,9 +217,8 @@ makepointer key dest destmode = do unless inoverlay $ - unlessM (reuseOldFile unstagedmap key file dest) $ do- r <- linkFromAnnex key dest destmode- case r of+ unlessM (reuseOldFile unstagedmap key file dest) $+ linkFromAnnex key dest destmode >>= \case LinkAnnexFailed -> liftIO $ writePointerFile dest key destmode _ -> noop
Annex/Branch.hs view
@@ -446,18 +446,16 @@ [genstream dir h jh jlogh] return $ cleanup dir jlogh jlogf where- genstream dir h jh jlogh streamer = do- v <- readDirectory jh- case v of- Nothing -> return ()- Just file -> do- unless (dirCruft file) $ do- let path = dir </> file- sha <- Git.HashObject.hashFile h path- hPutStrLn jlogh file- streamer $ Git.UpdateIndex.updateIndexLine- sha FileBlob (asTopFilePath $ fileJournal file)- genstream dir h jh jlogh streamer+ genstream dir h jh jlogh streamer = readDirectory jh >>= \case+ Nothing -> return ()+ Just file -> do+ unless (dirCruft file) $ do+ let path = dir </> file+ sha <- Git.HashObject.hashFile h path+ hPutStrLn jlogh file+ streamer $ Git.UpdateIndex.updateIndexLine+ sha FileBlob (asTopFilePath $ fileJournal file)+ genstream dir h jh jlogh streamer -- Clean up the staged files, as listed in the temp log file. -- The temp file is used to avoid needing to buffer all the -- filenames in memory.
Annex/ChangedRefs.hs view
@@ -39,31 +39,26 @@ -- When possible, coalesce ref writes that occur closely together -- in time. Delay up to 0.05 seconds to get more ref writes. waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs-waitChangedRefs (ChangedRefsHandle _ chan) = do- v <- atomically $ readTBMChan chan- case v of+waitChangedRefs (ChangedRefsHandle _ chan) =+ atomically (readTBMChan chan) >>= \case Nothing -> return $ ChangedRefs [] Just r -> do threadDelay 50000 rs <- atomically $ loop [] return $ ChangedRefs (r:rs) where- loop rs = do- v <- tryReadTBMChan chan- case v of- Just (Just r) -> loop (r:rs)- _ -> return rs+ loop rs = tryReadTBMChan chan >>= \case+ Just (Just r) -> loop (r:rs)+ _ -> return rs -- | Remove any changes that might be buffered in the channel, -- without waiting for any new changes. drainChangedRefs :: ChangedRefsHandle -> IO () drainChangedRefs (ChangedRefsHandle _ chan) = atomically go where- go = do- v <- tryReadTBMChan chan- case v of- Just (Just _) -> go- _ -> return ()+ go = tryReadTBMChan chan >>= \case+ Just (Just _) -> go+ _ -> return () stopWatchingChangedRefs :: ChangedRefsHandle -> IO () stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do
Annex/Content.hs view
@@ -50,6 +50,7 @@ ) where import System.IO.Unsafe (unsafeInterleaveIO)+import System.PosixCompat.Files import qualified Data.Set as S import Annex.Common@@ -84,7 +85,6 @@ import Annex.UUID import Annex.InodeSentinal import Utility.InodeCache-import Utility.PosixFiles {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool@@ -149,30 +149,25 @@ ( checkOr is_unlocked lockfile , return is_missing )- checkOr d lockfile = do- v <- checkLocked lockfile- return $ case v of- Nothing -> d- Just True -> is_locked- Just False -> is_unlocked+ checkOr d lockfile = checkLocked lockfile >>= return . \case+ Nothing -> d+ Just True -> is_locked+ Just False -> is_unlocked #else checkindirect f = liftIO $ ifM (doesFileExist f)- ( do- v <- lockShared f- case v of- Nothing -> return is_locked- Just lockhandle -> do- dropLock lockhandle- return is_unlocked+ ( lockShared f >>= \case+ Nothing -> return is_locked+ Just lockhandle -> do+ dropLock lockhandle+ return is_unlocked , return is_missing ) {- In Windows, see if we can take a shared lock. If so, - remove the lock file to clean up after ourselves. -} checkdirect contentfile lockfile = ifM (liftIO $ doesFileExist contentfile)- ( modifyContent lockfile $ liftIO $ do- v <- lockShared lockfile- case v of+ ( modifyContent lockfile $ liftIO $+ lockShared >>= \case Nothing -> return is_locked Just lockhandle -> do dropLock lockhandle@@ -428,8 +423,7 @@ inprogress <- if samefilesystem then sizeOfDownloadsInProgress (/= key) else pure 0- free <- liftIO . getDiskFree =<< dir- case free of+ dir >>= liftIO . getDiskFree >>= \case Just have -> do reserve <- annexDiskReserve <$> Annex.getGitConfig let delta = need + reserve - have - alreadythere + inprogress@@ -581,9 +575,8 @@ -} linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed-linkAnnex fromto key src (Just srcic) dest destmode = do- mdestic <- withTSDelta (liftIO . genInodeCache dest)- case mdestic of+linkAnnex fromto key src (Just srcic) dest destmode =+ withTSDelta (liftIO . genInodeCache dest) >>= \case Just destic -> do cs <- Database.Keys.getInodeCaches key if null cs@@ -602,17 +595,15 @@ failed = do Database.Keys.addInodeCaches key [srcic] return LinkAnnexFailed- checksrcunchanged = do- mcache <- withTSDelta (liftIO . genInodeCache src)- case mcache of- Just srcic' | compareStrong srcic srcic' -> do- destic <- withTSDelta (liftIO . genInodeCache dest)- Database.Keys.addInodeCaches key $- catMaybes [destic, Just srcic]- return LinkAnnexOk- _ -> do- liftIO $ nukeFile dest- failed+ checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case+ Just srcic' | compareStrong srcic srcic' -> do+ destic <- withTSDelta (liftIO . genInodeCache dest)+ Database.Keys.addInodeCaches key $+ catMaybes [destic, Just srcic]+ return LinkAnnexOk+ _ -> do+ liftIO $ nukeFile dest+ failed {- Hard links or copies src to dest, which must not already exists. -
Annex/Direct.hs view
@@ -111,9 +111,8 @@ withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile where- withkey sha _mode a = when (sha /= nullSha) $ do- k <- catKey sha- case k of+ withkey sha _mode a = when (sha /= nullSha) $+ catKey sha >>= \case Nothing -> noop Just key -> void $ a key $ makeabs $ DiffTree.file diff@@ -427,14 +426,12 @@ then moveconfig coreworktree indirectworktree else moveconfig indirectworktree coreworktree setConfig (ConfigKey Git.Config.coreBare) val- moveconfig src dest = do- v <- getConfigMaybe src- case v of- Nothing -> noop- Just wt -> do- unsetConfig src- setConfig dest wt- reloadConfig+ moveconfig src dest = getConfigMaybe src >>= \case+ Nothing -> noop+ Just wt -> do+ unsetConfig src+ setConfig dest wt+ reloadConfig {- Since direct mode sets core.bare=true, incoming pushes could change - the currently checked out branch. To avoid this problem, HEAD@@ -474,8 +471,7 @@ where switch currhead = do let orighead = fromDirectBranch currhead- v <- inRepo $ Git.Ref.sha currhead- case v of+ inRepo (Git.Ref.sha currhead) >>= \case Just headsha | orighead /= currhead -> do inRepo $ Git.Branch.update "leaving direct mode" orighead headsha
Annex/FileMatcher.hs view
@@ -133,12 +133,10 @@ #ifdef WITH_MAGICMIME magicmime <- liftIO $ catchMaybeIO $ do m <- magicOpen [MagicMimeType]- liftIO $ do- md <- getEnv "GIT_ANNEX_DIR"- case md of- Nothing -> magicLoadDefault m- Just d -> magicLoad m- (d </> "magic" </> "magic.mgc")+ liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case+ Nothing -> magicLoadDefault m+ Just d -> magicLoad m+ (d </> "magic" </> "magic.mgc") return m #endif let parse = parseToken $ commonTokens
Annex/Fixup.hs view
@@ -15,11 +15,11 @@ import Utility.Path import Utility.SafeCommand import Utility.Directory-import Utility.PosixFiles import Utility.Exception import System.IO import System.FilePath+import System.PosixCompat.Files import Data.List import Control.Monad import Control.Monad.IfElse
Annex/Ingest.hs view
@@ -169,9 +169,8 @@ ) go _ _ _ = failure "failed to generate a key" - golocked key mcache s = do- v <- tryNonAsync (moveAnnex key $ contentLocation source)- case v of+ golocked key mcache s =+ tryNonAsync (moveAnnex key $ contentLocation source) >>= \case Right True -> do populateAssociatedFiles key source success key mcache s @@ -184,8 +183,7 @@ -- already has a hard link. cleanCruft source cleanOldKeys (keyFilename source) key- r <- linkToAnnex key (keyFilename source) (Just cache)- case r of+ linkToAnnex key (keyFilename source) (Just cache) >>= \case LinkAnnexFailed -> failure "failed to link to annex" _ -> do finishIngestUnlocked' key source@@ -259,8 +257,7 @@ fs <- filter (/= ingestedf) . map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key- fs' <- filterM (`sameInodeCache` caches) fs- case fs' of+ filterM (`sameInodeCache` caches) fs >>= \case -- If linkToAnnex fails, the associated -- file with the content is still present, -- so no need for any recovery.@@ -342,14 +339,12 @@ =<< Annex.getState Annex.cachedcurrentbranch where cache :: Annex (Maybe Git.Branch)- cache = do- mb <- inRepo Git.Branch.currentUnsafe- case mb of- Nothing -> return Nothing- Just b -> do- Annex.changeState $ \s ->- s { Annex.cachedcurrentbranch = Just b }- return (Just b)+ cache = inRepo Git.Branch.currentUnsafe >>= \case+ Nothing -> return Nothing+ Just b -> do+ Annex.changeState $ \s ->+ s { Annex.cachedcurrentbranch = Just b }+ return (Just b) {- Adds a file to the work tree for the key, and stages it in the index. - The content of the key may be provided in a temp file, which will be@@ -389,10 +384,8 @@ Nothing -> return True ) where- linkunlocked mode = do- r <- linkFromAnnex key file mode- case r of- LinkAnnexFailed -> liftIO $- writePointerFile file key mode- _ -> return ()+ linkunlocked mode = linkFromAnnex key file mode >>= \case+ LinkAnnexFailed -> liftIO $+ writePointerFile file key mode+ _ -> return () writepointer mode = liftIO $ writePointerFile file key mode
Annex/Init.hs view
@@ -93,8 +93,7 @@ whenM versionSupportsUnlockedPointers $ do configureSmudgeFilter scanUnlockedFiles- v <- checkAdjustedClone- case v of+ checkAdjustedClone >>= \case NeedUpgradeForAdjustedClone -> void $ upgrade True versionForAdjustedClone InAdjustedClone -> return ()
Annex/LockPool/PosixOrPid.hs view
@@ -49,12 +49,10 @@ checkLocked :: LockFile -> Annex (Maybe Bool) checkLocked f = Posix.checkLocked f `pidLockCheck` checkpid where- checkpid pidlock = do- v <- Pid.checkLocked pidlock- case v of- -- Only return true when the posix lock file exists.- Just _ -> Posix.checkLocked f- Nothing -> return Nothing+ checkpid pidlock = Pid.checkLocked pidlock >>= \case+ -- Only return true when the posix lock file exists.+ Just _ -> Posix.checkLocked f+ Nothing -> return Nothing getLockStatus :: LockFile -> Annex LockStatus getLockStatus f = Posix.getLockStatus f
Annex/MetaData.hs view
@@ -39,8 +39,7 @@ -} genMetaData :: Key -> FilePath -> FileStatus -> Annex () genMetaData key file status = do- v <- catKeyFileHEAD file- case v of+ catKeyFileHEAD file >>= \case Nothing -> noop Just oldkey -> whenM (copyMetaData oldkey key)
CHANGELOG view
@@ -1,3 +1,11 @@+git-annex (6.20171124) unstable; urgency=medium++ * Display progress meter when uploading a key without size information,+ getting the size by statting the content file.+ * Fix build with dns-3.0.++ -- Joey Hess <id@joeyh.name> Fri, 24 Nov 2017 10:49:36 -0400+ git-annex (6.20171109) unstable; urgency=medium * Fix export of subdir of a branch.
Command/EnableTor.hs view
@@ -15,7 +15,9 @@ import P2P.Annex import Utility.Tor import Annex.UUID+#ifndef mingw32_HOST_OS import Config.Files+#endif import P2P.IO import qualified P2P.Protocol as P2P import Utility.ThreadScheduler
Command/Export.hs view
@@ -215,20 +215,20 @@ let storer = storeExport ea sent <- case ek of AnnexKey k -> ifM (inAnnex k)- ( metered Nothing k $ \m -> do- let rollback = void $- performUnexport r ea db [ek] loc- notifyTransfer Upload af $- upload (uuid r) k af noRetry $ \pm -> do- let m' = combineMeterUpdate pm m- sendAnnex k rollback- (\f -> storer f k loc m')+ ( notifyTransfer Upload af $+ upload (uuid r) k af noRetry $ \pm -> do+ let rollback = void $+ performUnexport r ea db [ek] loc+ sendAnnex k rollback $ \f ->+ metered Nothing k (return $ Just f) $ \m -> do+ let m' = combineMeterUpdate pm m+ storer f k loc m' , do showNote "not available" return False ) -- Sending a non-annexed file.- GitKey sha1k -> metered Nothing sha1k $ \m ->+ GitKey sha1k -> metered Nothing sha1k (return Nothing) $ \m -> withTmpFile "export" $ \tmp h -> do b <- catObject contentsha liftIO $ L.hPut h b
Common.hs view
@@ -18,6 +18,7 @@ import System.Posix.IO as X hiding (createPipe) #endif import System.Exit as X+import System.PosixCompat.Files as X hiding (fileSize) import Utility.Misc as X import Utility.Exception as X@@ -28,7 +29,6 @@ import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X-import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Network as X import Utility.Split as X
Messages/Progress.hs view
@@ -24,12 +24,18 @@ #endif {- Shows a progress meter while performing a transfer of a key.- - The action is passed a callback to use to update the meter. -}-metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a-metered othermeter key a = withMessageState $ go (keySize key)+ - The action is passed a callback to use to update the meter.+ -+ - When the key's size is not known, the srcfile is statted to get the size.+ - This allows uploads of keys without size to still have progress+ - displayed.+ --}+metered :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (MeterUpdate -> Annex a) -> Annex a+metered othermeter key getsrcfile a = withMessageState $ \st ->+ flip go st =<< getsz where go _ (MessageState { outputType = QuietOutput }) = nometer- go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do+ go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do showOutput meter <- liftIO $ mkMeter msize bandwidthMeter $ displayMeterHandle stdout@@ -38,7 +44,7 @@ r <- a (combinemeter m) liftIO $ clearMeterHandle meter stdout return r- go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =+ go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = #if WITH_CONCURRENTOUTPUT withProgressRegion $ \r -> do meter <- liftIO $ mkMeter msize bandwidthMeter $ \_ s ->@@ -61,14 +67,22 @@ combinemeter m = case othermeter of Nothing -> m Just om -> combineMeterUpdate m om+ + getsz = case keySize key of+ Just sz -> return (Just sz)+ Nothing -> do+ srcfile <- getsrcfile+ case srcfile of+ Nothing -> return Nothing+ Just f -> catchMaybeIO $ liftIO $ getFileSize f {- Use when the command's own progress output is preferred. - The command's output will be suppressed and git-annex's progress meter - used for concurrent output, and json progress. -}-commandMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a-commandMetered combinemeterupdate key a = +commandMetered :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (MeterUpdate -> Annex a) -> Annex a+commandMetered combinemeterupdate key getsrcfile a = withMessageState $ \s -> if needOutputMeter s- then metered combinemeterupdate key a+ then metered combinemeterupdate key getsrcfile a else a (fromMaybe nullMeterUpdate combinemeterupdate) {- Poll file size to display meter, but only when concurrent output or@@ -76,7 +90,7 @@ meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a meteredFile file combinemeterupdate key a = withMessageState $ \s -> if needOutputMeter s- then metered combinemeterupdate key $ \p ->+ then metered combinemeterupdate key (return Nothing) $ \p -> watchFileSize file p a else a
Remote/Git.hs view
@@ -435,7 +435,7 @@ copyFromRemote r key file dest p | Git.repoIsHttp (repo r) = unVerified $ Annex.Content.downloadUrl key p (keyUrls r key) dest- | otherwise = commandMetered (Just p) key $+ | otherwise = commandMetered (Just p) key (return Nothing) $ copyFromRemote' r key file dest copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)@@ -546,27 +546,24 @@ {- Tries to copy a key's content to a remote's annex. -} copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool-copyToRemote r key file meterupdate = - commandMetered (Just meterupdate) key $- copyToRemote' r key file--copyToRemote' :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool-copyToRemote' r key file meterupdate+copyToRemote r key file meterupdate | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ commitOnCleanup r $ copylocal =<< Annex.Content.prepSendAnnex key | Git.repoIsSsh (repo r) = commitOnCleanup r $- Annex.Content.sendAnnex key noop $ \object -> do- -- This is too broad really, but recvkey normally- -- verifies content anyway, so avoid complicating- -- it with a local sendAnnex check and rollback.- unlocked <- isDirect <||> versionSupportsUnlockedPointers- Ssh.rsyncHelper (Just meterupdate)- =<< Ssh.rsyncParamsRemote unlocked r Upload key object file+ Annex.Content.sendAnnex key noop $ \object ->+ withmeter object $ \p -> do+ -- This is too broad really, but recvkey normally+ -- verifies content anyway, so avoid complicating+ -- it with a local sendAnnex check and rollback.+ unlocked <- isDirect <||> versionSupportsUnlockedPointers+ Ssh.rsyncHelper (Just p)+ =<< Ssh.rsyncParamsRemote unlocked r Upload key object file | otherwise = giveup "copying to non-ssh repo not supported" where+ withmeter object = commandMetered (Just meterupdate) key (return $ Just object) copylocal Nothing = return False- copylocal (Just (object, checksuccess)) = do+ copylocal (Just (object, checksuccess)) = withmeter object $ \p -> do -- The checksuccess action is going to be run in -- the remote's Annex, but it needs access to the local -- Annex monad's state.@@ -581,11 +578,11 @@ ensureInitialized copier <- mkCopier hardlink params let verify = Annex.Content.RemoteVerify r- runTransfer (Transfer Download u key) file forwardRetry $ \p ->- let p' = combineMeterUpdate meterupdate p+ runTransfer (Transfer Download u key) file forwardRetry $ \p' ->+ let p'' = combineMeterUpdate p p' in Annex.Content.saveState True `after` Annex.Content.getViaTmp verify key- (\dest -> copier object dest p' (liftIO checksuccessio))+ (\dest -> copier object dest p'' (liftIO checksuccessio)) ) fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
Remote/Helper/Special.hs view
@@ -187,7 +187,7 @@ go (Just storer) = preparecheckpresent k $ safely . go' storer go Nothing = return False go' storer (Just checker) = sendAnnex k rollback $ \src ->- displayprogress p k $ \p' ->+ displayprogress p k (Just src) $ \p' -> storeChunks (uuid baser) chunkconfig enck k src p' (storechunk enc storer) checker@@ -207,7 +207,7 @@ retrieveKeyFileGen k dest p enc = safely $ prepareretriever k $ safely . go where- go (Just retriever) = displayprogress p k $ \p' ->+ go (Just retriever) = displayprogress p k Nothing $ \p' -> retrieveChunks retriever (uuid baser) chunkconfig enck k dest p' (sink dest enc encr) go Nothing = return False@@ -227,8 +227,8 @@ chunkconfig = chunkConfig cfg - displayprogress p k a- | displayProgress cfg = metered (Just p) k a+ displayprogress p k srcfile a+ | displayProgress cfg = metered (Just p) k (return srcfile) a | otherwise = a p {- Sink callback for retrieveChunks. Stores the file content into the
Remote/P2P.hs view
@@ -21,6 +21,7 @@ import Types.GitConfig import qualified Git import Annex.UUID+import Annex.Content import Config import Config.Cost import Remote.Helper.Git@@ -78,13 +79,15 @@ return (Just this) store :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool-store u addr connpool k af p = - metered (Just p) k $ \p' -> fromMaybe False- <$> runProto u addr connpool (P2P.put k af p')+store u addr connpool k af p = do+ let getsrcfile = fmap fst <$> prepSendAnnex k+ metered (Just p) k getsrcfile $ \p' -> + fromMaybe False+ <$> runProto u addr connpool (P2P.put k af p') retrieve :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) retrieve u addr connpool k af dest p = unVerified $ - metered (Just p) k $ \p' -> fromMaybe False + metered (Just p) k (return Nothing) $ \p' -> fromMaybe False <$> runProto u addr connpool (P2P.get dest k af p') remove :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool
Remote/WebDAV.hs view
@@ -16,7 +16,9 @@ import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.Lazy.UTF8 as L8 import Network.HTTP.Client (HttpException(..), RequestBody)+#if MIN_VERSION_http_client(0,5,0) import qualified Network.HTTP.Client as HTTP+#endif import Network.HTTP.Types import System.IO.Error import Control.Monad.Catch
Utility/DirWatcher/Win32Notify.hs view
@@ -11,7 +11,7 @@ import Utility.DirWatcher.Types import System.Win32.Notify-import qualified Utility.PosixFiles as Files+import qualified System.PosixCompat.Files as Files watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO WatchManager watchDir dir ignored scanevents hooks = do
Utility/Directory.hs view
@@ -16,6 +16,7 @@ import System.IO.Error import Control.Monad import System.FilePath+import System.PosixCompat.Files import Control.Applicative import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO)@@ -31,7 +32,6 @@ #endif import Utility.SystemDirectory-import Utility.PosixFiles import Utility.Tmp import Utility.Exception import Utility.Monad
Utility/FileMode.hs view
@@ -15,7 +15,7 @@ import System.IO import Control.Monad import System.PosixCompat.Types-import Utility.PosixFiles+import System.PosixCompat.Files #ifndef mingw32_HOST_OS import System.Posix.Files import Control.Monad.IO.Class (liftIO)
Utility/PID.hs view
@@ -13,8 +13,7 @@ import System.Posix.Types (ProcessID) import System.Posix.Process (getProcessID) #else-import System.Win32.Process (ProcessId)-import System.Win32.Process.Current (getCurrentProcessId)+import System.Win32.Process (ProcessId, getCurrentProcessId) #endif #ifndef mingw32_HOST_OS
− Utility/PosixFiles.hs
@@ -1,42 +0,0 @@-{- POSIX files (and compatablity wrappers).- -- - This is like System.PosixCompat.Files, but with a few fixes.- -- - Copyright 2014 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-tabs #-}--module Utility.PosixFiles (- module X,- rename-) where--import System.PosixCompat.Files as X hiding (rename)--#ifndef mingw32_HOST_OS-import System.Posix.Files (rename)-#else-import qualified System.Win32.File as Win32-import qualified System.Win32.HardLink as Win32-#endif--{- System.PosixCompat.Files.rename on Windows calls renameFile,- - so cannot rename directories. - -- - Instead, use Win32 moveFile, which can. It needs to be told to overwrite- - any existing file. -}-#ifdef mingw32_HOST_OS-rename :: FilePath -> FilePath -> IO ()-rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING-#endif--{- System.PosixCompat.Files.createLink throws an error, but windows- - does support hard links. -}-#ifdef mingw32_HOST_OS-createLink :: FilePath -> FilePath -> IO ()-createLink = Win32.createHardLink-#endif
Utility/SRV.hs view
@@ -44,7 +44,7 @@ where use = orderHosts . map tohosts tohosts (priority, weight, port, hostname) =- ( (priority, weight)+ ( (fromIntegral priority, fromIntegral weight) , (B8.toString hostname, PortNumber $ fromIntegral port) )
Utility/Shell.hs view
@@ -12,14 +12,11 @@ import Utility.SafeCommand #ifdef mingw32_HOST_OS import Utility.Path-import Utility.FileSystemEncoding import Utility.Exception import Utility.PartialPrelude-import Utility.Applicative #endif #ifdef mingw32_HOST_OS-import System.IO import System.FilePath #endif
Utility/Su.hs view
@@ -10,9 +10,9 @@ module Utility.Su where import Common-import Utility.Env #ifndef mingw32_HOST_OS+import Utility.Env import System.Posix.Terminal #endif
Utility/Tmp.hs view
@@ -15,13 +15,13 @@ import System.FilePath import System.Directory import Control.Monad.IO.Class+import System.PosixCompat.Files #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp) #endif import Utility.Exception import Utility.FileSystemEncoding-import Utility.PosixFiles type Template = String
Utility/UserInfo.hs view
@@ -15,11 +15,13 @@ ) where import Utility.Env-import Utility.Data import Utility.Exception+#ifndef mingw32_HOST_OS+import Utility.Data+import Control.Applicative+#endif import System.PosixCompat-import Control.Applicative import Prelude {- Current user's home directory.@@ -58,6 +60,7 @@ #ifndef mingw32_HOST_OS go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else- go [] = return $ Left ("environment not set: " ++ show envvars)+ go [] = return $ either Left (Right . extract) $+ Left ("environment not set: " ++ show envvars) #endif go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
Utility/WebApp.hs view
@@ -105,7 +105,7 @@ addr <- inet_addr "127.0.0.1" sock <- socket AF_INET Stream defaultProtocol preparesocket sock- bindSocket sock (SockAddrInet aNY_PORT addr)+ bind sock (SockAddrInet aNY_PORT addr) use sock where #else
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20171109+Version: 6.20171124 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -306,7 +306,7 @@ Executable git-annex Main-Is: git-annex.hs Build-Depends:- base (>= 4.5 && < 5.0),+ base (>= 4.6 && < 5.0), optparse-applicative (>= 0.11.0), containers (>= 0.5.0.0), exceptions (>= 0.6),@@ -360,7 +360,7 @@ split CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs- Extensions: PackageImports+ Extensions: PackageImports, LambdaCase -- Some things don't work with the non-threaded RTS. GHC-Options: -threaded Other-Extensions: TemplateHaskell@@ -380,8 +380,11 @@ Build-Depends: network (< 2.6), network (>= 2.4) if (os(windows))- Build-Depends: Win32 (== 2.3.1.1), Win32-extras, unix-compat (>= 0.4.1.3), setenv,- process (>= 1.4.2.0)+ Build-Depends:+ Win32 (>= 2.6.1.0),+ unix-compat (>= 0.5),+ setenv,+ process (>= 1.6.2.0) else Build-Depends: unix if impl(ghc <= 7.6.3)@@ -1026,7 +1029,6 @@ Utility.PartialPrelude Utility.Path Utility.Percentage- Utility.PosixFiles Utility.Process Utility.Process.Shim Utility.QuickCheck
stack.yaml view
@@ -21,7 +21,6 @@ - bloomfilter-2.0.1.0 - torrent-10000.1.1 - yesod-default-1.2.0-- optparse-applicative-0.14.0.0 explicit-setup-deps: git-annex: true resolver: lts-9.9