From 91366c896d9c9cb4519b451a64ed4d1e0ff52cb3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 16 Oct 2011 00:04:26 -0400 Subject: clean Annex stuff out of Utility/ --- Annex/Ssh.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Command/AddUrl.hs | 2 +- Command/Map.hs | 2 +- Locations.hs | 2 +- Remote/Bup.hs | 2 +- Remote/Git.hs | 4 ++-- Remote/Web.hs | 4 +++- Utility/Ssh.hs | 67 ------------------------------------------------------- Utility/Url.hs | 12 ++++------ 9 files changed, 80 insertions(+), 82 deletions(-) create mode 100644 Annex/Ssh.hs delete mode 100644 Utility/Ssh.hs diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs new file mode 100644 index 000000000..851c7c06b --- /dev/null +++ b/Annex/Ssh.hs @@ -0,0 +1,67 @@ +{- git-annex remote access with ssh + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Ssh where + +import Control.Monad.State (liftIO) + +import qualified Git +import Utility.SafeCommand +import Types +import Config +import Annex.UUID + +{- Generates parameters to ssh to a repository's host and run a command. + - Caller is responsible for doing any neccessary shellEscaping of the + - passed command. -} +sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam] +sshToRepo repo sshcmd = do + s <- getConfig repo "ssh-options" "" + let sshoptions = map Param (words s) + let sshport = case Git.urlPort repo of + Nothing -> [] + Just p -> [Param "-p", Param (show p)] + let sshhost = Param $ Git.urlHostUser repo + return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd + +{- Generates parameters to run a git-annex-shell command on a remote + - repository. -} +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 + uuid <- getRepoUUID r + sshparams <- sshToRepo r [Param $ sshcmd uuid ] + return $ Just ("ssh", sshparams) + | otherwise = return Nothing + where + dir = Git.workTree r + shellcmd = "git-annex-shell" + shellopts = Param command : File dir : params + sshcmd uuid = unwords $ + shellcmd : (map shellEscape $ toCommand shellopts) ++ + uuidcheck uuid + uuidcheck uuid + | null uuid = [] + | otherwise = ["--uuid", uuid] + +{- Uses a supplied function (such as boolSystem) 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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 2756af880..f32b5b86a 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -48,7 +48,7 @@ download url file = do let dummykey = Backend.URL.fromUrl url let tmp = gitAnnexTmpLocation g dummykey liftIO $ createDirectoryIfMissing True (parentDir tmp) - ok <- Url.download url tmp + ok <- liftIO $ Url.download url tmp if ok then do [(backend, _)] <- Backend.chooseBackends [file] diff --git a/Command/Map.hs b/Command/Map.hs index 18cb915e3..48cba63f9 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -16,7 +16,7 @@ import qualified Git import Annex.UUID import Logs.UUID import Logs.Trust -import Utility.Ssh +import Annex.Ssh import qualified Utility.Dot as Dot -- a link from the first repository to the second (its remote) diff --git a/Locations.hs b/Locations.hs index 4579fe05b..ceb6246b9 100644 --- a/Locations.hs +++ b/Locations.hs @@ -127,7 +127,7 @@ isLinkToAnnex s = ("/.git/" ++ objectDir) `isInfixOf` s - is one to one. - ":" is escaped to "&c", because despite it being 2011, people still care - about FAT. - - -} + -} keyFile :: Key -> FilePath keyFile key = replace "/" "%" $ replace ":" "&c" $ replace "%" "&s" $ replace "&" "&a" $ show key diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 8d36245a9..48014f1da 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -16,7 +16,7 @@ import Common.Annex import Types.Remote import qualified Git import Config -import Utility.Ssh +import Annex.Ssh import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto diff --git a/Remote/Git.hs b/Remote/Git.hs index 10183522f..8857d821d 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -13,7 +13,7 @@ import qualified Data.Map as M import Common.Annex import Utility.CopyFile import Utility.RsyncFile -import Utility.Ssh +import Annex.Ssh import Types.Remote import qualified Git import qualified Annex @@ -164,7 +164,7 @@ copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool copyFromRemote r key file | not $ Git.repoIsUrl r = rsyncOrCopyFile r (gitAnnexLocation r key) file | Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file - | Git.repoIsHttp r = Url.download (keyUrl r key) file + | Git.repoIsHttp r = liftIO $ Url.download (keyUrl r key) file | otherwise = error "copying from non-ssh, non-http repo not supported" {- Tries to copy a key's content to a remote's annex. -} diff --git a/Remote/Web.hs b/Remote/Web.hs index 63963c530..3fea94531 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -49,7 +49,9 @@ downloadKey key file = get =<< getUrls key get [] = do warning "no known url" return False - get urls = anyM (`Url.download` file) urls + get urls = do + showOutput -- make way for download progress bar + liftIO $ anyM (`Url.download` file) urls uploadKey :: Key -> Annex Bool uploadKey _ = do diff --git a/Utility/Ssh.hs b/Utility/Ssh.hs deleted file mode 100644 index 34e4390f6..000000000 --- a/Utility/Ssh.hs +++ /dev/null @@ -1,67 +0,0 @@ -{- git-annex remote access with ssh - - - - Copyright 2011 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Utility.Ssh where - -import Control.Monad.State (liftIO) - -import qualified Git -import Utility.SafeCommand -import Types -import Config -import Annex.UUID - -{- Generates parameters to ssh to a repository's host and run a command. - - Caller is responsible for doing any neccessary shellEscaping of the - - passed command. -} -sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam] -sshToRepo repo sshcmd = do - s <- getConfig repo "ssh-options" "" - let sshoptions = map Param (words s) - let sshport = case Git.urlPort repo of - Nothing -> [] - Just p -> [Param "-p", Param (show p)] - let sshhost = Param $ Git.urlHostUser repo - return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd - -{- Generates parameters to run a git-annex-shell command on a remote - - repository. -} -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 - uuid <- getRepoUUID r - sshparams <- sshToRepo r [Param $ sshcmd uuid ] - return $ Just ("ssh", sshparams) - | otherwise = return Nothing - where - dir = Git.workTree r - shellcmd = "git-annex-shell" - shellopts = Param command : File dir : params - sshcmd uuid = unwords $ - shellcmd : (map shellEscape $ toCommand shellopts) ++ - uuidcheck uuid - uuidcheck uuid - | null uuid = [] - | otherwise = ["--uuid", uuid] - -{- Uses a supplied function (such as boolSystem) 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 diff --git a/Utility/Url.hs b/Utility/Url.hs index 6ddeecc14..b5f5b78c0 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -12,13 +12,10 @@ module Utility.Url ( ) where import Control.Applicative -import Control.Monad.State (liftIO) import qualified Network.Browser as Browser import Network.HTTP import Network.URI -import Types -import Messages import Utility.SafeCommand import Utility @@ -38,13 +35,12 @@ exists url = {- Used to download large files, such as the contents of keys. - Uses wget or curl program for its progress bar. (Wget has a better one, - so is preferred.) -} -download :: URLString -> FilePath -> Annex Bool +download :: URLString -> FilePath -> IO Bool download url file = do - showOutput -- make way for program's progress bar - e <- liftIO $ inPath "wget" + e <- inPath "wget" if e then - liftIO $ boolSystem "wget" + boolSystem "wget" [Params "-c -O", File file, File url] else -- Uses the -# progress display, because the normal @@ -52,7 +48,7 @@ download url file = do -- the remainder to download as the whole file, -- and not indicating how much percent was -- downloaded before the resume. - liftIO $ boolSystem "curl" + boolSystem "curl" [Params "-L -C - -# -o", File file, File url] {- Downloads a small file. -} -- cgit v1.2.3