From 2a43985605c162bde5410ab6e3144a150289ed0f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 5 Mar 2013 13:40:40 -0400 Subject: [PATCH] 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. --- Annex/UUID.hs | 41 ++++++++++++++++++++--------------------- Init.hs | 3 +-- Logs/Group.hs | 3 +-- Logs/Location.hs | 9 +++------ Logs/Transfer.hs | 2 +- Logs/Trust.hs | 11 ++++++----- Logs/UUID.hs | 38 +++++--------------------------------- Logs/UUIDBased.hs | 20 ++++++++++++-------- Logs/Web.hs | 3 ++- Remote.hs | 21 ++++++++++++--------- Remote/Bup.hs | 14 +++++++------- Remote/Directory.hs | 6 +++--- Remote/Git.hs | 22 +++++++++++----------- Remote/Glacier.hs | 17 +++++++++-------- Remote/Helper/Ssh.hs | 12 ++++++------ Remote/Hook.hs | 8 ++++---- Remote/List.hs | 6 +++--- Remote/Rsync.hs | 6 +++--- Remote/S3.hs | 10 ++++++---- Remote/Web.hs | 4 ++-- Remote/WebDAV.hs | 10 ++++++---- Types.hs | 2 +- Types/Remote.hs | 7 ++++--- Types/UUID.hs | 30 +++++++++++++++++++++--------- 24 files changed, 149 insertions(+), 156 deletions(-) diff --git a/Annex/UUID.hs b/Annex/UUID.hs index c36861bbe3..8b84aba0bf 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -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 diff --git a/Init.hs b/Init.hs index 358a54e818..f925900126 100644 --- a/Init.hs +++ b/Init.hs @@ -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 () diff --git a/Logs/Group.hs b/Logs/Group.hs index a069edcdf3..8ccb6b7f25 100644 --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -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) diff --git a/Logs/Location.hs b/Logs/Location.hs index 0f57b66634..8bab5cd558 100644 --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -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.) -} diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 6d6d3d8902..97a6484b18 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -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 diff --git a/Logs/Trust.hs b/Logs/Trust.hs index 058250740f..d61e1f960e 100644 --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -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. -} diff --git a/Logs/UUID.hs b/Logs/UUID.hs index 2f24a388e4..cfdc3151fc 100644 --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -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 diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs index c1901eef7f..63ee00e639 100644 --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -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 diff --git a/Logs/Web.hs b/Logs/Web.hs index 7cfad86481..8d2349e540 100644 --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -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" diff --git a/Remote.hs b/Remote.hs index 22e304de37..3f8f5f04ec 100644 --- a/Remote.hs +++ b/Remote.hs @@ -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 diff --git a/Remote/Bup.hs b/Remote/Bup.hs index f81751f825..602bda70c7 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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. -} diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 3070a530b8..1bc4b8cfaa 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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, diff --git a/Remote/Git.hs b/Remote/Git.hs index d39e0afe26..82fff1a32d 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 "") diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 173e366d28..f476967770 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -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 = diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 135b5c144a..adedd1b177 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -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] diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 8b02312035..77dc107938 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 diff --git a/Remote/List.hs b/Remote/List.hs index 1cfbab8720..b0ad3c72b0 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 21a4d4324a..705e2f531e 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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 diff --git a/Remote/S3.hs b/Remote/S3.hs index 1d24c49384..c90a746eb1 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -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 diff --git a/Remote/Web.hs b/Remote/Web.hs index f984137a9c..3fed619ba7 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -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, diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 5714cd075c..c439dd6b23 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -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) diff --git a/Types.hs b/Types.hs index d19ac3de15..5a4fed3be0 100644 --- a/Types.hs +++ b/Types.hs @@ -9,7 +9,7 @@ module Types ( Annex, Backend, Key, - UUID(..), + UUID, GitConfig(..), RemoteGitConfig(..), Remote, diff --git a/Types/Remote.hs b/Types/Remote.hs index 05763e4d3d..e1fd029b04 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -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 diff --git a/Types/UUID.hs b/Types/UUID.hs index 8a304dffab..1a272fddcf 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -1,24 +1,36 @@ {- git-annex UUID type - - - Copyright 2011 Joey Hess + - Copyright 2011,2013 Joey Hess - - 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)