git-annex 7.20190730 → 7.20190819
raw patch · 42 files changed
+1360/−260 lines, 42 filesdep +silently
Dependencies added: silently
Files
- Annex/DirHashes.hs +1/−1
- Annex/FileMatcher.hs +3/−1
- Annex/Hook.hs +2/−6
- Annex/View.hs +6/−2
- Annex/WorkTree.hs +1/−1
- Backend/Hash.hs +1/−0
- Build/DesktopFile.hs +2/−0
- CHANGELOG +40/−0
- COPYRIGHT +4/−0
- Command/Init.hs +6/−0
- Command/Merge.hs +22/−13
- Git/CatFile.hs +1/−1
- Git/Hook.hs +13/−2
- Git/Url.hs +7/−1
- Limit.hs +7/−7
- Remote/Adb.hs +9/−6
- Remote/Directory.hs +9/−6
- Remote/GCrypt.hs +12/−9
- Remote/Git.hs +9/−0
- Remote/GitLFS.hs +449/−0
- Remote/Helper/ExportImport.hs +5/−3
- Remote/Helper/ReadOnly.hs +6/−7
- Remote/List.hs +2/−0
- Remote/S3.hs +22/−16
- Test.hs +60/−39
- Test/Framework.hs +66/−40
- Types/GitConfig.hs +2/−0
- Types/Remote.hs +1/−1
- Utility/Env/Set.hs +0/−1
- Utility/GitLFS.hs +439/−0
- Utility/Gpg.hs +1/−1
- Utility/InodeCache.hs +0/−1
- Utility/Metered.hs +18/−8
- Utility/Path/Max.hs +3/−3
- Utility/Rsync.hs +10/−1
- Utility/Url.hs +67/−58
- doc/git-annex-adjust.mdwn +5/−0
- doc/git-annex-import.mdwn +11/−5
- doc/git-annex-merge.mdwn +12/−5
- doc/git-annex.mdwn +20/−13
- git-annex.cabal +5/−2
- stack.yaml +1/−0
Annex/DirHashes.hs view
@@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess <id@joeyh.name> -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher. -} module Annex.DirHashes (
Annex/FileMatcher.hs view
@@ -35,8 +35,10 @@ import Git.FilePath import Types.Remote (RemoteConfig) import Annex.CheckAttr-import Annex.Magic import Git.CheckAttr (unspecifiedAttr)+#ifdef WITH_MAGICMIME+import Annex.Magic+#endif import Data.Either import qualified Data.Set as S
Annex/Hook.hs view
@@ -13,7 +13,6 @@ import Annex.Common import qualified Git.Hook as Git-import Config import qualified Annex import Utility.Shell @@ -57,11 +56,8 @@ ] hookWrite :: Git.Hook -> Annex ()-hookWrite h = - -- cannot have git hooks in a crippled filesystem (no execute bit)- unlessM crippledFileSystem $- unlessM (inRepo $ Git.hookWrite h) $- hookWarning h "already exists, not configuring"+hookWrite h = unlessM (inRepo $ Git.hookWrite h) $+ hookWarning h "already exists, not configuring" hookUnWrite :: Git.Hook -> Annex () hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
Annex/View.hs view
@@ -283,8 +283,12 @@ - MetaFields that were present in the input metadata - (excluding fields that are not visible). -} prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool-prop_view_roundtrips f metadata visible = null f || viewTooLarge view ||- all hasfields (viewedFiles view viewedFileFromReference f metadata)+prop_view_roundtrips f metadata visible = or+ [ null f+ , null (takeFileName f) && null (takeDirectory f)+ , viewTooLarge view+ , all hasfields (viewedFiles view viewedFileFromReference f metadata)+ ] where view = View (Git.Ref "master") $ map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . B.null . fromMetaValue) mv) visible)
Annex/WorkTree.hs view
@@ -78,7 +78,7 @@ - an annex object. If so, make the unlocked file use that content. -} scanUnlockedFiles :: Annex ()-scanUnlockedFiles = whenM (inRepo $ Git.Ref.exists Git.Ref.headRef) $ do+scanUnlockedFiles = whenM (inRepo Git.Ref.headExists) $ do showSideAction "scanning for unlocked files" Database.Keys.runWriter $ liftIO . Database.Keys.SQL.dropAllAssociatedFiles
Backend/Hash.hs view
@@ -10,6 +10,7 @@ module Backend.Hash ( backends, testKeyBackend,+ keyHash, ) where import Annex.Common
Build/DesktopFile.hs view
@@ -22,10 +22,12 @@ import Assistant.Install.Menu import System.Environment+#ifndef mingw32_HOST_OS import System.PosixCompat.User import Data.Maybe import Control.Applicative import Prelude+#endif systemwideInstall :: IO Bool #ifndef mingw32_HOST_OS
CHANGELOG view
@@ -1,3 +1,43 @@+git-annex (7.20190819) upstream; urgency=medium++ * New git-lfs special remote, which can be used to store data on any git-lfs+ server, including github, gitlab, and gogs.+ * Support fully encrypting all data sent to a git-lfs special remote,+ using a combination of gcrypt to encrypt the git data, and git-annex's+ encryption of its data.+ * Use the same optimisation for --in=here as has always been+ used for --in=. rather than the slow code path that unncessarily+ queries the git-annex branch.+ * Allow setting up a gcrypt special remote with encryption=shared.+ * Fix querying git for object type when operating on a file containing+ newlines.+ * merge: When run with a branch parameter, merges from that branch.+ This is especially useful when using an adjusted branch, because+ it applies the same adjustment to the branch before merging it.+ * init: Install working hook scripts when run on a crippled filesystem+ and on Windows. If your repository was set up by an old version+ of git-annex that omitted the hooks, you can simply re-run git-annex init+ to install them.+ * init: When the repo is already initialized, and --version requests a+ different version, error out rather than silently not changing the+ version.+ * S3: Fix encoding when generating public urls of S3 objects.+ * Make git-annex-standalone.deb include the shell completions again.+ * Makefile: Changed default zsh completion location to zsh default fpath.+ Systems such as Debian that have overridden the default fpath will+ need to set ZSH_COMPLETIONS_PATH.+ * test: Add pass using adjusted unlocked branch.+ * Fix intermittent failure of the test suite, where its repeated opening+ and writing to the sqlite database somehow caused inode cache information+ to occasionally be lost.+ * Fix several test suite failures on Windows.+ * Windows installer: Always install to 64 bit program files directory,+ since it needs 64 bit git now.+ * Build with silently-1.2.5.1 on Windows; the old one used "NUL" device+ which is not supported with recent versions of ghc.++ -- Joey Hess <id@joeyh.name> Mon, 19 Aug 2019 12:23:16 -0400+ git-annex (7.20190730) upstream; urgency=medium * Improved probing when CoW copies can be made between files on the same
COPYRIGHT view
@@ -25,6 +25,10 @@ 2013 Michael Snoyman License: Expat +Files: Utility/GitLFS.hs+Copyright: © 2019 Joey Hess <id@joeyh.name>+License: AGPL-3++ Files: Utility/* Copyright: 2012-2019 Joey Hess <id@joeyh.name> License: BSD-2-clause
Command/Init.hs view
@@ -51,6 +51,12 @@ perform :: InitOptions -> CommandPerform perform os = do+ case initVersion os of+ Nothing -> noop+ Just wantversion -> getVersion >>= \case+ Just v | v /= wantversion ->+ giveup $ "This repository is already a initialized with version " ++ show (fromRepoVersion v) ++ ", not changing to requested version."+ _ -> noop initialize (if null (initDesc os) then Nothing else Just (initDesc os)) (initVersion os)
Command/Merge.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2011, 2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -9,27 +9,36 @@ import Command import qualified Annex.Branch+import qualified Git+import qualified Git.Branch import Annex.CurrentBranch-import Command.Sync (prepMerge, mergeLocal, mergeConfig)+import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge) cmd :: Command cmd = command "merge" SectionMaintenance- "automatically merge changes from remotes"- paramNothing (withParams seek)+ "merge changes from remotes"+ (paramOptional paramRef) (withParams seek) seek :: CmdParams -> CommandSeek-seek _ = do- commandAction mergeBranch- commandAction mergeSynced+seek [] = do+ prepMerge+ commandAction mergeAnnexBranch+ commandAction mergeSyncedBranch+seek bs = do+ prepMerge+ forM_ bs (commandAction . mergeBranch . Git.Ref) -mergeBranch :: CommandStart-mergeBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do+mergeAnnexBranch :: CommandStart+mergeAnnexBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do Annex.Branch.update -- commit explicitly, in case no remote branches were merged Annex.Branch.commit =<< Annex.Branch.commitMessage next $ return True -mergeSynced :: CommandStart-mergeSynced = do- prepMerge- mergeLocal mergeConfig def =<< getCurrentBranch+mergeSyncedBranch :: CommandStart+mergeSyncedBranch = mergeLocal mergeConfig def =<< getCurrentBranch++mergeBranch :: Git.Ref -> CommandStart+mergeBranch r = starting "merge" (ActionItemOther (Just (Git.fromRef r))) $ do+ currbranch <- getCurrentBranch+ next $ merge currbranch mergeConfig def Git.Branch.ManualCommit r
Git/CatFile.hs view
@@ -182,7 +182,7 @@ queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType) queryObjectType r repo = maybe Nothing (readObjectType . takeWhile (/= '\n'))- <$> querySingle (Param "cat-file") r repo hGetContentsStrict+ <$> querySingle (Param "-t") r repo hGetContentsStrict queryContent :: Ref -> Repo -> IO (Maybe L.ByteString) queryContent r repo = fmap (\b -> L.fromChunks [b])
Git/Hook.hs view
@@ -31,7 +31,18 @@ hookFile h r = localGitDir r </> "hooks" </> hookName h {- Writes a hook. Returns False if the hook already exists with a different- - content. Upgrades old scripts. -}+ - content. Upgrades old scripts.+ -+ - This can install hooks on both filesystem like FAT that do not support+ - execute bits, and on Windows.+ -+ - If the filesystem does not support execute bits, it's typically mounted+ - such that all files have the execute bit set. So just write the hook+ - and ignore failure to make it executable.+ -+ - On Windows, git will run hooks that are not executable. The hook+ - is run with a bundled bash, so should start with #!/bin/sh+ -} hookWrite :: Hook -> Repo -> IO Bool hookWrite h r = ifM (doesFileExist f) ( expectedContent h r >>= \case@@ -45,7 +56,7 @@ go = do viaTmp writeFile f (hookScript h) p <- getPermissions f- setPermissions f $ p {executable = True}+ void $ tryIO $ setPermissions f $ p {executable = True} return True {- Removes a hook. Returns False if the hook contained something else, and
Git/Url.hs view
@@ -11,9 +11,10 @@ port, hostuser, authority,+ path, ) where -import Network.URI hiding (scheme, authority)+import Network.URI hiding (scheme, authority, path) import Common import Git.Types@@ -65,6 +66,11 @@ authpart :: (URIAuth -> a) -> Repo -> Maybe a authpart a Repo { location = Url u } = a <$> uriAuthority u authpart _ repo = notUrl repo++{- Path part of an URL repo. -}+path :: Repo -> FilePath+path Repo { location = Url u } = uriPath u+path repo = notUrl repo notUrl :: Repo -> a notUrl repo = error $
Limit.hs view
@@ -110,15 +110,15 @@ {- Adds a limit to skip files not believed to be present - in a specfied repository. Optionally on a prior date. -} addIn :: String -> Annex ()-addIn s = addLimit =<< mk+addIn s = do+ u <- Remote.nameToUUID name+ hereu <- getUUID+ addLimit $ if u == hereu && null date+ then use inhere+ else use (inuuid u) where (name, date) = separate (== '@') s- mk- | name == "." = if null date- then use inhere- else use . inuuid =<< getUUID- | otherwise = use . inuuid =<< Remote.nameToUUID name- use a = return $ Right $ \notpresent -> checkKey (a notpresent)+ use a = Right $ checkKey . a inuuid u notpresent key | null date = do us <- Remote.keyLocations key
Remote/Adb.hs view
@@ -291,17 +291,19 @@ where src = androidExportLocation adir loc -storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)-storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p = catchDefaultIO Nothing $+storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier)+storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p = -- Check if overwrite is safe before sending, because sending the -- file is expensive and don't want to do it unncessarily. ifM checkcanoverwrite ( ifM (store'' serial dest src checkcanoverwrite)- ( liftIO $ either (const Nothing) id - <$> getExportContentIdentifier serial adir loc- , return Nothing+ ( liftIO $ getExportContentIdentifier serial adir loc >>= return . \case+ Right (Just cid) -> Right cid+ Right Nothing -> Left "adb failed to store file"+ Left _ -> Left "unable to get content identifier for file stored on adtb"+ , return $ Left "adb failed to store file" )- , return Nothing+ , return $ Left "unsafe to overwrite file" ) where dest = androidExportLocation adir loc@@ -377,6 +379,7 @@ mkAdbCommand serial cmd = [Param "-s", Param (fromAndroidSerial serial)] ++ cmd -- Gets the current content identifier for a file on the android device.+-- If the file is not present, returns Right Nothing getExportContentIdentifier :: AndroidSerial -> AndroidPath -> ExportLocation -> IO (Either ExitCode (Maybe ContentIdentifier)) getExportContentIdentifier serial adir loc = liftIO $ do ls <- adbShellRaw serial $ unwords
Remote/Directory.hs view
@@ -395,20 +395,23 @@ | currcid == Just cid = cont | otherwise = return Nothing -storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)+storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) storeExportWithContentIdentifierM dir src _k loc overwritablecids p =- catchDefaultIO Nothing $ do+ catchIO go (return . Left . show)+ where+ go = do liftIO $ createDirectoryIfMissing True destdir withTmpFileIn destdir template $ \tmpf tmph -> do liftIO $ withMeteredFile src p (L.hPut tmph) liftIO $ hFlush tmph+ liftIO $ hClose tmph liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf >>= \case- Nothing -> return Nothing+ Nothing -> + return $ Left "unable to generate content identifier" Just newcid ->- checkExportContent dir loc (newcid:overwritablecids) Nothing $ const $ do+ checkExportContent dir loc (newcid:overwritablecids) (Left "unsafe to overwrite file") $ const $ do liftIO $ rename tmpf dest- return (Just newcid)- where+ return (Right newcid) dest = exportPath dir loc (destdir, base) = splitFileName dest template = relatedTemplate (base ++ ".tmp")
Remote/GCrypt.hs view
@@ -12,6 +12,7 @@ coreGCryptId, setupRepo, accessShellConfig,+ setGcryptEncryption, ) where import qualified Data.Map as M@@ -318,16 +319,18 @@ setGcryptEncryption :: RemoteConfig -> String -> Annex () setGcryptEncryption c remotename = do let participants = remoteconfig Git.GCrypt.remoteParticipantConfigKey- case cipherKeyIds =<< extractCipher c of+ case extractCipher c of Nothing -> noCrypto- Just (KeyIds { keyIds = ks}) -> do- setConfig participants (unwords ks)- let signingkey = ConfigKey $ Git.GCrypt.remoteSigningKey remotename- cmd <- gpgCmd <$> Annex.getGitConfig- skeys <- M.keys <$> liftIO (secretKeys cmd)- case filter (`elem` ks) skeys of- [] -> noop- (k:_) -> setConfig signingkey k+ Just cip -> case cipherKeyIds cip of+ Nothing -> noop+ Just (KeyIds { keyIds = ks}) -> do+ setConfig participants (unwords ks)+ let signingkey = ConfigKey $ Git.GCrypt.remoteSigningKey remotename+ cmd <- gpgCmd <$> Annex.getGitConfig+ skeys <- M.keys <$> liftIO (secretKeys cmd)+ case filter (`elem` ks) skeys of+ [] -> noop+ (k:_) -> setConfig signingkey k setConfig (remoteconfig Git.GCrypt.remotePublishParticipantConfigKey) (Git.Config.boolConfig True) where
Remote/Git.hs view
@@ -43,6 +43,7 @@ import Logs.Location import Utility.Metered import Utility.CopyFile+import Utility.FileMode import Utility.Env import Utility.Batch import Utility.SimpleProtocol@@ -51,6 +52,7 @@ import Remote.Helper.ExportImport import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt+import qualified Remote.GitLFS import qualified Remote.P2P import qualified Remote.Helper.P2P as P2PHelper import P2P.Address@@ -143,6 +145,9 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc+ -- Remote.GitLFS may be used with a repo that is also encrypted+ -- with gcrypt so is checked first.+ | remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc | Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc | otherwise = case repoP2PAddress r of Nothing -> do@@ -737,6 +742,8 @@ copycowtried = case st of State _ _ (CopyCoWTried v) _ -> v dorsync = do+ -- dest may already exist, so make sure rsync can write to it+ void $ liftIO $ tryIO $ allowWrite dest oh <- mkOutputHandler Ssh.rsyncHelper oh (Just p) $ rsyncparams ++ [File src, File dest]@@ -814,9 +821,11 @@ getRepoFromState :: State -> Annex Git.Repo getRepoFromState (State _ _ _ a) = fst <$> a +#ifndef mingw32_HOST_OS {- The config of the remote git repository, cached for speed. -} getGitConfigFromState :: State -> Annex GitConfig getGitConfigFromState (State _ _ _ a) = snd <$> a+#endif mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State mkState r u gc = do
+ Remote/GitLFS.hs view
@@ -0,0 +1,449 @@+{- Using git-lfs as a remote.+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Remote.GitLFS (remote, gen) where++import Annex.Common+import Types.Remote+import Annex.Url+import Types.Key+import Types.Creds+import qualified Annex+import qualified Git+import qualified Git.Types as Git+import qualified Git.Url+import qualified Git.GCrypt+import Config+import Config.Cost+import Remote.Helper.Special+import Remote.Helper.ExportImport+import Remote.Helper.Git+import Remote.Helper.Http+import qualified Remote.GCrypt+import Annex.Ssh+import Annex.UUID+import Crypto+import Backend.Hash+import Utility.Hash+import Utility.SshHost+import Logs.RemoteState+import qualified Utility.GitLFS as LFS++import Control.Concurrent.STM+import Data.String+import Network.HTTP.Types+import Network.HTTP.Client hiding (port)+import System.Log.Logger+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++remote :: RemoteType+remote = RemoteType+ { typename = "git-lfs"+ -- Remote.Git takes care of enumerating git-lfs remotes too,+ -- and will call our gen on them.+ , enumerate = const (return [])+ , generate = gen+ , setup = mySetup+ , exportSupported = exportUnsupported+ , importSupported = importUnsupported+ }++gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)+gen r u c gc = do+ -- If the repo uses gcrypt, get the underlaying repo without the+ -- gcrypt url, to do LFS endpoint discovery on.+ r' <- if Git.GCrypt.isEncrypted r+ then do+ g <- Annex.gitRepo+ liftIO $ Git.GCrypt.encryptedRemote g r+ else pure r+ h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing r' gc+ cst <- remoteCost gc expensiveRemoteCost+ return $ Just $ specialRemote' specialcfg c+ (simplyPrepare $ store u h)+ (simplyPrepare $ retrieve u h)+ (simplyPrepare $ remove h)+ (simplyPrepare $ checkKey u h)+ (this cst)+ where+ this cst = Remote+ { uuid = u+ , cost = cst+ , name = Git.repoDescribe r+ , storeKey = storeKeyDummy+ , retrieveKeyFile = retreiveKeyFileDummy+ , retrieveKeyFileCheap = retrieveCheap+ -- content stored on git-lfs is hashed with SHA256+ -- no matter what git-annex key it's for, and the hash+ -- is checked on download+ , retrievalSecurityPolicy = RetrievalAllKeysSecure+ , removeKey = removeKeyDummy+ , lockContent = Nothing+ , checkPresent = checkPresentDummy+ , checkPresentCheap = False+ , exportActions = exportUnsupported+ , importActions = importUnsupported+ , whereisKey = Nothing+ , remoteFsck = Nothing+ , repairRepo = Nothing+ , config = c+ , getRepo = return r+ , gitconfig = gc+ , localpath = Nothing+ , remotetype = remote+ , availability = GloballyAvailable+ , readonly = False+ -- content cannot be removed from a git-lfs repo+ , appendonly = True+ , mkUnavailable = return Nothing+ , getInfo = gitRepoInfo (this cst)+ , claimUrl = Nothing+ , checkUrl = Nothing+ }+ specialcfg = (specialRemoteCfg c)+ -- chunking would not improve git-lfs+ { chunkConfig = NoChunks+ }++mySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+mySetup _ mu _ c gc = do+ u <- maybe (liftIO genUUID) return mu++ (c', _encsetup) <- encryptionSetup c gc+ case (isEncrypted c', Git.GCrypt.urlPrefix `isPrefixOf` url) of+ (False, False) -> noop+ (True, True) -> Remote.GCrypt.setGcryptEncryption c' remotename+ (True, False) -> unlessM (Annex.getState Annex.force) $+ giveup $ unwords $+ [ "Encryption is enabled for this remote,"+ , "but only the files that git-annex stores on"+ , "it would be encrypted; "+ , "anything that git push sends to it would"+ , "not be encrypted. Recommend prefixing the"+ , "url with \"gcrypt::\" to also encrypt"+ , "git pushes."+ , "(Use --force if you want to use this"+ , "likely insecure configuration.)"+ ]+ (False, True) -> unlessM (Annex.getState Annex.force) $+ giveup $ unwords $+ [ "You used a \"gcrypt::\" url for this remote,"+ , "but encryption=none prevents git-annex"+ , "from encrypting files it stores there."+ , "(Use --force if you want to use this"+ , "likely insecure configuration.)"+ ]++ -- The url is not stored in the remote log, because the same+ -- git-lfs repo can be accessed using different urls by different+ -- people (eg over ssh or http).+ --+ -- Instead, set up remote.name.url to point to the repo,+ -- (so it's also usable by git as a non-special remote),+ -- and set remote.name.git-lfs = true+ let c'' = M.delete "url" c'+ gitConfigSpecialRemote u c'' [("git-lfs", "true")]+ setConfig (ConfigKey ("remote." ++ getRemoteName c ++ ".url")) url+ return (c'', u)+ where+ url = fromMaybe (giveup "Specify url=") (M.lookup "url" c)+ remotename = fromJust (M.lookup "name" c)++data LFSHandle = LFSHandle+ { downloadEndpoint :: Maybe LFS.Endpoint+ , uploadEndpoint :: Maybe LFS.Endpoint+ , remoteRepo :: Git.Repo+ , remoteGitConfig :: RemoteGitConfig+ }++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+ 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+ gossh = case mkSshHost <$> Git.Url.hostuser r of+ Nothing -> do+ warning "Unable to parse ssh url for git-lfs remote."+ return Nothing+ Just (Left err) -> do+ warning err+ return Nothing+ Just (Right hostuser) -> do+ let port = Git.Url.port r+ -- Remove leading /~/ from path. That is added when+ -- converting a scp-style repository location with+ -- a relative path into an url, and is legal+ -- according to git-clone(1), but github does not+ -- support it.+ let remotepath = if "/~/" `isPrefixOf` Git.Url.path r+ then drop 3 (Git.Url.path r)+ else Git.Url.path r+ let ps = LFS.sshDiscoverEndpointCommand remotepath tro+ -- Note that no shellEscape is done here, because+ -- at least github's git-lfs implementation does+ -- not allow for shell quoting.+ let remotecmd = unwords ps+ (sshcommand, sshparams) <- sshCommand NoConsumeStdin (hostuser, port) (remoteGitConfig h) remotecmd+ liftIO (tryIO (readProcess sshcommand (toCommand sshparams))) >>= \case+ Left err -> do+ warning $ "ssh connection to git-lfs remote failed: " ++ show err+ return Nothing+ Right resp -> case LFS.parseSshDiscoverEndpointResponse (fromString resp) of+ Nothing -> do+ warning $ "unexpected response from git-lfs remote when doing ssh endpoint discovery"+ return Nothing+ Just endpoint -> return (Just endpoint)++-- The endpoint is cached for later use.+getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint)+getLFSEndpoint tro hv = do+ h <- liftIO $ atomically $ readTVar hv+ case f h of+ Just endpoint -> return (Just endpoint)+ Nothing -> discoverLFSEndpoint tro h >>= \case+ Just endpoint -> do+ liftIO $ atomically $ writeTVar hv $+ case tro of+ LFS.RequestDownload -> + h { downloadEndpoint = Just endpoint }+ LFS.RequestUpload ->+ h { uploadEndpoint = Just endpoint }+ return (Just endpoint)+ Nothing -> return Nothing+ where+ f = case tro of+ LFS.RequestDownload -> downloadEndpoint+ LFS.RequestUpload -> uploadEndpoint++-- Make an API request that is expected to have a small response body.+-- Not for use in downloading an object.+makeSmallAPIRequest :: Request -> Annex (Response L.ByteString)+makeSmallAPIRequest req = do+ uo <- getUrlOptions+ let req' = applyRequest uo req+ liftIO $ debugM "git-lfs" (show req')+ resp <- liftIO $ httpLbs req' (httpManager uo)+ -- Only debug the http status code, not the json+ -- which may include an authentication token.+ liftIO $ debugM "git-lfs" (show $ responseStatus resp)+ return resp++sendTransferRequest+ :: LFS.IsTransferResponseOperation op+ => 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"++extractKeySha256 :: Key -> Maybe LFS.SHA256+extractKeySha256 k = case keyVariety k of+ SHA2Key (HashSize 256) (HasExt hasext)+ | hasext -> eitherToMaybe $ E.decodeUtf8' (keyHash k)+ | otherwise -> eitherToMaybe $ E.decodeUtf8' (keyName k)+ _ -> Nothing++-- The size of an encrypted key is the size of the input data, but we need+-- the actual object size.+extractKeySize :: Key -> Maybe Integer+extractKeySize k+ | isEncKey k = Nothing+ | otherwise = keySize k++mkUploadRequest :: UUID -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)+mkUploadRequest u k content = case (extractKeySha256 k, extractKeySize k) of+ (Just sha256, Just size) ->+ ret sha256 size+ (_, Just size) -> do+ sha256 <- calcsha256+ remembersha256 sha256+ ret sha256 size+ _ -> do+ sha256 <- calcsha256+ size <- liftIO $ getFileSize content+ rememberboth sha256 size+ ret sha256 size+ where+ calcsha256 = liftIO $ T.pack . show . sha2_256 <$> L.readFile content+ ret sha256 size = do+ let obj = LFS.TransferRequestObject+ { LFS.req_oid = sha256+ , LFS.req_size = size+ }+ let req = LFS.TransferRequest+ { LFS.req_operation = LFS.RequestUpload+ , LFS.req_transfers = [LFS.Basic]+ , LFS.req_ref = Nothing + , LFS.req_objects = [obj]+ }+ return (req, sha256, size)+ + remembersha256 sha256 = setRemoteState u k (T.unpack sha256)+ rememberboth sha256 size = setRemoteState u k $+ show size ++ " " ++ T.unpack sha256++mkDownloadRequest :: UUID -> Key -> Annex (Maybe (LFS.TransferRequest, LFS.SHA256, Integer))+mkDownloadRequest u k = case (extractKeySha256 k, extractKeySize k) of+ (Just sha256, Just size) -> ret sha256 size+ (_, Just size) ->+ remembersha256 >>= \case+ Just sha256 -> ret sha256 size+ Nothing -> return Nothing+ _ -> do+ rememberboth >>= \case+ Just (sha256, size) -> ret sha256 size+ Nothing -> return Nothing+ where+ ret sha256 size = do+ let obj = LFS.TransferRequestObject+ { LFS.req_oid = sha256+ , LFS.req_size = size+ }+ let req = LFS.TransferRequest+ { LFS.req_operation = LFS.RequestDownload+ , LFS.req_transfers = [LFS.Basic]+ , LFS.req_ref = Nothing + , LFS.req_objects = [obj]+ }+ return $ Just (req, sha256, size)+ remembersha256 = fmap T.pack <$> getRemoteState u k+ rememberboth = maybe Nothing parse <$> getRemoteState u k+ where+ parse s = case words s of+ [ssize, ssha256] -> do+ size <- readish ssize+ return (T.pack ssha256, size)+ _ -> Nothing++store :: UUID -> TVar LFSHandle -> Storer+store u h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case+ Nothing -> return False+ Just endpoint -> flip catchNonAsync failederr $ do+ (req, sha256, size) <- mkUploadRequest u k src+ sendTransferRequest req endpoint >>= \case+ Left err -> do+ warning err+ return False+ Right resp -> do+ body <- liftIO $ httpBodyStorer src p+ forM_ (LFS.objects resp) $+ send body sha256 size+ return True+ where+ send body sha256 size tro+ | LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size =+ giveup "git-lfs server requested other object than the one we asked to send"+ | otherwise = case LFS.resp_error tro of+ Just err -> giveup $+ T.unpack $ LFS.respobjerr_message err+ Nothing -> case LFS.resp_actions tro of+ Nothing -> noop+ Just op -> case LFS.uploadOperationRequests op body sha256 size of+ Nothing -> giveup "unable to parse git-lfs server upload url"+ Just [] -> noop -- server already has it+ Just reqs -> forM_ reqs $+ makeSmallAPIRequest . setRequestCheckStatus+ failederr e = do+ warning (show e)+ return False++retrieve :: UUID -> TVar LFSHandle -> Retriever+retrieve u h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case+ Nothing -> giveup "unable to connect to git-lfs endpoint"+ Just endpoint -> mkDownloadRequest u k >>= \case+ Nothing -> giveup "unable to download this object from git-lfs"+ Just (req, sha256, size) -> sendTransferRequest req endpoint >>= \case+ Left err -> giveup (show err)+ Right resp -> case LFS.objects resp of+ [] -> giveup "git-lfs server did not provide a way to download this object"+ (tro:_)+ | LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size ->+ giveup "git-lfs server replied with other object than the one we requested"+ | otherwise -> go dest p tro+ where+ go dest p tro = case LFS.resp_error tro of+ Just err -> giveup $ T.unpack $ LFS.respobjerr_message err+ Nothing -> case LFS.resp_actions tro of+ Nothing -> giveup "git-lfs server did not provide a way to download this object"+ Just op -> case LFS.downloadOperationRequest op of+ Nothing -> giveup "unable to parse git-lfs server download url"+ Just req -> do+ uo <- getUrlOptions+ liftIO $ downloadConduit p req dest uo++checkKey :: UUID -> TVar LFSHandle -> CheckPresent+checkKey u h key = getLFSEndpoint LFS.RequestDownload h >>= \case+ Nothing -> giveup "unable to connect to git-lfs endpoint"+ Just endpoint -> mkDownloadRequest u key >>= \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+ where+ go sha256 size httpresp+ | responseStatus httpresp == status200 = go' sha256 size $+ LFS.parseTransferResponse (responseBody httpresp)+ | otherwise = giveup $+ "git-lfs server refused request: " ++ show (responseStatus httpresp)+ + go' :: LFS.SHA256 -> Integer -> LFS.ParsedTransferResponse LFS.DownloadOperation -> Annex Bool+ go' _ _ (LFS.ParseFailed err) =+ giveup $ "unable to parse response from git-lfs server: " ++ err+ -- If the server responds with a json error message,+ -- the content is presumably not present.+ go' _ _ (LFS.ParsedTransferResponseError _) = return False+ -- If the server responds with at least one download operation,+ -- we will assume the content is present. We could also try to HEAD+ -- that download, but there's no guarantee HEAD is supported, and+ -- at most that would detect breakage where the server is confused+ -- about what objects it has.+ go' sha256 size (LFS.ParsedTransferResponse resp) =+ case LFS.objects resp of+ [] -> return False+ (tro:_)+ | isNothing (LFS.resp_actions tro) -> return False+ | isJust (LFS.resp_error tro) -> return False+ | LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size ->+ giveup "git-lfs server replied with other object than the one we requested"+ | otherwise -> return True++retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool+retrieveCheap _ _ _ = return False++remove :: TVar LFSHandle -> Remover+remove _h _key = do+ warning "git-lfs does not support removing content"+ return False
Remote/Helper/ExportImport.hs view
@@ -57,7 +57,7 @@ importUnsupported = ImportActions { listImportableContents = return Nothing , retrieveExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing- , storeExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing+ , storeExportWithContentIdentifier = \_ _ _ _ _ -> return (Left "import not supported") , removeExportWithContentIdentifier = \_ _ _ -> return False , removeExportDirectoryWhenEmpty = Just $ \_ -> return False , checkPresentExportWithContentIdentifier = \_ _ _ -> return False@@ -154,8 +154,10 @@ oldcids <- liftIO $ concat <$> mapM (ContentIdentifier.getContentIdentifiers db (uuid r')) oldks storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case- Nothing -> return False- Just newcid -> do+ Left err -> do+ warning err+ return False+ Right newcid -> do withExclusiveLock gitAnnexContentIdentifierLock $ do liftIO $ ContentIdentifier.recordContentIdentifier db (uuid r') newcid k liftIO $ ContentIdentifier.flushDbQueue db
Remote/Helper/ReadOnly.hs view
@@ -65,18 +65,17 @@ readonlyRenameExport :: Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) readonlyRenameExport _ _ _ = return Nothing -readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)-readonlyStoreExportWithContentIdentifier _ _ _ _ _ = do- readonlyWarning- return Nothing+readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier)+readonlyStoreExportWithContentIdentifier _ _ _ _ _ =+ return $ Left readonlyWarning readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool readonlyRemoveExportWithContentIdentifier _ _ _ = readonlyFail readonlyFail :: Annex Bool readonlyFail = do- readonlyWarning+ warning readonlyWarning return False -readonlyWarning :: Annex ()-readonlyWarning = warning "this remote is readonly"+readonlyWarning :: String+readonlyWarning = "this remote is readonly"
Remote/List.hs view
@@ -40,6 +40,7 @@ import qualified Remote.Tahoe import qualified Remote.Glacier import qualified Remote.Ddar+import qualified Remote.GitLFS import qualified Remote.Hook import qualified Remote.External @@ -63,6 +64,7 @@ , Remote.Tahoe.remote , Remote.Glacier.remote , Remote.Ddar.remote+ , Remote.GitLFS.remote , Remote.Hook.remote , Remote.External.remote ]
Remote/S3.hs view
@@ -29,6 +29,7 @@ import Network.HTTP.Conduit (Manager) import Network.HTTP.Client (responseStatus, responseBody, RequestBody(..)) import Network.HTTP.Types+import Network.URI import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.IORef@@ -387,15 +388,15 @@ where go = withS3Handle hv $ \case Just h -> do- retrieveHelper info h (Left (T.pack exporturl)) f p+ retrieveHelper info h (Left (T.pack exportloc)) f p return True Nothing -> case getPublicUrlMaker info of Nothing -> do warning $ needS3Creds (uuid r) return False Just geturl -> Url.withUrlOptions $ - liftIO . Url.download p (geturl exporturl) f- exporturl = bucketExportLocation info loc+ liftIO . Url.download p (geturl exportloc) f+ exportloc = bucketExportLocation info loc removeExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool removeExportS3 hv r info k loc = withS3Handle hv $ \case@@ -575,7 +576,7 @@ -- -- When the bucket is not versioned, data loss can result. -- This is why that configuration requires --force to enable.-storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier)+storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p | versioning info = go -- FIXME Actual aws version that supports getting Etag for a store@@ -584,20 +585,18 @@ #if MIN_VERSION_aws(0,99,0) | otherwise = go #else- | otherwise = do- warning "git-annex is built with too old a version of the aws library to support this operation"- return Nothing+ | otherwise = return $+ Left "git-annex is built with too old a version of the aws library to support this operation" #endif where go = storeExportS3' hv r info magic src k loc p >>= \case- (False, _) -> return Nothing- (True, (_, Just vid)) -> return $ Just $+ (False, _) -> return $ Left "failed to store content in S3 bucket"+ (True, (_, Just vid)) -> return $ Right $ mkS3VersionedContentIdentifier vid- (True, (Just etag, Nothing)) -> return $ Just $+ (True, (Just etag, Nothing)) -> return $ Right $ mkS3UnversionedContentIdentifier etag- (True, (Nothing, Nothing)) -> do- warning "did not get ETag for store to S3 bucket"- return Nothing+ (True, (Nothing, Nothing)) -> + return $ Left "did not get ETag for store to S3 bucket" -- Does not guarantee that the removed object has the content identifier, -- but when the bucket is versioned, the removed object content can still@@ -930,7 +929,14 @@ "https://" ++ T.unpack (bucket info) ++ ".s3.amazonaws.com/" genericPublicUrl :: URLString -> BucketObject -> URLString-genericPublicUrl baseurl p = baseurl Posix.</> p+genericPublicUrl baseurl p = + baseurl Posix.</> escapeURIString skipescape p+ where+ -- Don't need to escape '/' because the bucket object+ -- is not necessarily a single url component. + -- But do want to escape eg '+' and ' '+ skipescape '/' = True+ skipescape c = isUnescapedInURIComponent c genCredentials :: CredPair -> IO AWS.Credentials genCredentials (keyid, secret) = AWS.Credentials@@ -1128,8 +1134,8 @@ | otherwise = return (Right (Left fallback)) s3VersionIDPublicUrl :: (S3Info -> BucketObject -> URLString) -> S3Info -> S3VersionID -> URLString-s3VersionIDPublicUrl mk info (S3VersionID obj vid) = mk info $ concat- [ T.unpack obj+s3VersionIDPublicUrl mk info (S3VersionID obj vid) = concat+ [ mk info (T.unpack obj) , "?versionId=" , T.unpack vid -- version ID is "url ready" so no escaping needed ]
Test.hs view
@@ -36,7 +36,6 @@ import qualified Git.Ref import qualified Git.LsTree import qualified Git.FilePath-import qualified Git.Merge import qualified Annex.Locations #ifndef mingw32_HOST_OS import qualified Types.GitConfig@@ -63,6 +62,7 @@ import qualified Annex.CatFile import qualified Annex.Path import qualified Annex.VectorClock+import qualified Annex.AdjustedBranch import qualified Annex.View import qualified Annex.View.ViewedFile import qualified Logs.View@@ -94,7 +94,7 @@ optParser :: Parser TestOptions optParser = TestOptions- <$> suiteOptionParser ingredients (tests False mempty)+ <$> suiteOptionParser ingredients (tests False True mempty) <*> switch ( long "keep-failures" <> help "preserve repositories on test failure"@@ -126,7 +126,8 @@ runsubprocesstests (Just _) = isolateGitConfig $ do ensuretmpdir crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' tmpdir- case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of+ adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported+ case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of Nothing -> error "No tests found!?" Just act -> ifM act ( exitSuccess@@ -142,12 +143,14 @@ , rerunningTests [consoleTestReporter] ] -tests :: Bool -> TestOptions -> TestTree-tests crippledfilesystem opts = testGroup "Tests" $ properties :- map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes+tests :: Bool -> Bool -> TestOptions -> TestTree+tests crippledfilesystem adjustedbranchok opts = + testGroup "Tests" $ properties :+ map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes where testmodes = catMaybes- [ Just ("v7 unlocked", (testMode opts (RepoVersion 7)) { unlockedFiles = True })+ [ canadjust ("v7 adjusted unlocked branch", (testMode opts (RepoVersion 7)) { adjustedUnlockedBranch = True })+ , unlesscrippled ("v7 unlocked", (testMode opts (RepoVersion 7)) { unlockedFiles = True }) , unlesscrippled ("v5", testMode opts (RepoVersion 5)) , unlesscrippled ("v7 locked", testMode opts (RepoVersion 7)) , Just ("v5 direct", (testMode opts (RepoVersion 5)) { forceDirect = True })@@ -155,6 +158,9 @@ unlesscrippled v | crippledfilesystem = Nothing | otherwise = Just v+ canadjust v+ | adjustedbranchok = Just v+ | otherwise = Nothing properties :: TestTree properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"@@ -386,14 +392,6 @@ let importf = subdir </> "f" writecontent (importdir </> importf) (content importf) return (importdir </> subdir, importdir </> importf, importf)- annexed_present_imported f = ifM (annexeval Config.crippledFileSystem)- ( annexed_present_unlocked f- , annexed_present_locked f- )- annexed_notpresent_imported f = ifM (annexeval Config.crippledFileSystem)- ( annexed_notpresent_unlocked f- , annexed_notpresent_locked f- ) test_reinject :: Assertion test_reinject = intmpclonerepoInDirect $ do@@ -470,7 +468,12 @@ test_get = test_get' intmpclonerepo test_get_ssh_remote :: Assertion-test_get_ssh_remote = test_get' (with_ssh_origin intmpclonerepo)+test_get_ssh_remote = +#ifndef mingw32_HOST_OS+ test_get' (with_ssh_origin intmpclonerepo)+#else+ noop+#endif test_get' :: (Assertion -> Assertion) -> Assertion test_get' setup = setup $ do@@ -493,7 +496,12 @@ test_move = test_move' intmpclonerepo test_move_ssh_remote :: Assertion-test_move_ssh_remote = test_move' (with_ssh_origin intmpclonerepo)+test_move_ssh_remote =+#ifndef mingw32_HOST_OS+ test_move' (with_ssh_origin intmpclonerepo)+#else+ noop+#endif test_move' :: (Assertion -> Assertion) -> Assertion test_move' setup = setup $ do@@ -592,7 +600,7 @@ test_lock = intmpclonerepoInDirect $ do annexed_notpresent annexedfile unlessM (annexeval Annex.Version.versionSupportsUnlockedPointers) $- ifM (unlockedFiles <$> getTestMode)+ ifM (hasUnlockedFiles <$> getTestMode) ( git_annex_shouldfail "lock" [annexedfile] @? "lock failed to fail with not present file" , git_annex_shouldfail "unlock" [annexedfile] @? "unlock failed to fail with not present file" )@@ -698,7 +706,7 @@ ) test_fix :: Assertion-test_fix = intmpclonerepoInDirect $ unlessM (unlockedFiles <$> getTestMode) $ do+test_fix = intmpclonerepoInDirect $ unlessM (hasUnlockedFiles <$> getTestMode) $ do annexed_notpresent annexedfile git_annex "fix" [annexedfile] @? "fix of not present failed" annexed_notpresent annexedfile@@ -769,7 +777,7 @@ git_annex "get" [f] @? "get of file failed" Utility.FileMode.allowWrite f writecontent f (changedcontent f)- ifM (annexeval Config.isDirect <||> unlockedFiles <$> getTestMode)+ ifM (annexeval Config.isDirect <||> hasUnlockedFiles <$> getTestMode) ( git_annex "fsck" [] @? "fsck failed on unlocked file with changed file content" , git_annex_shouldfail "fsck" [] @? "fsck failed to fail with corrupted file content" )@@ -850,7 +858,7 @@ checkbackend sha1annexedfile backendSHA256 test_unused :: Assertion--- This test is broken in direct mode+-- This test is broken in direct mode. test_unused = intmpclonerepoInDirect $ do checkunused [] "in new clone" git_annex "get" [annexedfile] @? "get of file failed"@@ -860,13 +868,15 @@ checkunused [] "after get" boolSystem "git" [Param "rm", Param "-fq", File annexedfile] @? "git rm failed" checkunused [] "after rm"- boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "foo"] @? "git commit failed"+ -- commit the rm, and when on an adjusted branch, sync it back to+ -- the master branch+ git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed" checkunused [] "after commit" -- unused checks origin/master; once it's gone it is really unused boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "git remote rm origin failed" checkunused [annexedfilekey] "after origin branches are gone" boolSystem "git" [Param "rm", Param "-fq", File sha1annexedfile] @? "git rm failed"- boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "foo"] @? "git commit failed"+ git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed" checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile" -- good opportunity to test dropkey also@@ -884,7 +894,7 @@ -- This is only relevant when using locked files; if the file is -- unlocked, the work tree file has the content, and there's no way -- to associate it with the key.- unlessM (unlockedFiles <$> getTestMode) $ do+ unlessM (hasUnlockedFiles <$> getTestMode) $ do writecontent "unusedfile" "unusedcontent" git_annex "add" ["unusedfile"] @? "add of unusedfile failed" unusedfilekey <- getKey backendSHA256E "unusedfile"@@ -916,7 +926,7 @@ -- When an unlocked file is modified, git diff will cause git-annex -- to add its content to the repository. Make sure that's not -- found as unused.- whenM (unlockedFiles <$> getTestMode) $ do+ whenM (hasUnlockedFiles <$> getTestMode) $ do let f = "unlockedfile" writecontent f "unlockedcontent1" boolSystem "git" [Param "add", File "unlockedfile"] @? "git add failed"@@ -1376,7 +1386,7 @@ - lost track of whether a file was a symlink. -} test_conflict_resolution_symlink_bit :: Assertion-test_conflict_resolution_symlink_bit = unlessM (unlockedFiles <$> getTestMode) $+test_conflict_resolution_symlink_bit = unlessM (hasUnlockedFiles <$> getTestMode) $ withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> withtmpclonerepo $ \r3 -> do@@ -1585,6 +1595,7 @@ test_rsync_remote :: Assertion test_rsync_remote = intmpclonerepo $ do+#ifndef mingw32_HOST_OS createDirectory "dir" git_annex "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" git_annex "get" [annexedfile] @? "get of file failed"@@ -1597,6 +1608,9 @@ annexed_present annexedfile git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile+#else+ noop+#endif test_bup_remote :: Assertion test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do@@ -1705,7 +1719,7 @@ {- Regression test for Windows bug where symlinks were not - calculated correctly for files in subdirs. -}- unlessM (unlockedFiles <$> getTestMode) $ do+ unlessM (hasUnlockedFiles <$> getTestMode) $ do git_annex "sync" [] @? "sync failed" l <- annexeval $ Utility.FileSystemEncoding.decodeBL <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo")@@ -1736,22 +1750,22 @@ git_annex "get" [] @? "get of files failed" annexed_present annexedfile + -- Nothing to commit, but this makes sure the master branch+ -- is in sync with the adjusted branch, which it may not be+ -- depending on how the repository was set up.+ commitchanges git_annex "export" ["master", "--to", "foo"] @? "export to dir failed" dircontains annexedfile (content annexedfile) writedir "import" (content "import") git_annex "import" ["master", "--from", "foo"] @? "import from dir failed"- up <- Git.Merge.mergeUnrelatedHistoriesParam- let mergeps = [Param "merge", Param "foo/master", Param "-mmerge"] ++ maybeToList up- boolSystem "git" mergeps @? "git merge foo/master failed"- -- FIXME fails when in an adjusted unlocked branch because- -- it's imported locked- --annexed_present "import"+ git_annex "merge" ["foo/master"] @? "git annex merge foo/master failed"+ annexed_present_imported "import" nukeFile "import" writecontent "import" (content "newimport1") git_annex "add" ["import"] @? "add of import failed"- boolSystem "git" [Param "commit", Param "-q", Param "-mchanged"] @? "git commit failed"+ commitchanges git_annex "export" ["master", "--to", "foo"] @? "export modified file to dir failed" dircontains "import" (content "newimport1") @@ -1760,7 +1774,7 @@ nukeFile "import" writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed"- boolSystem "git" [Param "commit", Param "-q", Param "-mchanged"] @? "git commit failed"+ commitchanges git_annex_shouldfail "export" ["master", "--to", "foo"] @? "export failed to fail in conflict" dircontains "import" (content "newimport2") @@ -1770,7 +1784,7 @@ nukeFile "import" writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed"- boolSystem "git" [Param "commit", Param "-q", Param "-mchanged"] @? "git commit failed"+ commitchanges git_annex "export" ["master", "--to", "foo"] @? "export failed after import conflict" dircontains "import" (content "newimport3") where@@ -1778,6 +1792,10 @@ ((v==) <$> readFile ("dir" </> f)) @? ("did not find expected content of " ++ "dir" </> f) writedir f = writecontent ("dir" </> f)+ -- When on an adjusted branch, this updates the master branch+ -- to match it, which is necessary since the master branch is going+ -- to be exported.+ commitchanges = git_annex "sync" ["--no-pull", "--no-push"] @? "sync failed" test_export_import_subdir :: Assertion test_export_import_subdir = intmpclonerepoInDirect $ do@@ -1791,6 +1809,11 @@ @? "git mv failed" boolSystem "git" [Param "commit", Param "-m", Param "moved"] @? "git commit failed"+ + -- When on an adjusted branch, this updates the master branch+ -- to match it, which is necessary since the master branch is going+ -- to be exported.+ git_annex "sync" ["--no-pull", "--no-push"] @? "sync failed" -- Run three times because there was a bug that took a couple -- of runs to lead to the wrong tree being written to the remote@@ -1815,9 +1838,7 @@ testimport = do git_annex "import" ["master:"++subdir, "--from", "foo"] @? "import of subdir failed"- up <- Git.Merge.mergeUnrelatedHistoriesParam- let mergeps = [Param "merge", Param "foo/master", Param "-mmerge"] ++ maybeToList up- boolSystem "git" mergeps @? "git merge foo/master failed"+ git_annex "merge" ["foo/master"] @? "git annex merge foo/master failed" -- Make sure that import did not import the file to the top -- of the repo.
Test/Framework.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite framework -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -42,47 +42,26 @@ import qualified Utility.ThreadScheduler import qualified Utility.Tmp.Dir import qualified Utility.Metered+import qualified Utility.SafeCommand import qualified Command.Uninit-import qualified CmdLine.GitAnnex as GitAnnex --- This is equivilant to running git-annex, but it's all run in-process--- so test coverage collection works.+-- Run git-annex. git_annex :: String -> [String] -> IO Bool-git_annex command params = git_annex' command params >>= \case- Right () -> return True- Left e -> do- hPutStrLn stderr (show e)- return False+git_annex command params = do+ pp <- Annex.Path.programPath+ Utility.SafeCommand.boolSystem pp $+ map Utility.SafeCommand.Param (command:params) -- For when git-annex is expected to fail.+-- Run with -q to squelch error. git_annex_shouldfail :: String -> [String] -> IO Bool-git_annex_shouldfail command params = git_annex' command ("-q":params) >>= \case- Right () -> return False- Left _ -> return True--git_annex' :: String -> [String] -> IO (Either SomeException ())-git_annex' command params = do- -- catch all errors, including normally fatal errors- try run ::IO (Either SomeException ())- where- run = GitAnnex.run dummyTestOptParser- dummyTestRunner- dummyBenchmarkGenerator- (command:params)- dummyTestOptParser = pure mempty- dummyTestRunner _ = noop- dummyBenchmarkGenerator _ _ = return noop+git_annex_shouldfail command params = not <$> git_annex command ("-q":params) {- Runs git-annex and returns its output. -} git_annex_output :: String -> [String] -> IO String git_annex_output command params = do pp <- Annex.Path.programPath- got <- Utility.Process.readProcess pp (command:params)- -- Since the above is a separate process, code coverage stats are- -- not gathered for things run in it.- -- Run same command again, to get code coverage.- _ <- git_annex command params- return got+ Utility.Process.readProcess pp (command:params) git_annex_expectoutput :: String -> [String] -> [String] -> IO () git_annex_expectoutput command params expected = do@@ -102,7 +81,9 @@ innewrepo a = withgitrepo $ \r -> indir r a inmainrepo :: Assertion -> Assertion-inmainrepo = indir mainrepodir+inmainrepo a = do+ d <- mainrepodir+ indir d a with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do@@ -151,7 +132,8 @@ withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion withtmpclonerepo' cfg a = do dir <- tmprepodir- clone <- clonerepo mainrepodir dir cfg+ maindir <- mainrepodir+ clone <- clonerepo maindir dir cfg r <- tryNonAsync (a clone) case r of Right () -> return ()@@ -164,7 +146,9 @@ disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm" withgitrepo :: (FilePath -> Assertion) -> Assertion-withgitrepo = bracket (setuprepo mainrepodir) return+withgitrepo a = do+ maindir <- mainrepodir+ bracket (setuprepo maindir) return a indir :: FilePath -> IO a -> IO a indir dir a = do@@ -369,7 +353,7 @@ runchecks as f annexed_notpresent :: FilePath -> Assertion-annexed_notpresent f = ifM (unlockedFiles <$> getTestMode)+annexed_notpresent f = ifM (hasUnlockedFiles <$> getTestMode) ( annexed_notpresent_unlocked f , annexed_notpresent_locked f )@@ -381,7 +365,7 @@ annexed_notpresent_unlocked = runchecks [checkregularfile, checkispointerfile, notinlocationlog] annexed_present :: FilePath -> Assertion-annexed_present f = ifM (unlockedFiles <$> getTestMode)+annexed_present f = ifM (hasUnlockedFiles <$> getTestMode) ( annexed_present_unlocked f , annexed_present_locked f )@@ -395,7 +379,25 @@ annexed_present_unlocked :: FilePath -> Assertion annexed_present_unlocked = runchecks [checkregularfile, checkcontent, checkwritable, inlocationlog]+ +annexed_present_imported :: FilePath -> Assertion+annexed_present_imported f = ifM (annexeval Config.crippledFileSystem)+ ( annexed_present_unlocked f+ , ifM (adjustedUnlockedBranch <$> getTestMode) + ( annexed_present_unlocked f+ , annexed_present_locked f+ )+ ) +annexed_notpresent_imported :: FilePath -> Assertion+annexed_notpresent_imported f = ifM (annexeval Config.crippledFileSystem)+ ( annexed_notpresent_unlocked f+ , ifM (adjustedUnlockedBranch <$> getTestMode)+ ( annexed_notpresent_unlocked f+ , annexed_notpresent_locked f+ )+ )+ unannexed :: FilePath -> Assertion unannexed = runchecks [checkregularfile, checkcontent, checkwritable] @@ -408,6 +410,7 @@ data TestMode = TestMode { forceDirect :: Bool , unlockedFiles :: Bool+ , adjustedUnlockedBranch :: Bool , annexVersion :: Types.RepoVersion.RepoVersion , keepFailures :: Bool } deriving (Read, Show)@@ -416,21 +419,26 @@ testMode opts v = TestMode { forceDirect = False , unlockedFiles = False+ , adjustedUnlockedBranch = False , annexVersion = v , keepFailures = keepFailuresOption opts } +hasUnlockedFiles :: TestMode -> Bool+hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m+ withTestMode :: TestMode -> TestTree -> TestTree -> TestTree withTestMode testmode inittests = withResource prepare release . const where prepare = do setTestMode testmode+ setmainrepodir =<< newmainrepodir case tryIngredients [consoleTestReporter] mempty inittests of Nothing -> error "No tests found!?" Just act -> unlessM act $ error "init tests failed! cannot continue" return ()- release _ = cleanup mainrepodir+ release _ = noop setTestMode :: TestMode -> IO () setTestMode testmode = do@@ -456,7 +464,6 @@ , ("GIT_ANNEX_USE_GIT_SSH", "1") , ("TESTMODE", show testmode) ]- runFakeSsh :: [String] -> IO () runFakeSsh ("-n":ps) = runFakeSsh ps runFakeSsh (_host:cmd:[]) = do@@ -472,6 +479,9 @@ testmode <- getTestMode when (forceDirect testmode) $ git_annex "direct" ["-q"] @? "git annex direct failed"+ when (adjustedUnlockedBranch testmode) $ do+ boolSystem "git" [Param "commit", Param "--allow-empty", Param "-m", Param "empty"] @? "git commit failed"+ git_annex "adjust" ["--unlock"] @? "git annex adjust failed" changeToTmpDir :: FilePath -> IO () changeToTmpDir t = do@@ -481,8 +491,24 @@ tmpdir :: String tmpdir = ".t" -mainrepodir :: FilePath-mainrepodir = tmpdir </> "repo"+mainrepodir :: IO FilePath+mainrepodir = Utility.Env.getEnvDefault "MAINREPODIR"+ (giveup "MAINREPODIR not set")++setmainrepodir :: FilePath -> IO ()+setmainrepodir d = Utility.Env.Set.setEnv "MAINREPODIR" d True++newmainrepodir :: IO FilePath+newmainrepodir = go (0 :: Int)+ where+ go n = do+ let d = tmpdir </> "main" ++ show n+ ifM (doesDirectoryExist d)+ ( go $ n + 1+ , do+ createDirectory d+ return d+ ) tmprepodir :: IO FilePath tmprepodir = go (0 :: Int)
Types/GitConfig.hs view
@@ -263,6 +263,7 @@ , remoteAnnexAndroidDirectory :: Maybe FilePath , remoteAnnexAndroidSerial :: Maybe String , remoteAnnexGCrypt :: Maybe String+ , remoteAnnexGitLFS :: Bool , remoteAnnexDdarRepo :: Maybe String , remoteAnnexHookType :: Maybe String , remoteAnnexExternalType :: Maybe String@@ -321,6 +322,7 @@ , remoteAnnexAndroidDirectory = notempty $ getmaybe "androiddirectory" , remoteAnnexAndroidSerial = notempty $ getmaybe "androidserial" , remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"+ , remoteAnnexGitLFS = getbool "git-lfs" False , remoteAnnexDdarRepo = getmaybe "ddarrepo" , remoteAnnexHookType = notempty $ getmaybe "hooktype" , remoteAnnexExternalType = notempty $ getmaybe "externaltype"
Types/Remote.hs view
@@ -292,7 +292,7 @@ -> [ContentIdentifier] -- ^ old content that it's safe to overwrite -> MeterUpdate- -> a (Maybe ContentIdentifier)+ -> a (Either String ContentIdentifier) -- This is used rather than removeExport when a special remote -- supports imports. --
Utility/Env/Set.hs view
@@ -10,7 +10,6 @@ module Utility.Env.Set where #ifdef mingw32_HOST_OS-import qualified System.Environment as E import qualified System.SetEnv import Utility.Env #else
+ Utility/GitLFS.hs view
@@ -0,0 +1,439 @@+{- git-lfs API+ - + - https://github.com/git-lfs/git-lfs/blob/master/docs/api+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Utility.GitLFS (+ -- * transfer requests+ TransferRequest(..),+ TransferRequestOperation(..),+ TransferAdapter(..),+ TransferRequestObject(..),+ startTransferRequest,+ -- * responses to transfer requests+ TransferResponse(..),+ TransferResponseOperation(..),+ IsTransferResponseOperation,+ DownloadOperation(..),+ UploadOperation(..),+ OperationParams(..),+ ParsedTransferResponse(..),+ parseTransferResponse,+ -- * making transfers+ downloadOperationRequest,+ uploadOperationRequests,+ -- * endpoint discovery+ Endpoint,+ guessEndpoint,+ HostUser,+ sshDiscoverEndpointCommand,+ parseSshDiscoverEndpointResponse,+ -- * errors+ TransferResponseError(..),+ TransferResponseObjectError(..),+ -- * additional data types+ Url,+ SHA256,+ GitRef(..),+ NumSeconds,+ HTTPHeader,+ 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+import Network.HTTP.Client+import Data.List+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import qualified Data.ByteString.Lazy as L+import qualified Data.CaseInsensitive as CI+import qualified Network.URI as URI++data TransferRequest = TransferRequest+ { req_operation :: TransferRequestOperation+ , req_transfers :: [TransferAdapter]+ , req_ref :: Maybe GitRef+ , req_objects :: [TransferRequestObject]+ }+ deriving (Generic, Show)++instance ToJSON TransferRequest where+ toJSON = genericToJSON transferRequestOptions+ toEncoding = genericToEncoding transferRequestOptions++instance FromJSON TransferRequest where+ parseJSON = genericParseJSON transferRequestOptions++transferRequestOptions :: Options+transferRequestOptions = stripFieldPrefix nonNullOptions++data TransferRequestObject = TransferRequestObject+ { req_oid :: SHA256+ , req_size :: Integer+ }+ deriving (Generic, Show)++instance ToJSON TransferRequestObject where+ toJSON = genericToJSON transferRequestObjectOptions+ toEncoding = genericToEncoding transferRequestObjectOptions++instance FromJSON TransferRequestObject where+ parseJSON = genericParseJSON transferRequestObjectOptions++transferRequestObjectOptions :: Options+transferRequestObjectOptions = stripFieldPrefix defaultOptions++data TransferRequestOperation = RequestDownload | RequestUpload+ deriving (Show)++instance ToJSON TransferRequestOperation where+ toJSON RequestDownload = "download"+ toJSON RequestUpload = "upload"++instance FromJSON TransferRequestOperation where+ parseJSON (String "download") = pure RequestDownload+ parseJSON (String "upload") = pure RequestUpload+ parseJSON invalid = typeMismatch "TransferRequestOperation" invalid++data TransferResponse op = TransferResponse+ { transfer :: Maybe TransferAdapter+ , objects :: [TransferResponseOperation op]+ }+ deriving (Generic, Show)++instance IsTransferResponseOperation op => ToJSON (TransferResponse op) where+ toJSON = genericToJSON nonNullOptions+ toEncoding = genericToEncoding nonNullOptions++instance IsTransferResponseOperation op => FromJSON (TransferResponse op)++-- | This is an error with a TransferRequest as a whole. It's also possible+-- for a TransferRequest to overall succeed, but fail for some+-- objects; such failures use TransferResponseObjectError.+data TransferResponseError = TransferResponseError+ { resperr_message :: T.Text+ , resperr_request_id :: Maybe T.Text+ , resperr_documentation_url :: Maybe Url+ }+ deriving (Generic, Show)++instance ToJSON TransferResponseError where+ toJSON = genericToJSON transferResponseErrorOptions+ toEncoding = genericToEncoding transferResponseErrorOptions++instance FromJSON TransferResponseError where+ parseJSON = genericParseJSON transferResponseErrorOptions++transferResponseErrorOptions :: Options+transferResponseErrorOptions = stripFieldPrefix nonNullOptions++-- | An error with a single object within a TransferRequest.+data TransferResponseObjectError = TransferResponseObjectError+ { respobjerr_code :: Int+ , respobjerr_message :: T.Text+ }+ deriving (Generic, Show)++instance ToJSON TransferResponseObjectError where+ toJSON = genericToJSON transferResponseObjectErrorOptions+ toEncoding = genericToEncoding transferResponseObjectErrorOptions++instance FromJSON TransferResponseObjectError where+ parseJSON = genericParseJSON transferResponseObjectErrorOptions++transferResponseObjectErrorOptions :: Options+transferResponseObjectErrorOptions = stripFieldPrefix nonNullOptions++data TransferAdapter = Basic+ deriving (Show)++instance ToJSON TransferAdapter where+ toJSON Basic = "basic"++instance FromJSON TransferAdapter where+ parseJSON (String "basic") = pure Basic+ parseJSON invalid = typeMismatch "basic" invalid++data TransferResponseOperation op = TransferResponseOperation+ { resp_oid :: SHA256+ , resp_size :: Integer+ , resp_authenticated :: Maybe Bool+ , resp_actions :: Maybe op+ , resp_error :: Maybe TransferResponseObjectError+ }+ deriving (Generic, Show)++instance ToJSON op => ToJSON (TransferResponseOperation op) where+ toJSON = genericToJSON transferResponseOperationOptions+ toEncoding = genericToEncoding transferResponseOperationOptions++instance FromJSON op => FromJSON (TransferResponseOperation op) where+ parseJSON = genericParseJSON transferResponseOperationOptions++transferResponseOperationOptions :: Options+transferResponseOperationOptions = stripFieldPrefix nonNullOptions++-- | Class of types that can be responses to a transfer request,+-- that contain an operation to use to make the transfer.+class (FromJSON op, ToJSON op) => IsTransferResponseOperation op++data DownloadOperation = DownloadOperation+ { download :: OperationParams }+ deriving (Generic, Show)++instance IsTransferResponseOperation DownloadOperation+instance ToJSON DownloadOperation+instance FromJSON DownloadOperation++data UploadOperation = UploadOperation+ { upload :: OperationParams+ , verify :: Maybe OperationParams+ }+ deriving (Generic, Show)++instance IsTransferResponseOperation UploadOperation++instance ToJSON UploadOperation where+ toJSON = genericToJSON nonNullOptions+ toEncoding = genericToEncoding nonNullOptions++instance FromJSON UploadOperation++data OperationParams = OperationParams+ { href :: Url+ , header :: Maybe (M.Map HTTPHeader HTTPHeaderValue)+ , expires_in :: Maybe NumSeconds+ , expires_at :: Maybe T.Text+ }+ deriving (Generic, Show)++instance ToJSON OperationParams where+ toJSON = genericToJSON nonNullOptions+ toEncoding = genericToEncoding nonNullOptions++instance FromJSON OperationParams++data Verification = Verification+ { verification_oid :: SHA256+ , verification_size :: Integer+ }+ deriving (Generic, Show)++instance ToJSON Verification where+ toJSON = genericToJSON verificationOptions+ toEncoding = genericToEncoding verificationOptions++instance FromJSON Verification where+ parseJSON = genericParseJSON verificationOptions++verificationOptions :: Options+verificationOptions = stripFieldPrefix defaultOptions++-- | Sent over ssh connection when using that to find the endpoint.+data SshDiscoveryResponse = SshDiscoveryResponse+ { endpoint_href :: Url+ , endpoint_header :: Maybe (M.Map HTTPHeader HTTPHeaderValue)+ , endpoint_expires_in :: Maybe NumSeconds+ , endpoint_expires_at :: Maybe T.Text+ } deriving (Generic, Show)++instance ToJSON SshDiscoveryResponse where+ toJSON = genericToJSON sshDiscoveryResponseOptions+ toEncoding = genericToEncoding sshDiscoveryResponseOptions++instance FromJSON SshDiscoveryResponse where+ parseJSON = genericParseJSON sshDiscoveryResponseOptions++sshDiscoveryResponseOptions :: Options+sshDiscoveryResponseOptions = stripFieldPrefix nonNullOptions++data GitRef = GitRef+ { name :: T.Text }+ deriving (Generic, Show)++instance FromJSON GitRef+instance ToJSON GitRef++type SHA256 = T.Text++-- | The endpoint of a git-lfs server.+data Endpoint+ = EndpointURI URI.URI+ | EndpointDiscovered SshDiscoveryResponse+ deriving (Show)++-- | Command to run via ssh with to discover an endpoint. The FilePath is+-- the location of the git repository on the ssh server.+--+-- Note that, when sshing to the server, you should take care that the+-- hostname you pass to ssh is really a hostname and not something that ssh+-- will parse an an option, such as -oProxyCommand=".+sshDiscoverEndpointCommand :: FilePath -> TransferRequestOperation -> [String]+sshDiscoverEndpointCommand remotepath tro =+ [ "git-lfs-authenticate"+ , remotepath+ , case tro of+ RequestDownload -> "download"+ RequestUpload -> "upload"+ ]++-- | Parse the json output when doing ssh endpoint discovery.+parseSshDiscoverEndpointResponse :: L.ByteString -> Maybe Endpoint+parseSshDiscoverEndpointResponse resp = EndpointDiscovered <$> decode resp++-- | 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+ _ -> Nothing+ where+ endpoint = EndpointURI $ uri+ -- force https because the git-lfs protocol uses http+ -- basic auth tokens, which should not be exposed+ { URI.uriScheme = "https:"+ , URI.uriPath = guessedpath+ }+ + guessedpath+ | ".git" `isSuffixOf` URI.uriPath uri =+ URI.uriPath uri ++ "/info/lfs"+ | ".git/" `isSuffixOf` URI.uriPath uri =+ URI.uriPath uri ++ "info/lfs"+ | otherwise = (droptrailing '/' (URI.uriPath uri)) ++ ".git/info/lfs"+ + droptrailing c = reverse . dropWhile (== c) . reverse++-- | 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++addLfsJsonHeaders :: Request -> Request+addLfsJsonHeaders r = r+ { requestHeaders = requestHeaders r +++ [ ("Accept", lfsjson)+ , ("Content-Type", lfsjson)+ ]+ }+ where+ lfsjson = "application/vnd.git-lfs+json"++data ParsedTransferResponse op+ = ParsedTransferResponse (TransferResponse op)+ | ParsedTransferResponseError TransferResponseError+ | ParseFailed String++-- | Parse the body of a response to a transfer request.+parseTransferResponse+ :: IsTransferResponseOperation op+ => L.ByteString+ -> ParsedTransferResponse op+parseTransferResponse resp = case eitherDecode resp of+ Right tr -> ParsedTransferResponse tr+ -- If unable to decode as a TransferResponse, try to decode+ -- as a TransferResponseError instead, in case the LFS server+ -- sent an error message.+ Left err ->+ either (const $ ParseFailed err) ParsedTransferResponseError $+ eitherDecode resp++-- | Builds a http request to perform a download.+downloadOperationRequest :: DownloadOperation -> Maybe Request+downloadOperationRequest = operationParamsRequest . download++-- | Builds http request to perform an upload. The content to upload is+-- provided in the RequestBody, along with its SHA256 and size.+--+-- When the LFS server requested verification, there will be a second+-- Request that does that; it should be run only after the upload has+-- succeeded.+--+-- When the LFS server already contains the object, an empty list may be+-- returned.+uploadOperationRequests :: UploadOperation -> RequestBody -> SHA256 -> Integer -> Maybe [Request]+uploadOperationRequests op content oid size = + case (mkdlreq, mkverifyreq) of+ (Nothing, _) -> Nothing+ (Just dlreq, Nothing) -> Just [dlreq]+ (Just dlreq, Just verifyreq) -> Just [dlreq, verifyreq]+ where+ mkdlreq = mkdlreq'+ <$> operationParamsRequest (upload op)+ mkdlreq' r = r+ { method = "PUT"+ , requestBody = content+ }+ mkverifyreq = mkverifyreq'+ <$> (operationParamsRequest =<< verify op)+ mkverifyreq' r = addLfsJsonHeaders $ r+ { method = "POST"+ , requestBody = RequestBodyLBS $ encode $+ Verification oid size+ }++operationParamsRequest :: OperationParams -> Maybe Request+operationParamsRequest ps = do+ r <- parseRequest (T.unpack (href ps))+ let headers = map convheader $ maybe [] M.toList (header ps)+ return $ r { requestHeaders = headers }+ where+ convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)++type Url = T.Text++type NumSeconds = Integer++type HTTPHeader = T.Text++type HTTPHeaderValue = T.Text++-- Prevent Nothing from serializing to null.+nonNullOptions :: Options+nonNullOptions = defaultOptions { omitNothingFields = True }++-- Remove prefix from field names.+stripFieldPrefix :: Options -> Options+stripFieldPrefix o =+ o { fieldLabelModifier = drop 1 . dropWhile (/= '_') }
Utility/Gpg.hs view
@@ -16,10 +16,10 @@ import System.Posix.IO import Utility.Env import Utility.Env.Set+import Utility.FileMode #else import Utility.Tmp #endif-import Utility.FileMode import Utility.Format (decode_c) import Control.Concurrent
Utility/InodeCache.hs view
@@ -48,7 +48,6 @@ #ifdef mingw32_HOST_OS import Data.Word (Word64)-import System.Directory #else import System.Posix.Files #endif
Utility/Metered.hs view
@@ -210,7 +210,14 @@ - to update a meter. -} commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool-commandMeter progressparser oh meterupdate cmd params = +commandMeter progressparser oh meterupdate cmd params = do+ ret <- commandMeter' progressparser oh meterupdate cmd params+ return $ case ret of+ Just ExitSuccess -> True+ _ -> False++commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode)+commandMeter' progressparser oh meterupdate cmd params = outputFilter cmd params Nothing (feedprogress zeroBytesProcessed []) handlestderr@@ -245,9 +252,13 @@ demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool-demeterCommandEnv oh cmd params environ = outputFilter cmd params environ- (\outh -> avoidProgress True outh stdouthandler)- (\errh -> avoidProgress True errh $ stderrHandler oh)+demeterCommandEnv oh cmd params environ = do+ ret <- outputFilter cmd params environ+ (\outh -> avoidProgress True outh stdouthandler)+ (\errh -> avoidProgress True errh $ stderrHandler oh)+ return $ case ret of+ Just ExitSuccess -> True+ _ -> False where stdouthandler l = unless (quietMode oh) $@@ -270,16 +281,15 @@ -> Maybe [(String, String)] -> (Handle -> IO ()) -> (Handle -> IO ())- -> IO Bool-outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do+ -> IO (Maybe ExitCode)+outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do (_, Just outh, Just errh, pid) <- createProcess p { std_out = CreatePipe , std_err = CreatePipe } void $ async $ tryIO (outfilter outh) >> hClose outh void $ async $ tryIO (errfilter errh) >> hClose errh- ret <- checkSuccessProcess pid- return ret+ waitForProcess pid where p = (proc cmd (toCommand params)) { env = environ }
Utility/Path/Max.hs view
@@ -11,13 +11,13 @@ module Utility.Path.Max where import System.FilePath-import Data.List-import Control.Applicative-import Prelude #ifndef mingw32_HOST_OS import Utility.Exception import System.Posix.Files+import Data.List+import Control.Applicative+import Prelude #endif {- Maximum size to use for a file in a specified directory.
Utility/Rsync.hs view
@@ -103,7 +103,16 @@ - The params must enable rsync's --progress mode for this to work. -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool-rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup+rsyncProgress oh meter ps =+ commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case+ Just ExitSuccess -> return True+ Just (ExitFailure exitcode) -> do+ when (exitcode /= 1) $+ hPutStrLn stderr $ "rsync exited " ++ show exitcode+ return False+ Nothing -> do+ hPutStrLn stderr $ "unable to run rsync"+ return False {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before - the first progress output, and each thereafter). The first number
Utility/Url.hs view
@@ -29,6 +29,7 @@ assumeUrlExists, download, downloadQuiet,+ downloadConduit, sinkResponseFile, downloadPartial, parseURIRelaxed,@@ -335,12 +336,11 @@ case (urlDownloader uo, parseUrlRequest (show u)) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust (matchStatusCodeException (== found302))- (downloadconduit req)+ (downloadConduit meterupdate req file uo >> return True) (followredir r) (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) | isfileurl u -> downloadfile u | isftpurl u -> downloadcurlrestricted r u url ftpport- `catchNonAsync` (dlfailed . show) | otherwise -> unsupportedUrlScheme u dlfailed (DownloadWithCurl _, _) | isfileurl u -> downloadfile u@@ -354,58 +354,6 @@ ftpport = 21 - downloadconduit req = catchMaybeIO (getFileSize file) >>= \case- Just sz | sz > 0 -> resumeconduit req' sz- _ -> runResourceT $ do- liftIO $ debugM "url" (show req')- resp <- http req' (httpManager uo)- if responseStatus resp == ok200- then store zeroBytesProcessed WriteMode resp- else showrespfailure resp- where- req' = applyRequest uo $ req- -- Override http-client's default decompression of gzip- -- compressed files. We want the unmodified file content.- { requestHeaders = (hAcceptEncoding, "identity") :- filter ((/= hAcceptEncoding) . fst)- (requestHeaders req)- , decompress = const False- }- - alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416 - && case lookup hContentRange h of- -- This could be improved by fixing- -- https://github.com/aristidb/http-types/issues/87- Just crh -> crh == B8.fromString ("bytes */" ++ show sz)- -- Some http servers send no Content-Range header when- -- the range extends beyond the end of the file.- -- There is no way to distinguish between the file- -- being the same size on the http server, vs- -- it being shorter than the file we already have.- -- So assume we have the whole content of the file- -- already, the same as wget and curl do.- Nothing -> True-- -- Resume download from where a previous download was interrupted, - -- when supported by the http server. The server may also opt to- -- send the whole file rather than resuming.- resumeconduit req sz = catchJust- (matchStatusCodeHeadersException (alreadydownloaded sz))- dl- (const $ return True)- where- dl = runResourceT $ do- let req' = req { requestHeaders = resumeFromHeader sz : requestHeaders req }- liftIO $ debugM "url" (show req')- resp <- http req' (httpManager uo)- if responseStatus resp == partialContent206- then store (BytesProcessed sz) AppendMode resp- else if responseStatus resp == ok200- then store zeroBytesProcessed WriteMode resp- else showrespfailure resp- - showrespfailure = liftIO . dlfailed . B8.toString - . statusMessage . responseStatus showhttpexception he = do let msg = case he of HttpExceptionRequest _ (StatusCodeException r _) ->@@ -417,6 +365,7 @@ HttpExceptionRequest _ other -> show other _ -> show he dlfailed msg+ dlfailed msg | noerror = return False | otherwise = do@@ -424,10 +373,6 @@ hFlush stderr return False - store initialp mode resp = do- sinkResponseFile meterupdate initialp file mode resp- return True- basecurlparams = curlParams uo [ if noerror then Param "-S"@@ -453,6 +398,8 @@ L.writeFile file return True + -- Conduit does not support ftp, so will throw an exception on a+ -- redirect to a ftp url; fall back to curl. followredir r ex@(HttpExceptionRequest _ (StatusCodeException resp _)) = case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of Just url' -> case parseURIRelaxed url' of@@ -463,6 +410,68 @@ Nothing -> throwIO ex followredir _ ex = throwIO ex +{- Download a perhaps large file using conduit, with auto-resume+ - of incomplete downloads.+ -+ - Does not catch exceptions.+ -}+downloadConduit :: MeterUpdate -> Request -> FilePath -> UrlOptions -> IO ()+downloadConduit meterupdate req file uo =+ catchMaybeIO (getFileSize file) >>= \case+ Just sz | sz > 0 -> resumedownload sz+ _ -> runResourceT $ do+ liftIO $ debugM "url" (show req')+ resp <- http req' (httpManager uo)+ if responseStatus resp == ok200+ then store zeroBytesProcessed WriteMode resp+ else respfailure resp+ where+ req' = applyRequest uo $ req+ -- Override http-client's default decompression of gzip+ -- compressed files. We want the unmodified file content.+ { requestHeaders = (hAcceptEncoding, "identity") :+ filter ((/= hAcceptEncoding) . fst)+ (requestHeaders req)+ , decompress = const False+ }++ -- Resume download from where a previous download was interrupted, + -- when supported by the http server. The server may also opt to+ -- send the whole file rather than resuming.+ resumedownload sz = catchJust+ (matchStatusCodeHeadersException (alreadydownloaded sz))+ dl+ (const noop)+ where+ dl = runResourceT $ do+ let req'' = req' { requestHeaders = resumeFromHeader sz : requestHeaders req }+ liftIO $ debugM "url" (show req'')+ resp <- http req'' (httpManager uo)+ if responseStatus resp == partialContent206+ then store (BytesProcessed sz) AppendMode resp+ else if responseStatus resp == ok200+ then store zeroBytesProcessed WriteMode resp+ else respfailure resp+ + alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416 + && case lookup hContentRange h of+ -- This could be improved by fixing+ -- https://github.com/aristidb/http-types/issues/87+ Just crh -> crh == B8.fromString ("bytes */" ++ show sz)+ -- Some http servers send no Content-Range header when+ -- the range extends beyond the end of the file.+ -- There is no way to distinguish between the file+ -- being the same size on the http server, vs+ -- it being shorter than the file we already have.+ -- So assume we have the whole content of the file+ -- already, the same as wget and curl do.+ Nothing -> True+ + store initialp mode resp =+ sinkResponseFile meterupdate initialp file mode resp+ + respfailure = giveup . B8.toString . statusMessage . responseStatus+ {- Sinks a Response's body to a file. The file can either be opened in - WriteMode or AppendMode. Updates the meter as data is received. -
doc/git-annex-adjust.mdwn view
@@ -24,6 +24,11 @@ and to other repositories, as well as to merge in changes from other repositories, run `git annex sync`. +When in an adjusted branch, using `git merge otherbranch` is often not+ideal, because merging a non-adjusted branch may lead to unncessary+merge conflicts, or add files in non-adjusted form. To avoid those+problems, use `git annex merge otherbranch`.+ Re-running this command with the same options while inside the adjusted branch will update the adjusted branch as necessary (eg for `--hide-missing`), and will also propagate commits
doc/git-annex-import.mdwn view
@@ -35,17 +35,23 @@ To import from a special remote, you must specify the name of a branch. A corresponding remote tracking branch will be updated by `git annex import`. After that point, it's the same as if you had run a `git fetch`-from a regular git remote; you can `git merge` the changes into your+from a regular git remote; you can merge the changes into your currently checked out branch. For example: git annex import master --from myremote- git merge myremote/master+ git annex merge myremote/master -Note that you may need to pass `--allow-unrelated-histories` the first time-you `git merge` from an import. Think of this as the remote being a-separate git repository with its own files. If you first+You could just as well use `git merge myremote/master` as the second step,+but using `git-annex merge` avoids a couple of gotchas. When using adjusted+branches, it adjusts the branch before merging from it. And it avoids+the merge failing on the first merge from an import due to unrelated+histories.++If you do use `git merge`, you can pass `--allow-unrelated-histories` the+first time you `git merge` from an import. Think of this as the remote+being a separate git repository with its own files. If you first `git annex export` files to a remote, and then `git annex import` from it, you won't need that option.
doc/git-annex-merge.mdwn view
@@ -1,17 +1,22 @@ # NAME -git-annex merge - automatically merge changes from remotes+git-annex merge - merge changes from remotes # SYNOPSIS -git annex merge+git annex merge [branch] # DESCRIPTION -This performs the same merging (and merge conflict resolution)-that is done by the sync command, but without pushing or pulling any-data.+When run without any parameters, this performs the same merging (and merge+conflict resolution) that is done by the sync command, but without pushing+or pulling any data. +When a branch to merge is specified, this merges it, using the same merge+conflict resolution as the sync command. This is especially useful on+an adjusted branch, because it applies the same adjustment to the+branch before merging it.+ When annex.resolvemerge is set to false, merge conflict resolution will not be done. @@ -20,6 +25,8 @@ [[git-annex]](1) [[git-annex-sync]](1)++[[git-annex-adjust]](1) # AUTHOR
doc/git-annex.mdwn view
@@ -1546,71 +1546,71 @@ For example, to use the wipe command, set it to `wipe -f %file`. -* `remote.<name>.rsyncurl`+* `remote.<name>.annex-rsyncurl` Used by rsync special remotes, this configures the location of the rsync repository to use. Normally this is automatically set up by `git annex initremote`, but you can change it if needed. -* `remote.<name>.buprepo`+* `remote.<name>.annex-buprepo` Used by bup special remotes, this configures the location of the bup repository to use. Normally this is automatically set up by `git annex initremote`, but you can change it if needed. -* `remote.<name>.ddarrepo`+* `remote.<name>.annex-ddarrepo` Used by ddar special remotes, this configures the location of the ddar repository to use. Normally this is automatically set up by `git annex initremote`, but you can change it if needed. -* `remote.<name>.directory`+* `remote.<name>.annex-directory` Used by directory special remotes, this configures the location of the directory where annexed files are stored for this remote. Normally this is automatically set up by `git annex initremote`, but you can change it if needed. -* `remote.<name>.adb`+* `remote.<name>.annex-adb` Used to identify remotes on Android devices accessed via adb. Normally this is automatically set up by `git annex initremote`. -* `remote.<name>.androiddirectory`+* `remote.<name>.annex-androiddirectory` Used by adb special remotes, this is the directory on the Android device where files are stored for this remote. Normally this is automatically set up by `git annex initremote`, but you can change it if needed. -* `remote.<name>.androidserial`+* `remote.<name>.annex-androidserial` Used by adb special remotes, this is the serial number of the Android device used by the remote. Normally this is automatically set up by `git annex initremote`, but you can change it if needed, eg when upgrading to a new Android device. -* `remote.<name>.s3`+* `remote.<name>.annex-s3` Used to identify Amazon S3 special remotes. Normally this is automatically set up by `git annex initremote`. -* `remote.<name>.glacier`+* `remote.<name>.annex-glacier` Used to identify Amazon Glacier special remotes. Normally this is automatically set up by `git annex initremote`. -* `remote.<name>.webdav`+* `remote.<name>.annex-webdav` Used to identify webdav special remotes. Normally this is automatically set up by `git annex initremote`. -* `remote.<name>.tahoe`+* `remote.<name>.annex-tahoe` Used to identify tahoe special remotes. Points to the configuration directory for tahoe. -* `remote.<name>.gcrypt`+* `remote.<name>.annex-gcrypt` Used to identify gcrypt special remotes. Normally this is automatically set up by `git annex initremote`.@@ -1619,7 +1619,14 @@ If the gcrypt remote is accessible over ssh and has git-annex-shell available to manage it, it's set to "shell". -* `remote.<name>.hooktype`, `remote.<name>.externaltype`+* `remote.<name>.annex-git-lfs`++ Used to identify git-lfs special remotes.+ Normally this is automatically set up by `git annex initremote`.++ It is set to "true" if this is a git-lfs remote.++* `remote.<name>.annex-hooktype`, `remote.<name>.annex-externaltype` Used by hook special remotes and external special remotes to record the type of the remote.
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 7.20190730+Version: 7.20190819 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -393,7 +393,8 @@ Win32 (>= 2.6.1.0), unix-compat (>= 0.5), setenv,- process (>= 1.6.2.0)+ process (>= 1.6.2.0),+ silently (>= 1.2.5.1) else Build-Depends: unix (>= 2.7.2) @@ -931,6 +932,7 @@ Remote.External.Types Remote.GCrypt Remote.Git+ Remote.GitLFS Remote.Glacier Remote.Helper.AWS Remote.Helper.Chunked@@ -1039,6 +1041,7 @@ Utility.FileSystemEncoding Utility.Format Utility.FreeDesktop+ Utility.GitLFS Utility.Glob Utility.Gpg Utility.Hash
stack.yaml view
@@ -23,6 +23,7 @@ - torrent-10000.1.1 - sandi-0.5 - http-client-0.5.14+- silently-1.2.5.1 explicit-setup-deps: git-annex: true resolver: lts-13.29