summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant/MakeRemote.hs14
-rw-r--r--Command/EnableRemote.hs4
-rw-r--r--Command/InitRemote.hs17
-rw-r--r--Git/GCrypt.hs27
-rw-r--r--Remote/Bup.hs9
-rw-r--r--Remote/Directory.hs8
-rw-r--r--Remote/GCrypt.hs164
-rw-r--r--Remote/Git.hs70
-rw-r--r--Remote/Glacier.hs12
-rw-r--r--Remote/Helper/Git.hs30
-rw-r--r--Remote/Hook.hs8
-rw-r--r--Remote/List.hs2
-rw-r--r--Remote/Rsync.hs8
-rw-r--r--Remote/S3.hs12
-rw-r--r--Remote/WebDAV.hs9
-rw-r--r--Types/Crypto.hs2
-rw-r--r--Types/Remote.hs2
17 files changed, 306 insertions, 92 deletions
diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs
index e26d6057a..fa662babd 100644
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@@ -68,8 +68,8 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Command.InitRemote.findExisting name
where
go Nothing = setupSpecialRemote name Rsync.remote config
- =<< Command.InitRemote.generateNew name
- go (Just v) = setupSpecialRemote name Rsync.remote config v
+ (Nothing, Command.InitRemote.newConfig name)
+ go (Just (u, c)) = setupSpecialRemote name Rsync.remote config (Just u, c)
config = M.fromList
[ ("encryption", "shared")
, ("rsyncurl", location)
@@ -89,7 +89,7 @@ initSpecialRemote name remotetype config = go 0
r <- Command.InitRemote.findExisting fullname
case r of
Nothing -> setupSpecialRemote fullname remotetype config
- =<< Command.InitRemote.generateNew fullname
+ (Nothing, Command.InitRemote.newConfig fullname)
Just _ -> go (n + 1)
{- Enables an existing special remote. -}
@@ -98,15 +98,15 @@ enableSpecialRemote name remotetype config = do
r <- Command.InitRemote.findExisting name
case r of
Nothing -> error $ "Cannot find a special remote named " ++ name
- Just v -> setupSpecialRemote name remotetype config v
+ Just (u, c) -> setupSpecialRemote name remotetype config (Just u, c)
-setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (UUID, R.RemoteConfig) -> Annex RemoteName
-setupSpecialRemote name remotetype config (u, c) = do
+setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
+setupSpecialRemote name remotetype config (mu, c) = do
{- Currently, only 'weak' ciphers can be generated from the
- assistant, because otherwise GnuPG may block once the entropy
- pool is drained, and as of now there's no way to tell the user
- to perform IO actions to refill the pool. -}
- c' <- R.setup remotetype u $
+ (c', u) <- R.setup remotetype mu $
M.insert "highRandomQuality" "false" $ M.union config c
describeUUID u name
configSet u c'
diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs
index ea606c284..977c80487 100644
--- a/Command/EnableRemote.hs
+++ b/Command/EnableRemote.hs
@@ -47,8 +47,8 @@ unknownNameError prefix = do
perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do
- c' <- R.setup t u c
- next $ cleanup u c'
+ (c', u') <- R.setup t (Just u) c
+ next $ cleanup u' c'
cleanup :: UUID -> R.RemoteConfig -> CommandCleanup
cleanup u c = do
diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs
index 684a2cc91..5a240f800 100644
--- a/Command/InitRemote.hs
+++ b/Command/InitRemote.hs
@@ -14,7 +14,6 @@ import Command
import qualified Remote
import qualified Logs.Remote
import qualified Types.Remote as R
-import Annex.UUID
import Logs.UUID
import Logs.Trust
@@ -34,18 +33,18 @@ start (name:ws) = ifM (isJust <$> findExisting name)
( error $ "There is already a special remote named \"" ++ name ++
"\". (Use enableremote to enable an existing special remote.)"
, do
- (u, c) <- generateNew name
+ let c = newConfig name
t <- findType config
showStart "initremote" name
- next $ perform t u name $ M.union config c
+ next $ perform t name $ M.union config c
)
where
config = Logs.Remote.keyValToConfig ws
-perform :: RemoteType -> UUID -> String -> R.RemoteConfig -> CommandPerform
-perform t u name c = do
- c' <- R.setup t u c
+perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
+perform t name c = do
+ (c', u) <- R.setup t Nothing c
next $ cleanup u name c'
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup
@@ -63,10 +62,8 @@ findExisting name = do
<$> Logs.Remote.readRemoteLog
return $ headMaybe matches
-generateNew :: String -> Annex (UUID, R.RemoteConfig)
-generateNew name = do
- uuid <- liftIO genUUID
- return (uuid, M.singleton nameKey name)
+newConfig :: String -> R.RemoteConfig
+newConfig name = M.singleton nameKey name
findByName :: String -> M.Map UUID R.RemoteConfig -> [(UUID, R.RemoteConfig)]
findByName n = filter (matching . snd) . M.toList
diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs
index e22bd74a2..18d8fa771 100644
--- a/Git/GCrypt.hs
+++ b/Git/GCrypt.hs
@@ -44,23 +44,25 @@ encryptedRepo baserepo = go
go _ = notencrypted
notencrypted = error "not a gcrypt encrypted repository"
+type RemoteName = String
+
{- gcrypt gives each encrypted repository a uique gcrypt-id,
- which is stored in the repository (in encrypted form)
- and cached in a per-remote gcrypt-id configuration setting. -}
-remoteRepoId :: Repo -> Repo -> Maybe String
+remoteRepoId :: Repo -> Maybe RemoteName -> Maybe String
remoteRepoId = getRemoteConfig "gcrypt-id"
-getRemoteConfig :: String -> Repo -> Repo -> Maybe String
-getRemoteConfig field baserepo remote = do
- name <- remoteName remote
- Config.getMaybe (remoteConfigKey field name) baserepo
+getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String
+getRemoteConfig field repo remotename = do
+ n <- remotename
+ Config.getMaybe (remoteConfigKey field n) repo
{- Gpg keys that the remote is encrypted for.
- If empty, gcrypt uses --default-recipient-self -}
-particiantList :: Maybe Repo -> Repo -> Repo -> KeyIds
-particiantList globalconfigrepo baserepo remote = KeyIds $ parse $ firstJust
- [ getRemoteConfig "participants" baserepo remote
- , Config.getMaybe defaultkey baserepo
+getParticiantList :: Maybe Repo -> Repo -> Maybe RemoteName -> KeyIds
+getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust
+ [ getRemoteConfig "gcrypt-participants" repo remotename
+ , Config.getMaybe defaultkey repo
, Config.getMaybe defaultkey =<< globalconfigrepo
]
where
@@ -69,5 +71,8 @@ particiantList globalconfigrepo baserepo remote = KeyIds $ parse $ firstJust
parse (Just l) = words l
parse Nothing = []
-remoteConfigKey :: String -> String -> String
-remoteConfigKey key field = "remote." ++ field ++ "." ++ key
+remoteParticipantConfigKey :: RemoteName -> String
+remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants"
+
+remoteConfigKey :: String -> RemoteName -> String
+remoteConfigKey key remotename = "remote." ++ remotename ++ "." ++ key
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 9ef335218..09e89e38f 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -29,6 +29,7 @@ import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Digest.Pure.SHA
import Utility.UserInfo
import Annex.Content
+import Annex.UUID
import Utility.Metered
type BupRepo = String
@@ -78,8 +79,10 @@ gen r u c gc = do
where
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
-bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
-bupSetup u c = do
+bupSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+bupSetup mu c = do
+ u <- maybe (liftIO genUUID) return mu
+
-- verify configuration is sane
let buprepo = fromMaybe (error "Specify buprepo=") $
M.lookup "buprepo" c
@@ -96,7 +99,7 @@ bupSetup u c = do
-- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c' "buprepo" buprepo
- return c'
+ return (c', u)
bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam]
bupParams command buprepo params =
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 0b3ce443b..8eb317418 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -26,6 +26,7 @@ import Remote.Helper.Encryptable
import Remote.Helper.Chunked
import Crypto
import Annex.Content
+import Annex.UUID
import Utility.Metered
remote :: RemoteType
@@ -65,8 +66,9 @@ gen r u c gc = do
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
-directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
-directorySetup u c = do
+directorySetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+directorySetup mu c = do
+ u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let dir = fromMaybe (error "Specify directory=") $
M.lookup "directory" c
@@ -78,7 +80,7 @@ directorySetup u c = do
-- The directory is stored in git config, not in this remote's
-- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c' "directory" absdir
- return $ M.delete "directory" c'
+ return (M.delete "directory" c', u)
{- Locations to try to access a given Key in the Directory.
- We try more than since we used to write to different hash directories. -}
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
new file mode 100644
index 000000000..f839f6647
--- /dev/null
+++ b/Remote/GCrypt.hs
@@ -0,0 +1,164 @@
+{- git remotes encrypted using git-remote-gcrypt
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.GCrypt (remote, gen) where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Types.Remote
+import Types.GitConfig
+import Types.Crypto
+import qualified Git
+import qualified Git.Command
+import qualified Git.Config
+import qualified Git.GCrypt
+import qualified Git.Types as Git ()
+import qualified Annex.Branch
+import qualified Annex.Content
+import Config
+import Config.Cost
+import Remote.Helper.Git
+import Remote.Helper.Encryptable
+import Utility.Metered
+import Crypto
+import Annex.UUID
+
+remote :: RemoteType
+remote = RemoteType {
+ typename = "gcrypt",
+ -- Remote.Git takes care of enumerating gcrypt remotes too,
+ -- and will call our gen on them.
+ enumerate = return [],
+ generate = gen,
+ setup = gCryptSetup
+}
+
+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
+gen gcryptr u c gc = do
+ g <- gitRepo
+ -- get underlying git repo with real path, not gcrypt path
+ r <- liftIO $ Git.GCrypt.encryptedRepo g gcryptr
+ let r' = r { Git.remoteName = Git.remoteName gcryptr }
+ -- read config of underlying repo if it's local
+ r'' <- if Git.repoIsLocalUnknown r'
+ then liftIO $ catchDefaultIO r' $ Git.Config.read r'
+ else return r'
+ 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)
+ this
+ where
+ this = Remote
+ { uuid = u
+ , cost = cst
+ , name = Git.repoDescribe r
+ , storeKey = \_ _ _ -> noCrypto
+ , retrieveKeyFile = \_ _ _ _ -> noCrypto
+ , retrieveKeyFileCheap = \_ _ -> return False
+ , removeKey = remove
+ , 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
+ }
+
+noCrypto :: Annex a
+noCrypto = error "cannot use gcrypt remote without encryption enabled"
+
+gCryptSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+gCryptSetup mu c = go $ M.lookup "gitrepo" c
+ where
+ remotename = fromJust (M.lookup "name" c)
+ go Nothing = error "Specify gitrepo="
+ go (Just gitrepo) = do
+ c' <- encryptionSetup c
+ inRepo $ Git.Command.run
+ [ Params "remote add"
+ , Param remotename
+ , Param $ Git.GCrypt.urlPrefix ++ gitrepo
+ ]
+
+ {- Configure gcrypt to use the same list of keyids that
+ - were passed to initremote, unless shared encryption
+ - was used. -}
+ case extractCipher c' of
+ Nothing -> noCrypto
+ Just (EncryptedCipher _ _ (KeyIds { keyIds = ks})) ->
+ setConfig (ConfigKey $ Git.GCrypt.remoteParticipantConfigKey remotename) (unwords ks)
+ _ -> noop
+
+ {- Run a git fetch and a push to the git repo in order to get
+ - its gcrypt-id set up, so that later git annex commands
+ - will use the remote as a ggcrypt remote. The fetch is
+ - needed if the repo already exists; the push is needed
+ - if the repo has not yet been initialized by gcrypt. -}
+ void $ inRepo $ Git.Command.runBool
+ [ Param "fetch"
+ , Param remotename
+ ]
+ void $ inRepo $ Git.Command.runBool
+ [ Param "push"
+ , Param remotename
+ , Param $ show $ Annex.Branch.fullname
+ ]
+ g <- inRepo Git.Config.reRead
+ case Git.GCrypt.remoteRepoId g (Just remotename) of
+ Nothing -> error "unable to determine gcrypt-id of remote"
+ Just v -> do
+ let u = genUUIDInNameSpace gCryptNameSpace v
+ if Just u == mu || mu == Nothing
+ then return (c', u)
+ else error "uuid mismatch"
+
+store :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
+store r (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 $ \h -> undefined
+ | otherwise = error "storing on non-ssh remote repo not supported"
+ where
+ 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)
+
+retrieve :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
+retrieve r (cipher, enck) k d p = undefined
+
+remove :: Key -> Annex Bool
+remove k = undefined
+
+checkPresent :: Remote -> Key -> Annex (Either String Bool)
+checkPresent r k
+ | not $ Git.repoIsUrl (repo r) =
+ guardUsable (repo r) unknown $
+ liftIO $ catchDefaultIO unknown $
+ Right <$> doesFileExist (gCryptLocation r k)
+ | Git.repoIsSsh (repo r) = undefined
+ | otherwise = error "storing on non-ssh remote repo not supported"
+ where
+ unknown = Left $ "unable to check " ++ Git.repoDescribe (repo r) ++ show (repo r)
+
+gCryptLocation :: Remote -> Key -> FilePath
+gCryptLocation r key = Git.repoLocation (repo r) </> annexLocation key hashDirLower
diff --git a/Remote/Git.hs b/Remote/Git.hs
index b3f64bfb8..93c923853 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -13,9 +13,6 @@ 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
@@ -47,10 +44,14 @@ import Utility.Metered
#ifndef mingw32_HOST_OS
import Utility.CopyFile
#endif
+import Remote.Helper.Git
+import qualified Remote.GCrypt
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 {
@@ -91,11 +92,10 @@ 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 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
@@ -112,14 +112,12 @@ gen r u _ gc = go <$> remoteCost gc defcst
, hasKeyCheap = repoCheap r
, whereisKey = Nothing
, config = M.empty
- , localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
- then Just $ Git.repoPath r
- else Nothing
+ , 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
}
@@ -131,13 +129,6 @@ repoAvail r
| 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
@@ -154,8 +145,9 @@ tryGitConfigRead r
headers <- getHttpHeaders
store $ geturlconfig headers
| Git.GCrypt.isEncrypted r = do
+ -- Generate a UUID from the gcrypt-id
g <- gitRepo
- case Git.GCrypt.remoteRepoId g r of
+ case Git.GCrypt.remoteRepoId g (Git.remoteName r) of
Nothing -> return r
Just v -> store $ liftIO $ setUUID r $
genUUIDInNameSpace gCryptNameSpace v
@@ -261,17 +253,6 @@ inAnnex r key
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
-
keyUrls :: Git.Repo -> Key -> [String]
keyUrls r key = map tourl locs
where
@@ -415,15 +396,16 @@ 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
- )
+{- 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. -}
@@ -456,6 +438,16 @@ rsyncOrCopyFile rsyncparams src dest p =
dorsync = rsyncHelper (Just p) $
rsyncparams ++ [File src, File dest]
+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
+ )
+
{- 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]
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index d81066415..f351c66e9 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -25,6 +25,7 @@ import Creds
import Utility.Metered
import qualified Annex
import Annex.Content
+import Annex.UUID
import System.Process
@@ -67,13 +68,18 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
remotetype = remote
}
-glacierSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
-glacierSetup u c = do
+glacierSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+glacierSetup mu c = do
+ u <- maybe (liftIO genUUID) return mu
+ glacierSetup' u c
+glacierSetup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+glacierSetup' u c = do
c' <- encryptionSetup c
let fullconfig = c' `M.union` defaults
genVault fullconfig u
gitConfigSpecialRemote u fullconfig "glacier" "true"
- setRemoteCredPair fullconfig (AWS.creds u)
+ c'' <- setRemoteCredPair fullconfig (AWS.creds u)
+ return (c'', u)
where
remotename = fromJust (M.lookup "name" c)
defvault = remotename ++ "-" ++ fromUUID u
diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs
new file mode 100644
index 000000000..7c24ff2e7
--- /dev/null
+++ b/Remote/Helper/Git.hs
@@ -0,0 +1,30 @@
+{- Utilities for git remotes.
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Git where
+
+import Common.Annex
+import qualified Git
+
+repoCheap :: Git.Repo -> Bool
+repoCheap = not . Git.repoIsUrl
+
+localpathCalc :: Git.Repo -> Maybe FilePath
+localpathCalc r = if globallyAvailableCalc r
+ then Nothing
+ else Just $ Git.repoPath r
+
+globallyAvailableCalc :: Git.Repo -> Bool
+globallyAvailableCalc r = not $
+ Git.repoIsLocal r || Git.repoIsLocalUnknown r
+
+{- 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
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 338d95ce7..6a8e44ab5 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -18,6 +18,7 @@ import qualified Git
import Config
import Config.Cost
import Annex.Content
+import Annex.UUID
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
@@ -62,13 +63,14 @@ gen r u c gc = do
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
-hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
-hookSetup u c = do
+hookSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+hookSetup mu c = do
+ u <- maybe (liftIO genUUID) return mu
let hooktype = fromMaybe (error "Specify hooktype=") $
M.lookup "hooktype" c
c' <- encryptionSetup c
gitConfigSpecialRemote u c' "hooktype" hooktype
- return c'
+ return (c', u)
hookEnv :: Action -> Key -> Maybe FilePath -> IO (Maybe [(String, String)])
hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv)
diff --git a/Remote/List.hs b/Remote/List.hs
index 0651d83aa..c106e9ad9 100644
--- a/Remote/List.hs
+++ b/Remote/List.hs
@@ -22,6 +22,7 @@ import qualified Git
import qualified Git.Config
import qualified Remote.Git
+import qualified Remote.GCrypt
#ifdef WITH_S3
import qualified Remote.S3
#endif
@@ -38,6 +39,7 @@ import qualified Remote.Hook
remoteTypes :: [RemoteType]
remoteTypes =
[ Remote.Git.remote
+ , Remote.GCrypt.remote
#ifdef WITH_S3
, Remote.S3.remote
#endif
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 4ad0fdadd..0887877e9 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -23,6 +23,7 @@ import qualified Git
import Config
import Config.Cost
import Annex.Content
+import Annex.UUID
import Annex.Ssh
import Remote.Helper.Special
import Remote.Helper.Encryptable
@@ -111,8 +112,9 @@ gen r u c gc = do
++ unwords rsh
else return ([], rawurl)
-rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
-rsyncSetup u c = do
+rsyncSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+rsyncSetup mu c = do
+ u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let url = fromMaybe (error "Specify rsyncurl=") $
M.lookup "rsyncurl" c
@@ -121,7 +123,7 @@ rsyncSetup u c = do
-- The rsyncurl is stored in git config, not only in this remote's
-- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c' "rsyncurl" url
- return c'
+ return (c', u)
rsyncEscape :: RsyncOpts -> String -> String
rsyncEscape o s
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 814dd3a23..4f04bb7af 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -30,6 +30,7 @@ import Crypto
import Creds
import Utility.Metered
import Annex.Content
+import Annex.UUID
import Logs.Web
type Bucket = String
@@ -70,8 +71,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
remotetype = remote
}
-s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
-s3Setup u c = if isIA c then archiveorg else defaulthost
+s3Setup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+s3Setup mu c = do
+ u <- maybe (liftIO genUUID) return mu
+ s3Setup' u c
+s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+s3Setup' u c = if isIA c then archiveorg else defaulthost
where
remotename = fromJust (M.lookup "name" c)
defbucket = remotename ++ "-" ++ fromUUID u
@@ -85,7 +90,8 @@ s3Setup u c = if isIA c then archiveorg else defaulthost
use fullconfig = do
gitConfigSpecialRemote u fullconfig "s3" "true"
- setRemoteCredPair fullconfig (AWS.creds u)
+ c' <- setRemoteCredPair fullconfig (AWS.creds u)
+ return (c', u)
defaulthost = do
c' <- encryptionSetup c
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index c444a7f2b..7c1949047 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -32,6 +32,7 @@ import Crypto
import Creds
import Utility.Metered
import Annex.Content
+import Annex.UUID
type DavUrl = String
type DavUser = B8.ByteString
@@ -73,15 +74,17 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
remotetype = remote
}
-webdavSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
-webdavSetup u c = do
+webdavSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+webdavSetup mu c = do
+ u <- maybe (liftIO genUUID) return mu
let url = fromMaybe (error "Specify url=") $
M.lookup "url" c
c' <- encryptionSetup c
creds <- getCreds c' u
testDav url creds
gitConfigSpecialRemote u c' "webdav" "true"
- setRemoteCredPair c' (davCreds u)
+ c'' <- setRemoteCredPair c' (davCreds u)
+ return (c'', u)
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r k _f p = metered (Just p) k $ \meterupdate ->
diff --git a/Types/Crypto.hs b/Types/Crypto.hs
index 6d4131129..1a9a7774a 100644
--- a/Types/Crypto.hs
+++ b/Types/Crypto.hs
@@ -70,4 +70,4 @@ calcMac mac = case mac of
HmacSha384 -> showDigest $* hmacSha384
HmacSha512 -> showDigest $* hmacSha512
where
- ($*) g f x y = g $ f x y
+ ($*) g f x y = g $ f x y
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 8492be06d..6c0f89346 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -31,7 +31,7 @@ data RemoteTypeA a = RemoteType {
-- generates a remote of this type
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (RemoteA a),
-- initializes or changes a remote
- setup :: UUID -> RemoteConfig -> a RemoteConfig
+ setup :: Maybe UUID -> RemoteConfig -> a (RemoteConfig, UUID)
}
instance Eq (RemoteTypeA a) where
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-30 22:01:47 +0000