diff options
Diffstat (limited to 'Remote/Git.hs')
| -rw-r--r-- | Remote/Git.hs | 244 |
1 files changed, 113 insertions, 131 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs index e269b9ad8..d4e5987dc 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -13,12 +13,7 @@ module Remote.Git ( repoAvail, ) where -import qualified Data.Map as M -import Control.Exception.Extensible - import Common.Annex -import Utility.Rsync -import Remote.Helper.Ssh import Annex.Ssh import Types.Remote import Types.GitConfig @@ -26,6 +21,7 @@ import qualified Git import qualified Git.Config import qualified Git.Construct import qualified Git.Command +import qualified Git.GCrypt import qualified Annex import Logs.Presence import Logs.Transfer @@ -34,7 +30,7 @@ import Annex.Exception import qualified Annex.Content import qualified Annex.BranchState import qualified Annex.Branch -import qualified Utility.Url as Url +import qualified Annex.Url as Url import Utility.Tmp import Config import Config.Cost @@ -46,10 +42,19 @@ import Utility.Metered #ifndef mingw32_HOST_OS import Utility.CopyFile #endif +import Utility.Env +import Utility.Batch +import Remote.Helper.Git +import Remote.Helper.Messages +import qualified Remote.Helper.Ssh as Ssh +import qualified Remote.GCrypt +import Config.Files import Control.Concurrent import Control.Concurrent.MSampleVar import System.Process (std_in, std_err) +import qualified Data.Map as M +import Control.Exception.Extensible remote :: RemoteType remote = RemoteType { @@ -90,14 +95,13 @@ configRead r = do (False, _, NoUUID) -> tryGitConfigRead r _ -> return r -repoCheap :: Git.Repo -> Bool -repoCheap = not . Git.repoIsUrl - -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote -gen r u _ gc = go <$> remoteCost gc defcst +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) +gen r u c gc + | Git.GCrypt.isEncrypted r = Remote.GCrypt.gen r u c gc + | otherwise = go <$> remoteCost gc defcst where defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost - go cst = new + go cst = Just new where new = Remote { uuid = u @@ -110,15 +114,19 @@ gen r u _ gc = go <$> remoteCost gc defcst , hasKey = inAnnex r , hasKeyCheap = repoCheap r , whereisKey = Nothing - , config = M.empty - , localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r - then Just $ Git.repoPath r - else Nothing + , remoteFsck = if Git.repoIsUrl r + then Nothing + else Just $ fsckOnRemote r + , repairRepo = if Git.repoIsUrl r + then Nothing + else Just $ repairRemote r + , config = c + , localpath = localpathCalc r , repo = r , gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r } , readonly = Git.repoIsHttp r - , globallyAvailable = not $ Git.repoIsLocal r || Git.repoIsLocalUnknown r + , globallyAvailable = globallyAvailableCalc r , remotetype = remote } @@ -126,24 +134,25 @@ gen r u _ gc = go <$> remoteCost gc defcst repoAvail :: Git.Repo -> Annex Bool repoAvail r | Git.repoIsHttp r = return True + | Git.GCrypt.isEncrypted r = do + g <- gitRepo + liftIO $ do + er <- Git.GCrypt.encryptedRemote g r + if Git.repoIsLocal er || Git.repoIsLocalUnknown er + then catchBoolIO $ + void (Git.Config.read er) >> return True + else return True | Git.repoIsUrl r = return True | Git.repoIsLocalUnknown r = return False | otherwise = liftIO $ catchBoolIO $ onLocal r $ return True -{- Avoids performing an action on a local repository that's not usable. - - Does not check that the repository is still available on disk. -} -guardUsable :: Git.Repo -> a -> Annex a -> Annex a -guardUsable r onerr a - | Git.repoIsLocalUnknown r = return onerr - | otherwise = a - {- Tries to read the config for a specified remote, updates state, and - returns the updated repo. -} tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead r | haveconfig r = return r -- already read | Git.repoIsSsh r = store $ do - v <- onRemote r (pipedconfig, Left undefined) "configlist" [] [] + v <- Ssh.onRemote r (pipedconfig, Left undefined) "configlist" [] [] case v of Right r' | haveconfig r' -> return r' @@ -152,6 +161,7 @@ tryGitConfigRead r | Git.repoIsHttp r = do headers <- getHttpHeaders store $ geturlconfig headers + | Git.GCrypt.isEncrypted r = handlegcrypt =<< getConfigMaybe (remoteConfig r "uuid") | Git.repoIsUrl r = return r | otherwise = store $ safely $ onLocal r $ do ensureInitialized @@ -164,23 +174,22 @@ tryGitConfigRead r safely a = either (const $ return r) return =<< liftIO (try a :: IO (Either SomeException Git.Repo)) - pipedconfig cmd params = try run :: IO (Either SomeException Git.Repo) - where - run = withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h - val <- hGetContentsStrict h - r' <- Git.Config.store val r - when (getUncachedUUID r' == NoUUID && not (null val)) $ do - warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r - warningIO $ "Instead, got: " ++ show val - warningIO $ "This is unexpected; please check the network transport!" - return r' - p = proc cmd $ toCommand params + pipedconfig cmd params = do + v <- Git.Config.fromPipe r cmd params + case v of + Right (r', val) -> do + when (getUncachedUUID r' == NoUUID && not (null val)) $ do + warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r + warningIO $ "Instead, got: " ++ show val + warningIO $ "This is unexpected; please check the network transport!" + return $ Right r' + Left l -> return $ Left l geturlconfig headers = do + ua <- Url.getUserAgent v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do hClose h - ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") headers [] tmpfile) + ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") headers [] tmpfile ua) ( pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] , return $ Left undefined ) @@ -210,7 +219,7 @@ tryGitConfigRead r Nothing -> return r Just n -> do whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ - set_ignore $ "does not have git-annex installed" + set_ignore "does not have git-annex installed" return r set_ignore msg = case Git.remoteName r of @@ -219,6 +228,15 @@ tryGitConfigRead r let k = "remote." ++ n ++ ".annex-ignore" warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting " ++ k inRepo $ Git.Command.run [Param "config", Param k, Param "true"] + + handlegcrypt Nothing = return r + handlegcrypt (Just _cacheduuid) = do + -- Generate UUID from the gcrypt-id + g <- gitRepo + case Git.GCrypt.remoteRepoId g (Git.remoteName r) of + Nothing -> return r + Just v -> store $ liftIO $ setUUID r $ + genUUIDInNameSpace gCryptNameSpace v {- Checks if a given remote has the content for a key inAnnex. - If the remote cannot be accessed, or if it cannot determine @@ -231,39 +249,19 @@ inAnnex r key | otherwise = checklocal where checkhttp headers = do - showchecking - liftIO $ ifM (anyM (\u -> Url.check u headers (keySize key)) (keyUrls r key)) + showChecking r + ifM (anyM (\u -> Url.withUserAgent $ Url.checkBoth u headers (keySize key)) (keyUrls r key)) ( return $ Right True , return $ Left "not found" ) - checkremote = do - showchecking - onRemote r (check, unknown) "inannex" [Param (key2file key)] [] - where - check c p = dispatch <$> safeSystem c p - dispatch ExitSuccess = Right True - dispatch (ExitFailure 1) = Right False - dispatch _ = unknown - checklocal = guardUsable r unknown $ dispatch <$> check + checkremote = Ssh.inAnnex r key + checklocal = guardUsable r (cantCheck r) $ dispatch <$> check where check = liftIO $ catchMsgIO $ onLocal r $ Annex.Content.inAnnexSafe key dispatch (Left e) = Left e dispatch (Right (Just b)) = Right b - dispatch (Right Nothing) = unknown - unknown = Left $ "unable to check " ++ Git.repoDescribe r - showchecking = showAction $ "checking " ++ Git.repoDescribe r - -{- Runs an action on a local repository inexpensively, by making an annex - - monad using that repository. -} -onLocal :: Git.Repo -> Annex a -> IO a -onLocal r a = do - s <- Annex.new r - Annex.eval s $ do - -- No need to update the branch; its data is not used - -- for anything onLocal is used to do. - Annex.BranchState.disableUpdate - a + dispatch (Right Nothing) = cantCheck r keyUrls :: Git.Repo -> Key -> [String] keyUrls r key = map tourl locs @@ -286,12 +284,8 @@ dropKey r key logStatus key InfoMissing Annex.Content.saveState True return True - | Git.repoIsHttp (repo r) = error "dropping from http repo not supported" - | otherwise = commitOnCleanup r $ onRemote (repo r) (boolSystem, False) "dropkey" - [ Params "--quiet --force" - , Param $ key2file key - ] - [] + | Git.repoIsHttp (repo r) = error "dropping from http remote not supported" + | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key {- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool @@ -299,7 +293,7 @@ copyFromRemote r key file dest _p = copyFromRemote' r key file dest copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool copyFromRemote' r key file dest | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do - let params = rsyncParams r + let params = Ssh.rsyncParams r u <- getUUID -- run copy from perspective of remote liftIO $ onLocal (repo r) $ do @@ -311,11 +305,12 @@ copyFromRemote' r key file dest upload u key file noRetry (rsyncOrCopyFile params object dest) <&&> checksuccess - | Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> - rsyncHelper (Just feeder) - =<< rsyncParamsRemote r Download key dest file + | Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do + direct <- isDirect + Ssh.rsyncHelper (Just feeder) + =<< Ssh.rsyncParamsRemote direct r Download key dest file | Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls (repo r) key) dest - | otherwise = error "copying from non-ssh, non-http repo not supported" + | otherwise = error "copying from non-ssh, non-http remote not supported" where {- Feed local rsync's progress info back to the remote, - by forking a feeder thread that runs @@ -340,9 +335,9 @@ copyFromRemote' r key file dest u <- getUUID let fields = (Fields.remoteUUID, fromUUID u) : maybe [] (\f -> [(Fields.associatedFile, f)]) file - Just (cmd, params) <- git_annex_shell (repo r) "transferinfo" + Just (cmd, params) <- Ssh.git_annex_shell (repo r) "transferinfo" [Param $ key2file key] fields - v <- liftIO $ (newEmptySV :: IO (MSampleVar Integer)) + v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) tid <- liftIO $ forkIO $ void $ tryIO $ do bytes <- readSV v p <- createProcess $ @@ -353,7 +348,7 @@ copyFromRemote' r key file dest hClose $ stderrHandle p let h = stdinHandle p let send b = do - hPutStrLn h $ show b + hPrint h b hFlush h send bytes forever $ @@ -385,8 +380,10 @@ copyToRemote r key file p guardUsable (repo r) False $ commitOnCleanup r $ copylocal =<< Annex.Content.prepSendAnnex key | Git.repoIsSsh (repo r) = commitOnCleanup r $ - Annex.Content.sendAnnex key noop $ \object -> - rsyncHelper (Just p) =<< rsyncParamsRemote r Upload key object file + Annex.Content.sendAnnex key noop $ \object -> do + direct <- isDirect + Ssh.rsyncHelper (Just p) + =<< Ssh.rsyncParamsRemote direct r Upload key object file | otherwise = error "copying to non-ssh repo not supported" where copylocal Nothing = return False @@ -395,7 +392,7 @@ copyToRemote r key file p -- the remote's Annex, but it needs access to the current -- Annex monad's state. checksuccessio <- Annex.withCurrentState checksuccess - let params = rsyncParams r + let params = Ssh.rsyncParams r u <- getUUID -- run copy from perspective of remote liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key) @@ -408,15 +405,37 @@ copyToRemote r key file p (\d -> rsyncOrCopyFile params object d p) ) -rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool -rsyncHelper callback params = do - showOutput -- make way for progress bar - ifM (liftIO $ (maybe rsync rsyncProgress callback) params) - ( return True - , do - showLongNote "rsync failed -- run git annex again to resume file transfer" - return False - ) +fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) +fsckOnRemote r params + | Git.repoIsUrl r = do + s <- Ssh.git_annex_shell r "fsck" params [] + return $ case s of + Nothing -> return False + Just (c, ps) -> batchCommand c ps + | otherwise = return $ do + program <- readProgramFile + env <- getEnvironment + r' <- Git.Config.read r + let env' = + [ ("GIT_WORK_TREE", Git.repoPath r') + , ("GIT_DIR", Git.localGitDir r') + ] ++ env + batchCommandEnv program (Param "fsck" : params) (Just env') + +{- The passed repair action is run in the Annex monad of the remote. -} +repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool) +repairRemote r a = return $ Remote.Git.onLocal r a + +{- Runs an action on a local repository inexpensively, by making an annex + - monad using that repository. -} +onLocal :: Git.Repo -> Annex a -> IO a +onLocal r a = do + s <- Annex.new r + Annex.eval s $ do + -- No need to update the branch; its data is not used + -- for anything onLocal is used to do. + Annex.BranchState.disableUpdate + a {- Copys a file with rsync unless both locations are on the same - filesystem. Then cp could be faster. -} @@ -428,7 +447,7 @@ rsyncOrCopyFile rsyncparams src dest p = #else ifM (sameDeviceIds src dest) (docopy, dorsync) where - sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b) + sameDeviceIds a b = (==) <$> getDeviceId a <*> getDeviceId b getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f) docopy = liftIO $ bracket (forkIO $ watchfilesize zeroBytesProcessed) @@ -446,46 +465,9 @@ rsyncOrCopyFile rsyncparams src dest p = watchfilesize sz _ -> watchfilesize oldsz #endif - dorsync = rsyncHelper (Just p) $ + dorsync = Ssh.rsyncHelper (Just p) $ rsyncparams ++ [File src, File dest] -{- Generates rsync parameters that ssh to the remote and asks it - - to either receive or send the key's content. -} -rsyncParamsRemote :: Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam] -rsyncParamsRemote r direction key file afile = do - u <- getUUID - direct <- isDirect - let fields = (Fields.remoteUUID, fromUUID u) - : (Fields.direct, if direct then "1" else "") - : maybe [] (\f -> [(Fields.associatedFile, f)]) afile - Just (shellcmd, shellparams) <- git_annex_shell (repo r) - (if direction == Download then "sendkey" else "recvkey") - [ Param $ key2file key ] - fields - -- Convert the ssh command into rsync command line. - let eparam = rsyncShell (Param shellcmd:shellparams) - let o = rsyncParams r - if direction == Download - then return $ o ++ rsyncopts eparam dummy (File file) - else return $ o ++ rsyncopts eparam (File file) dummy - where - rsyncopts ps source dest - | end ps == [dashdash] = ps ++ [source, dest] - | otherwise = ps ++ [dashdash, source, dest] - dashdash = Param "--" - {- The rsync shell parameter controls where rsync - - goes, so the source/dest parameter can be a dummy value, - - that just enables remote rsync mode. - - For maximum compatability with some patched rsyncs, - - the dummy value needs to still contain a hostname, - - even though this hostname will never be used. -} - dummy = Param "dummy:" - --- --inplace to resume partial files -rsyncParams :: Remote -> [CommandParam] -rsyncParams r = [Params "--progress --inplace"] ++ - map Param (remoteAnnexRsyncOptions $ gitconfig r) - commitOnCleanup :: Remote -> Annex a -> Annex a commitOnCleanup r a = go `after` a where @@ -496,12 +478,12 @@ commitOnCleanup r a = go `after` a Annex.Branch.commit "update" | otherwise = void $ do Just (shellcmd, shellparams) <- - git_annex_shell (repo r) "commit" [] [] + Ssh.git_annex_shell (repo r) "commit" [] [] -- Throw away stderr, since the remote may not -- have a new enough git-annex shell to -- support committing. - liftIO $ catchMaybeIO $ do + liftIO $ catchMaybeIO $ withQuietOutput createProcessSuccess $ proc shellcmd $ toCommand shellparams |