type based git config handling for remotes

Still a couple of places that use git config ad-hoc, but this is most of it
done.
This commit is contained in:
Joey Hess 2013-01-01 13:52:47 -04:00
parent 16b2454680
commit 4008590c68
33 changed files with 341 additions and 299 deletions

View file

@ -28,8 +28,8 @@ module Annex (
gitRepo,
inRepo,
fromRepo,
getConfig,
changeConfig,
getGitConfig,
changeGitConfig,
changeGitRepo,
) where
@ -46,7 +46,7 @@ import Git.CheckAttr
import Git.SharedRepository
import qualified Git.Queue
import Types.Backend
import Types.Config
import Types.GitConfig
import qualified Types.Remote
import Types.Crypto
import Types.BranchState
@ -92,7 +92,7 @@ type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> Fi
-- internal state storage
data AnnexState = AnnexState
{ repo :: Git.Repo
, config :: Config
, gitconfig :: GitConfig
, backends :: [BackendA Annex]
, remotes :: [Types.Remote.RemoteA Annex]
, output :: MessageState
@ -122,7 +122,7 @@ data AnnexState = AnnexState
newState :: Git.Repo -> AnnexState
newState gitrepo = AnnexState
{ repo = gitrepo
, config = extractConfig gitrepo
, gitconfig = extractGitConfig gitrepo
, backends = []
, remotes = []
, output = defaultMessageState
@ -202,17 +202,17 @@ inRepo a = liftIO . a =<< gitRepo
fromRepo :: (Git.Repo -> a) -> Annex a
fromRepo a = a <$> gitRepo
{- Gets the Config settings. -}
getConfig :: Annex Config
getConfig = getState config
{- Gets the GitConfig settings. -}
getGitConfig :: Annex GitConfig
getGitConfig = getState gitconfig
{- Modifies a Config setting. -}
changeConfig :: (Config -> Config) -> Annex ()
changeConfig a = changeState $ \s -> s { config = a (config s) }
{- Modifies a GitConfig setting. -}
changeGitConfig :: (GitConfig -> GitConfig) -> Annex ()
changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) }
{- Changing the git Repo data also involves re-extracting its Config. -}
{- Changing the git Repo data also involves re-extracting its GitConfig. -}
changeGitRepo :: Git.Repo -> Annex ()
changeGitRepo r = changeState $ \s -> s
{ repo = r
, config = extractConfig r
, gitconfig = extractGitConfig r
}

View file

@ -187,7 +187,7 @@ withTmp key action = do
- in a destination (or the annex) printing a warning if not. -}
checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
checkDiskSpace destination key alreadythere = do
reserve <- annexDiskReserve <$> Annex.getConfig
reserve <- annexDiskReserve <$> Annex.getGitConfig
free <- liftIO . getDiskFree =<< dir
force <- Annex.getState Annex.force
case (free, keySize key) of
@ -395,7 +395,7 @@ saveState :: Bool -> Annex ()
saveState nocommit = doSideAction $ do
Annex.Queue.flush
unless nocommit $
whenM (annexAlwaysCommit <$> Annex.getConfig) $
whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
Annex.Branch.commit "update"
{- Downloads content from any of a list of urls. -}

View file

@ -54,7 +54,7 @@ get = maybe new return =<< getState repoqueue
new :: Annex Git.Queue.Queue
new = do
q <- Git.Queue.new . annexQueueSize <$> getConfig
q <- Git.Queue.new . annexQueueSize <$> getGitConfig
store q
return q

View file

@ -59,7 +59,7 @@ sshInfo (host, port) = ifM caching
caching = return False
#else
caching = fromMaybe SysConfig.sshconnectioncaching
. annexSshCaching <$> Annex.getConfig
. annexSshCaching <$> Annex.getGitConfig
#endif
cacheParams :: FilePath -> [CommandParam]

View file

@ -9,6 +9,7 @@ module Annex.Version where
import Common.Annex
import Config
import qualified Annex
type Version = String
@ -25,10 +26,7 @@ versionField :: ConfigKey
versionField = annexConfig "version"
getVersion :: Annex (Maybe Version)
getVersion = handle <$> getConfig versionField ""
where
handle [] = Nothing
handle v = Just v
getVersion = annexVersion <$> Annex.getGitConfig
setVersion :: Annex ()
setVersion = setConfig versionField defaultVersion

View file

@ -17,7 +17,6 @@ import Logs.Trust
import qualified Remote
import qualified Types.Remote as Remote
import qualified Git
import Config
import Control.Concurrent.STM
import System.Posix.Types
@ -48,7 +47,7 @@ modifyDaemonStatus a = do
{- Returns a function that updates the lists of syncable remotes. -}
calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
calcSyncRemotes = do
rs <- filterM (repoSyncable . Remote.repo) =<<
rs <- filter (remoteAnnexSync . Remote.gitconfig) .
concat . Remote.byCost <$> Remote.enabledRemoteList
alive <- trustExclude DeadTrusted (map Remote.uuid rs)
let good r = Remote.uuid r `elem` alive

View file

@ -44,7 +44,7 @@ commitThread :: NamedThread
commitThread = NamedThread "Committer" $ do
delayadd <- liftAnnex $
maybe delayaddDefault (return . Just . Seconds)
=<< annexDelayAdd <$> Annex.getConfig
=<< annexDelayAdd <$> Annex.getGitConfig
runEvery (Seconds 1) <~> do
-- We already waited one second as a simple rate limiter.
-- Next, wait until at least one change is available for

View file

