diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.DirHashes ( diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -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 diff --git a/Annex/Hook.hs b/Annex/Hook.hs --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -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) $ diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -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) diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -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 diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -10,6 +10,7 @@ module Backend.Hash ( backends, testKeyBackend, + keyHash, ) where import Annex.Common diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -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 diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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 diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -25,6 +25,10 @@ 2013 Michael Snoyman License: Expat +Files: Utility/GitLFS.hs +Copyright: © 2019 Joey Hess +License: AGPL-3+ + Files: Utility/* Copyright: 2012-2019 Joey Hess License: BSD-2-clause diff --git a/Command/Init.hs b/Command/Init.hs --- a/Command/Init.hs +++ b/Command/Init.hs @@ -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) diff --git a/Command/Merge.hs b/Command/Merge.hs --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011, 2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - 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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -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]) diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -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 diff --git a/Git/Url.hs b/Git/Url.hs --- a/Git/Url.hs +++ b/Git/Url.hs @@ -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 $ diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -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 diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -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 diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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") diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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 diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs new file mode 100644 --- /dev/null +++ b/Remote/GitLFS.hs @@ -0,0 +1,449 @@ +{- Using git-lfs as a remote. + - + - Copyright 2019 Joey Hess + - + - 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 diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -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 diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -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" diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -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 ] diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -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 ] diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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. diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -1,6 +1,6 @@ {- git-annex test suite framework - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2019 Joey Hess - - 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) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -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" diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -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. -- diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs --- a/Utility/Env/Set.hs +++ b/Utility/Env/Set.hs @@ -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 diff --git a/Utility/GitLFS.hs b/Utility/GitLFS.hs new file mode 100644 --- /dev/null +++ b/Utility/GitLFS.hs @@ -0,0 +1,439 @@ +{- git-lfs API + - + - https://github.com/git-lfs/git-lfs/blob/master/docs/api + - + - Copyright 2019 Joey Hess + - + - 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 (/= '_') } diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -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 diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -48,7 +48,6 @@ #ifdef mingw32_HOST_OS import Data.Word (Word64) -import System.Directory #else import System.Posix.Files #endif diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -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 } diff --git a/Utility/Path/Max.hs b/Utility/Path/Max.hs --- a/Utility/Path/Max.hs +++ b/Utility/Path/Max.hs @@ -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. diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -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 diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -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. - diff --git a/doc/git-annex-adjust.mdwn b/doc/git-annex-adjust.mdwn --- a/doc/git-annex-adjust.mdwn +++ b/doc/git-annex-adjust.mdwn @@ -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 diff --git a/doc/git-annex-import.mdwn b/doc/git-annex-import.mdwn --- a/doc/git-annex-import.mdwn +++ b/doc/git-annex-import.mdwn @@ -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. diff --git a/doc/git-annex-merge.mdwn b/doc/git-annex-merge.mdwn --- a/doc/git-annex-merge.mdwn +++ b/doc/git-annex-merge.mdwn @@ -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 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1546,71 +1546,71 @@ For example, to use the wipe command, set it to `wipe -f %file`. -* `remote..rsyncurl` +* `remote..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..buprepo` +* `remote..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..ddarrepo` +* `remote..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..directory` +* `remote..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..adb` +* `remote..annex-adb` Used to identify remotes on Android devices accessed via adb. Normally this is automatically set up by `git annex initremote`. -* `remote..androiddirectory` +* `remote..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..androidserial` +* `remote..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..s3` +* `remote..annex-s3` Used to identify Amazon S3 special remotes. Normally this is automatically set up by `git annex initremote`. -* `remote..glacier` +* `remote..annex-glacier` Used to identify Amazon Glacier special remotes. Normally this is automatically set up by `git annex initremote`. -* `remote..webdav` +* `remote..annex-webdav` Used to identify webdav special remotes. Normally this is automatically set up by `git annex initremote`. -* `remote..tahoe` +* `remote..annex-tahoe` Used to identify tahoe special remotes. Points to the configuration directory for tahoe. -* `remote..gcrypt` +* `remote..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..hooktype`, `remote..externaltype` +* `remote..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..annex-hooktype`, `remote..annex-externaltype` Used by hook special remotes and external special remotes to record the type of the remote. diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 7.20190730 +Version: 7.20190819 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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