diff options
Diffstat (limited to 'Remote/Git.hs')
-rw-r--r-- | Remote/Git.hs | 268 |
1 files changed, 268 insertions, 0 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs new file mode 100644 index 000000000..43e75b97b --- /dev/null +++ b/Remote/Git.hs @@ -0,0 +1,268 @@ +{- Standard git remotes. + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Remote.GitRemote ( + generate, + onRemote +) where + +import Control.Exception.Extensible +import Control.Monad.State (liftIO) +import qualified Data.Map as Map +import Data.String.Utils +import System.Cmd.Utils +import Control.Monad (unless, filterM) + +import RemoteClass +import Types +import qualified GitRepo as Git +import qualified Annex +import Locations +import UUID +import Utility +import qualified Content +import Messages +import CopyFile +import RsyncFile +import Ssh + +generate :: Annex [Remote Annex] +generate = do + readConfigs + g <- Annex.gitRepo + rs <- filterM repoNotIgnored (Git.remotes g) + mapM genRemote rs + +genRemote :: Git.Repo -> Annex (Remote Annex) +genRemote r = do + u <- getUUID r + c <- repoCost r + return Remote { + uuid = u, + cost = c, + name = Git.repoDescribe r, + storeKey = copyToRemote r, + retrieveKeyFile = copyFromRemote r, + removeKey = dropKey r, + hasKey = inAnnex r, + hasKeyCheap = not (Git.repoIsUrl r) + } + +{- Reads the configs of git remotes. + - + - It's assumed to be cheap to read the config of non-URL remotes, + - so this is done each time git-annex is run. Conversely, + - the config of an URL remote is only read when there is no + - cached UUID value. + -} +readConfigs :: Annex () +readConfigs = do + g <- Annex.gitRepo + allremotes <- filterM repoNotIgnored $ Git.remotes g + let cheap = filter (not . Git.repoIsUrl) allremotes + let expensive = filter Git.repoIsUrl allremotes + doexpensive <- filterM cachedUUID expensive + unless (null doexpensive) $ + showNote $ "getting UUID for " ++ + list doexpensive ++ "..." + let todo = cheap ++ doexpensive + unless (null todo) $ do + mapM_ tryGitConfigRead todo + where + cachedUUID r = do + u <- getUUID r + return $ null u + +{- The git configs for the git repo's remotes is not read on startup + - because reading it may be expensive. This function tries to read the + - config for a specified remote, and updates state. If successful, it + - returns the updated git repo. -} +tryGitConfigRead :: Git.Repo -> Annex (Either Git.Repo Git.Repo) +tryGitConfigRead r + | not $ Map.null $ Git.configMap r = return $ Right r -- already read + | Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" [] + | Git.repoIsUrl r = return $ Left r + | otherwise = store $ safely $ Git.configRead r + where + -- Reading config can fail due to IO error or + -- for other reasons; catch all possible exceptions. + safely a = do + result <- liftIO (try (a)::IO (Either SomeException Git.Repo)) + case result of + Left _ -> return r + Right r' -> return r' + pipedconfig cmd params = safely $ + pOpen ReadFromPipe cmd (toCommand params) $ + Git.hConfigRead r + store a = do + r' <- a + g <- Annex.gitRepo + let l = Git.remotes g + let g' = Git.remotesAdd g $ exchange l r' + Annex.changeState $ \s -> s { Annex.repo = g' } + return $ Right r' + exchange [] _ = [] + exchange (old:ls) new = + if Git.repoRemoteName old == Git.repoRemoteName new + then new : exchange ls new + else old : exchange ls new + +{- Calculates cost for a repo. + - + - The default cost is 100 for local repositories, and 200 for remote + - repositories; it can also be configured by remote.<name>.annex-cost + -} +repoCost :: Git.Repo -> Annex Int +repoCost r = do + c <- Annex.repoConfig r "cost" "" + if not $ null c + then return $ read c + else if Git.repoIsUrl r + then return 200 + else return 100 + +{- Checks if a repo should be ignored, based either on annex-ignore + - setting, or on command-line options. Allows command-line to override + - annex-ignore. -} +repoNotIgnored :: Git.Repo -> Annex Bool +repoNotIgnored r = do + ignored <- Annex.repoConfig r "ignore" "false" + to <- match Annex.toremote + from <- match Annex.fromremote + if to || from + then return True + else return $ not $ Git.configTrue ignored + where + match a = do + n <- Annex.getState a + return $ n == Git.repoRemoteName r + +{- Checks if a given remote has the content for a key inAnnex. + - If the remote cannot be accessed, returns a Left error. + -} +inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool) +inAnnex r key = if Git.repoIsUrl r + then checkremote + else liftIO (try checklocal ::IO (Either IOException Bool)) + where + checklocal = do + -- run a local check inexpensively, + -- by making an Annex monad using the remote + a <- Annex.new r [] + Annex.eval a (Content.inAnnex key) + checkremote = do + showNote ("checking " ++ Git.repoDescribe r ++ "...") + inannex <- onRemote r (boolSystem, False) "inannex" + [Param (show key)] + return $ Right inannex + +dropKey :: Git.Repo -> Key -> Annex Bool +dropKey r key = + onRemote r (boolSystem, False) "dropkey" + [ Params "--quiet --force" + , Param $ show key + ] + +{- Tries to copy a key's content from a remote's annex to a file. -} +copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool +copyFromRemote r key file + | not $ Git.repoIsUrl r = liftIO $ copyFile (gitAnnexLocation r key) file + | Git.repoIsSsh r = rsynchelper r True key file + | otherwise = error "copying from non-ssh repo not supported" + +{- Tries to copy a key's content to a remote's annex. -} +copyToRemote :: Git.Repo -> Key -> Annex Bool +copyToRemote r key + | not $ Git.repoIsUrl r = do + g <- Annex.gitRepo + let keysrc = gitAnnexLocation g key + -- run copy from perspective of remote + liftIO $ do + a <- Annex.new r [] + Annex.eval a $ do + ok <- Content.getViaTmp key $ + \f -> liftIO $ copyFile keysrc f + Annex.queueRun + return ok + | Git.repoIsSsh r = do + g <- Annex.gitRepo + let keysrc = gitAnnexLocation g key + rsynchelper r False key keysrc + | otherwise = error "copying to non-ssh repo not supported" + +rsynchelper :: Git.Repo -> Bool -> Key -> FilePath -> Annex (Bool) +rsynchelper r sending key file = do + showProgress -- make way for progress bar + p <- rsyncParams r sending key file + res <- liftIO $ boolSystem "rsync" p + if res + then return res + else do + showLongNote "rsync failed -- run git annex again to resume file transfer" + return res + +{- Generates rsync parameters that ssh to the remote and asks it + - to either receive or send the key's content. -} +rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [CommandParam] +rsyncParams r sending key file = do + Just (shellcmd, shellparams) <- git_annex_shell r + (if sending then "sendkey" else "recvkey") + [ Param $ show key + -- Command is terminated with "--", because + -- rsync will tack on its own options afterwards, + -- and they need to be ignored. + , Param "--" + ] + -- Convert the ssh command into rsync command line. + let eparam = rsyncShell (Param shellcmd:shellparams) + o <- Annex.repoConfig r "rsync-options" "" + let base = options ++ map Param (words o) ++ eparam + if sending + then return $ base ++ [dummy, File file] + else return $ base ++ [File file, dummy] + where + -- inplace makes rsync resume partial files + options = [Params "-p --progress --inplace"] + -- the rsync shell parameter controls where rsync + -- goes, so the source/dest parameter can be a dummy value, + -- that just enables remote rsync mode. + dummy = Param ":" + +{- Uses a supplied function to run a git-annex-shell command on a remote. + - + - Or, if the remote does not support running remote commands, returns + - a specified error value. -} +onRemote + :: Git.Repo + -> (FilePath -> [CommandParam] -> IO a, a) + -> String + -> [CommandParam] + -> Annex a +onRemote r (with, errorval) command params = do + s <- git_annex_shell r command params + case s of + Just (c, ps) -> liftIO $ with c ps + Nothing -> return errorval + +{- Generates parameters to run a git-annex-shell command on a remote. -} +git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam])) +git_annex_shell r command params + | not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts) + | Git.repoIsSsh r = do + sshparams <- sshToRepo r [Param sshcmd] + return $ Just ("ssh", sshparams) + | otherwise = return Nothing + where + dir = Git.workTree r + shellcmd = "git-annex-shell" + shellopts = (Param command):(File dir):params + sshcmd = shellcmd ++ " " ++ + unwords (map shellEscape $ toCommand shellopts) + +{- Human visible list of remotes. -} +list :: [Git.Repo] -> String +list remotes = join ", " $ map Git.repoDescribe remotes |