@ -19,7 +19,6 @@ import qualified Types.Remote as Remote
import Annex.UUID (getUUID)
import Logs.Remote
import Logs.Trust
import Config
import qualified Git
#ifdef WITH_XMPP
import Assistant.XMPP.Client
@ -146,9 +145,9 @@ repoList reposelector
unconfigured <- map snd . catMaybes . filter wantedremote
. map (findinfo m)
<$> (trustExclude DeadTrusted $ M.keys m)
unsyncable <- map Remote.uuid . filter wantedrepo <$>
(filterM (\r -> not <$> repoSyncable (Remote.repo r))
=<< Remote.enabledRemoteList)
unsyncable <- map Remote.uuid . filter wantedrepo .
filter (not . remoteAnnexSync . Remote.gitconfig)
<$> Remote.enabledRemoteList
return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
wantedrepo r
| Remote.readonly r = False
@ -189,6 +188,6 @@ getDisableSyncR = flipSync False
flipSync :: Bool -> UUID -> Handler ()
flipSync enable uuid = do
mremote <- runAnnex undefined $ snd <$> Remote.repoFromUUID uuid
mremote <- runAnnex undefined $ Remote.remoteFromUUID uuid
changeSyncable mremote enable
redirect RepositoriesR

View file

@ -15,12 +15,12 @@ import Assistant.DaemonStatus
import Assistant.MakeRemote (uniqueRemoteName)
import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
import qualified Remote
import qualified Types.Remote as Remote
import qualified Remote.List as Remote
import Logs.UUID
import Logs.Group
import Logs.PreferredContent
import Types.StandardGroups
import qualified Config
import qualified Git
import qualified Git.Command
import qualified Git.Config
@ -40,12 +40,12 @@ data RepoConfig = RepoConfig
}
deriving (Show)
getRepoConfig :: UUID -> Git.Repo -> Maybe Remote -> Annex RepoConfig
getRepoConfig uuid r mremote = RepoConfig
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
getRepoConfig uuid mremote = RepoConfig
<$> pure (T.pack $ maybe "here" Remote.name mremote)
<*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap)
<*> getrepogroup
<*> Config.repoSyncable r
<*> pure (maybe True (remoteAnnexSync . Remote.gitconfig) mremote)
where
getrepogroup = do
groups <- lookupGroups uuid
@ -113,8 +113,8 @@ getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
editForm :: Bool -> UUID -> Handler RepHtml
editForm new uuid = page "Configure repository" (Just Configuration) $ do
(repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid
curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo mremote
mremote <- lift $ runAnnex undefined $ Remote.remoteFromUUID uuid
curr <- lift $ runAnnex undefined $ getRepoConfig uuid mremote
lift $ checkarchivedirectory curr
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ editRepositoryAForm curr

View file

@ -44,7 +44,7 @@ orderedList = do
Just name | not (null name) ->
return [lookupBackendName name]
_ -> do
l' <- gen . annexBackends <$> Annex.getConfig
l' <- gen . annexBackends <$> Annex.getGitConfig
Annex.changeState $ \s -> s { Annex.backends = l' }
return l'
where

View file

@ -200,7 +200,7 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do
disk_size :: Stat
disk_size = stat "available local disk space" $ json id $ lift $
calcfree
<$> (annexDiskReserve <$> Annex.getConfig)
<$> (annexDiskReserve <$> Annex.getGitConfig)
<*> inRepo (getDiskFree . gitAnnexDir)
where
calcfree reserve (Just have) = unwords

View file

@ -72,8 +72,8 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
unwords (map Types.Remote.name s)
return l
available = filter (not . Remote.specialRemote)
<$> (filterM (repoSyncable . Types.Remote.repo)
=<< Remote.enabledRemoteList)
. filter (remoteAnnexSync . Types.Remote.gitconfig)
<$> Remote.enabledRemoteList
good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
fastest = fromMaybe [] . headMaybe . Remote.byCost

View file

@ -180,9 +180,9 @@ exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
- so will easily fit on even my lowest memory systems.
-}
bloomCapacity :: Annex Int
bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getConfig
bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getGitConfig
bloomAccuracy :: Annex Int
bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getConfig
bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getGitConfig
bloomBitsHashes :: Annex (Int, Int)
bloomBitsHashes = do
capacity <- bloomCapacity

View file

@ -16,6 +16,10 @@ import qualified Annex
type UnqualifiedConfigKey = String
data ConfigKey = ConfigKey String
{- Looks up a setting in git config. -}
getConfig :: ConfigKey -> String -> Annex String
getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def
{- Changes a git config setting in both internal state and .git/config -}
setConfig :: ConfigKey -> String -> Annex ()
setConfig (ConfigKey key) value = do
@ -27,16 +31,6 @@ unsetConfig :: ConfigKey -> Annex ()
unsetConfig (ConfigKey key) = inRepo $ Git.Command.run "config"
[Param "--unset", Param key]
{- Looks up a setting in git config. -}
getConfig :: ConfigKey -> String -> Annex String
getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def
{- Looks up a per-remote config setting in git config.
- Failing that, tries looking for a global config option. -}
getRemoteConfig :: Git.Repo -> UnqualifiedConfigKey -> String -> Annex String
getRemoteConfig r key def =
getConfig (remoteConfig r key) =<< getConfig (annexConfig key) def
{- A per-remote config setting in git config. -}
remoteConfig :: Git.Repo -> UnqualifiedConfigKey -> ConfigKey
remoteConfig r key = ConfigKey $
@ -46,16 +40,15 @@ remoteConfig r key = ConfigKey $
annexConfig :: UnqualifiedConfigKey -> ConfigKey
annexConfig key = ConfigKey $ "annex." ++ key
{- Calculates cost for a remote. Either the default, or as configured
{- Calculates cost for a remote. Either the specific default, or as configured
- by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
- is set and prints a number, that is used. -}
remoteCost :: Git.Repo -> Int -> Annex Int
remoteCost r def = do
cmd <- getRemoteConfig r "cost-command" ""
(fromMaybe def . readish) <$>
if not $ null cmd
then liftIO $ readProcess "sh" ["-c", cmd]
else getRemoteConfig r "cost" ""
remoteCost :: RemoteGitConfig -> Int -> Annex Int
remoteCost c def = case remoteAnnexCostCommand c of
Just cmd | not (null cmd) -> liftIO $
(fromMaybe def . readish) <$>
readProcess "sh" ["-c", cmd]
_ -> return $ fromMaybe def $ remoteAnnexCost c
cheapRemoteCost :: Int
cheapRemoteCost = 100
@ -81,38 +74,22 @@ prop_cost_sane = False `notElem`
, semiCheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost
]
{- Checks if a repo should be ignored. -}
repoNotIgnored :: Git.Repo -> Annex Bool
repoNotIgnored r = not . fromMaybe False . Git.Config.isTrue
<$> getRemoteConfig r "ignore" ""
{- Checks if a repo should be synced. -}
repoSyncable :: Git.Repo -> Annex Bool
repoSyncable r = fromMaybe True . Git.Config.isTrue
<$> getRemoteConfig r "sync" ""
{- Gets the trust level set for a remote in git config. -}
getTrustLevel :: Git.Repo -> Annex (Maybe String)
getTrustLevel r = fromRepo $ Git.Config.getMaybe key
where
(ConfigKey key) = remoteConfig r "trustlevel"
getNumCopies :: Maybe Int -> Annex Int
getNumCopies (Just v) = return v
getNumCopies Nothing = annexNumCopies <$> Annex.getConfig
getNumCopies Nothing = annexNumCopies <$> Annex.getGitConfig
isDirect :: Annex Bool
isDirect = annexDirect <$> Annex.getConfig
isDirect = annexDirect <$> Annex.getGitConfig
setDirect :: Bool -> Annex ()
setDirect b = do
setConfig (annexConfig "direct") $ if b then "true" else "false"
Annex.changeConfig $ \c -> c { annexDirect = b }
Annex.changeGitConfig $ \c -> c { annexDirect = b }
{- Gets the http headers to use. -}
getHttpHeaders :: Annex [String]
getHttpHeaders = do
v <- annexHttpHeadersCommand <$> Annex.getConfig
v <- annexHttpHeadersCommand <$> Annex.getGitConfig
case v of
Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
Nothing -> annexHttpHeaders <$> Annex.getConfig
Nothing -> annexHttpHeaders <$> Annex.getGitConfig

View file

@ -171,7 +171,7 @@ options = Option.common ++
] ++ Option.matcher
where
setnumcopies v = maybe noop
(\n -> Annex.changeConfig $ \c -> c { annexNumCopies = n })
(\n -> Annex.changeGitConfig $ \c -> c { annexNumCopies = n })
(readish v)
setgitconfig v = Annex.changeGitRepo =<< inRepo (Git.Config.store v)

