summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
Diffstat (limited to 'Remote')
-rw-r--r--Remote/GCrypt.hs101
-rw-r--r--Remote/Rsync.hs63
2 files changed, 100 insertions, 64 deletions
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 396cb367e..2ff137f57 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -28,6 +28,9 @@ import Remote.Helper.Encryptable
import Utility.Metered
import Crypto
import Annex.UUID
+import Annex.Ssh
+import qualified Remote.Rsync
+import Utility.Rsync
remote :: RemoteType
remote = RemoteType {
@@ -52,33 +55,47 @@ gen gcryptr u c gc = do
gen' r'' u c gc
gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
-gen' r u c gc = new <$> remoteCost gc defcst
- where
- defcst = if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost
- new cst = encryptableRemote c
- (store this)
- (retrieve this)
+gen' r u c gc = do
+ cst <- remoteCost gc $
+ if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost
+ (rsynctransport, rsyncurl) <- rsyncTransport r
+ let rsyncopts = Remote.Rsync.genRsyncOpts c gc rsynctransport rsyncurl
+ let this = Remote
+ { uuid = u
+ , cost = cst
+ , name = Git.repoDescribe r
+ , storeKey = \_ _ _ -> noCrypto
+ , retrieveKeyFile = \_ _ _ _ -> noCrypto
+ , retrieveKeyFileCheap = \_ _ -> return False
+ , removeKey = remove this rsyncopts
+ , hasKey = checkPresent this rsyncopts
+ , hasKeyCheap = repoCheap r
+ , whereisKey = Nothing
+ , config = M.empty
+ , localpath = localpathCalc r
+ , repo = r
+ , gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }
+ , readonly = Git.repoIsHttp r
+ , globallyAvailable = globallyAvailableCalc r
+ , remotetype = remote
+ }
+ return $ encryptableRemote c
+ (store this rsyncopts)
+ (retrieve this rsyncopts)
this
- where
- this = Remote
- { uuid = u
- , cost = cst
- , name = Git.repoDescribe r
- , storeKey = \_ _ _ -> noCrypto
- , retrieveKeyFile = \_ _ _ _ -> noCrypto
- , retrieveKeyFileCheap = \_ _ -> return False
- , removeKey = remove this
- , hasKey = checkPresent this
- , hasKeyCheap = repoCheap r
- , whereisKey = Nothing
- , config = M.empty
- , localpath = localpathCalc r
- , repo = r
- , gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }
- , readonly = Git.repoIsHttp r
- , globallyAvailable = globallyAvailableCalc r
- , remotetype = remote
- }
+
+rsyncTransport :: Git.Repo -> Annex ([CommandParam], String)
+rsyncTransport r
+ | "ssh://" `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length "ssh://") loc
+ | "//:" `isInfixOf` loc = othertransport
+ | ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc
+ | otherwise = othertransport
+ where
+ loc = Git.repoLocation r
+ sshtransport (host, path) = do
+ opts <- sshCachingOptions (host, Nothing) []
+ return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ path)
+ othertransport = return ([], loc)
noCrypto :: Annex a
noCrypto = error "cannot use gcrypt remote without encryption enabled"
@@ -131,28 +148,29 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c
then return (c', u)
else error "uuid mismatch"
-store :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-store r (cipher, enck) k p
+store :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
+store r rsyncopts (cipher, enck) k p
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $
sendwith $ \meterupdate h -> do
createDirectoryIfMissing True $ parentDir dest
readBytes (meteredWriteFile meterupdate dest) h
return True
- | Git.repoIsSsh (repo r) = sendwith $ \meterupdate h -> undefined
+ | Git.repoIsSsh (repo r) = Remote.Rsync.storeEncrypted rsyncopts gpgopts (cipher, enck) k p
| otherwise = unsupportedUrl
where
+ gpgopts = getGpgEncParams r
dest = gCryptLocation r enck
sendwith a = metered (Just p) k $ \meterupdate ->
Annex.Content.sendAnnex k noop $ \src ->
liftIO $ catchBoolIO $
- encrypt (getGpgEncParams r) cipher (feedFile src) (a meterupdate)
+ encrypt gpgopts cipher (feedFile src) (a meterupdate)
-retrieve :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
-retrieve r (cipher, enck) k d p
+retrieve :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
+retrieve r rsyncopts (cipher, enck) k d p
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
retrievewith $ L.readFile src
return True
- | Git.repoIsSsh (repo r) = undefined
+ | Git.repoIsSsh (repo r) = Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p
| otherwise = unsupportedUrl
where
src = gCryptLocation r enck
@@ -161,26 +179,29 @@ retrieve r (cipher, enck) k d p
decrypt cipher (feedBytes b)
(readBytes $ meteredWriteFile meterupdate d)
-remove :: Remote -> Key -> Annex Bool
-remove r k
+remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
+remove r rsyncopts k
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
liftIO $ removeDirectoryRecursive (parentDir dest)
return True
- | Git.repoIsSsh (repo r) = undefined
+ | Git.repoIsSsh (repo r) = Remote.Rsync.remove rsyncopts k
| otherwise = unsupportedUrl
where
dest = gCryptLocation r k
-checkPresent :: Remote -> Key -> Annex (Either String Bool)
-checkPresent r k
+checkPresent :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex (Either String Bool)
+checkPresent r rsyncopts k
| not $ Git.repoIsUrl (repo r) =
guardUsable (repo r) unknown $
liftIO $ catchDefaultIO unknown $
Right <$> doesFileExist (gCryptLocation r k)
- | Git.repoIsSsh (repo r) = undefined
+ | Git.repoIsSsh (repo r) = Remote.Rsync.checkPresent (repo r) rsyncopts k
| otherwise = unsupportedUrl
where
unknown = Left $ "unable to check " ++ Git.repoDescribe (repo r) ++ show (repo r)
+{- Annexed objects are stored directly under the top of the gcrypt repo
+ - (not in annex/objects), and are hashed using lower-case directories for max
+ - portability. -}
gCryptLocation :: Remote -> Key -> FilePath
-gCryptLocation r key = Git.repoLocation (repo r) </> annexLocation key hashDirLower
+gCryptLocation r key = Git.repoLocation (repo r) </> keyPath key hashDirLower
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 0887877e9..b328f6560 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -7,7 +7,16 @@
{-# LANGUAGE CPP #-}
-module Remote.Rsync (remote) where
+module Remote.Rsync (
+ remote,
+ storeEncrypted,
+ retrieveEncrypted,
+ remove,
+ checkPresent,
+ withRsyncScratchDir,
+ genRsyncOpts,
+ RsyncOpts
+) where
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
@@ -52,9 +61,10 @@ remote = RemoteType {
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
cst <- remoteCost gc expensiveRemoteCost
- (transport, url) <- rsyncTransport
- let o = RsyncOpts url (transport ++ opts) escape
- islocal = rsyncUrlIsPath $ rsyncUrl o
+ (transport, url) <- rsyncTransport gc $
+ fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
+ let o = genRsyncOpts c gc transport url
+ let islocal = rsyncUrlIsPath $ rsyncUrl o
return $ encryptableRemote c
(storeEncrypted o $ getGpgEncParams (c,gc))
(retrieveEncrypted o)
@@ -79,6 +89,9 @@ gen r u c gc = do
, globallyAvailable = not $ islocal
, remotetype = remote
}
+
+genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> [CommandParam] -> RsyncUrl -> RsyncOpts
+genRsyncOpts c gc transport url = RsyncOpts url (transport ++ opts) escape
where
opts = map Param $ filter safe $ remoteAnnexRsyncOptions gc
escape = M.lookup "shellescape" c /= Just "no"
@@ -89,28 +102,30 @@ gen r u c gc = do
| opt == "--delete" = False
| opt == "--delete-excluded" = False
| otherwise = True
- rawurl = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
+
+rsyncTransport :: RemoteGitConfig -> RsyncUrl -> Annex ([CommandParam], RsyncUrl)
+rsyncTransport gc rawurl
+ | rsyncUrlIsShell rawurl =
+ (\rsh -> return (rsyncShell rsh, resturl)) =<<
+ case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
+ "ssh":sshopts -> do
+ let (port, sshopts') = sshReadPort sshopts
+ host = takeWhile (/=':') resturl
+ -- Connection caching
+ (Param "ssh":) <$> sshCachingOptions
+ (host, port)
+ (map Param $ loginopt ++ sshopts')
+ "rsh":rshopts -> return $ map Param $ "rsh" :
+ loginopt ++ rshopts
+ rsh -> error $ "Unknown Rsync transport: "
+ ++ unwords rsh
+ | otherwise = return ([], rawurl)
+ where
(login,resturl) = case separate (=='@') rawurl of
- (h, "") -> (Nothing, h)
- (l, h) -> (Just l, h)
+ (h, "") -> (Nothing, h)
+ (l, h) -> (Just l, h)
loginopt = maybe [] (\l -> ["-l",l]) login
- fromNull as xs | null xs = as
- | otherwise = xs
- rsyncTransport = if rsyncUrlIsShell rawurl
- then (\rsh -> return (rsyncShell rsh, resturl)) =<<
- case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
- "ssh":sshopts -> do
- let (port, sshopts') = sshReadPort sshopts
- host = takeWhile (/=':') resturl
- -- Connection caching
- (Param "ssh":) <$> sshCachingOptions
- (host, port)
- (map Param $ loginopt ++ sshopts')
- "rsh":rshopts -> return $ map Param $ "rsh" :
- loginopt ++ rshopts
- rsh -> error $ "Unknown Rsync transport: "
- ++ unwords rsh
- else return ([], rawurl)
+ fromNull as xs = if null xs then as else xs
rsyncSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
rsyncSetup mu c = do
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-29 07:16:01 +0000