partially completed switch away from having NoUUID in the UUID type

Not sure if this is any better, or even doesn't introduce a lot of bugs.
This commit is contained in:
Joey Hess 2013-03-05 13:40:40 -04:00
parent 5f14ad8e36
commit 2a43985605
24 changed files with 149 additions and 156 deletions

View file

@ -15,7 +15,7 @@ module Annex.UUID (
getUUID,
getRepoUUID,
getUncachedUUID,
prepUUID,
ensureUUID,
genUUID,
removeRepoUUID,
storeUUID,
@ -25,32 +25,25 @@ import Common.Annex
import qualified Git
import qualified Git.Config
import Config
import qualified Data.UUID as U
import System.Random
import Types.UUID
configkey :: ConfigKey
configkey = annexConfig "uuid"
{- Generates a random UUID, that does not include the MAC address. -}
genUUID :: IO UUID
genUUID = UUID . show <$> (randomIO :: IO U.UUID)
{- Get current repository's UUID. -}
getUUID :: Annex UUID
getUUID :: Annex (Maybe UUID)
getUUID = getRepoUUID =<< gitRepo
{- Looks up a repo's UUID, caching it in .git/config if it's not already. -}
getRepoUUID :: Git.Repo -> Annex UUID
getRepoUUID :: Git.Repo -> Annex (Maybe UUID)
getRepoUUID r = do
c <- toUUID <$> getConfig cachekey ""
let u = getUncachedUUID r
if c /= u && u /= NoUUID
then do
updatecache u
return u
else return c
case getUncachedUUID r of
v@(Just u)
| c /= v -> do
updatecache u
return v
_ -> return c
where
updatecache u = do
g <- gitRepo
@ -60,15 +53,21 @@ getRepoUUID r = do
removeRepoUUID :: Annex ()
removeRepoUUID = unsetConfig configkey
getUncachedUUID :: Git.Repo -> UUID
getUncachedUUID :: Git.Repo -> Maybe UUID
getUncachedUUID = toUUID . Git.Config.get key ""
where
(ConfigKey key) = configkey
{- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex ()
prepUUID = whenM ((==) NoUUID <$> getUUID) $
storeUUID configkey =<< liftIO genUUID
ensureUUID :: Annex UUID
ensureUUID = do
mu <- getUUID
case mu of
Just u -> return u
Nothing -> do
u <- liftIO genUUID
storeUUID configkey u
return u
storeUUID :: ConfigKey -> UUID -> Annex ()
storeUUID configfield = setConfig configfield . fromUUID

View file

@ -41,13 +41,12 @@ genDescription Nothing = do
initialize :: Maybe String -> Annex ()
initialize mdescription = do
prepUUID
u <- ensureUUID
setVersion defaultVersion
checkCrippledFileSystem
Annex.Branch.create
gitPreCommitHookWrite
createInodeSentinalFile
u <- getUUID
describeUUID u =<< genDescription mdescription
uninitialize :: Annex ()

View file

@ -36,7 +36,7 @@ lookupGroups u = (fromMaybe S.empty . M.lookup u) . groupsByUUID <$> groupMap
{- Applies a set modifier to change the groups for a uuid in the groupLog. -}
groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex ()
groupChange uuid@(UUID _) modifier = do
groupChange uuid modifier = do
curr <- lookupGroups uuid
ts <- liftIO getPOSIXTime
Annex.Branch.change groupLog $
@ -44,7 +44,6 @@ groupChange uuid@(UUID _) modifier = do
changeLog ts uuid (modifier curr) .
parseLog (Just . S.fromList . words)
Annex.changeState $ \s -> s { Annex.groupmap = Nothing }
groupChange NoUUID _ = error "unknown UUID; cannot modify"
groupSet :: UUID -> S.Set Group -> Annex ()
groupSet u g = groupChange u (const g)

View file

@ -31,20 +31,17 @@ import Annex.UUID
{- Log a change in the presence of a key's value in current repository. -}
logStatus :: Key -> LogStatus -> Annex ()
logStatus key status = do
u <- getUUID
logChange key u status
logStatus key status = maybe noop (\u -> logChange key u status) =<< getUUID
{- Log a change in the presence of a key's value in a repository. -}
logChange :: Key -> UUID -> LogStatus -> Annex ()
logChange key (UUID u) s = addLog (logFile key) =<< logNow s u
logChange _ NoUUID _ = noop
logChange key u s = addLog (logFile key) =<< logNow s (fromUUID u)
{- Returns a list of repository UUIDs that, according to the log, have
- the value of a key.
-}
loggedLocations :: Key -> Annex [UUID]
loggedLocations key = map toUUID <$> (currentLog . logFile) key
loggedLocations key = mapMaybe toUUID <$> (currentLog . logFile) key
{- Finds all keys that have location log information.
- (There may be duplicate keys in the list.) -}

View file

@ -259,7 +259,7 @@ parseTransferFile file
| otherwise = case drop (length bits - 3) bits of
[direction, u, key] -> Transfer
<$> readLcDirection direction
<*> pure (toUUID u)
<*> toUUID u
<*> fileKey key
_ -> Nothing
where

View file

@ -43,14 +43,13 @@ trustGet level = M.keys . M.filter (== level) <$> trustMap
{- Changes the trust level for a uuid in the trustLog. -}
trustSet :: UUID -> TrustLevel -> Annex ()
trustSet uuid@(UUID _) level = do
trustSet uuid level = do
ts <- liftIO getPOSIXTime
Annex.Branch.change trustLog $
showLog showTrustLog .
changeLog ts uuid level .
parseLog (Just . parseTrustLog)
Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
trustSet NoUUID _ = error "unknown UUID; cannot modify"
{- Returns the TrustLevel of a given repo UUID. -}
lookupTrust :: UUID -> Annex TrustLevel
@ -89,9 +88,11 @@ trustMapLoad = do
Annex.changeState $ \s -> s { Annex.trustmap = Just m }
return m
where
configuredtrust r = (\l -> Just (Types.Remote.uuid r, l))
=<< readTrustLevel
=<< remoteAnnexTrustLevel (Types.Remote.gitconfig r)
configuredtrust r = case Types.Remote.uuid r of
Just u -> (\l -> Just (u, l))
=<< readTrustLevel
=<< remoteAnnexTrustLevel (Types.Remote.gitconfig r)
Nothing -> Nothing
{- Does not include forcetrust or git config values, just those from the
- log file. -}

View file

@ -40,36 +40,7 @@ describeUUID :: UUID -> String -> Annex ()
describeUUID uuid desc = do
ts <- liftIO getPOSIXTime
Annex.Branch.change uuidLog $
showLog id . changeLog ts uuid desc . fixBadUUID . parseLog Just
{- Temporarily here to fix badly formatted uuid logs generated by
- versions 3.20111105 and 3.20111025.
-
- Those logs contain entries with the UUID and description flipped.
- Due to parsing, if the description is multiword, only the first
- will be taken to be the UUID. So, if the UUID of an entry does
- not look like a UUID, and the last word of the description does,
- flip them back.
-}
fixBadUUID :: Log String -> Log String
fixBadUUID = M.fromList . map fixup . M.toList
where
fixup (k, v)
| isbad = (fixeduuid, LogEntry (Date $ newertime v) fixedvalue)
| otherwise = (k, v)
where
kuuid = fromUUID k
isbad = not (isuuid kuuid) && isuuid lastword
ws = words $ value v
lastword = Prelude.last ws
fixeduuid = toUUID lastword
fixedvalue = unwords $ kuuid: Prelude.init ws
-- For the fixed line to take precidence, it should be
-- slightly newer, but only slightly.
newertime (LogEntry (Date d) _) = d + minimumPOSIXTimeSlice
newertime (LogEntry Unknown _) = minimumPOSIXTimeSlice
minimumPOSIXTimeSlice = 0.000001
isuuid s = length s == 36 && length (split "-" s) == 5
showLog id . changeLog ts uuid desc . parseLog Just
{- Records the uuid in the log, if it's not already there. -}
recordUUID :: UUID -> Annex ()
@ -90,9 +61,10 @@ uuidMap = maybe uuidMapLoad return =<< Annex.getState Annex.uuidmap
- it may not have been described and so otherwise would not appear. -}
uuidMapLoad :: Annex UUIDMap
uuidMapLoad = do
m <- (simpleMap . parseLog Just) <$> Annex.Branch.get uuidLog
u <- Annex.UUID.getUUID
let m' = M.insertWith' preferold u "" m
m <- (simpleMap . parseLog Just)
<$> Annex.Branch.get uuidLog
m' <- maybe m (\u -> M.insertWith' preferold u "" m)
<$> Annex.UUID.getUUID
Annex.changeState $ \s -> s { Annex.uuidmap = Just m' }
return m'
where

View file

@ -64,11 +64,12 @@ parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines
where
parse line
| null ws = Nothing
| otherwise = parser u (unwords info) >>= makepair
| otherwise = case toUUID $ Prelude.head ws of
Just u -> parser u (unwords info) >>= makepair u
Nothing -> Nothing
where
makepair v = Just (u, LogEntry ts v)
makepair u v = Just (u, LogEntry ts v)
ws = words line
u = toUUID $ Prelude.head ws
t = Prelude.last ws
ts
| tskey `isPrefixOf` t =
@ -105,10 +106,13 @@ prop_TimeStamp_sane :: Bool
prop_TimeStamp_sane = Unknown < Date 1
prop_addLog_sane :: Bool
prop_addLog_sane = newWins && newestWins
prop_addLog_sane = isJust mu && newWins && newestWins
where
newWins = addLog (UUID "foo") (LogEntry (Date 1) "new") l == l2
newestWins = addLog (UUID "foo") (LogEntry (Date 1) "newest") l2 /= l2
newWins = addLog (u) (LogEntry (Date 1) "new") l == l2
newestWins = addLog (u) (LogEntry (Date 1) "newest") l2 /= l2
l = M.fromList [(UUID "foo", LogEntry (Date 0) "old")]
l2 = M.fromList [(UUID "foo", LogEntry (Date 1) "new")]
l = M.fromList [(u, LogEntry (Date 0) "old")]
l2 = M.fromList [(u, LogEntry (Date 1) "new")]
mu = toUUID "foo"
u = fromMaybe (error "failed to make uuid") mu

View file

@ -22,7 +22,8 @@ type URLString = String
-- Dummy uuid for the whole web. Do not alter.
webUUID :: UUID
webUUID = UUID "00000000-0000-0000-0000-000000000001"
webUUID = fromMaybe (error "failed to construct webUUID")
(toUUID "00000000-0000-0000-0000-000000000001")
urlLog :: Key -> FilePath
urlLog key = hashDirLower key </> keyFile key ++ ".log.web"

View file

@ -56,8 +56,9 @@ import Remote.List
{- Map from UUIDs of Remotes to a calculated value. -}
remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)
remoteMap c = M.fromList . map (\r -> (uuid r, c r)) .
filter (\r -> uuid r /= NoUUID) <$> remoteList
remoteMap c = M.fromList . mapMaybe topair <$> remoteList
where
topair r = maybe Nothing (\u -> Just (u, c r)) (uuid r)
{- Map of UUIDs of remotes and their descriptions.
- The names of Remotes are added to suppliment any description that has
@ -82,7 +83,7 @@ byName' n = handle . filter matching <$> remoteList
where
handle [] = Left $ "there is no available git remote named \"" ++ n ++ "\""
handle (match:_)
| uuid match == NoUUID = Left $ "cannot determine uuid for " ++ name match
| isNothing (uuid match) = Left $ "cannot determine uuid for " ++ name match
| otherwise = Right match
matching r = n == name r || toUUID n == uuid r
@ -90,19 +91,21 @@ byName' n = handle . filter matching <$> remoteList
- and returns its UUID. Finds even remotes that are not configured in
- .git/config. -}
nameToUUID :: String -> Annex UUID
nameToUUID "." = getUUID -- special case for current repo
nameToUUID "here" = getUUID
nameToUUID "." = ensureUUID -- special case for current repo
nameToUUID "here" = ensureUUID
nameToUUID "" = error "no remote specified"
nameToUUID n = byName' n >>= go
where
go (Right r) = return $ uuid r
go (Right r) = return $ fromMaybe (error $ "cannot determine uuid for " ++ name r) (uuid r)
go (Left e) = fromMaybe (error e) <$> bydescription
bydescription = do
m <- uuidMap
case M.lookup n $ transform swap m of
Just u -> return $ Just u
Nothing -> return $ byuuid m
byuuid m = M.lookup (toUUID n) $ transform double m
byuuid m = case toUUID n of
Just u -> M.lookup u $ transform double m
Nothing -> Nothing
transform a = M.fromList . map a . M.toList
double (a, _) = (a, a)
@ -112,7 +115,7 @@ nameToUUID n = byName' n >>= go
- of the UUIDs. -}
prettyPrintUUIDs :: String -> [UUID] -> Annex String
prettyPrintUUIDs desc uuids = do
hereu <- getUUID
hereu <- ensureUUID
m <- uuidDescriptions
maybeShowJSON [(desc, map (jsonify m hereu) uuids)]
return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids
@ -137,7 +140,7 @@ prettyPrintUUIDs desc uuids = do
{- List of remote names and/or descriptions, for human display. -}
prettyListUUIDs :: [UUID] -> Annex [String]
prettyListUUIDs uuids = do
hereu <- getUUID
hereu <- ensureUUID
m <- uuidDescriptions
return $ map (\u -> prettify m hereu u) uuids
where

View file

@ -39,17 +39,17 @@ remote = RemoteType {
setup = bupSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
gen :: Git.Repo -> Maybe UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu c gc = do
bupr <- liftIO $ bup2GitRemote buprepo
cst <- remoteCost gc $
if bupLocal buprepo
then semiCheapRemoteCost
else expensiveRemoteCost
(u', bupr') <- getBupUUID bupr u
(mu', bupr') <- getBupUUID bupr mu
let new = Remote
{ uuid = u'
{ uuid = mu'
, cost = cst
, name = Git.repoDescribe r
, storeKey = store new buprepo
@ -223,20 +223,20 @@ onBupRemote r a command params = do
- local bup repositories to see if they are available, and getting their
- uuid (which may be different from the stored uuid for the bup remote).
-
- If a bup repository is not available, returns NoUUID.
- If a bup repository is not available, returns Nothing.
- This will cause checkPresent to indicate nothing from the bup remote
- is known to be present.
-
- Also, returns a version of the repo with config read, if it is local.
-}
getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo)
getBupUUID :: Git.Repo -> Maybe UUID -> Annex (Maybe UUID, Git.Repo)
getBupUUID r u
| Git.repoIsUrl r = return (u, r)
| otherwise = liftIO $ do
ret <- tryIO $ Git.Config.read r
case ret of
Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r')
Left _ -> return (NoUUID, r)
Left _ -> return (Nothing, r)
{- Converts a bup remote path spec into a Git.Repo. There are some
- differences in path representation between git and bup. -}

View file

@ -33,15 +33,15 @@ remote = RemoteType {
setup = directorySetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
gen :: Git.Repo -> (Maybe UUID) -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu c gc = do
cst <- remoteCost gc cheapRemoteCost
let chunksize = chunkSize c
return $ encryptableRemote c
(storeEncrypted dir chunksize)
(retrieveEncrypted dir chunksize)
Remote {
uuid = u,
uuid = mu,
cost = cst,
name = Git.repoDescribe r,
storeKey = store dir chunksize,

View file

@ -76,24 +76,24 @@ configRead :: Git.Repo -> Annex Git.Repo
configRead r = do
g <- fromRepo id
let c = extractRemoteGitConfig g (Git.repoDescribe r)
u <- getRepoUUID r
case (repoCheap r, remoteAnnexIgnore c, u) of
mu <- getRepoUUID r
case (repoCheap r, remoteAnnexIgnore c, mu) of
(_, True, _) -> return r
(True, _, _) -> tryGitConfigRead r
(False, _, NoUUID) -> tryGitConfigRead r
(False, _, Nothing) -> 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 :: Git.Repo -> Maybe UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu _ gc = go <$> remoteCost gc defcst
where
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
go cst = new
where
new = Remote
{ uuid = u
{ uuid = mu
, cost = cst
, name = Git.repoDescribe r
, storeKey = copyToRemote new
@ -165,7 +165,7 @@ tryGitConfigRead r
fileEncoding h
val <- hGetContentsStrict h
r' <- Git.Config.store val r
when (getUncachedUUID r' == NoUUID && not (null val)) $ do
when (isNothing (getUncachedUUID r') && not (null val)) $ do
warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
warningIO $ "Instead, got: " ++ show val
warningIO $ "This is unexpected; please check the network transport!"
@ -271,7 +271,7 @@ copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
copyFromRemote r key file dest
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
let params = rsyncParams r
u <- getUUID
u <- ensureUUID
-- run copy from perspective of remote
liftIO $ onLocal (repo r) $ do
ensureInitialized
@ -302,7 +302,7 @@ copyFromRemote r key file dest
- transferinfo, so stderr is dropped and failure ignored.
-}
feedprogressback a = do
u <- getUUID
u <- ensureUUID
let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) file
Just (cmd, params) <- git_annex_shell (repo r) "transferinfo"
@ -352,7 +352,7 @@ copyToRemote r key file p
copylocal Nothing = return False
copylocal (Just (object, checksuccess)) = do
let params = rsyncParams r
u <- getUUID
u <- ensureUUID
-- run copy from perspective of remote
liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key)
( return False
@ -404,7 +404,7 @@ rsyncOrCopyFile rsyncparams src dest p =
- to either receive or send the key's content. -}
rsyncParamsRemote :: Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
rsyncParamsRemote r direction key file afile = do
u <- getUUID
u <- ensureUUID
direct <- isDirect
let fields = (Fields.remoteUUID, fromUUID u)
: (Fields.direct, if direct then "1" else "")

View file

@ -38,8 +38,8 @@ remote = RemoteType {
setup = glacierSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
gen :: Git.Repo -> Maybe UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu c gc = new <$> remoteCost gc veryExpensiveRemoteCost
where
new cst = encryptableRemote c
(storeEncrypted this)
@ -47,7 +47,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
this
where
this = Remote {
uuid = u,
uuid = mu,
cost = cst,
name = Git.repoDescribe r,
storeKey = store this,
@ -205,8 +205,8 @@ checkPresent r k = do
glacierAction :: Remote -> [CommandParam] -> Annex Bool
glacierAction r params = runGlacier (config r) (uuid r) params
runGlacier :: RemoteConfig -> UUID -> [CommandParam] -> Annex Bool
runGlacier c u params = go =<< glacierEnv c u
runGlacier :: RemoteConfig -> Maybe UUID -> [CommandParam] -> Annex Bool
runGlacier c mu params = go =<< glacierEnv c mu
where
go Nothing = return False
go (Just e) = liftIO $
@ -218,8 +218,9 @@ glacierParams c params = datacenter:params
datacenter = Param $ "--region=" ++
(fromJust $ M.lookup "datacenter" c)
glacierEnv :: RemoteConfig -> UUID -> Annex (Maybe [(String, String)])
glacierEnv c u = go =<< getRemoteCredPairFor "glacier" c creds
glacierEnv :: RemoteConfig -> Maybe UUID -> Annex (Maybe [(String, String)])
glacierEnv _ Nothing = return Nothing
glacierEnv c (Just u) = go =<< getRemoteCredPairFor "glacier" c creds
where
go Nothing = return Nothing
go (Just (user, pass)) = do
@ -239,7 +240,7 @@ archive r k = fileprefix ++ key2file k
-- glacier vault create will succeed even if the vault already exists.
genVault :: RemoteConfig -> UUID -> Annex ()
genVault c u = unlessM (runGlacier c u params) $
genVault c u = unlessM (runGlacier c (Just u) params) $
error "Failed creating glacier vault."
where
params =

View file

@ -32,20 +32,20 @@ git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] ->
git_annex_shell r command params fields
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts ++ fieldopts)
| Git.repoIsSsh r = do
uuid <- getRepoUUID r
sshparams <- sshToRepo r [Param $ sshcmd uuid ]
mu <- getRepoUUID r
sshparams <- sshToRepo r [Param $ sshcmd mu ]
return $ Just ("ssh", sshparams)
| otherwise = return Nothing
where
dir = Git.repoPath r
shellcmd = "git-annex-shell"
shellopts = Param command : File dir : params
sshcmd uuid = unwords $
sshcmd mu = unwords $
shellcmd : map shellEscape (toCommand shellopts) ++
uuidcheck uuid ++
uuidcheck mu ++
map shellEscape (toCommand fieldopts)
uuidcheck NoUUID = []
uuidcheck (UUID u) = ["--uuid", u]
uuidcheck (Just u) = ["--uuid", fromUUID u]
uuidcheck Nothing = []
fieldopts
| null fields = []
| otherwise = fieldsep : map fieldopt fields ++ [fieldsep]

View file

@ -29,14 +29,14 @@ remote = RemoteType {
setup = hookSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
gen :: Git.Repo -> Maybe UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu c gc = do
cst <- remoteCost gc expensiveRemoteCost
return $ encryptableRemote c
(storeEncrypted hooktype)
(retrieveEncrypted hooktype)
Remote {
uuid = u,
uuid = mu,
cost = cst,
name = Git.repoDescribe r,
storeKey = store hooktype,
@ -54,7 +54,7 @@ gen r u c gc = do
remotetype = remote
}
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
hookSetup u c = do

View file

@ -80,11 +80,11 @@ remoteListRefresh = do
{- Generates a Remote. -}
remoteGen :: (M.Map UUID RemoteConfig) -> RemoteType -> Git.Repo -> Annex Remote
remoteGen m t r = do
u <- getRepoUUID r
mu <- getRepoUUID r
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
let c = fromMaybe M.empty $ maybe Nothing (\u -> M.lookup u m) mu
addHooks <$> generate t r mu c gc
{- Updates a local git Remote, re-reading its git config. -}
updateRemote :: Remote -> Annex Remote

View file

@ -39,14 +39,14 @@ remote = RemoteType {
setup = rsyncSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
gen :: Git.Repo -> Maybe UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu c gc = do
cst <- remoteCost gc expensiveRemoteCost
return $ encryptableRemote c
(storeEncrypted o)
(retrieveEncrypted o)
Remote
{ uuid = u
{ uuid = mu
, cost = cst
, name = Git.repoDescribe r
, storeKey = store o

View file

@ -37,8 +37,8 @@ remote = RemoteType {
setup = s3Setup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
gen :: Git.Repo -> Maybe UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu c gc = new <$> remoteCost gc expensiveRemoteCost
where
new cst = encryptableRemote c
(storeEncrypted this)
@ -46,7 +46,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
this
where
this = Remote {
uuid = u,
uuid = mu,
cost = cst,
name = Git.repoDescribe r,
storeKey = store this,
@ -206,7 +206,9 @@ s3Bool (Left e) = s3Warning e
s3Action :: Remote -> a -> ((AWSConnection, String) -> Annex a) -> Annex a
s3Action r noconn action = do
let bucket = M.lookup "bucket" $ config r
conn <- s3Connection (config r) (uuid r)
conn <- case uuid r of
Nothing -> return Nothing
Just u -> s3Connection (config r) u
case (bucket, conn) of
(Just b, Just c) -> action (c, b)
_ -> return noconn

View file

@ -35,10 +35,10 @@ list = do
r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown
return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen :: Git.Repo -> Maybe UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r _ _ gc =
return Remote {
uuid = webUUID,
uuid = Just webUUID,
cost = expensiveRemoteCost,
name = Git.repoDescribe r,
storeKey = uploadKey,

View file

@ -50,8 +50,8 @@ remote = RemoteType {
setup = webdavSetup
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
gen :: Git.Repo -> (Maybe UUID) -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r mu c gc = new <$> remoteCost gc expensiveRemoteCost
where
new cst = encryptableRemote c
(storeEncrypted this)
@ -59,7 +59,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
this
where
this = Remote {
uuid = u,
uuid = mu,
cost = cst,
name = Git.repoDescribe r,
storeKey = store this,
@ -205,7 +205,9 @@ withStoredFiles r k baseurl user pass onerr a
davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
davAction r unconfigured action = do
mcreds <- getCreds (config r) (uuid r)
mcreds <- case uuid r of
Nothing -> return Nothing
Just u -> getCreds (config r) u
case (mcreds, M.lookup "url" $ config r) of
(Just (user, pass), Just url) ->
action (url, toDavUser user, toDavPass pass)

View file

@ -9,7 +9,7 @@ module Types (
Annex,
Backend,
Key,
UUID(..),
UUID,
GitConfig(..),
RemoteGitConfig(..),
Remote,

View file

@ -28,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 -> RemoteGitConfig -> a (RemoteA a),
generate :: Git.Repo -> (Maybe UUID) -> RemoteConfig -> RemoteGitConfig -> a (RemoteA a),
-- initializes or changes a remote
setup :: UUID -> RemoteConfig -> a RemoteConfig
}
@ -41,8 +41,9 @@ type AssociatedFile = Maybe FilePath
{- An individual remote. -}
data RemoteA a = Remote {
-- each Remote has a unique uuid
uuid :: UUID,
-- each available Remote has a unique uuid
-- remotes may be unavailable or not fully set up and have Nothing
uuid :: Maybe UUID,
-- each Remote has a human visible name
name :: String,
-- Remotes have a use cost; higher is more expensive

View file

@ -1,24 +1,36 @@
{- git-annex UUID type
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
- Copyright 2011,2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Types.UUID where
module Types.UUID (
UUID,
UUIDMap,
fromUUID,
toUUID,
genUUID
) where
import qualified Data.Map as M
import qualified Data.UUID as U
import System.Random
import Control.Applicative
-- A UUID is either an arbitrary opaque string, or UUID info may be missing.
data UUID = NoUUID | UUID String
-- A UUID an arbitrary opaque string, which cannot be empty.
data UUID = UUID String
deriving (Eq, Ord, Show, Read)
type UUIDMap = M.Map UUID String
fromUUID :: UUID -> String
fromUUID (UUID u) = u
fromUUID NoUUID = ""
toUUID :: String -> UUID
toUUID [] = NoUUID
toUUID s = UUID s
toUUID :: String -> Maybe UUID
toUUID [] = Nothing
toUUID s = Just (UUID s)
type UUIDMap = M.Map UUID String
{- Generates a random UUID, that does not include the MAC address. -}
genUUID :: IO UUID
genUUID = UUID . show <$> (randomIO :: IO U.UUID)