View file

@ -28,7 +28,6 @@ import qualified Annex.Branch
import qualified Annex
import Logs.UUIDBased
import Remote.List
import Config
import qualified Types.Remote
{- Filename of trust.log. -}
@ -85,14 +84,14 @@ trustMapLoad = do
overrides <- Annex.getState Annex.forcetrust
logged <- trustMapRaw
configured <- M.fromList . catMaybes
<$> (mapM configuredtrust =<< remoteList)
<$> (map configuredtrust <$> remoteList)
let m = M.union overrides $ M.union configured logged
Annex.changeState $ \s -> s { Annex.trustmap = Just m }
return m
where
configuredtrust r = maybe Nothing (\l -> Just (Types.Remote.uuid r, l))
<$> maybe Nothing readTrustLevel
<$> getTrustLevel (Types.Remote.repo r)
configuredtrust r = (\l -> Just (Types.Remote.uuid r, l))
=<< readTrustLevel
=<< remoteAnnexTrustLevel (Types.Remote.gitconfig r)
{- Does not include forcetrust or git config values, just those from the
- log file. -}

View file

@ -27,7 +27,7 @@ module Remote (
byCost,
prettyPrintUUIDs,
prettyListUUIDs,
repoFromUUID,
remoteFromUUID,
remotesWithUUID,
remotesWithoutUUID,
keyLocations,
@ -53,7 +53,6 @@ import Logs.UUID
import Logs.Trust
import Logs.Location hiding (logStatus)
import Remote.List
import qualified Git
{- Map from UUIDs of Remotes to a calculated value. -}
remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)
@ -147,15 +146,12 @@ prettyListUUIDs uuids = do
where
n = finddescription m u
{- Gets the git repo associated with a UUID.
{- Gets the remote associated with a UUID.
- There's no associated remote when this is the UUID of the local repo. -}
repoFromUUID :: UUID -> Annex (Git.Repo, Maybe Remote)
repoFromUUID u = ifM ((==) u <$> getUUID)
( (,) <$> gitRepo <*> pure Nothing
, do
remote <- fromMaybe (error "Unknown UUID") . M.lookup u
<$> remoteMap id
return (repo remote, Just remote)
remoteFromUUID :: UUID -> Annex (Maybe Remote)
remoteFromUUID u = ifM ((==) u <$> getUUID)
( return Nothing
, Just . fromMaybe (error "Unknown UUID") . M.lookup u <$> remoteMap id
)
{- Filters a list of remotes to ones that have the listed uuids. -}

View file

@ -38,35 +38,41 @@ remote = RemoteType {
setup = bupSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u c = do
buprepo <- getRemoteConfig r "buprepo" (error "missing buprepo")
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
bupr <- liftIO $ bup2GitRemote buprepo
cst <- remoteCost gc $
if bupLocal buprepo
then semiCheapRemoteCost
else expensiveRemoteCost
(u', bupr') <- getBupUUID bupr u
let new = Remote
{ uuid = u'
, cost = cst
, name = Git.repoDescribe r
, storeKey = store new buprepo
, retrieveKeyFile = retrieve buprepo
, retrieveKeyFileCheap = retrieveCheap buprepo
, removeKey = remove
, hasKey = checkPresent r bupr'
, hasKeyCheap = bupLocal buprepo
, whereisKey = Nothing
, config = c
, repo = r
, gitconfig = gc
, localpath = if bupLocal buprepo && not (null buprepo)
then Just buprepo
else Nothing
, remotetype = remote
, readonly = False
}
return $ encryptableRemote c
(storeEncrypted r buprepo)
(storeEncrypted new buprepo)
(retrieveEncrypted buprepo)
Remote
{ uuid = u'
, cost = cst
, name = Git.repoDescribe r
, storeKey = store r buprepo
, retrieveKeyFile = retrieve buprepo
, retrieveKeyFileCheap = retrieveCheap buprepo
, removeKey = remove
, hasKey = checkPresent r bupr'
, hasKeyCheap = bupLocal buprepo
, whereisKey = Nothing
, config = c
, repo = r
, localpath = if bupLocal buprepo && not (null buprepo)
then Just buprepo
else Nothing
, remotetype = remote
, readonly = False
}
new
where
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
bupSetup u c = do
@ -106,21 +112,20 @@ pipeBup params inh outh = do
ExitSuccess -> return True
_ -> return False
bupSplitParams :: Git.Repo -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]
bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]
bupSplitParams r buprepo k src = do
o <- getRemoteConfig r "bup-split-options" ""
let os = map Param $ words o
let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r
showOutput -- make way for bup output
return $ bupParams "split" buprepo
(os ++ [Param "-n", Param (bupRef k)] ++ src)
store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store :: Remote -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r buprepo k _f _p = do
src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo k [File src]
liftIO $ boolSystem "bup" params
storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted :: Remote -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r buprepo (cipher, enck) k _p = do
src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo enck []

View file

@ -33,10 +33,9 @@ remote = RemoteType {
setup = directorySetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u c = do
dir <- getRemoteConfig r "directory" (error "missing directory")
cst <- remoteCost r cheapRemoteCost
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
cst <- remoteCost gc cheapRemoteCost
let chunksize = chunkSize c
return $ encryptableRemote c
(storeEncrypted dir chunksize)
@ -54,10 +53,13 @@ gen r u c = do
whereisKey = Nothing,
config = M.empty,
repo = r,
gitconfig = gc,
localpath = Just dir,
readonly = False,
remotetype = remote
}
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
directorySetup u c = do

View file

@ -19,6 +19,7 @@ import Utility.CopyFile
import Utility.Rsync
import Remote.Helper.Ssh
import Types.Remote
import Types.GitConfig
import qualified Git
import qualified Git.Config
import qualified Git.Construct
@ -73,10 +74,11 @@ list = do
- cached UUID value. -}
configRead :: Git.Repo -> Annex Git.Repo
configRead r = do
notignored <- repoNotIgnored r
g <- fromRepo id
let c = extractRemoteGitConfig g (Git.repoDescribe r)
u <- getRepoUUID r
case (repoCheap r, notignored, u) of
(_, False, _) -> return r
case (repoCheap r, remoteAnnexIgnore c, u) of
(_, True, _) -> return r
(True, _, _) -> tryGitConfigRead r
(False, _, NoUUID) -> tryGitConfigRead r
_ -> return r
@ -84,29 +86,32 @@ configRead r = do
repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u _ = new <$> remoteCost r defcst
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u _ gc = go <$> remoteCost gc defcst
where
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
new cst = Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = copyToRemote r
, retrieveKeyFile = copyFromRemote r
, retrieveKeyFileCheap = copyFromRemoteCheap r
, removeKey = dropKey r
, hasKey = inAnnex r
, hasKeyCheap = repoCheap r
, whereisKey = Nothing
, config = M.empty
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
then Just $ Git.repoPath r
else Nothing
, repo = r
, readonly = Git.repoIsHttp r
, remotetype = remote
}
go cst = new
where
new = Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = copyToRemote new
, retrieveKeyFile = copyFromRemote new
, retrieveKeyFileCheap = copyFromRemoteCheap new
, removeKey = dropKey new
, hasKey = inAnnex r
, hasKeyCheap = repoCheap r
, whereisKey = Nothing
, config = M.empty
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
then Just $ Git.repoPath r
else Nothing
, repo = r
, gitconfig = gc
, readonly = Git.repoIsHttp r
, remotetype = remote
}
{- Checks relatively inexpensively if a repository is available for use. -}
repoAvail :: Git.Repo -> Annex Bool
@ -236,10 +241,10 @@ keyUrls r key = map tourl (annexLocations key)
where
tourl l = Git.repoLocation r ++ "/" ++ l
dropKey :: Git.Repo -> Key -> Annex Bool
dropKey :: Remote -> Key -> Annex Bool
dropKey r key
| not $ Git.repoIsUrl r =
guardUsable r False $ commitOnCleanup r $ liftIO $ onLocal r $ do
| not $ Git.repoIsUrl (repo r) =
guardUsable (repo r) False $ commitOnCleanup r $ liftIO $ onLocal (repo r) $ do
ensureInitialized
whenM (Annex.Content.inAnnex key) $ do
Annex.Content.lockContent key $
@ -247,29 +252,29 @@ dropKey r key
logStatus key InfoMissing
Annex.Content.saveState True
return True
| Git.repoIsHttp r = error "dropping from http repo not supported"
| otherwise = commitOnCleanup r $ onRemote r (boolSystem, False) "dropkey"
| Git.repoIsHttp (repo r) = error "dropping from http repo not supported"
| otherwise = commitOnCleanup r $ onRemote (repo r) (boolSystem, False) "dropkey"
[ Params "--quiet --force"
, Param $ key2file key
]
[]
{- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Git.Repo -> Key -> AssociatedFile -> FilePath -> Annex Bool
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
copyFromRemote r key file dest
| not $ Git.repoIsUrl r = guardUsable r False $ do
params <- rsyncParams r
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
let params = rsyncParams r
u <- getUUID
-- run copy from perspective of remote
liftIO $ onLocal r $ do
liftIO $ onLocal (repo r) $ do
ensureInitialized
Annex.Content.sendAnnex key $ \object ->
upload u key file noRetry $
rsyncOrCopyFile params object dest
| Git.repoIsSsh r = feedprogressback $ \feeder ->
| Git.repoIsSsh (repo r) = feedprogressback $ \feeder ->
rsyncHelper (Just feeder)
=<< rsyncParamsRemote r True key dest file
| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
| Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls (repo r) key) dest
| otherwise = error "copying from non-ssh, non-http repo not supported"
where
{- Feed local rsync's progress info back to the remote,
@ -289,7 +294,7 @@ copyFromRemote r key file dest
u <- getUUID
let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) file
Just (cmd, params) <- git_annex_shell r "transferinfo"
Just (cmd, params) <- git_annex_shell (repo r) "transferinfo"
[Param $ key2file key] fields
v <- liftIO $ newEmptySV
tid <- liftIO $ forkIO $ void $ tryIO $ do
@ -310,12 +315,12 @@ copyFromRemote r key file dest
let feeder = writeSV v
bracketIO noop (const $ tryIO $ killThread tid) (a feeder)
copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool
copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool
copyFromRemoteCheap r key file
| not $ Git.repoIsUrl r = guardUsable r False $ do
loc <- liftIO $ gitAnnexLocation key r
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
loc <- liftIO $ gitAnnexLocation key (repo r)
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
| Git.repoIsSsh r =
| Git.repoIsSsh (repo r) =
ifM (Annex.Content.preseedTmp key file)
( copyFromRemote r key Nothing file
, return False
@ -323,18 +328,20 @@ copyFromRemoteCheap r key file
| otherwise = return False
{- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Git.Repo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote r key file p
| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ copylocal
| Git.repoIsSsh r = commitOnCleanup r $ Annex.Content.sendAnnex key $ \object ->
rsyncHelper (Just p) =<< rsyncParamsRemote r False key object file
| not $ Git.repoIsUrl (repo r) =
guardUsable (repo r) False $ commitOnCleanup r $ copylocal
| Git.repoIsSsh (repo r) = commitOnCleanup r $
Annex.Content.sendAnnex key $ \object ->
rsyncHelper (Just p) =<< rsyncParamsRemote r False key object file
| otherwise = error "copying to non-ssh repo not supported"
where
copylocal = Annex.Content.sendAnnex key $ \object -> do
params <- rsyncParams r
let params = rsyncParams r
u <- getUUID
-- run copy from perspective of remote
liftIO $ onLocal r $ ifM (Annex.Content.inAnnex key)
liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key)
( return False
, do
ensureInitialized
@ -382,18 +389,18 @@ rsyncOrCopyFile rsyncparams src dest p =
{- Generates rsync parameters that ssh to the remote and asks it
- to either receive or send the key's content. -}
rsyncParamsRemote :: Git.Repo -> Bool -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
rsyncParamsRemote :: Remote -> Bool -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
rsyncParamsRemote r sending key file afile = do
u <- getUUID
let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
Just (shellcmd, shellparams) <- git_annex_shell r
Just (shellcmd, shellparams) <- git_annex_shell (repo r)
(if sending then "sendkey" else "recvkey")
[ Param $ key2file key ]
fields
-- Convert the ssh command into rsync command line.
let eparam = rsyncShell (Param shellcmd:shellparams)
o <- rsyncParams r
let o = rsyncParams r
if sending
then return $ o ++ rsyncopts eparam dummy (File file)
else return $ o ++ rsyncopts eparam (File file) dummy
@ -410,25 +417,22 @@ rsyncParamsRemote r sending key file afile = do
- even though this hostname will never be used. -}
dummy = Param "dummy:"
rsyncParams :: Git.Repo -> Annex [CommandParam]
rsyncParams r = do
o <- getRemoteConfig r "rsync-options" ""
return $ options ++ map Param (words o)
where
-- --inplace to resume partial files
options = [Params "-p --progress --inplace"]
-- --inplace to resume partial files
rsyncParams :: Remote -> [CommandParam]
rsyncParams r = [Params "-p --progress --inplace"] ++
map Param (remoteAnnexRsyncOptions $ gitconfig r)
commitOnCleanup :: Git.Repo -> Annex a -> Annex a
commitOnCleanup :: Remote -> Annex a -> Annex a
commitOnCleanup r a = go `after` a
where
go = Annex.addCleanup (Git.repoLocation r) cleanup
go = Annex.addCleanup (Git.repoLocation $ repo r) cleanup
cleanup
| not $ Git.repoIsUrl r = liftIO $ onLocal r $
| not $ Git.repoIsUrl (repo r) = liftIO $ onLocal (repo r) $
doQuietSideAction $
Annex.Branch.commit "update"
| otherwise = void $ do
Just (shellcmd, shellparams) <-
git_annex_shell r "commit" [] []
git_annex_shell (repo r) "commit" [] []
-- Throw away stderr, since the remote may not
-- have a new enough git-annex shell to

View file

@ -37,8 +37,8 @@ remote = RemoteType {
setup = glacierSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u c = new <$> remoteCost r veryExpensiveRemoteCost
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
where
new cst = encryptableRemote c
(storeEncrypted this)
@ -58,6 +58,7 @@ gen r u c = new <$> remoteCost r veryExpensiveRemoteCost
whereisKey = Nothing,
config = c,
repo = r,
gitconfig = gc,
localpath = Nothing,
readonly = False,
remotetype = remote

View file

@ -13,15 +13,16 @@ import Common.Annex
import Types.Remote
import qualified Annex
import Annex.LockPool
import Config
import Annex.Perms
{- Modifies a remote's access functions to first run the
- annex-start-command hook, and trigger annex-stop-command on shutdown.
- This way, the hooks are only run when a remote is actively being used.
-}
addHooks :: Remote -> Annex Remote
addHooks r = addHooks' r <$> lookupHook r "start" <*> lookupHook r "stop"
addHooks :: Remote -> Remote
addHooks r = addHooks' r
(remoteAnnexStartCommand $ gitconfig r)
(remoteAnnexStopCommand $ gitconfig r)
addHooks' :: Remote -> Maybe String -> Maybe String -> Remote
addHooks' r Nothing Nothing = r
addHooks' r starthook stophook = r'
@ -83,10 +84,3 @@ runHooks r starthook stophook a = do
Left _ -> noop
Right _ -> run stophook
liftIO $ closeFd fd
lookupHook :: Remote -> String -> Annex (Maybe String)
lookupHook r n = go =<< getRemoteConfig (repo r) hookname ""
where
go "" = return Nothing
go command = return $ Just command
hookname = n ++ "-command"

View file

@ -10,17 +10,19 @@ module Remote.Helper.Ssh where
import Common.Annex
import qualified Git
import qualified Git.Url
import Config
import Annex.UUID
import Annex.Ssh
import Fields
import Types.GitConfig
{- 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
opts <- map Param . words <$> getRemoteConfig repo "ssh-options" ""
g <- fromRepo id
let c = extractRemoteGitConfig g (Git.repoDescribe repo)
let opts = map Param $ remoteAnnexSshOptions c
params <- sshParams (Git.Url.hostuser repo, Git.Url.port repo) opts
return $ params ++ sshcmd

View file

@ -29,10 +29,9 @@ remote = RemoteType {
setup = hookSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u c = do
hooktype <- getRemoteConfig r "hooktype" (error "missing hooktype")
cst <- remoteCost r expensiveRemoteCost
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
cst <- remoteCost gc expensiveRemoteCost
return $ encryptableRemote c
(storeEncrypted hooktype)
(retrieveEncrypted hooktype)
@ -50,9 +49,12 @@ gen r u c = do
config = M.empty,
localpath = Nothing,
repo = r,
gitconfig = gc,
readonly = False,
remotetype = remote
}
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
hookSetup u c = do

View file

@ -15,8 +15,8 @@ import Common.Annex
import qualified Annex
import Logs.Remote
import Types.Remote
import Types.GitConfig
import Annex.UUID
import Config
import Remote.Helper.Hooks
import qualified Git
import qualified Git.Config
@ -81,7 +81,10 @@ remoteListRefresh = do
remoteGen :: (M.Map UUID RemoteConfig) -> RemoteType -> Git.Repo -> Annex Remote
remoteGen m t r = do
u <- getRepoUUID r
addHooks =<< generate t r u (fromMaybe M.empty $ M.lookup u m)
g <- fromRepo id
let gc = extractRemoteGitConfig g (Git.repoDescribe r)
let c = fromMaybe M.empty $ M.lookup u m
addHooks <$> generate t r u c gc
{- Updates a local git Remote, re-reading its git config. -}
updateRemote :: Remote -> Annex Remote
@ -97,7 +100,7 @@ updateRemote remote = do
{- All remotes that are not ignored. -}
enabledRemoteList :: Annex [Remote]
enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList
enabledRemoteList = filter (not . remoteAnnexIgnore . gitconfig) <$> remoteList
{- Checks if a remote is a special remote -}
specialRemote :: Remote -> Bool

View file

@ -38,10 +38,9 @@ remote = RemoteType {
setup = rsyncSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u c = do
o <- genRsyncOpts r c
cst <- remoteCost r expensiveRemoteCost
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
cst <- remoteCost gc expensiveRemoteCost
return $ encryptableRemote c
(storeEncrypted o)
(retrieveEncrypted o)
@ -58,27 +57,24 @@ gen r u c = do
, whereisKey = Nothing
, config = M.empty
, repo = r
, gitconfig = gc
, localpath = if rsyncUrlIsPath $ rsyncUrl o
then Just $ rsyncUrl o
else Nothing
, readonly = False
, remotetype = remote
}
genRsyncOpts :: Git.Repo -> RemoteConfig -> Annex RsyncOpts
genRsyncOpts r c = do
url <- getRemoteConfig r "rsyncurl" (error "missing rsyncurl")
opts <- map Param . filter safe . words
<$> getRemoteConfig r "rsync-options" ""
let escape = M.lookup "shellescape" c /= Just "no"
return $ RsyncOpts url opts escape
where
safe o
o = RsyncOpts url opts escape
url = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
opts = map Param $ filter safe $ remoteAnnexRsyncOptions gc
escape = M.lookup "shellescape" c /= Just "no"
safe opt
-- Don't allow user to pass --delete to rsync;
-- that could cause it to delete other keys
-- in the same hash bucket as a key it sends.
| o == "--delete" = False
| o == "--delete-excluded" = False
| opt == "--delete" = False
| opt == "--delete-excluded" = False
| otherwise = True
rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig

View file

@ -37,8 +37,8 @@ remote = RemoteType {
setup = s3Setup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u c = new <$> remoteCost r expensiveRemoteCost
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
where
new cst = encryptableRemote c
(storeEncrypted this)
@ -58,6 +58,7 @@ gen r u c = new <$> remoteCost r expensiveRemoteCost
whereisKey = Nothing,
config = c,
repo = r,
gitconfig = gc,
localpath = Nothing,
readonly = False,
remotetype = remote

View file

@ -35,8 +35,8 @@ list = do
r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown
return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r _ _ =
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r _ _ gc =
return Remote {
uuid = webUUID,
cost = expensiveRemoteCost,
@ -49,6 +49,7 @@ gen r _ _ =
hasKeyCheap = False,
whereisKey = Just getUrls,
config = M.empty,
gitconfig = gc,
localpath = Nothing,
repo = r,
readonly = True,

View file

@ -43,8 +43,8 @@ remote = RemoteType {
setup = webdavSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
gen r u c = new <$> remoteCost r expensiveRemoteCost
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
where
new cst = encryptableRemote c
(storeEncrypted this)
@ -64,6 +64,7 @@ gen r u c = new <$> remoteCost r expensiveRemoteCost
whereisKey = Nothing,
config = c,
repo = r,
gitconfig = gc,
localpath = Nothing,
readonly = False,
remotetype = remote

View file

@ -10,7 +10,8 @@ module Types (
Backend,
Key,
UUID(..),
Config(..),
GitConfig(..),
RemoteGitConfig(..),
Remote,
RemoteType,
Option,
@ -19,7 +20,7 @@ module Types (
import Annex
import Types.Backend
import Types.Config
import Types.GitConfig
import Types.Key
import Types.UUID
import Types.Remote

View file

@ -1,64 +0,0 @@
{- git-annex configuration
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Types.Config (
Config(..),
extractConfig,
) where
import Common
import qualified Git
import qualified Git.Config
import Utility.DataUnits
{- Main git-annex settings. Each setting corresponds to a git-config key
- such as annex.foo -}
data Config = Config
{ annexNumCopies :: Int
, annexDiskReserve :: Integer
, annexDirect :: Bool
, annexBackends :: [String]
, annexQueueSize :: Maybe Int
, annexBloomCapacity :: Maybe Int
, annexBloomAccuracy :: Maybe Int
, annexSshCaching :: Maybe Bool
, annexAlwaysCommit :: Bool
, annexDelayAdd :: Maybe Int
, annexHttpHeaders :: [String]
, annexHttpHeadersCommand :: Maybe String
}
extractConfig :: Git.Repo -> Config
extractConfig r = Config
{ annexNumCopies = get "numcopies" 1
, annexDiskReserve = fromMaybe onemegabyte $
readSize dataUnits =<< getmaybe "diskreserve"
, annexDirect = getbool "direct" False
, annexBackends = fromMaybe [] $
words <$> getmaybe "backends"
, annexQueueSize = getmayberead "queuesize"
, annexBloomCapacity = getmayberead "bloomcapacity"
, annexBloomAccuracy = getmayberead "bloomaccuracy"
, annexSshCaching = getmaybebool "sshcaching"
, annexAlwaysCommit = getbool "alwayscommit" True
, annexDelayAdd = getmayberead "delayadd"
, annexHttpHeaders = getlist "http-headers"
, annexHttpHeadersCommand = getmaybe "http-headers-command"
}
where
get k def = fromMaybe def $ getmayberead k
getbool k def = fromMaybe def $ getmaybebool k
getmaybebool k = Git.Config.isTrue =<< getmaybe k
getmayberead k = readish =<< getmaybe k
getmaybe k = Git.Config.getMaybe (key k) r
getlist k = Git.Config.getList (key k) r
key k = "annex." ++ k
onemegabyte = 1000000
{- Per-remote git-annex settings. Each setting corresponds to a git-config
- key such as annex.<remote>.foo -}

122
Types/GitConfig.hs Normal file
View file

@ -0,0 +1,122 @@
{- git-annex configuration
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Types.GitConfig (
GitConfig(..),
extractGitConfig,
RemoteGitConfig(..),
extractRemoteGitConfig,
) where
import Common
import qualified Git
import qualified Git.Config
import Utility.DataUnits
{- Main git-annex settings. Each setting corresponds to a git-config key
- such as annex.foo -}
data GitConfig = GitConfig
{ annexVersion :: Maybe String
, annexNumCopies :: Int
, annexDiskReserve :: Integer
, annexDirect :: Bool
, annexBackends :: [String]
, annexQueueSize :: Maybe Int
, annexBloomCapacity :: Maybe Int
, annexBloomAccuracy :: Maybe Int
, annexSshCaching :: Maybe Bool
, annexAlwaysCommit :: Bool
, annexDelayAdd :: Maybe Int
, annexHttpHeaders :: [String]
, annexHttpHeadersCommand :: Maybe String
}
extractGitConfig :: Git.Repo -> GitConfig
extractGitConfig r = GitConfig
{ annexVersion = notempty $ getmaybe "version"
, annexNumCopies = get "numcopies" 1
, annexDiskReserve = fromMaybe onemegabyte $
readSize dataUnits =<< getmaybe "diskreserve"
, annexDirect = getbool "direct" False
, annexBackends = fromMaybe [] $ words <$> getmaybe "backends"
, annexQueueSize = getmayberead "queuesize"
, annexBloomCapacity = getmayberead "bloomcapacity"
, annexBloomAccuracy = getmayberead "bloomaccuracy"
, annexSshCaching = getmaybebool "sshcaching"
, annexAlwaysCommit = getbool "alwayscommit" True
, annexDelayAdd = getmayberead "delayadd"
, annexHttpHeaders = getlist "http-headers"
, annexHttpHeadersCommand = getmaybe "http-headers-command"
}
where
get k def = fromMaybe def $ getmayberead k
getbool k def = fromMaybe def $ getmaybebool k
getmaybebool k = Git.Config.isTrue =<< getmaybe k
getmayberead k = readish =<< getmaybe k
getmaybe k = Git.Config.getMaybe (key k) r
getlist k = Git.Config.getList (key k) r
key k = "annex." ++ k
onemegabyte = 1000000
{- Per-remote git-annex settings. Each setting corresponds to a git-config
- key such as <remote>.annex-foo, or if that is not set, a default from
- annex.foo -}
data RemoteGitConfig = RemoteGitConfig
{ remoteAnnexCost :: Maybe Int
, remoteAnnexCostCommand :: Maybe String
, remoteAnnexIgnore :: Bool
, remoteAnnexSync :: Bool
, remoteAnnexTrustLevel :: Maybe String
, remoteAnnexStartCommand :: Maybe String
, remoteAnnexStopCommand :: Maybe String
-- these settings are specific to particular types of remotes
, remoteAnnexSshOptions :: [String]
, remoteAnnexRsyncOptions :: [String]
, remoteAnnexRsyncUrl :: Maybe String
, remoteAnnexBupRepo :: Maybe String
, remoteAnnexBupSplitOptions :: [String]
, remoteAnnexDirectory :: Maybe FilePath
, remoteAnnexHookType :: Maybe String
}
extractRemoteGitConfig :: Git.Repo -> String -> RemoteGitConfig
extractRemoteGitConfig r remotename = RemoteGitConfig
{ remoteAnnexCost = getmayberead "cost"
, remoteAnnexCostCommand = notempty $ getmaybe "cost-command"
, remoteAnnexIgnore = getbool "ignore" False
, remoteAnnexSync = getbool "sync" True
, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel"
, remoteAnnexStartCommand = notempty $ getmaybe "start-command"
, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"
, remoteAnnexSshOptions = getoptions "ssh-options"
, remoteAnnexRsyncOptions = getoptions "rsync-options"
, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl"
, remoteAnnexBupRepo = getmaybe "buprepo"
, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
, remoteAnnexDirectory = notempty $ getmaybe "directory"
, remoteAnnexHookType = notempty $ getmaybe "hooktype"
}
where
getbool k def = fromMaybe def $ getmaybebool k
getmaybebool k = Git.Config.isTrue =<< getmaybe k
getmayberead k = readish =<< getmaybe k
getmaybe k = maybe (Git.Config.getMaybe (key k) r) Just $
Git.Config.getMaybe (remotekey k) r
getoptions k = fromMaybe [] $ words <$> getmaybe k
key k = "annex." ++ k
remotekey k = "remote." ++ remotename ++ ".annex-" ++ k
notempty :: Maybe String -> Maybe String
notempty Nothing = Nothing
notempty (Just "") = Nothing
notempty (Just s) = Just s

View file

@ -16,6 +16,7 @@ import qualified Git
import Types.Key
import Types.UUID
import Types.Meters
import Types.GitConfig
type RemoteConfigKey = String
type RemoteConfig = M.Map RemoteConfigKey String
@ -27,7 +28,7 @@ data RemoteTypeA a = RemoteType {
-- enumerates remotes of this type
enumerate :: a [Git.Repo],
-- generates a remote of this type
generate :: Git.Repo -> UUID -> RemoteConfig -> a (RemoteA a),
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (RemoteA a),
-- initializes or changes a remote
setup :: UUID -> RemoteConfig -> a RemoteConfig
}
@ -64,8 +65,10 @@ data RemoteA a = Remote {
whereisKey :: Maybe (Key -> a [String]),
-- a Remote has a persistent configuration store
config :: RemoteConfig,
-- git configuration for the remote
-- git repo for the Remote
repo :: Git.Repo,
-- a Remote's configuration from git
gitconfig :: RemoteGitConfig,
-- a Remote can be assocated with a specific local filesystem path
localpath :: Maybe FilePath,
-- a Remote can be known to be readonly