summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoeyHess <>2019-10-09 16:34:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-10-09 16:34:00 (GMT)
commit66f771a916b67bd08f4070487e79e4a4359fd852 (patch)
tree6e09eba777f8bcebac4f30093c63f3ffd029e741
parent09e89c7ef80c7e879bfe1376102101cca6baf130 (diff)
version 7.201910097.20191009
-rw-r--r--Annex/AdjustedBranch/Name.hs2
-rw-r--r--Annex/Content/PointerFile.hs17
-rw-r--r--Annex/FileMatcher.hs14
-rw-r--r--Annex/Hook.hs18
-rw-r--r--Annex/Init.hs4
-rw-r--r--Annex/Magic.hs9
-rw-r--r--Assistant/Threads/Cronner.hs2
-rw-r--r--CHANGELOG32
-rw-r--r--COPYRIGHT4
-rw-r--r--CmdLine/GitAnnex/Options.hs32
-rw-r--r--Command/Adjust.hs4
-rw-r--r--Command/Assistant.hs2
-rw-r--r--Command/RemoteDaemon.hs4
-rw-r--r--Command/Watch.hs2
-rw-r--r--Config/Smudge.hs27
-rw-r--r--Database/Fsck.hs2
-rw-r--r--Database/Handle.hs51
-rw-r--r--Database/Keys/SQL.hs2
-rw-r--r--Git/AutoCorrect.hs28
-rw-r--r--Git/CatFile.hs4
-rw-r--r--Git/Credential.hs64
-rw-r--r--Limit.hs68
-rw-r--r--Remote/GitLFS.hs99
-rw-r--r--Test/Framework.hs17
-rw-r--r--Types/AdjustedBranch.hs3
-rw-r--r--Utility/GitLFS.hs106
-rw-r--r--Utility/Su.hs4
-rw-r--r--doc/git-annex-adjust.mdwn18
-rw-r--r--doc/git-annex-copy.mdwn2
-rw-r--r--doc/git-annex-matching-options.mdwn37
-rw-r--r--doc/git-annex-remotedaemon.mdwn13
-rw-r--r--doc/git-annex.mdwn29
-rw-r--r--git-annex.cabal4
33 files changed, 557 insertions, 167 deletions
diff --git a/Annex/AdjustedBranch/Name.hs b/Annex/AdjustedBranch/Name.hs
index 8c074af..5987662 100644
--- a/Annex/AdjustedBranch/Name.hs
+++ b/Annex/AdjustedBranch/Name.hs
@@ -49,7 +49,7 @@ instance SerializeAdjustment LinkAdjustment where
serializeAdjustment FixAdjustment = "fixed"
serializeAdjustment UnFixAdjustment = "unfixed"
deserializeAdjustment "unlocked" = Just UnlockAdjustment
- deserializeAdjustment "locked" = Just UnlockAdjustment
+ deserializeAdjustment "locked" = Just LockAdjustment
deserializeAdjustment "fixed" = Just FixAdjustment
deserializeAdjustment "unfixed" = Just UnFixAdjustment
deserializeAdjustment _ = Nothing
diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs
index 2949ac9..2ed0db5 100644
--- a/Annex/Content/PointerFile.hs
+++ b/Annex/Content/PointerFile.hs
@@ -9,15 +9,20 @@
module Annex.Content.PointerFile where
+#if ! defined(mingw32_HOST_OS)
+import System.Posix.Files
+#else
import System.PosixCompat.Files
+#endif
import Annex.Common
import Annex.Perms
import Annex.Link
import Annex.ReplaceFile
import Annex.InodeSentinal
-import Utility.InodeCache
import Annex.Content.LowLevel
+import Utility.InodeCache
+import Utility.Touch
{- Populates a pointer file with the content of a key.
-
@@ -48,10 +53,18 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
- Does not check if the pointer file is modified. -}
depopulatePointerFile :: Key -> FilePath -> Annex ()
depopulatePointerFile key file = do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
+ st <- liftIO $ catchMaybeIO $ getFileStatus file
+ let mode = fmap fileMode st
secureErase file
liftIO $ nukeFile file
ic <- replaceFile file $ \tmp -> do
liftIO $ writePointerFile tmp key mode
+#if ! defined(mingw32_HOST_OS)
+ -- Don't advance mtime; this avoids unncessary re-smudging
+ -- by git in some cases.
+ liftIO $ maybe noop
+ (\t -> touch tmp t False)
+ (fmap modificationTimeHiRes st)
+#endif
withTSDelta (liftIO . genInodeCache tmp)
maybe noop (restagePointerFile (Restage True) file) ic
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index 6358049..b41a4a4 100644
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -113,14 +113,14 @@ tokenizeMatcher = filter (not . null) . concatMap splitparens . words
where
splitparens = segmentDelim (`elem` "()")
-commonKeylessTokens :: [ParseToken (MatchFiles Annex)]
-commonKeylessTokens =
+commonKeylessTokens :: LimitBy -> [ParseToken (MatchFiles Annex)]
+commonKeylessTokens lb =
[ SimpleToken "anything" (simply limitAnything)
, SimpleToken "nothing" (simply limitNothing)
, ValueToken "include" (usev limitInclude)
, ValueToken "exclude" (usev limitExclude)
- , ValueToken "largerthan" (usev $ limitSize (>))
- , ValueToken "smallerthan" (usev $ limitSize (<))
+ , ValueToken "largerthan" (usev $ limitSize lb (>))
+ , ValueToken "smallerthan" (usev $ limitSize lb (<))
]
commonKeyedTokens :: [ParseToken (MatchFiles Annex)]
@@ -147,7 +147,7 @@ preferredContentKeylessTokens pcd =
[ SimpleToken "standard" (call $ matchStandard pcd)
, SimpleToken "groupwanted" (call $ matchGroupWanted pcd)
, SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir)
- ] ++ commonKeylessTokens
+ ] ++ commonKeylessTokens LimitAnnexFiles
where
preferreddir = fromMaybe "public" $
M.lookup "preferreddir" =<< (`M.lookup` configMap pcd) =<< repoUUID pcd
@@ -182,7 +182,9 @@ mkLargeFilesParser = do
let mimer n = ValueToken n $
const $ Left $ "\""++n++"\" not supported; not built with MagicMime support"
#endif
- let parse = parseToken $ commonKeyedTokens ++ commonKeylessTokens ++
+ let parse = parseToken $
+ commonKeyedTokens ++
+ commonKeylessTokens LimitDiskFiles ++
#ifdef WITH_MAGICMIME
[ mimer "mimetype" $
matchMagic "mimetype" getMagicMimeType providedMimeType
diff --git a/Annex/Hook.hs b/Annex/Hook.hs
index b56b3bf..69dca86 100644
--- a/Annex/Hook.hs
+++ b/Annex/Hook.hs
@@ -1,10 +1,10 @@
{- git-annex git hooks
-
- - Note that it's important that the scripts installed by git-annex
- - not change, otherwise removing old hooks using an old version of
- - the script would fail.
+ - Note that it's important that the content of scripts installed by
+ - git-annex not change, otherwise removing old hooks using an old
+ - version of the script would fail.
-
- - Copyright 2013-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -18,6 +18,16 @@ import Utility.Shell
import qualified Data.Map as M
+-- Remove all hooks.
+unHook :: Annex ()
+unHook = do
+ hookUnWrite preCommitHook
+ hookUnWrite postReceiveHook
+ hookUnWrite postCheckoutHook
+ hookUnWrite postMergeHook
+ hookUnWrite preCommitAnnexHook
+ hookUnWrite postUpdateAnnexHook
+
preCommitHook :: Git.Hook
preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .") []
diff --git a/Annex/Init.hs b/Annex/Init.hs
index bcfe017..e590620 100644
--- a/Annex/Init.hs
+++ b/Annex/Init.hs
@@ -128,8 +128,8 @@ initialize' mversion = checkCanInitialize $ do
uninitialize :: Annex ()
uninitialize = do
- hookUnWrite preCommitHook
- hookUnWrite postReceiveHook
+ unHook
+ deconfigureSmudgeFilter
removeRepoUUID
removeVersion
diff --git a/Annex/Magic.hs b/Annex/Magic.hs
index 6dc823b..8569381 100644
--- a/Annex/Magic.hs
+++ b/Annex/Magic.hs
@@ -17,6 +17,7 @@ module Annex.Magic (
) where
import Types.Mime
+import Control.Monad.IO.Class
#ifdef WITH_MAGICMIME
import Magic
import Utility.Env
@@ -52,8 +53,8 @@ getMagicMime m f = Just . parse <$> magicFile m f
getMagicMime _ _ = return Nothing
#endif
-getMagicMimeType :: Magic -> FilePath -> IO (Maybe MimeType)
-getMagicMimeType m f = fmap fst <$> getMagicMime m f
+getMagicMimeType :: MonadIO m => Magic -> FilePath -> m (Maybe MimeType)
+getMagicMimeType m f = liftIO $ fmap fst <$> getMagicMime m f
-getMagicMimeEncoding :: Magic -> FilePath -> IO (Maybe MimeEncoding)
-getMagicMimeEncoding m f = fmap snd <$> getMagicMime m f
+getMagicMimeEncoding :: MonadIO m => Magic -> FilePath -> m(Maybe MimeEncoding)
+getMagicMimeEncoding m f = liftIO $ fmap snd <$> getMagicMime m f
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index 6122680..a13acab 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/Assistant/Threads/Cronner.hs
@@ -132,7 +132,7 @@ sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnextti
tolate nowt tz = case mmaxt of
Just maxt -> nowt > maxt
-- allow the job to start 10 minutes late
- Nothing ->diffUTCTime
+ Nothing -> diffUTCTime
(localTimeToUTC tz nowt)
(localTimeToUTC tz t) > 600
run nowt = do
diff --git a/CHANGELOG b/CHANGELOG
index 231c843..21a27df 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,35 @@
+git-annex (7.20191009) upstream; urgency=medium
+
+ * Fix bug in handling of annex.largefiles that use largerthan/smallerthan.
+ When adding a modified file, it incorrectly used the file size of the
+ old version of the file, not the current size.
+ * Added --mimetype and --mimeencoding file matching options.
+ * Added --unlocked and --locked file matching options.
+ * Added adjust --lock, to enter an adjusted branch where files are locked.
+ * git-lfs: Added support for http basic auth.
+ * git-lfs: Only do endpoint discovery once when concurrency is enabled.
+ * fsck --incremental/--more: Fix bug that prevented the incremental fsck
+ information from being updated every 5 minutes as it was supposed to be;
+ it was only updated after 1000 files were checked, which may be more
+ files that are possible to fsck in a given fsck time window.
+ Thanks to Peter Simons for help with analysis of this bug.
+ * Test: Use more robust directory removal when built with directory-1.2.7.
+ * Close sqlite databases more robustly.
+ * remotedaemon: Don't list --stop in help since it's not supported.
+ * enable-tor: Run kdesu with -c option.
+ * enable-tor: Use pkexec to run command as root when gksu and kdesu are not
+ available.
+ * When dropping an unlocked file, preserve its mtime, which avoids
+ git status unncessarily running the clean filter on the file.
+ * uninit: Remove several git hooks that git-annex init sets up.
+ * uninit: Remove the smudge and clean filters that git-annex init sets up.
+ * Work around git cat-file --batch's odd stripping of carriage return
+ from the end of the line (some windows infection), avoiding crashing
+ when the repo contains a filename ending in a carriage return.
+ * git-annex-standalone.rpm: Fix the git-annex-shell symlink.
+
+ -- Joey Hess <id@joeyh.name> Wed, 09 Oct 2019 12:31:31 -0400
+
git-annex (7.20190912) upstream; urgency=medium
* Default to v7 for new repositories.
diff --git a/COPYRIGHT b/COPYRIGHT
index 7fe4c9d..a2324d7 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -10,6 +10,10 @@ Copyright: © 2012-2017 Joey Hess <id@joeyh.name>
© 2014 Sören Brunk
License: AGPL-3+
+Files: doc/special_remotes/external/*
+Copyright: © 2013 Joey Hess <id@joeyh.name>
+License: GPL-3+
+
Files: Remote/Ddar.hs
Copyright: © 2011 Joey Hess <id@joeyh.name>
© 2014 Robie Basak <robie@justgohome.co.uk>
diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs
index 7be2e27..ae66588 100644
--- a/CmdLine/GitAnnex/Options.hs
+++ b/CmdLine/GitAnnex/Options.hs
@@ -282,6 +282,26 @@ keyMatchingOptions' =
<> help "match files accessed within a time interval"
<> hidden
)
+ , globalSetter Limit.addMimeType $ strOption
+ ( long "mimetype" <> metavar paramGlob
+ <> help "match files by mime type"
+ <> hidden
+ )
+ , globalSetter Limit.addMimeEncoding $ strOption
+ ( long "mimeencoding" <> metavar paramGlob
+ <> help "match files by mime encoding"
+ <> hidden
+ )
+ , globalFlag Limit.addUnlocked
+ ( long "unlocked"
+ <> help "match files that are unlocked"
+ <> hidden
+ )
+ , globalFlag Limit.addLocked
+ ( long "locked"
+ <> help "match files that are locked"
+ <> hidden
+ )
]
-- Options to match files which may not yet be annexed.
@@ -387,16 +407,20 @@ data DaemonOptions = DaemonOptions
, stopDaemonOption :: Bool
}
-parseDaemonOptions :: Parser DaemonOptions
-parseDaemonOptions = DaemonOptions
- <$> switch
+parseDaemonOptions :: Bool -> Parser DaemonOptions
+parseDaemonOptions canstop
+ | canstop = DaemonOptions <$> foreground <*> stop
+ | otherwise = DaemonOptions <$> foreground <*> pure False
+ where
+ foreground = switch
( long "foreground"
<> help "do not daemonize"
)
- <*> switch
+ stop = switch
( long "stop"
<> help "stop daemon"
)
+
completeRemotes :: HasCompleter f => Mod f a
completeRemotes = completer $ mkCompleter $ \input -> do
r <- maybe (pure Nothing) (Just <$$> Git.Config.read)
diff --git a/Command/Adjust.hs b/Command/Adjust.hs
index 679f98a..1ef8b00 100644
--- a/Command/Adjust.hs
+++ b/Command/Adjust.hs
@@ -26,6 +26,10 @@ linkAdjustmentParser =
( long "unlock"
<> help "unlock annexed files"
)
+ <|> flag' LockAdjustment
+ ( long "lock"
+ <> help "lock annexed files"
+ )
<|> flag' FixAdjustment
( long "fix"
<> help "fix symlinks to annnexed files"
diff --git a/Command/Assistant.hs b/Command/Assistant.hs
index 21ef8a2..9377357 100644
--- a/Command/Assistant.hs
+++ b/Command/Assistant.hs
@@ -34,7 +34,7 @@ data AssistantOptions = AssistantOptions
optParser :: CmdParamsDesc -> Parser AssistantOptions
optParser _ = AssistantOptions
- <$> parseDaemonOptions
+ <$> parseDaemonOptions True
<*> switch
( long "autostart"
<> help "start in known repositories"
diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs
index 95fefff..9f3901b 100644
--- a/Command/RemoteDaemon.hs
+++ b/Command/RemoteDaemon.hs
@@ -15,9 +15,9 @@ import Utility.Daemon
cmd :: Command
cmd = noCommit $
- command "remotedaemon" SectionMaintenance
+ command "remotedaemon" SectionCommon
"persistent communication with remotes"
- paramNothing (run <$$> const parseDaemonOptions)
+ paramNothing (run <$$> const (parseDaemonOptions False))
run :: DaemonOptions -> CommandSeek
run o
diff --git a/Command/Watch.hs b/Command/Watch.hs
index 9cd1e6d..7a613ad 100644
--- a/Command/Watch.hs
+++ b/Command/Watch.hs
@@ -15,7 +15,7 @@ cmd :: Command
cmd = notBareRepo $
command "watch" SectionCommon
"watch for changes and autocommit"
- paramNothing (seek <$$> const parseDaemonOptions)
+ paramNothing (seek <$$> const (parseDaemonOptions True))
seek :: DaemonOptions -> CommandSeek
seek o = commandAction $ start False o Nothing
diff --git a/Config/Smudge.hs b/Config/Smudge.hs
index f1d7bc4..b81db28 100644
--- a/Config/Smudge.hs
+++ b/Config/Smudge.hs
@@ -1,6 +1,6 @@
{- Git smudge filter configuration
-
- - Copyright 2011-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -32,10 +32,25 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
gfs <- readattr gf
liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
createDirectoryIfMissing True (takeDirectory lf)
- writeFile lf (lfs ++ "\n" ++ stdattr)
+ writeFile lf (lfs ++ "\n" ++ unlines stdattr)
where
readattr = liftIO . catchDefaultIO "" . readFileStrict
- stdattr = unlines
- [ "* filter=annex"
- , ".* !filter"
- ]
+
+stdattr :: [String]
+stdattr =
+ [ "* filter=annex"
+ , ".* !filter"
+ ]
+
+-- Note that this removes the local git attributes for filtering,
+-- which is what git-annex installed, but it does not change anything
+-- that may have been committed to a .gitattributes in the repository.
+-- git-annex does not commit that.
+deconfigureSmudgeFilter :: Annex ()
+deconfigureSmudgeFilter = do
+ lf <- Annex.fromRepo Git.attributesLocal
+ ls <- liftIO $ catchDefaultIO [] $ lines <$> readFileStrict lf
+ liftIO $ writeFile lf $ unlines $
+ filter (\l -> l `notElem` stdattr && not (null l)) ls
+ unsetConfig (ConfigKey "filter.annex.smudge")
+ unsetConfig (ConfigKey "filter.annex.clean")
diff --git a/Database/Fsck.hs b/Database/Fsck.hs
index c0c4015..09f9222 100644
--- a/Database/Fsck.hs
+++ b/Database/Fsck.hs
@@ -83,7 +83,7 @@ addDb (FsckHandle h _) k = H.queueDb h checkcommit $
| sz > 1000 = return True
| otherwise = do
now <- getCurrentTime
- return $ diffUTCTime lastcommittime now > 300
+ return $ diffUTCTime now lastcommittime > 300
{- Doesn't know about keys that were just added with addDb. -}
inDb :: FsckHandle -> Key -> IO Bool
diff --git a/Database/Handle.hs b/Database/Handle.hs
index 389ec36..a7a56b7 100644
--- a/Database/Handle.hs
+++ b/Database/Handle.hs
@@ -1,10 +1,12 @@
{- Persistent sqlite database handles.
-
- - Copyright 2015-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
+
module Database.Handle (
DbHandle,
DbConcurrency(..),
@@ -23,6 +25,8 @@ import Database.Persist.Sqlite
import qualified Database.Sqlite as Sqlite
import Control.Monad
import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
+import Control.Monad.Logger (MonadLogger)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception (throwIO, BlockedIndefinitelyOnMVar(..))
@@ -193,7 +197,7 @@ runSqliteRobustly tablename db a = do
go conn retries = do
r <- try $ runResourceT $ runNoLoggingT $
- withSqlConn (wrapConnection conn) $
+ withSqlConnRobustly (wrapConnection conn) $
runSqlConn a
case r of
Right v -> return v
@@ -237,3 +241,46 @@ runSqliteRobustly tablename db a = do
nullselect = T.pack $ "SELECT null from " ++ tablename ++ " limit 1"
briefdelay = threadDelay 1000 -- 1/1000th second
+
+-- Like withSqlConn, but more robust.
+withSqlConnRobustly
+ :: (MonadUnliftIO m, MonadLogger m, IsPersistBackend backend, BaseBackend backend ~ SqlBackend)
+ => (LogFunc -> IO backend)
+ -> (backend -> m a)
+ -> m a
+withSqlConnRobustly open f = do
+ logFunc <- askLogFunc
+ withRunInIO $ \run -> bracket
+ (open logFunc)
+ closeRobustly
+ (run . f)
+
+-- Sqlite can throw ErrorBusy while closing a database; this catches
+-- the exception and retries.
+closeRobustly
+ :: (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)
+ => backend
+ -> IO ()
+closeRobustly conn = go maxretries briefdelay
+ where
+ briefdelay = 1000 -- 1/1000th second
+
+ -- Try up to 14 times; with the delay doubling each time,
+ -- the maximum delay before giving up is 16 seconds.
+ maxretries = 14 :: Int
+
+ go retries delay = do
+ r <- try $ close' conn
+ case r of
+ Right () -> return ()
+ Left ex@(Sqlite.SqliteException { Sqlite.seError = e })
+ | e == Sqlite.ErrorBusy -> do
+ threadDelay delay
+ let delay' = delay * 2
+ let retries' = retries - 1
+ if retries' < 1
+ then rethrow "while closing database connection" ex
+ else go retries' delay'
+ | otherwise -> rethrow "while closing database connection" ex
+
+ rethrow msg e = throwIO $ userError $ show e ++ "(" ++ msg ++ ")"
diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs
index 2314a8d..019990f 100644
--- a/Database/Keys/SQL.hs
+++ b/Database/Keys/SQL.hs
@@ -57,7 +57,7 @@ queueDb a (WriteHandle h) = H.queueDb h checkcommit a
| sz > 1000 = return True
| otherwise = do
now <- getCurrentTime
- return $ diffUTCTime lastcommittime now > 300
+ return $ diffUTCTime now lastcommittime > 300
addAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO ()
addAssociatedFile ik f = queueDb $ do
diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs
index 2faaa32..c7b0fd2 100644
--- a/Git/AutoCorrect.hs
+++ b/Git/AutoCorrect.hs
@@ -40,13 +40,14 @@ fuzzymatches input showchoice choices = fst $ unzip $
similarEnough (_, cst) = cst < similarityFloor
{- Takes action based on git's autocorrect configuration, in preparation for
- - an autocorrected command being run. -}
+ - an autocorrected command being run.
+ -}
prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO ()
prepare input showmatch matches r =
case readish . Git.Config.get "help.autocorrect" "0" =<< r of
Just n
| n == 0 -> list
- | n < 0 -> warn
+ | n < 0 -> warn Nothing
| otherwise -> sleep n
Nothing -> list
where
@@ -55,17 +56,16 @@ prepare input showmatch matches r =
, ""
, "Did you mean one of these?"
] ++ map (\m -> "\t" ++ showmatch m) matches
- warn =
- hPutStr stderr $ unlines
- [ "WARNING: You called a command named '" ++
- input ++ "', which does not exist."
- , "Continuing under the assumption that you meant '" ++
- showmatch (Prelude.head matches) ++ "'"
- ]
+ warn :: Maybe Float -> IO ()
+ warn mdelaysec = hPutStr stderr $ unlines
+ [ "WARNING: You called a git-annex command named '" ++
+ input ++ "', which does not exist."
+ , case mdelaysec of
+ Nothing -> "Continuing under the assumption that you meant " ++ match
+ Just sec -> "Continuing in " ++ show sec ++ " seconds, assuming that you meant " ++ match
+ ]
+ where
+ match = "'" ++ showmatch (Prelude.head matches) ++ "'."
sleep n = do
- warn
- hPutStrLn stderr $ unwords
- [ "in"
- , show (fromIntegral n / 10 :: Float)
- , "seconds automatically..."]
+ warn (Just (fromIntegral n / 10 :: Float))
threadDelay (n * 100000) -- deciseconds to microseconds
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index e49976a..49b8945 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -132,6 +132,10 @@ query hdl object newlinefallback receive
-- filename itself contains a newline, have to fall back to another
-- method of getting the information.
| '\n' `elem` s = newlinefallback
+ -- git strips carriage return from the end of a line, out of some
+ -- misplaced desire to support windows, so also use the newline
+ -- fallback for those.
+ | "\r" `isSuffixOf` s = newlinefallback
| otherwise = CoProcess.query hdl send receive
where
send to = hPutStrLn to s
diff --git a/Git/Credential.hs b/Git/Credential.hs
new file mode 100644
index 0000000..5de95d1
--- /dev/null
+++ b/Git/Credential.hs
@@ -0,0 +1,64 @@
+{- git credential interface
+ -
+ - Copyright 2019 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Git.Credential where
+
+import Common
+import Git
+import Git.Command
+import Utility.Url
+
+import qualified Data.Map as M
+
+data Credential = Credential { fromCredential :: M.Map String String }
+
+credentialUsername :: Credential -> Maybe String
+credentialUsername = M.lookup "username" . fromCredential
+
+credentialPassword :: Credential -> Maybe String
+credentialPassword = M.lookup "password" . fromCredential
+
+-- | This may prompt the user for login information, or get cached login
+-- information.
+getUrlCredential :: URLString -> Repo -> IO Credential
+getUrlCredential = runCredential "fill" . urlCredential
+
+-- | Call if the credential the user entered works, and can be cached for
+-- later use if git is configured to do so.
+approveUrlCredential :: Credential -> Repo -> IO ()
+approveUrlCredential c = void . runCredential "approve" c
+
+-- | Call if the credential the user entered does not work.
+rejectUrlCredential :: Credential -> Repo -> IO ()
+rejectUrlCredential c = void . runCredential "reject" c
+
+urlCredential :: URLString -> Credential
+urlCredential = Credential . M.singleton "url"
+
+runCredential :: String -> Credential -> Repo -> IO Credential
+runCredential action input r =
+ parseCredential <$> pipeWriteRead
+ [ Param "credential"
+ , Param action
+ ]
+ (Just (flip hPutStr formatinput))
+ r
+ where
+ formatinput = concat
+ [ formatCredential input
+ , "\n" -- blank line signifies end of input
+ ]
+
+formatCredential :: Credential -> String
+formatCredential = unlines . map (\(k, v) -> k ++"=" ++ v) . M.toList . fromCredential
+
+parseCredential :: String -> Credential
+parseCredential = Credential . M.fromList . map go . lines
+ where
+ go l = case break (== '=') l of
+ (k, _:v) -> (k, v)
+ (k, []) -> (k, "")
diff --git a/Limit.hs b/Limit.hs
index 67d1540..5ac0fe6 100644
--- a/Limit.hs
+++ b/Limit.hs
@@ -1,6 +1,6 @@
{- user-specified limits on files to act on
-
- - Copyright 2011-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -16,6 +16,7 @@ import Annex.WorkTree
import Annex.Action
import Annex.UUID
import Annex.Magic
+import Annex.Link
import Logs.Trust
import Annex.NumCopies
import Types.Key
@@ -37,6 +38,10 @@ import Data.Time.Clock.POSIX
import qualified Data.Set as S
import qualified Data.Map as M
+{- Some limits can look at the current status of files on
+ - disk, or in the annex. This allows controlling which happens. -}
+data LimitBy = LimitDiskFiles | LimitAnnexFiles
+
{- Checks if there are user-specified limits. -}
limited :: Annex Bool
limited = (not . Utility.Matcher.isEmpty) <$> getMatcher'
@@ -94,12 +99,33 @@ matchGlobFile glob = go
go (MatchingKey _ (AssociatedFile Nothing)) = pure False
go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob af
-matchMagic :: String -> (Magic -> FilePath -> IO (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex
+addMimeType :: String -> Annex ()
+addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType
+
+addMimeEncoding :: String -> Annex ()
+addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding
+
+addMagicLimit :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> String -> Annex ()
+addMagicLimit limitname querymagic selectprovidedinfo glob = do
+ magic <- liftIO initMagicMime
+ addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob
+ where
+ querymagic' magic f = liftIO (isPointerFile f) >>= \case
+ -- Avoid getting magic of a pointer file, which would
+ -- wrongly be detected as text.
+ Just _ -> return Nothing
+ -- When the file is an annex symlink, get magic of the
+ -- object file.
+ Nothing -> isAnnexLink f >>= \case
+ Just k -> withObjectLoc k $ querymagic magic
+ Nothing -> querymagic magic f
+
+matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex
matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $ const go
where
cglob = compileGlob glob CaseSensative -- memoized
go (MatchingKey _ _) = pure False
- go (MatchingFile fi) = liftIO $ catchBoolIO $
+ go (MatchingFile fi) = catchBoolIO $
maybe False (matchGlob cglob)
<$> querymagic magic (currFile fi)
go (MatchingInfo p) =
@@ -107,6 +133,22 @@ matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $
matchMagic limitname _ _ Nothing _ =
Left $ "unable to load magic database; \""++limitname++"\" cannot be used"
+addUnlocked :: Annex ()
+addUnlocked = addLimit $ Right $ const $ matchLockStatus False
+
+addLocked :: Annex ()
+addLocked = addLimit $ Right $ const $ matchLockStatus True
+
+matchLockStatus :: Bool -> MatchInfo -> Annex Bool
+matchLockStatus _ (MatchingKey _ _) = pure False
+matchLockStatus _ (MatchingInfo _) = pure False
+matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do
+ islocked <- isPointerFile (currFile fi) >>= \case
+ Just _key -> return False
+ Nothing -> isSymbolicLink
+ <$> getSymbolicLinkStatus (currFile fi)
+ return (islocked == wantlocked)
+
{- Adds a limit to skip files not believed to be present
- in a specfied repository. Optionally on a prior date. -}
addIn :: String -> Annex ()
@@ -264,26 +306,28 @@ limitSecureHash _ = checkKey $ pure . cryptographicallySecure . keyVariety
{- Adds a limit to skip files that are too large or too small -}
addLargerThan :: String -> Annex ()
-addLargerThan = addLimit . limitSize (>)
+addLargerThan = addLimit . limitSize LimitAnnexFiles (>)
addSmallerThan :: String -> Annex ()
-addSmallerThan = addLimit . limitSize (<)
+addSmallerThan = addLimit . limitSize LimitAnnexFiles (<)
-limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex
-limitSize vs s = case readSize dataUnits s of
+limitSize :: LimitBy -> (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex
+limitSize lb vs s = case readSize dataUnits s of
Nothing -> Left "bad size"
Just sz -> Right $ go sz
where
- go sz _ (MatchingFile fi) = lookupFileKey fi >>= check fi sz
+ go sz _ (MatchingFile fi) = case lb of
+ LimitAnnexFiles -> lookupFileKey fi >>= \case
+ Just key -> checkkey sz key
+ Nothing -> return False
+ LimitDiskFiles -> do
+ filesize <- liftIO $ catchMaybeIO $ getFileSize (currFile fi)
+ return $ filesize `vs` Just sz
go sz _ (MatchingKey key _) = checkkey sz key
go sz _ (MatchingInfo p) =
getInfo (providedFileSize p)
>>= \sz' -> return (Just sz' `vs` Just sz)
checkkey sz key = return $ keySize key `vs` Just sz
- check _ sz (Just key) = checkkey sz key
- check fi sz Nothing = do
- filesize <- liftIO $ catchMaybeIO $ getFileSize (currFile fi)
- return $ filesize `vs` Just sz
addMetaData :: String -> Annex ()
addMetaData = addLimit . limitMetaData
diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs
index 4765d2f..3c43ab1 100644
--- a/Remote/GitLFS.hs
+++ b/Remote/GitLFS.hs
@@ -17,6 +17,7 @@ import qualified Git
import qualified Git.Types as Git
import qualified Git.Url
import qualified Git.GCrypt
+import qualified Git.Credential as Git
import Config
import Config.Cost
import Remote.Helper.Special
@@ -42,6 +43,7 @@ import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
+import qualified Control.Concurrent.MSemN as MSemN
remote :: RemoteType
remote = RemoteType
@@ -64,7 +66,8 @@ gen r u c gc = do
g <- Annex.gitRepo
liftIO $ Git.GCrypt.encryptedRemote g r
else pure r
- h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing r' gc
+ sem <- liftIO $ MSemN.new 1
+ h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc
cst <- remoteCost gc expensiveRemoteCost
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store u h)
@@ -159,31 +162,34 @@ mySetup _ mu _ c gc = do
data LFSHandle = LFSHandle
{ downloadEndpoint :: Maybe LFS.Endpoint
, uploadEndpoint :: Maybe LFS.Endpoint
+ , getEndPointLock :: MSemN.MSemN Int
, remoteRepo :: Git.Repo
, remoteGitConfig :: RemoteGitConfig
}
+-- Only let one thread at a time do endpoint discovery.
+withEndPointLock :: LFSHandle -> Annex a -> Annex a
+withEndPointLock h = bracket_
+ (liftIO $ MSemN.wait l 1)
+ (liftIO $ MSemN.signal l 1)
+ where
+ l = getEndPointLock h
+
discoverLFSEndpoint :: LFS.TransferRequestOperation -> LFSHandle -> Annex (Maybe LFS.Endpoint)
discoverLFSEndpoint tro h
| Git.repoIsSsh r = gossh
| Git.repoIsHttp r = gohttp
- | otherwise = do
- warning "git-lfs endpoint has unsupported URI scheme"
- return Nothing
+ | otherwise = unsupportedurischeme
where
r = remoteRepo h
lfsrepouri = case Git.location r of
Git.Url u -> u
_ -> giveup $ "unsupported git-lfs remote location " ++ Git.repoLocation r
- gohttp = case tro of
- LFS.RequestDownload -> return $ LFS.guessEndpoint lfsrepouri
- LFS.RequestUpload -> do
- -- git-lfs does support storing over http,
- -- but it would need prompting for http basic
- -- authentication each time git-annex discovered
- -- the endpoint.
- warning "Storing content in git-lfs currently needs a ssh repository url, not http."
- return Nothing
+
+ unsupportedurischeme = do
+ warning "git-lfs endpoint has unsupported URI scheme"
+ return Nothing
+
gossh = case mkSshHost <$> Git.Url.hostuser r of
Nothing -> do
warning "Unable to parse ssh url for git-lfs remote."
@@ -216,6 +222,48 @@ discoverLFSEndpoint tro h
warning $ "unexpected response from git-lfs remote when doing ssh endpoint discovery"
return Nothing
Just endpoint -> return (Just endpoint)
+
+ -- The endpoint may or may not need http basic authentication,
+ -- which involves using git-credential to prompt for the password.
+ --
+ -- To determine if it does, make a download or upload request to
+ -- it, not including any objects in the request, and see if
+ -- the server requests authentication.
+ gohttp = case LFS.guessEndpoint lfsrepouri of
+ Nothing -> unsupportedurischeme
+ Just endpoint -> do
+ let testreq = LFS.startTransferRequest endpoint transfernothing
+ flip catchNonAsync (const (returnendpoint endpoint)) $ do
+ resp <- makeSmallAPIRequest testreq
+ if needauth (responseStatus resp)
+ then do
+ cred <- prompt $ inRepo $ Git.getUrlCredential (show lfsrepouri)
+ let endpoint' = addbasicauth cred endpoint
+ let testreq' = LFS.startTransferRequest endpoint' transfernothing
+ flip catchNonAsync (const (returnendpoint endpoint')) $ do
+ resp' <- makeSmallAPIRequest testreq'
+ inRepo $ if needauth (responseStatus resp')
+ then Git.rejectUrlCredential cred
+ else Git.approveUrlCredential cred
+ returnendpoint endpoint'
+ else returnendpoint endpoint
+ where
+ transfernothing = LFS.TransferRequest
+ { LFS.req_operation = tro
+ , LFS.req_transfers = [LFS.Basic]
+ , LFS.req_ref = Nothing
+ , LFS.req_objects = []
+ }
+ returnendpoint = return . Just
+
+ needauth status = status == unauthorized401
+
+ addbasicauth cred endpoint =
+ case (Git.credentialUsername cred, Git.credentialPassword cred) of
+ (Just u, Just p) ->
+ LFS.modifyEndpointRequest endpoint $
+ applyBasicAuth (encodeBS u) (encodeBS p)
+ _ -> endpoint
-- The endpoint is cached for later use.
getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint)
@@ -223,7 +271,7 @@ getLFSEndpoint tro hv = do
h <- liftIO $ atomically $ readTVar hv
case f h of
Just endpoint -> return (Just endpoint)
- Nothing -> discoverLFSEndpoint tro h >>= \case
+ Nothing -> withEndPointLock h $ discoverLFSEndpoint tro h >>= \case
Just endpoint -> do
liftIO $ atomically $ writeTVar hv $
case tro of
@@ -256,16 +304,14 @@ sendTransferRequest
=> LFS.TransferRequest
-> LFS.Endpoint
-> Annex (Either String (LFS.TransferResponse op))
-sendTransferRequest req endpoint =
- case LFS.startTransferRequest endpoint req of
- Just httpreq -> do
- httpresp <- makeSmallAPIRequest $ setRequestCheckStatus httpreq
- return $ case LFS.parseTransferResponse (responseBody httpresp) of
- LFS.ParsedTransferResponse resp -> Right resp
- LFS.ParsedTransferResponseError tro -> Left $
- T.unpack $ LFS.resperr_message tro
- LFS.ParseFailed err -> Left err
- Nothing -> return $ Left "unable to parse git-lfs endpoint url"
+sendTransferRequest req endpoint = do
+ let httpreq = LFS.startTransferRequest endpoint req
+ httpresp <- makeSmallAPIRequest $ setRequestCheckStatus httpreq
+ return $ case LFS.parseTransferResponse (responseBody httpresp) of
+ LFS.ParsedTransferResponse resp -> Right resp
+ LFS.ParsedTransferResponseError tro -> Left $
+ T.unpack $ LFS.resperr_message tro
+ LFS.ParseFailed err -> Left err
extractKeySha256 :: Key -> Maybe LFS.SHA256
extractKeySha256 k = case keyVariety k of
@@ -409,9 +455,8 @@ checkKey u h key = getLFSEndpoint LFS.RequestDownload h >>= \case
-- Unable to find enough information to request the key
-- from git-lfs, so it's not present there.
Nothing -> return False
- Just (req, sha256, size) -> case LFS.startTransferRequest endpoint req of
- Nothing -> giveup "unable to parse git-lfs endpoint url"
- Just httpreq -> go sha256 size =<< makeSmallAPIRequest httpreq
+ Just (req, sha256, size) -> go sha256 size
+ =<< makeSmallAPIRequest (LFS.startTransferRequest endpoint req)
where
go sha256 size httpresp
| responseStatus httpresp == status200 = go' sha256 size $
diff --git a/Test/Framework.hs b/Test/Framework.hs
index 000d80e..93e9e3a 100644
--- a/Test/Framework.hs
+++ b/Test/Framework.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE CPP #-}
+
module Test.Framework where
import Test.Tasty
@@ -223,26 +225,33 @@ isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
a
+removeDirectoryForCleanup :: FilePath -> IO ()
+#if MIN_VERSION_directory(1,2,7)
+removeDirectoryForCleanup = removePathForcibly
+#else
+removeDirectoryForCleanup = removeDirectoryRecursive
+#endif
+
cleanup :: FilePath -> IO ()
cleanup dir = whenM (doesDirectoryExist dir) $ do
Command.Uninit.prepareRemoveAnnexDir' dir
-- This can fail if files in the directory are still open by a
-- subprocess.
- void $ tryIO $ removeDirectoryRecursive dir
+ void $ tryIO $ removeDirectoryForCleanup dir
finalCleanup :: IO ()
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
Annex.Action.reapZombies
Command.Uninit.prepareRemoveAnnexDir' tmpdir
- catchIO (removeDirectoryRecursive tmpdir) $ \e -> do
+ catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do
print e
putStrLn "sleeping 10 seconds and will retry directory cleanup"
Utility.ThreadScheduler.threadDelaySeconds $
Utility.ThreadScheduler.Seconds 10
whenM (doesDirectoryExist tmpdir) $ do
Annex.Action.reapZombies
- removeDirectoryRecursive tmpdir
-
+ removeDirectoryForCleanup tmpdir
+
checklink :: FilePath -> Assertion
checklink f = ifM (annexeval Config.crippledFileSystem)
( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))
diff --git a/Types/AdjustedBranch.hs b/Types/AdjustedBranch.hs
index bf59658..f3ed1af 100644
--- a/Types/AdjustedBranch.hs
+++ b/Types/AdjustedBranch.hs
@@ -39,7 +39,8 @@ instance ReversableAdjustment Adjustment where
instance ReversableAdjustment LinkAdjustment where
reverseAdjustment UnlockAdjustment = LockAdjustment
- reverseAdjustment LockAdjustment = UnlockAdjustment
+ -- Keep the file locked intentionally when reversing LockAdjustment.
+ reverseAdjustment LockAdjustment = LockAdjustment
reverseAdjustment FixAdjustment = UnFixAdjustment
reverseAdjustment UnFixAdjustment = FixAdjustment
diff --git a/Utility/GitLFS.hs b/Utility/GitLFS.hs
index 754df04..82c4808 100644
--- a/Utility/GitLFS.hs
+++ b/Utility/GitLFS.hs
@@ -7,18 +7,29 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
+-- | This implementation of the git-lfs API uses http Request and Response,
+-- but leaves actually connecting up the http client to the user.
+--
+-- You'll want to use a Manager that supports https, since the protocol
+-- uses http basic auth.
+--
+-- Some LFS servers, notably Github's, may require a User-Agent header
+-- in some of the requests, in order to allow eg, uploads. No such header
+-- is added by default, so be sure to add your own.
+
{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Utility.GitLFS (
- -- * transfer requests
+ -- * Transfer requests
TransferRequest(..),
TransferRequestOperation(..),
TransferAdapter(..),
TransferRequestObject(..),
startTransferRequest,
- -- * responses to transfer requests
+
+ -- * Responses to transfer requests
TransferResponse(..),
TransferResponseOperation(..),
IsTransferResponseOperation,
@@ -27,19 +38,23 @@ module Utility.GitLFS (
OperationParams(..),
ParsedTransferResponse(..),
parseTransferResponse,
- -- * making transfers
+
+ -- * Making transfers
downloadOperationRequest,
uploadOperationRequests,
- -- * endpoint discovery
+
+ -- * Endpoint discovery
Endpoint,
guessEndpoint,
- HostUser,
+ modifyEndpointRequest,
sshDiscoverEndpointCommand,
parseSshDiscoverEndpointResponse,
- -- * errors
+
+ -- * Errors
TransferResponseError(..),
TransferResponseObjectError(..),
- -- * additional data types
+
+ -- * Additional data types
Url,
SHA256,
GitRef(..),
@@ -48,16 +63,6 @@ module Utility.GitLFS (
HTTPHeaderValue,
) where
--- | This implementation of the git-lfs API uses http Request and Response,
--- but leaves actually connecting up the http client to the user.
---
--- You'll want to use a Manager that supports https, since the protocol
--- uses http basic auth.
---
--- Some LFS servers, notably Github's, may require a User-Agent header
--- in some of the requests, in order to allow eg, uploads. No such header
--- is added by dedault, so be sure to add your own.
-
import Data.Aeson
import Data.Aeson.Types
import GHC.Generics
@@ -278,9 +283,7 @@ instance ToJSON GitRef
type SHA256 = T.Text
-- | The endpoint of a git-lfs server.
-data Endpoint
- = EndpointURI URI.URI
- | EndpointDiscovered SshDiscoveryResponse
+data Endpoint = Endpoint Request
deriving (Show)
-- | Command to run via ssh with to discover an endpoint. The FilePath is
@@ -298,20 +301,41 @@ sshDiscoverEndpointCommand remotepath tro =
RequestUpload -> "upload"
]
+-- Internal smart constructor for an Endpoint.
+--
+-- Since this uses the LFS batch API, it adds /objects/batch
+-- to the endpoint url. It also adds the necessary headers to use JSON.
+mkEndpoint :: URI.URI -> Maybe Endpoint
+mkEndpoint uri = do
+ r <- requestFromURI uri
+ let r' = addLfsJsonHeaders $ r { path = path r <> "/objects/batch" }
+ return (Endpoint r')
+
-- | Parse the json output when doing ssh endpoint discovery.
parseSshDiscoverEndpointResponse :: L.ByteString -> Maybe Endpoint
-parseSshDiscoverEndpointResponse resp = EndpointDiscovered <$> decode resp
+parseSshDiscoverEndpointResponse resp = do
+ sr <- decode resp
+ uri <- URI.parseURI (T.unpack (endpoint_href sr))
+ endpoint <- mkEndpoint uri
+ return $ modifyEndpointRequest endpoint $ case endpoint_header sr of
+ Nothing -> id
+ Just headers ->
+ let headers' = map convheader (M.toList headers)
+ in \req -> req
+ { requestHeaders = requestHeaders req ++ headers' }
+ where
+ convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
-- | Guesses the LFS endpoint from the http url of a git remote.
--
-- https://github.com/git-lfs/git-lfs/blob/master/docs/api/server-discovery.md
guessEndpoint :: URI.URI -> Maybe Endpoint
guessEndpoint uri = case URI.uriScheme uri of
- "https:" -> Just endpoint
- "http:" -> Just endpoint
+ "https:" -> endpoint
+ "http:" -> endpoint
_ -> Nothing
where
- endpoint = EndpointURI $ uri
+ endpoint = mkEndpoint $ uri
-- force https because the git-lfs protocol uses http
-- basic auth tokens, which should not be exposed
{ URI.uriScheme = "https:"
@@ -327,28 +351,22 @@ guessEndpoint uri = case URI.uriScheme uri of
droptrailing c = reverse . dropWhile (== c) . reverse
+-- | When an Endpoint is used to generate a Request, this allows adjusting
+-- that Request.
+--
+-- This can be used to add http basic authentication to an Endpoint:
+--
+-- > modifyEndpointRequest (guessEndpoint u) (applyBasicAuth "user" "pass")
+modifyEndpointRequest :: Endpoint -> (Request -> Request) -> Endpoint
+modifyEndpointRequest (Endpoint r) f = Endpoint (f r)
+
-- | Makes a Request that will start the process of making a transfer to or
-- from the LFS endpoint.
-startTransferRequest :: Endpoint -> TransferRequest -> Maybe Request
-startTransferRequest (EndpointURI uri) tr = do
- r <- requestFromURI uri
- return $ addLfsJsonHeaders $ r
- -- Since this uses the LFS batch API, it adds /objects/batch
- -- to the endpoint url.
- { path = path r <> "/objects/batch"
- , method = "POST"
- , requestBody = RequestBodyLBS (encode tr)
- }
-startTransferRequest (EndpointDiscovered sr) tr = do
- uri <- URI.parseURI (T.unpack (endpoint_href sr))
- req <- startTransferRequest (EndpointURI uri) tr
- let headers = map convheader $ maybe [] M.toList $ endpoint_header sr
- return $ req { requestHeaders = requestHeaders req ++ headers }
- where
- convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
-
--- | "user@host" or just the hostname.
-type HostUser = String
+startTransferRequest :: Endpoint -> TransferRequest -> Request
+startTransferRequest (Endpoint r) tr = r
+ { method = "POST"
+ , requestBody = RequestBodyLBS (encode tr)
+ }
addLfsJsonHeaders :: Request -> Request
addLfsJsonHeaders r = r
diff --git a/Utility/Su.hs b/Utility/Su.hs
index a0500e4..d9ec5e8 100644
--- a/Utility/Su.hs
+++ b/Utility/Su.hs
@@ -76,7 +76,9 @@ mkSuCommand cmd ps = firstM (\(SuCommand _ p _) -> inPath p) =<< selectcmds
[ SuCommand (MayPromptPassword SomePassword) "gksu"
[Param shellcmd]
, SuCommand (MayPromptPassword SomePassword) "kdesu"
- [Param shellcmd]
+ [Param "-c", Param shellcmd]
+ , SuCommand (MayPromptPassword SomePassword) "pkexec"
+ ([Param cmd] ++ ps)
-- Available in Debian's menu package; knows about lots of
-- ways to gain root.
, SuCommand (MayPromptPassword SomePassword) "su-to-root"
diff --git a/doc/git-annex-adjust.mdwn b/doc/git-annex-adjust.mdwn
index 1b6a93f..8e5333f 100644
--- a/doc/git-annex-adjust.mdwn
+++ b/doc/git-annex-adjust.mdwn
@@ -4,7 +4,7 @@ git-annex adjust - enter an adjusted branch
# SYNOPSIS
-git annex adjust `--unlock|--fix|--hide-missing [--unlock|--fix]`
+git annex adjust `--unlock|--lock|--fix|--hide-missing [--unlock|--lock|--fix]`
# DESCRIPTION
@@ -49,6 +49,20 @@ back to the original branch.
disk space, any modification made to a file will cause the old version of the
file to be lost from the local repository. So, enable annex.thin with care.
+ When in an adjusted unlocked branch, `git annex add` will add files
+ unlocked instead of the default behavior of adding them locked.
+
+* `--lock`
+
+ Lock all annexed file in the adjusted branch. This may be preferred
+ by those who like seeing broken symlinks when the content of an
+ annexed file is not present.
+
+ When in an adjusted locked branch, `git annex add` will add files locked,
+ as usual. However, `git add` (and `git commit -a` etc) still add files
+ unlocked. This is because it's not possible for those git commands to
+ add files locked.
+
* `--fix`
Fix the symlinks to annexed files to point to the local git annex
@@ -74,7 +88,7 @@ back to the original branch.
still operate on them, and can be used to download missing
files from remotes.
- This option can be combined with --unlock or --fix.
+ This option can be combined with --unlock, --lock, or --fix.
# SEE ALSO
diff --git a/doc/git-annex-copy.mdwn b/doc/git-annex-copy.mdwn
index ab60c43..84c23d4 100644
--- a/doc/git-annex-copy.mdwn
+++ b/doc/git-annex-copy.mdwn
@@ -69,7 +69,7 @@ Copies the content of files from or to another remote.
* `--key=keyname`
- Use this option to move a specified key.
+ Use this option to copy a specified key.
* file matching options
diff --git a/doc/git-annex-matching-options.mdwn b/doc/git-annex-matching-options.mdwn
index 81f705f..bc8cad5 100644
--- a/doc/git-annex-matching-options.mdwn
+++ b/doc/git-annex-matching-options.mdwn
@@ -159,6 +159,43 @@ in either of two repositories.
If the OS or filesystem does not support access times, this will not
match any files.
+* `--unlocked`
+
+ Matches annexed files that are unlocked.
+
+* `--locked`
+
+ Matches annexed files that are locked.
+
+* `--mimetype=glob`
+
+ Looks up the MIME type of a file, and checks if the glob matches it.
+
+ For example, `--mimetype="text/*"` will match many varieties of text files,
+ including "text/plain", but also "text/x-shellscript", "text/x-makefile",
+ etc.
+
+ The MIME types are the same that are displayed by running `file --mime-type`
+
+ If the file's annexed content is not present, the file will not match.
+
+ This is only available to use when git-annex was built with the
+ MagicMime build flag.
+
+* `--mimeencoding=glob`
+
+ Looks up the MIME encoding of a file, and checks if the glob matches it.
+
+ For example, `--mimeencoding=binary` will match many kinds of binary
+ files.
+
+ The MIME encodings are the same that are displayed by running `file --mime-encoding`
+
+ If the file's annexed content is not present, the file will not match.
+
+ This is only available to use when git-annex was built with the
+ MagicMime build flag.
+
* `--not`
Inverts the next matching option. For example, to only act on
diff --git a/doc/git-annex-remotedaemon.mdwn b/doc/git-annex-remotedaemon.mdwn
index 609698e..f5df943 100644
--- a/doc/git-annex-remotedaemon.mdwn
+++ b/doc/git-annex-remotedaemon.mdwn
@@ -9,20 +9,15 @@ git annex remotedaemon
# DESCRIPTION
The remotedaemon provides persistent communication with remotes.
-It detects when git branches on remotes have changes, and fetches
-the changes from them.
-
-The assistant runs the remotedaemon and communicates with it on
-stdio using a simple textual protocol.
Several types of remotes are supported:
For ssh remotes, the remotedaemon tries to maintain a connection to the
remote git repository, and uses git-annex-shell notifychanges to detect
-when the remote git repository has changed. For this to work, the git
-remote must have [[git-annex-shell]](1) installed, with notifychanges
-support. The first version of git-annex-shell that supports it is
-5.20140405.
+when the remote git repository has changed, and fetches changes from it.
+For this to work, the git remote must have [[git-annex-shell]](1)
+installed, with notifychanges support. The first version of git-annex-shell
+that supports it is 5.20140405.
For tor-annex remotes, the remotedaemon runs a tor hidden service,
accepting connections from other nodes and serving up the contents of the
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 121e0d9..bea502f 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -197,6 +197,12 @@ subdirectories).
See [[git-annex-webapp]](1) for details.
+* `remotedaemon`
+
+ Persistant communication with remotes.
+
+ See [[git-annex-remotedaemon]](1) for details.
+
# REPOSITORY SETUP COMMANDS
* `init [description]`
@@ -687,12 +693,6 @@ subdirectories).
See [[git-annex-smudge]](1) for details.
-* `remotedaemon`
-
- Detects when network remotes have received git pushes and fetches from them.
-
- See [[git-annex-remotedaemon]](1) for details.
-
* `findref [ref]`
Lists files in a git ref. (deprecated)
@@ -868,7 +868,7 @@ Like other git commands, git-annex is configured via `.git/config`.
the repository that use insecure hashes.
To configure the behavior in new clones of the repository,
- this can be set in [[git-annex-config]].
+ this can be set using [[git-annex-config]].
* `annex.maxextensionlength`
@@ -906,8 +906,11 @@ Like other git commands, git-annex is configured via `.git/config`.
* `annex.addunlocked`
Set to true to make commands like `git-annex add` that add files to the
- repository add them in unlocked form. The default is to add files in
- locked form.
+ repository add them in unlocked form. The default is for these commands
+ to add files in locked form.
+
+ (Using `git add` always adds files in unlocked form and it is not
+ affected by this setting.)
When a repository has core.symlinks set to false, it implicitly
sets annex.addunlocked to true.
@@ -941,7 +944,7 @@ Like other git commands, git-annex is configured via `.git/config`.
This controls which refs `git-annex unused` considers to be used.
See REFSPEC FORMAT in [[git-annex-unused]](1) for details.
-* `annex.jobs
+* `annex.jobs`
Configure the number of concurrent jobs to run. Default is 1.
@@ -1051,14 +1054,14 @@ Like other git commands, git-annex is configured via `.git/config`.
and the git-annex post-receive hook.
To configure the behavior in all clones of the repository,
- this can be set in [[git-annex-config]].
+ this can be set in [[git-annex-config]](1).
* `annex.synccontent`
Set to true to make git-annex sync default to syncing content.
To configure the behavior in all clones of the repository,
- this can be set in [[git-annex-config]].
+ this can be set in [[git-annex-config]](1).
* `annex.debug`
@@ -1630,7 +1633,7 @@ Remotes are configured using these settings in `.git/config`.
from automatically committing changes to files in the repository.
To configure the behavior in all clones of the repository,
- this can be set in [[git-annex-config]].
+ this can be set in [[git-annex-config]](1).
* `annex.startupscan`
diff --git a/git-annex.cabal b/git-annex.cabal
index c2a99e5..15d08ce 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 7.20190912
+Version: 7.20191009
Cabal-Version: >= 1.8
License: AGPL-3
Maintainer: Joey Hess <id@joeyh.name>
@@ -344,6 +344,7 @@ Executable git-annex
persistent-sqlite (>= 2.8.1),
persistent (>= 2.8.1),
persistent-template,
+ unliftio-core,
microlens,
aeson,
vector,
@@ -833,6 +834,7 @@ Executable git-annex
Git.Config
Git.ConfigTypes
Git.Construct
+ Git.Credential
Git.CurrentRepo
Git.DiffTree
Git.DiffTreeItem