add remotes slot to Annex
This required parameterizing the type for Remote, to avoid a cycle.
This commit is contained in:
parent
b40f253d6e
commit
f30320aa75
7 changed files with 41 additions and 46 deletions
5
Annex.hs
5
Annex.hs
|
@ -27,6 +27,7 @@ import Data.Maybe
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
import qualified GitQueue
|
import qualified GitQueue
|
||||||
import qualified BackendClass
|
import qualified BackendClass
|
||||||
|
import qualified RemoteClass
|
||||||
import Utility
|
import Utility
|
||||||
|
|
||||||
-- git-annex's monad
|
-- git-annex's monad
|
||||||
|
@ -37,6 +38,7 @@ data AnnexState = AnnexState
|
||||||
{ repo :: Git.Repo
|
{ repo :: Git.Repo
|
||||||
, backends :: [BackendClass.Backend Annex]
|
, backends :: [BackendClass.Backend Annex]
|
||||||
, supportedBackends :: [BackendClass.Backend Annex]
|
, supportedBackends :: [BackendClass.Backend Annex]
|
||||||
|
, remotes :: [RemoteClass.Remote Annex]
|
||||||
, repoqueue :: GitQueue.Queue
|
, repoqueue :: GitQueue.Queue
|
||||||
, quiet :: Bool
|
, quiet :: Bool
|
||||||
, force :: Bool
|
, force :: Bool
|
||||||
|
@ -46,13 +48,13 @@ data AnnexState = AnnexState
|
||||||
, toremote :: Maybe String
|
, toremote :: Maybe String
|
||||||
, fromremote :: Maybe String
|
, fromremote :: Maybe String
|
||||||
, exclude :: [String]
|
, exclude :: [String]
|
||||||
, remotesread :: Bool
|
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
newState :: Git.Repo -> [BackendClass.Backend Annex] -> AnnexState
|
newState :: Git.Repo -> [BackendClass.Backend Annex] -> AnnexState
|
||||||
newState gitrepo allbackends = AnnexState
|
newState gitrepo allbackends = AnnexState
|
||||||
{ repo = gitrepo
|
{ repo = gitrepo
|
||||||
, backends = []
|
, backends = []
|
||||||
|
, remotes = []
|
||||||
, supportedBackends = allbackends
|
, supportedBackends = allbackends
|
||||||
, repoqueue = GitQueue.empty
|
, repoqueue = GitQueue.empty
|
||||||
, quiet = False
|
, quiet = False
|
||||||
|
@ -63,7 +65,6 @@ newState gitrepo allbackends = AnnexState
|
||||||
, toremote = Nothing
|
, toremote = Nothing
|
||||||
, fromremote = Nothing
|
, fromremote = Nothing
|
||||||
, exclude = []
|
, exclude = []
|
||||||
, remotesread = False
|
|
||||||
}
|
}
|
||||||
|
|
||||||
{- Create and returns an Annex state object for the specified git repo. -}
|
{- Create and returns an Annex state object for the specified git repo. -}
|
||||||
|
|
|
@ -147,7 +147,7 @@ showLocations key exclude = do
|
||||||
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
|
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
|
||||||
message rs us = message rs [] ++ message [] us
|
message rs us = message rs [] ++ message [] us
|
||||||
|
|
||||||
showTriedRemotes :: [RemoteClass.Remote] -> Annex ()
|
showTriedRemotes :: [RemoteClass.Remote Annex] -> Annex ()
|
||||||
showTriedRemotes [] = return ()
|
showTriedRemotes [] = return ()
|
||||||
showTriedRemotes remotes =
|
showTriedRemotes remotes =
|
||||||
showLongNote $ "Unable to access these remotes: " ++
|
showLongNote $ "Unable to access these remotes: " ++
|
||||||
|
|
10
Remote.hs
10
Remote.hs
|
@ -24,21 +24,21 @@ import Trust
|
||||||
import LocationLog
|
import LocationLog
|
||||||
|
|
||||||
{- add generators for new Remotes here -}
|
{- add generators for new Remotes here -}
|
||||||
generators :: [Annex [Remote]]
|
generators :: [Annex [Remote Annex]]
|
||||||
generators = [Remote.GitRemote.generate]
|
generators = [Remote.GitRemote.generate]
|
||||||
|
|
||||||
{- generates a list of all available Remotes -}
|
{- generates a list of all available Remotes -}
|
||||||
generate :: Annex [Remote]
|
generate :: Annex [Remote Annex]
|
||||||
generate = do
|
generate = do
|
||||||
lists <- sequence generators
|
lists <- sequence generators
|
||||||
return $ concat lists
|
return $ concat lists
|
||||||
|
|
||||||
{- Filters a list of remotes to ones that have the listed uuids. -}
|
{- Filters a list of remotes to ones that have the listed uuids. -}
|
||||||
remotesWithUUID :: [Remote] -> [UUID] -> [Remote]
|
remotesWithUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
|
||||||
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
|
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
|
||||||
|
|
||||||
{- Filters a list of remotes to ones that do not have the listed uuids. -}
|
{- Filters a list of remotes to ones that do not have the listed uuids. -}
|
||||||
remotesWithoutUUID :: [Remote] -> [UUID] -> [Remote]
|
remotesWithoutUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
|
||||||
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
|
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
|
||||||
|
|
||||||
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
|
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
|
||||||
|
@ -46,7 +46,7 @@ remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
|
||||||
- Also returns a list of UUIDs that are trusted to have the key
|
- Also returns a list of UUIDs that are trusted to have the key
|
||||||
- (some may not have configured remotes).
|
- (some may not have configured remotes).
|
||||||
-}
|
-}
|
||||||
keyPossibilities :: Key -> Annex ([Remote], [UUID])
|
keyPossibilities :: Key -> Annex ([Remote Annex], [UUID])
|
||||||
keyPossibilities key = do
|
keyPossibilities key = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
u <- getUUID g
|
u <- getUUID g
|
||||||
|
|
|
@ -27,14 +27,14 @@ import CopyFile
|
||||||
import RsyncFile
|
import RsyncFile
|
||||||
import Ssh
|
import Ssh
|
||||||
|
|
||||||
generate :: Annex [Remote]
|
generate :: Annex [Remote Annex]
|
||||||
generate = do
|
generate = do
|
||||||
readConfigs
|
readConfigs
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
rs <- filterM repoNotIgnored (Git.remotes g)
|
rs <- filterM repoNotIgnored (Git.remotes g)
|
||||||
mapM genRemote rs
|
mapM genRemote rs
|
||||||
|
|
||||||
genRemote :: Git.Repo -> Annex Remote
|
genRemote :: Git.Repo -> Annex (Remote Annex)
|
||||||
genRemote r = do
|
genRemote r = do
|
||||||
u <- getUUID r
|
u <- getUUID r
|
||||||
c <- repoCost r
|
c <- repoCost r
|
||||||
|
@ -49,31 +49,26 @@ genRemote r = do
|
||||||
hasKeyCheap = not (Git.repoIsUrl r)
|
hasKeyCheap = not (Git.repoIsUrl r)
|
||||||
}
|
}
|
||||||
|
|
||||||
{- Reads the configs of all remotes.
|
{- Reads the configs of git remotes.
|
||||||
-
|
-
|
||||||
- As reading the config of remotes can be expensive, this
|
- It's assumed to be cheap to read the config of non-URL remotes,
|
||||||
- function will only read configs once per git-annex run. 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,
|
- so this is done each time git-annex is run. Conversely,
|
||||||
- the config of an URL remote is only read when there is no
|
- the config of an URL remote is only read when there is no
|
||||||
- cached UUID value.
|
- cached UUID value.
|
||||||
- -}
|
-}
|
||||||
readConfigs :: Annex ()
|
readConfigs :: Annex ()
|
||||||
readConfigs = do
|
readConfigs = do
|
||||||
remotesread <- Annex.getState Annex.remotesread
|
g <- Annex.gitRepo
|
||||||
unless remotesread $ do
|
allremotes <- filterM repoNotIgnored $ Git.remotes g
|
||||||
g <- Annex.gitRepo
|
let cheap = filter (not . Git.repoIsUrl) allremotes
|
||||||
allremotes <- filterM repoNotIgnored $ Git.remotes g
|
let expensive = filter Git.repoIsUrl allremotes
|
||||||
let cheap = filter (not . Git.repoIsUrl) allremotes
|
doexpensive <- filterM cachedUUID expensive
|
||||||
let expensive = filter Git.repoIsUrl allremotes
|
unless (null doexpensive) $
|
||||||
doexpensive <- filterM cachedUUID expensive
|
showNote $ "getting UUID for " ++
|
||||||
unless (null doexpensive) $
|
list doexpensive ++ "..."
|
||||||
showNote $ "getting UUID for " ++
|
let todo = cheap ++ doexpensive
|
||||||
list doexpensive ++ "..."
|
unless (null todo) $ do
|
||||||
let todo = cheap ++ doexpensive
|
mapM_ tryGitConfigRead todo
|
||||||
unless (null todo) $ do
|
|
||||||
mapM_ tryGitConfigRead todo
|
|
||||||
Annex.changeState $ \s -> s { Annex.remotesread = True }
|
|
||||||
where
|
where
|
||||||
cachedUUID r = do
|
cachedUUID r = do
|
||||||
u <- getUUID r
|
u <- getUUID r
|
||||||
|
|
|
@ -9,38 +9,36 @@ module RemoteClass where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
|
|
||||||
import Annex
|
|
||||||
import UUID
|
|
||||||
import Key
|
import Key
|
||||||
|
|
||||||
data Remote = Remote {
|
data Remote a = Remote {
|
||||||
-- each Remote has a unique uuid
|
-- each Remote has a unique uuid
|
||||||
uuid :: UUID,
|
uuid :: String,
|
||||||
-- each Remote has a human visible name
|
-- each Remote has a human visible name
|
||||||
name :: String,
|
name :: String,
|
||||||
-- Remotes have a use cost; higher is more expensive
|
-- Remotes have a use cost; higher is more expensive
|
||||||
cost :: Int,
|
cost :: Int,
|
||||||
-- Transfers a key to the remote.
|
-- Transfers a key to the remote.
|
||||||
storeKey :: Key -> Annex Bool,
|
storeKey :: Key -> a Bool,
|
||||||
-- retrieves a key's contents to a file
|
-- retrieves a key's contents to a file
|
||||||
retrieveKeyFile :: Key -> FilePath -> Annex Bool,
|
retrieveKeyFile :: Key -> FilePath -> a Bool,
|
||||||
-- removes a key's contents
|
-- removes a key's contents
|
||||||
removeKey :: Key -> Annex Bool,
|
removeKey :: Key -> a Bool,
|
||||||
-- Checks if a key is present in the remote; if the remote
|
-- Checks if a key is present in the remote; if the remote
|
||||||
-- cannot be accessed returns a Left error.
|
-- cannot be accessed returns a Left error.
|
||||||
hasKey :: Key -> Annex (Either IOException Bool),
|
hasKey :: Key -> a (Either IOException Bool),
|
||||||
-- Some remotes can check hasKey without an expensive network
|
-- Some remotes can check hasKey without an expensive network
|
||||||
-- operation.
|
-- operation.
|
||||||
hasKeyCheap :: Bool
|
hasKeyCheap :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Show Remote where
|
instance Show (Remote a) where
|
||||||
show remote = "Remote { uuid =\"" ++ uuid remote ++ "\" }"
|
show remote = "Remote { uuid =\"" ++ uuid remote ++ "\" }"
|
||||||
|
|
||||||
-- two remotes are the same if they have the same uuid
|
-- two remotes are the same if they have the same uuid
|
||||||
instance Eq Remote where
|
instance Eq (Remote a) where
|
||||||
a == b = uuid a == uuid b
|
x == y = uuid x == uuid y
|
||||||
|
|
||||||
-- order remotes by cost
|
-- order remotes by cost
|
||||||
instance Ord Remote where
|
instance Ord (Remote a) where
|
||||||
compare a b = compare (cost a) (cost b)
|
compare x y = compare (cost x) (cost y)
|
||||||
|
|
|
@ -91,7 +91,8 @@ tryGitConfigRead r
|
||||||
- -}
|
- -}
|
||||||
readConfigs :: Annex ()
|
readConfigs :: Annex ()
|
||||||
readConfigs = do
|
readConfigs = do
|
||||||
remotesread <- Annex.getState Annex.remotesread
|
-- remotesread <- Annex.getState Annex.remotesread
|
||||||
|
let remotesread = False
|
||||||
unless remotesread $ do
|
unless remotesread $ do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
allremotes <- filterM repoNotIgnored $ Git.remotes g
|
allremotes <- filterM repoNotIgnored $ Git.remotes g
|
||||||
|
@ -104,7 +105,7 @@ readConfigs = do
|
||||||
let todo = cheap ++ doexpensive
|
let todo = cheap ++ doexpensive
|
||||||
unless (null todo) $ do
|
unless (null todo) $ do
|
||||||
mapM_ tryGitConfigRead todo
|
mapM_ tryGitConfigRead todo
|
||||||
Annex.changeState $ \s -> s { Annex.remotesread = True }
|
-- Annex.changeState $ \s -> s { Annex.remotesread = True }
|
||||||
where
|
where
|
||||||
cachedUUID r = do
|
cachedUUID r = do
|
||||||
u <- getUUID r
|
u <- getUUID r
|
||||||
|
|
4
UUID.hs
4
UUID.hs
|
@ -36,7 +36,7 @@ import qualified SysConfig
|
||||||
type UUID = String
|
type UUID = String
|
||||||
|
|
||||||
configkey :: String
|
configkey :: String
|
||||||
configkey="annex.uuid"
|
configkey = "annex.uuid"
|
||||||
|
|
||||||
{- Generates a UUID. There is a library for this, but it's not packaged,
|
{- Generates a UUID. There is a library for this, but it's not packaged,
|
||||||
- so use the command line tool. -}
|
- so use the command line tool. -}
|
||||||
|
@ -74,7 +74,7 @@ getUUID r = do
|
||||||
cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid"
|
cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid"
|
||||||
|
|
||||||
getUncachedUUID :: Git.Repo -> UUID
|
getUncachedUUID :: Git.Repo -> UUID
|
||||||
getUncachedUUID r = Git.configGet r "annex.uuid" ""
|
getUncachedUUID r = Git.configGet r configkey ""
|
||||||
|
|
||||||
{- Make sure that the repo has an annex.uuid setting. -}
|
{- Make sure that the repo has an annex.uuid setting. -}
|
||||||
prepUUID :: Annex ()
|
prepUUID :: Annex ()
|
||||||
|
|
Loading…
Reference in a new issue