diff options
Diffstat (limited to 'Remote/Git.hs')
| -rw-r--r-- | Remote/Git.hs | 78 |
1 files changed, 50 insertions, 28 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs index d714cfec5..14157f498 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -144,7 +144,7 @@ repoAvail r else return True | Git.repoIsUrl r = return True | Git.repoIsLocalUnknown r = return False - | otherwise = liftIO $ catchBoolIO $ onLocal r $ return True + | otherwise = liftIO $ isJust <$> catchMaybeIO (Git.Config.read r) {- Tries to read the config for a specified remote, updates state, and - returns the updated repo. -} @@ -158,14 +158,15 @@ tryGitConfigRead r | haveconfig r' -> return r' | otherwise -> configlist_failed Left _ -> configlist_failed - | Git.repoIsHttp r = do - headers <- getHttpHeaders - store $ geturlconfig headers + | Git.repoIsHttp r = store geturlconfig | Git.GCrypt.isEncrypted r = handlegcrypt =<< getConfigMaybe (remoteConfig r "uuid") | Git.repoIsUrl r = return r - | otherwise = store $ safely $ onLocal r $ do - ensureInitialized - Annex.getState Annex.repo + | otherwise = store $ safely $ do + s <- Annex.new r + Annex.eval s $ do + Annex.BranchState.disableUpdate + ensureInitialized + Annex.getState Annex.repo where haveconfig = not . M.null . Git.config @@ -185,11 +186,11 @@ tryGitConfigRead r return $ Right r' Left l -> return $ Left l - geturlconfig headers = do - ua <- Url.getUserAgent + geturlconfig = do + uo <- Url.getUrlOptions v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do hClose h - ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") headers [] tmpfile ua) + ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") tmpfile uo) ( pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] , return $ Left undefined ) @@ -255,22 +256,22 @@ tryGitConfigRead r -} inAnnex :: Remote -> Key -> Annex (Either String Bool) inAnnex rmt key - | Git.repoIsHttp r = checkhttp =<< getHttpHeaders + | Git.repoIsHttp r = checkhttp | Git.repoIsUrl r = checkremote | otherwise = checklocal where r = repo rmt - checkhttp headers = do + checkhttp = do showChecking r - ifM (anyM (\u -> Url.withUserAgent $ Url.checkBoth u headers (keySize key)) (keyUrls rmt key)) + ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key)) ( return $ Right True , return $ Left "not found" ) checkremote = Ssh.inAnnex r key checklocal = guardUsable r (cantCheck r) $ dispatch <$> check where - check = liftIO $ catchMsgIO $ onLocal r $ - Annex.Content.inAnnexSafe key + check = either (Left . show) Right + <$> tryAnnex (onLocal rmt $ Annex.Content.inAnnexSafe key) dispatch (Left e) = Left e dispatch (Right (Just b)) = Right b dispatch (Right Nothing) = cantCheck r @@ -287,13 +288,13 @@ keyUrls r key = map tourl locs' #ifndef mingw32_HOST_OS locs' = locs #else - locs' = map (replace "\\" "/") (annexLocations key) + locs' = map (replace "\\" "/") locs #endif dropKey :: Remote -> Key -> Annex Bool dropKey r key | not $ Git.repoIsUrl (repo r) = - guardUsable (repo r) False $ commitOnCleanup r $ liftIO $ onLocal (repo r) $ do + guardUsable (repo r) False $ commitOnCleanup r $ onLocal r $ do ensureInitialized whenM (Annex.Content.inAnnex key) $ do Annex.Content.lockContent key $ @@ -313,7 +314,7 @@ copyFromRemote' r key file dest let params = Ssh.rsyncParams r Download u <- getUUID -- run copy from perspective of remote - liftIO $ onLocal (repo r) $ do + onLocal r $ do ensureInitialized v <- Annex.Content.prepSendAnnex key case v of @@ -412,7 +413,7 @@ copyToRemote r key file p let params = Ssh.rsyncParams r Upload u <- getUUID -- run copy from perspective of remote - liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key) + onLocal r $ ifM (Annex.Content.inAnnex key) ( return True , do ensureInitialized @@ -441,19 +442,40 @@ fsckOnRemote r params {- 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 +repairRemote r a = return $ 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 + ensureInitialized a +{- Runs an action from the perspective of a local remote. + - + - The AnnexState is cached for speed and to avoid resource leaks. + - + - The repository's git-annex branch is not updated, as an optimisation. + - No caller of onLocal can query data from the branch and be ensured + - it gets a current value. Caller of onLocal can make changes to + - the branch, however. + -} +onLocal :: Remote -> Annex a -> Annex a +onLocal r a = do + m <- Annex.getState Annex.remoteannexstate + case M.lookup (uuid r) m of + Nothing -> do + st <- liftIO $ Annex.new (repo r) + go st $ do + Annex.BranchState.disableUpdate + a + Just st -> go st a + where + cache st = Annex.changeState $ \s -> s + { Annex.remoteannexstate = M.insert (uuid r) st (Annex.remoteannexstate s) } + go st a' = do + (ret, st') <- liftIO $ Annex.run st a' + cache st' + return ret + {- Copys a file with rsync unless both locations are on the same - filesystem. Then cp could be faster. -} rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool @@ -490,7 +512,7 @@ commitOnCleanup r a = go `after` a where go = Annex.addCleanup (Git.repoLocation $ repo r) cleanup cleanup - | not $ Git.repoIsUrl (repo r) = liftIO $ onLocal (repo r) $ + | not $ Git.repoIsUrl (repo r) = onLocal r $ doQuietSideAction $ Annex.Branch.commit "update" | otherwise = void $ do |