add a UUIDDesc type containing a ByteString
Groundwork for handling uuid.log using ByteString
This commit is contained in:
parent
b781fbcccf
commit
894716512d
21 changed files with 94 additions and 74 deletions
4
Annex.hs
4
Annex.hs
|
@ -122,7 +122,7 @@ data AnnexState = AnnexState
|
||||||
, globalnumcopies :: Maybe NumCopies
|
, globalnumcopies :: Maybe NumCopies
|
||||||
, forcenumcopies :: Maybe NumCopies
|
, forcenumcopies :: Maybe NumCopies
|
||||||
, limit :: ExpandableMatcher Annex
|
, limit :: ExpandableMatcher Annex
|
||||||
, uuidmap :: Maybe UUIDMap
|
, uuiddescmap :: Maybe UUIDDescMap
|
||||||
, preferredcontentmap :: Maybe (FileMatcherMap Annex)
|
, preferredcontentmap :: Maybe (FileMatcherMap Annex)
|
||||||
, requiredcontentmap :: Maybe (FileMatcherMap Annex)
|
, requiredcontentmap :: Maybe (FileMatcherMap Annex)
|
||||||
, forcetrust :: TrustMap
|
, forcetrust :: TrustMap
|
||||||
|
@ -181,7 +181,7 @@ newState c r = do
|
||||||
, globalnumcopies = Nothing
|
, globalnumcopies = Nothing
|
||||||
, forcenumcopies = Nothing
|
, forcenumcopies = Nothing
|
||||||
, limit = BuildingMatcher []
|
, limit = BuildingMatcher []
|
||||||
, uuidmap = Nothing
|
, uuiddescmap = Nothing
|
||||||
, preferredcontentmap = Nothing
|
, preferredcontentmap = Nothing
|
||||||
, requiredcontentmap = Nothing
|
, requiredcontentmap = Nothing
|
||||||
, forcetrust = M.empty
|
, forcetrust = M.empty
|
||||||
|
|
|
@ -41,7 +41,7 @@ setDifferences = do
|
||||||
warning "Cannot change tunable parameters in already initialized repository."
|
warning "Cannot change tunable parameters in already initialized repository."
|
||||||
return oldds
|
return oldds
|
||||||
, if otherds == mempty
|
, if otherds == mempty
|
||||||
then ifM (any (/= u) . M.keys <$> uuidMap)
|
then ifM (any (/= u) . M.keys <$> uuidDescMap)
|
||||||
( do
|
( do
|
||||||
warning "Cannot change tunable parameters in a clone of an existing repository."
|
warning "Cannot change tunable parameters in a clone of an existing repository."
|
||||||
return mempty
|
return mempty
|
||||||
|
|
|
@ -45,6 +45,7 @@ import Annex.InodeSentinal
|
||||||
import Upgrade
|
import Upgrade
|
||||||
import Annex.Perms
|
import Annex.Perms
|
||||||
import Utility.UserInfo
|
import Utility.UserInfo
|
||||||
|
import Utility.FileSystemEncoding
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
import Utility.FileMode
|
import Utility.FileMode
|
||||||
import System.Posix.User
|
import System.Posix.User
|
||||||
|
@ -68,14 +69,14 @@ checkCanInitialize (AutoInit False) a = fromRepo Git.repoWorkTree >>= \case
|
||||||
giveup "Not initialized."
|
giveup "Not initialized."
|
||||||
)
|
)
|
||||||
|
|
||||||
genDescription :: Maybe String -> Annex String
|
genDescription :: Maybe String -> Annex UUIDDesc
|
||||||
genDescription (Just d) = return d
|
genDescription (Just d) = return $ UUIDDesc $ encodeBS d
|
||||||
genDescription Nothing = do
|
genDescription Nothing = do
|
||||||
reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath
|
reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath
|
||||||
hostname <- fromMaybe "" <$> liftIO getHostname
|
hostname <- fromMaybe "" <$> liftIO getHostname
|
||||||
let at = if null hostname then "" else "@"
|
let at = if null hostname then "" else "@"
|
||||||
v <- liftIO myUserName
|
v <- liftIO myUserName
|
||||||
return $ concat $ case v of
|
return $ UUIDDesc $ encodeBS $ concat $ case v of
|
||||||
Right username -> [username, at, hostname, ":", reldir]
|
Right username -> [username, at, hostname, ":", reldir]
|
||||||
Left _ -> [hostname, ":", reldir]
|
Left _ -> [hostname, ":", reldir]
|
||||||
|
|
||||||
|
|
|
@ -106,8 +106,8 @@ setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) = do
|
||||||
(c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg
|
(c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg
|
||||||
configSet u c'
|
configSet u c'
|
||||||
when setdesc $
|
when setdesc $
|
||||||
whenM (isNothing . M.lookup u <$> uuidMap) $
|
whenM (isNothing . M.lookup u <$> uuidDescMap) $
|
||||||
describeUUID u name
|
describeUUID u (toUUIDDesc name)
|
||||||
return name
|
return name
|
||||||
|
|
||||||
{- Returns the name of the git remote it created. If there's already a
|
{- Returns the name of the git remote it created. If there's already a
|
||||||
|
|
|
@ -57,7 +57,7 @@ type Configs = S.Set (FilePath, Sha)
|
||||||
{- All git-annex's config files, and actions to run when they change. -}
|
{- All git-annex's config files, and actions to run when they change. -}
|
||||||
configFilesActions :: [(FilePath, Assistant ())]
|
configFilesActions :: [(FilePath, Assistant ())]
|
||||||
configFilesActions =
|
configFilesActions =
|
||||||
[ (uuidLog, void $ liftAnnex uuidMapLoad)
|
[ (uuidLog, void $ liftAnnex uuidDescMapLoad)
|
||||||
, (remoteLog, void $ liftAnnex remoteListRefresh)
|
, (remoteLog, void $ liftAnnex remoteListRefresh)
|
||||||
, (trustLog, void $ liftAnnex trustMapLoad)
|
, (trustLog, void $ liftAnnex trustMapLoad)
|
||||||
, (groupLog, void $ liftAnnex groupMapLoad)
|
, (groupLog, void $ liftAnnex groupMapLoad)
|
||||||
|
|
|
@ -66,7 +66,7 @@ getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
|
||||||
getRepoConfig uuid mremote = do
|
getRepoConfig uuid mremote = do
|
||||||
-- Ensure we're editing current data by discarding caches.
|
-- Ensure we're editing current data by discarding caches.
|
||||||
void groupMapLoad
|
void groupMapLoad
|
||||||
void uuidMapLoad
|
void uuidDescMapLoad
|
||||||
|
|
||||||
groups <- lookupGroups uuid
|
groups <- lookupGroups uuid
|
||||||
remoteconfig <- M.lookup uuid <$> readRemoteLog
|
remoteconfig <- M.lookup uuid <$> readRemoteLog
|
||||||
|
@ -74,7 +74,7 @@ getRepoConfig uuid mremote = do
|
||||||
Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)
|
Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)
|
||||||
Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)
|
Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)
|
||||||
|
|
||||||
description <- fmap T.pack . M.lookup uuid <$> uuidMap
|
description <- fmap (T.pack . fromUUIDDesc) . M.lookup uuid <$> uuidDescMap
|
||||||
|
|
||||||
syncable <- case mremote of
|
syncable <- case mremote of
|
||||||
Just r -> liftIO $ getDynamicConfig $ remoteAnnexSync $ Remote.gitconfig r
|
Just r -> liftIO $ getDynamicConfig $ remoteAnnexSync $ Remote.gitconfig r
|
||||||
|
@ -90,8 +90,8 @@ getRepoConfig uuid mremote = do
|
||||||
setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
|
setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
|
||||||
setRepoConfig uuid mremote oldc newc = do
|
setRepoConfig uuid mremote oldc newc = do
|
||||||
when descriptionChanged $ liftAnnex $ do
|
when descriptionChanged $ liftAnnex $ do
|
||||||
maybe noop (describeUUID uuid . T.unpack) (repoDescription newc)
|
maybe noop (describeUUID uuid . toUUIDDesc . T.unpack) (repoDescription newc)
|
||||||
void uuidMapLoad
|
void uuidDescMapLoad
|
||||||
when nameChanged $ do
|
when nameChanged $ do
|
||||||
liftAnnex $ do
|
liftAnnex $ do
|
||||||
name <- uniqueRemoteName (legalName newc) 0 <$> Annex.getGitRemotes
|
name <- uniqueRemoteName (legalName newc) 0 <$> Annex.getGitRemotes
|
||||||
|
|
|
@ -289,7 +289,7 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
|
||||||
askcombine = page "Combine repositories?" (Just Configuration) $
|
askcombine = page "Combine repositories?" (Just Configuration) $
|
||||||
$(widgetFile "configurators/adddrive/combine")
|
$(widgetFile "configurators/adddrive/combine")
|
||||||
isknownuuid driveuuid =
|
isknownuuid driveuuid =
|
||||||
ifM (M.member driveuuid <$> liftAnnex uuidMap)
|
ifM (M.member driveuuid <$> liftAnnex uuidDescMap)
|
||||||
( knownrepo
|
( knownrepo
|
||||||
, askcombine
|
, askcombine
|
||||||
)
|
)
|
||||||
|
|
|
@ -418,7 +418,7 @@ getLogin sshinput = geti inputUsername ++ "@" ++ geti inputHostname
|
||||||
getConfirmSshR :: SshData -> UUID -> Handler Html
|
getConfirmSshR :: SshData -> UUID -> Handler Html
|
||||||
getConfirmSshR sshdata u
|
getConfirmSshR sshdata u
|
||||||
| u == NoUUID = handlenew
|
| u == NoUUID = handlenew
|
||||||
| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidMap)
|
| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidDescMap)
|
||||||
where
|
where
|
||||||
handlenew = sshConfigurator $ do
|
handlenew = sshConfigurator $ do
|
||||||
cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
|
cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
|
||||||
|
|
|
@ -29,5 +29,5 @@ start _ = giveup "Specify a repository and a description."
|
||||||
|
|
||||||
perform :: UUID -> String -> CommandPerform
|
perform :: UUID -> String -> CommandPerform
|
||||||
perform u description = do
|
perform u description = do
|
||||||
describeUUID u description
|
describeUUID u (toUUIDDesc description)
|
||||||
next $ return True
|
next $ return True
|
||||||
|
|
|
@ -100,7 +100,9 @@ cleanupSpecialRemote u c = do
|
||||||
unknownNameError :: String -> Annex a
|
unknownNameError :: String -> Annex a
|
||||||
unknownNameError prefix = do
|
unknownNameError prefix = do
|
||||||
m <- Annex.SpecialRemote.specialRemoteMap
|
m <- Annex.SpecialRemote.specialRemoteMap
|
||||||
descm <- M.unionWith Remote.addName <$> uuidMap <*> pure m
|
descm <- M.unionWith Remote.addName
|
||||||
|
<$> uuidDescMap
|
||||||
|
<*> pure (M.map toUUIDDesc m)
|
||||||
specialmsg <- if M.null m
|
specialmsg <- if M.null m
|
||||||
then pure "(No special remotes are currently known; perhaps use initremote instead?)"
|
then pure "(No special remotes are currently known; perhaps use initremote instead?)"
|
||||||
else Remote.prettyPrintUUIDsDescs
|
else Remote.prettyPrintUUIDsDescs
|
||||||
|
|
|
@ -51,11 +51,11 @@ seek o = do
|
||||||
expire <- parseExpire (expireParams o)
|
expire <- parseExpire (expireParams o)
|
||||||
actlog <- lastActivities (activityOption o)
|
actlog <- lastActivities (activityOption o)
|
||||||
u <- getUUID
|
u <- getUUID
|
||||||
us <- filter (/= u) . M.keys <$> uuidMap
|
us <- filter (/= u) . M.keys <$> uuidDescMap
|
||||||
descs <- uuidMap
|
descs <- uuidDescMap
|
||||||
commandActions $ map (start expire (noActOption o) actlog descs) us
|
commandActions $ map (start expire (noActOption o) actlog descs) us
|
||||||
|
|
||||||
start :: Expire -> Bool -> Log Activity -> M.Map UUID String -> UUID -> CommandStart
|
start :: Expire -> Bool -> Log Activity -> UUIDDescMap -> UUID -> CommandStart
|
||||||
start (Expire expire) noact actlog descs u =
|
start (Expire expire) noact actlog descs u =
|
||||||
case lastact of
|
case lastact of
|
||||||
Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do
|
Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do
|
||||||
|
@ -75,7 +75,7 @@ start (Expire expire) noact actlog descs u =
|
||||||
d <- liftIO $ durationSince $ posixSecondsToUTCTime c
|
d <- liftIO $ durationSince $ posixSecondsToUTCTime c
|
||||||
return $ "last active: " ++ fromDuration d ++ " ago"
|
return $ "last active: " ++ fromDuration d ++ " ago"
|
||||||
_ -> return "no activity"
|
_ -> return "no activity"
|
||||||
desc = fromUUID u ++ " " ++ fromMaybe "" (M.lookup u descs)
|
desc = fromUUID u ++ " " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs))
|
||||||
notexpired ent = case ent of
|
notexpired ent = case ent of
|
||||||
Unknown -> False
|
Unknown -> False
|
||||||
VectorClock c -> case lookupexpire of
|
VectorClock c -> case lookupexpire of
|
||||||
|
|
|
@ -326,7 +326,7 @@ repository_mode = simpleStat "repository mode" $ lift $
|
||||||
repo_list :: TrustLevel -> Stat
|
repo_list :: TrustLevel -> Stat
|
||||||
repo_list level = stat n $ nojson $ lift $ do
|
repo_list level = stat n $ nojson $ lift $ do
|
||||||
us <- filter (/= NoUUID) . M.keys
|
us <- filter (/= NoUUID) . M.keys
|
||||||
<$> (M.union <$> uuidMap <*> remoteMap Remote.name)
|
<$> (M.union <$> (M.map fromUUIDDesc <$> uuidDescMap) <*> remoteMap Remote.name)
|
||||||
rs <- fst <$> trustPartition level us
|
rs <- fst <$> trustPartition level us
|
||||||
countRepoList (length rs)
|
countRepoList (length rs)
|
||||||
-- This also handles json display.
|
-- This also handles json display.
|
||||||
|
|
|
@ -59,6 +59,6 @@ perform t name c = do
|
||||||
|
|
||||||
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup
|
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup
|
||||||
cleanup u name c = do
|
cleanup u name c = do
|
||||||
describeUUID u name
|
describeUUID u (toUUIDDesc name)
|
||||||
Logs.Remote.configSet u c
|
Logs.Remote.configSet u c
|
||||||
return True
|
return True
|
||||||
|
|
|
@ -61,10 +61,10 @@ getList o
|
||||||
let l = (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts
|
let l = (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts
|
||||||
return $ filter (\(_, _, t) -> t /= DeadTrusted) l
|
return $ filter (\(_, _, t) -> t /= DeadTrusted) l
|
||||||
getAllUUIDs = do
|
getAllUUIDs = do
|
||||||
rs <- M.toList <$> uuidMap
|
rs <- M.toList <$> uuidDescMap
|
||||||
rs3 <- forM rs $ \(u, n) -> (,,)
|
rs3 <- forM rs $ \(u, d) -> (,,)
|
||||||
<$> pure u
|
<$> pure u
|
||||||
<*> pure n
|
<*> pure (fromUUIDDesc d)
|
||||||
<*> lookupTrust u
|
<*> lookupTrust u
|
||||||
return $ sortBy (comparing snd3) $
|
return $ sortBy (comparing snd3) $
|
||||||
filter (\t -> thd3 t /= DeadTrusted) rs3
|
filter (\t -> thd3 t /= DeadTrusted) rs3
|
||||||
|
|
|
@ -150,13 +150,13 @@ showLog outputter cs = forM_ cs $ \c -> do
|
||||||
sequence_ $ compareChanges (outputter keyname)
|
sequence_ $ compareChanges (outputter keyname)
|
||||||
[(changetime c, new, old)]
|
[(changetime c, new, old)]
|
||||||
|
|
||||||
mkOutputter :: M.Map UUID String -> TimeZone -> LogOptions -> FilePath -> Outputter
|
mkOutputter :: UUIDDescMap -> TimeZone -> LogOptions -> FilePath -> Outputter
|
||||||
mkOutputter m zone o file
|
mkOutputter m zone o file
|
||||||
| rawDateOption o = normalOutput lookupdescription file show
|
| rawDateOption o = normalOutput lookupdescription file show
|
||||||
| gourceOption o = gourceOutput lookupdescription file
|
| gourceOption o = gourceOutput lookupdescription file
|
||||||
| otherwise = normalOutput lookupdescription file (showTimeStamp zone)
|
| otherwise = normalOutput lookupdescription file (showTimeStamp zone)
|
||||||
where
|
where
|
||||||
lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m
|
lookupdescription u = maybe (fromUUID u) (fromUUIDDesc) (M.lookup u m)
|
||||||
|
|
||||||
normalOutput :: (UUID -> String) -> FilePath -> (POSIXTime -> String) -> Outputter
|
normalOutput :: (UUID -> String) -> FilePath -> (POSIXTime -> String) -> Outputter
|
||||||
normalOutput lookupdescription file formattime logchange ts us =
|
normalOutput lookupdescription file formattime logchange ts us =
|
||||||
|
|
|
@ -43,7 +43,7 @@ start :: CommandStart
|
||||||
start = do
|
start = do
|
||||||
rs <- combineSame <$> (spider =<< gitRepo)
|
rs <- combineSame <$> (spider =<< gitRepo)
|
||||||
|
|
||||||
umap <- uuidMap
|
umap <- uuidDescMap
|
||||||
trustmap <- trustMapLoad
|
trustmap <- trustMapLoad
|
||||||
|
|
||||||
file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"
|
file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"
|
||||||
|
@ -79,7 +79,7 @@ runViewer file ((c, ps):rest) = ifM (liftIO $ inPath c)
|
||||||
- the repositories first, followed by uuids that were not matched
|
- the repositories first, followed by uuids that were not matched
|
||||||
- to a repository.
|
- to a repository.
|
||||||
-}
|
-}
|
||||||
drawMap :: [RepoRemotes] -> TrustMap -> M.Map UUID String -> String
|
drawMap :: [RepoRemotes] -> TrustMap -> UUIDDescMap -> String
|
||||||
drawMap rs trustmap umap = Dot.graph $ repos ++ others
|
drawMap rs trustmap umap = Dot.graph $ repos ++ others
|
||||||
where
|
where
|
||||||
repos = map (node umap (map fst rs) trustmap) rs
|
repos = map (node umap (map fst rs) trustmap) rs
|
||||||
|
@ -88,7 +88,9 @@ drawMap rs trustmap umap = Dot.graph $ repos ++ others
|
||||||
filter (\u -> M.lookup u trustmap /= Just DeadTrusted) $
|
filter (\u -> M.lookup u trustmap /= Just DeadTrusted) $
|
||||||
filter (`notElem` ruuids) (M.keys umap)
|
filter (`notElem` ruuids) (M.keys umap)
|
||||||
uuidnode u = trustDecorate trustmap u $
|
uuidnode u = trustDecorate trustmap u $
|
||||||
Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap
|
Dot.graphNode
|
||||||
|
(fromUUID u)
|
||||||
|
(fromUUIDDesc $ M.findWithDefault mempty u umap)
|
||||||
|
|
||||||
hostname :: Git.Repo -> String
|
hostname :: Git.Repo -> String
|
||||||
hostname r
|
hostname r
|
||||||
|
@ -100,10 +102,10 @@ basehostname r = fromMaybe "" $ headMaybe $ splitc '.' $ hostname r
|
||||||
|
|
||||||
{- A name to display for a repo. Uses the name from uuid.log if available,
|
{- A name to display for a repo. Uses the name from uuid.log if available,
|
||||||
- or the remote name if not. -}
|
- or the remote name if not. -}
|
||||||
repoName :: M.Map UUID String -> Git.Repo -> String
|
repoName :: UUIDDescMap -> Git.Repo -> String
|
||||||
repoName umap r
|
repoName umap r
|
||||||
| repouuid == NoUUID = fallback
|
| repouuid == NoUUID = fallback
|
||||||
| otherwise = M.findWithDefault fallback repouuid umap
|
| otherwise = maybe fallback fromUUIDDesc $ M.lookup repouuid umap
|
||||||
where
|
where
|
||||||
repouuid = getUncachedUUID r
|
repouuid = getUncachedUUID r
|
||||||
fallback = fromMaybe "unknown" $ Git.remoteName r
|
fallback = fromMaybe "unknown" $ Git.remoteName r
|
||||||
|
@ -116,7 +118,7 @@ nodeId r =
|
||||||
u@(UUID _) -> fromUUID u
|
u@(UUID _) -> fromUUID u
|
||||||
|
|
||||||
{- A node representing a repo. -}
|
{- A node representing a repo. -}
|
||||||
node :: M.Map UUID String -> [Git.Repo] -> TrustMap -> RepoRemotes -> String
|
node :: UUIDDescMap -> [Git.Repo] -> TrustMap -> RepoRemotes -> String
|
||||||
node umap fullinfo trustmap (r, rs) = unlines $ n:edges
|
node umap fullinfo trustmap (r, rs) = unlines $ n:edges
|
||||||
where
|
where
|
||||||
n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
|
n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
|
||||||
|
@ -125,7 +127,7 @@ node umap fullinfo trustmap (r, rs) = unlines $ n:edges
|
||||||
edges = map (edge umap fullinfo r) rs
|
edges = map (edge umap fullinfo r) rs
|
||||||
|
|
||||||
{- An edge between two repos. The second repo is a remote of the first. -}
|
{- An edge between two repos. The second repo is a remote of the first. -}
|
||||||
edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
|
edge :: UUIDDescMap -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
|
||||||
edge umap fullinfo from to =
|
edge umap fullinfo from to =
|
||||||
Dot.graphEdge (nodeId from) (nodeId fullto) edgename
|
Dot.graphEdge (nodeId from) (nodeId fullto) edgename
|
||||||
where
|
where
|
||||||
|
|
|
@ -296,8 +296,8 @@ commit o = stopUnless shouldcommit $ next $ next $ do
|
||||||
commitMsg :: Annex String
|
commitMsg :: Annex String
|
||||||
commitMsg = do
|
commitMsg = do
|
||||||
u <- getUUID
|
u <- getUUID
|
||||||
m <- uuidMap
|
m <- uuidDescMap
|
||||||
return $ "git-annex in " ++ fromMaybe "unknown" (M.lookup u m)
|
return $ "git-annex in " ++ maybe "unknown" fromUUIDDesc (M.lookup u m)
|
||||||
|
|
||||||
commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool
|
commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool
|
||||||
commitStaged commitmode commitmessage = do
|
commitStaged commitmode commitmessage = do
|
||||||
|
|
|
@ -129,7 +129,7 @@ diffCfg curcfg newcfg = Cfg
|
||||||
diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
|
diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
|
||||||
(f newcfg) (f curcfg)
|
(f newcfg) (f curcfg)
|
||||||
|
|
||||||
genCfg :: Cfg -> M.Map UUID String -> String
|
genCfg :: Cfg -> UUIDDescMap -> String
|
||||||
genCfg cfg descs = unlines $ intercalate [""]
|
genCfg cfg descs = unlines $ intercalate [""]
|
||||||
[ intro
|
[ intro
|
||||||
, trust
|
, trust
|
||||||
|
@ -223,7 +223,7 @@ genCfg cfg descs = unlines $ intercalate [""]
|
||||||
gline g val = [ unwords ["config", g, "=", val] ]
|
gline g val = [ unwords ["config", g, "=", val] ]
|
||||||
|
|
||||||
line setting u val =
|
line setting u val =
|
||||||
[ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")"
|
[ com $ "(for " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) ++ ")"
|
||||||
, unwords [setting, fromUUID u, "=", val]
|
, unwords [setting, fromUUID u, "=", val]
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -235,7 +235,7 @@ genCfg cfg descs = unlines $ intercalate [""]
|
||||||
, line' "numcopies" (show . fromNumCopies <$> cfgNumCopies cfg)
|
, line' "numcopies" (show . fromNumCopies <$> cfgNumCopies cfg)
|
||||||
]
|
]
|
||||||
|
|
||||||
settings :: Ord v => Cfg -> M.Map UUID String -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String]
|
settings :: Ord v => Cfg -> UUIDDescMap -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String]
|
||||||
settings cfg descs = settings' cfg (M.keysSet descs)
|
settings cfg descs = settings' cfg (M.keysSet descs)
|
||||||
|
|
||||||
settings' :: (Ord v, Ord f) => Cfg -> S.Set f -> (Cfg -> M.Map f v) -> [String] -> ((v, f) -> [String]) -> (f -> [String]) -> [String]
|
settings' :: (Ord v, Ord f) => Cfg -> S.Set f -> (Cfg -> M.Map f v) -> [String] -> ((v, f) -> [String]) -> (f -> [String]) -> [String]
|
||||||
|
|
34
Logs/UUID.hs
34
Logs/UUID.hs
|
@ -1,10 +1,4 @@
|
||||||
{- git-annex uuids
|
{- git-annex uuid log
|
||||||
-
|
|
||||||
- Each git repository used by git-annex has an annex.uuid setting that
|
|
||||||
- uniquely identifies that repository.
|
|
||||||
-
|
|
||||||
- UUIDs of remotes are cached in git config, using keys named
|
|
||||||
- remote.<name>.annex-uuid
|
|
||||||
-
|
-
|
||||||
- uuid.log stores a list of known uuids, and their descriptions.
|
- uuid.log stores a list of known uuids, and their descriptions.
|
||||||
-
|
-
|
||||||
|
@ -16,8 +10,8 @@
|
||||||
module Logs.UUID (
|
module Logs.UUID (
|
||||||
uuidLog,
|
uuidLog,
|
||||||
describeUUID,
|
describeUUID,
|
||||||
uuidMap,
|
uuidDescMap,
|
||||||
uuidMapLoad
|
uuidDescMapLoad
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Types.UUID
|
import Types.UUID
|
||||||
|
@ -28,15 +22,16 @@ import qualified Annex.Branch
|
||||||
import Logs
|
import Logs
|
||||||
import Logs.UUIDBased
|
import Logs.UUIDBased
|
||||||
import qualified Annex.UUID
|
import qualified Annex.UUID
|
||||||
|
import Utility.FileSystemEncoding
|
||||||
|
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
|
|
||||||
{- Records a description for a uuid in the log. -}
|
{- Records a description for a uuid in the log. -}
|
||||||
describeUUID :: UUID -> String -> Annex ()
|
describeUUID :: UUID -> UUIDDesc -> Annex ()
|
||||||
describeUUID uuid desc = do
|
describeUUID uuid desc = do
|
||||||
c <- liftIO currentVectorClock
|
c <- liftIO currentVectorClock
|
||||||
Annex.Branch.change uuidLog $
|
Annex.Branch.change uuidLog $
|
||||||
showLog id . changeLog c uuid desc . fixBadUUID . parseLog Just
|
showLog id . changeLog c uuid (fromUUIDDesc desc) . fixBadUUID . parseLog Just
|
||||||
|
|
||||||
{- Temporarily here to fix badly formatted uuid logs generated by
|
{- Temporarily here to fix badly formatted uuid logs generated by
|
||||||
- versions 3.20111105 and 3.20111025.
|
- versions 3.20111105 and 3.20111025.
|
||||||
|
@ -68,19 +63,20 @@ fixBadUUID = M.fromList . map fixup . M.toList
|
||||||
isuuid s = length s == 36 && length (splitc '-' s) == 5
|
isuuid s = length s == 36 && length (splitc '-' s) == 5
|
||||||
|
|
||||||
{- The map is cached for speed. -}
|
{- The map is cached for speed. -}
|
||||||
uuidMap :: Annex UUIDMap
|
uuidDescMap :: Annex UUIDDescMap
|
||||||
uuidMap = maybe uuidMapLoad return =<< Annex.getState Annex.uuidmap
|
uuidDescMap = maybe uuidDescMapLoad return =<< Annex.getState Annex.uuiddescmap
|
||||||
|
|
||||||
{- Read the uuidLog into a simple Map.
|
{- Read the uuidLog into a simple Map.
|
||||||
-
|
-
|
||||||
- The UUID of the current repository is included explicitly, since
|
- The UUID of the current repository is included explicitly, since
|
||||||
- it may not have been described and so otherwise would not appear. -}
|
- it may not have been described and otherwise would not appear. -}
|
||||||
uuidMapLoad :: Annex UUIDMap
|
uuidDescMapLoad :: Annex UUIDDescMap
|
||||||
uuidMapLoad = do
|
uuidDescMapLoad = do
|
||||||
m <- (simpleMap . parseLog Just) <$> Annex.Branch.get uuidLog
|
m <- (simpleMap . parseLog (Just . UUIDDesc . encodeBS))
|
||||||
|
<$> Annex.Branch.get uuidLog
|
||||||
u <- Annex.UUID.getUUID
|
u <- Annex.UUID.getUUID
|
||||||
let m' = M.insertWith preferold u "" m
|
let m' = M.insertWith preferold u mempty m
|
||||||
Annex.changeState $ \s -> s { Annex.uuidmap = Just m' }
|
Annex.changeState $ \s -> s { Annex.uuiddescmap = Just m' }
|
||||||
return m'
|
return m'
|
||||||
where
|
where
|
||||||
preferold = flip const
|
preferold = flip const
|
||||||
|
|
34
Remote.hs
34
Remote.hs
|
@ -1,10 +1,12 @@
|
||||||
{- git-annex remotes
|
{- git-annex remotes
|
||||||
-
|
-
|
||||||
- Copyright 2011-2018 Joey Hess <id@joeyh.name>
|
- Copyright 2011-2019 Joey Hess <id@joeyh.name>
|
||||||
-
|
-
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Remote (
|
module Remote (
|
||||||
Remote,
|
Remote,
|
||||||
uuid,
|
uuid,
|
||||||
|
@ -57,6 +59,7 @@ module Remote (
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Ord
|
import Data.Ord
|
||||||
|
import Data.String
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
|
|
||||||
|
@ -73,6 +76,7 @@ import Config
|
||||||
import Config.DynamicConfig
|
import Config.DynamicConfig
|
||||||
import Git.Types (RemoteName)
|
import Git.Types (RemoteName)
|
||||||
import Utility.Aeson
|
import Utility.Aeson
|
||||||
|
import Utility.FileSystemEncoding
|
||||||
|
|
||||||
{- Map from UUIDs of Remotes to a calculated value. -}
|
{- Map from UUIDs of Remotes to a calculated value. -}
|
||||||
remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
|
remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
|
||||||
|
@ -92,13 +96,16 @@ remoteMap' mkv mkk = M.fromList . catMaybes <$> (mapM mk =<< remoteList)
|
||||||
{- Map of UUIDs of repositories and their descriptions.
|
{- Map of UUIDs of repositories and their descriptions.
|
||||||
- The names of Remotes are added to suppliment any description that has
|
- The names of Remotes are added to suppliment any description that has
|
||||||
- been set for a repository. -}
|
- been set for a repository. -}
|
||||||
uuidDescriptions :: Annex (M.Map UUID String)
|
uuidDescriptions :: Annex UUIDDescMap
|
||||||
uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name
|
uuidDescriptions = M.unionWith addName
|
||||||
|
<$> uuidDescMap
|
||||||
|
<*> remoteMap (UUIDDesc . encodeBS . name)
|
||||||
|
|
||||||
addName :: String -> RemoteName -> String
|
{- Add a remote name to its description. -}
|
||||||
|
addName :: (IsString t, Monoid t, Eq t) => t -> t -> t
|
||||||
addName desc n
|
addName desc n
|
||||||
| desc == n || null desc = "[" ++ n ++ "]"
|
| desc == n || desc == mempty = "[" <> n <> "]"
|
||||||
| otherwise = desc ++ " [" ++ n ++ "]"
|
| otherwise = desc <> " [" <> n <> "]"
|
||||||
|
|
||||||
byUUID :: UUID -> Annex (Maybe Remote)
|
byUUID :: UUID -> Annex (Maybe Remote)
|
||||||
byUUID u = headMaybe . filter matching <$> remoteList
|
byUUID u = headMaybe . filter matching <$> remoteList
|
||||||
|
@ -170,8 +177,9 @@ nameToUUID' n = byName' n >>= go
|
||||||
NoUUID -> Left $ noRemoteUUIDMsg r
|
NoUUID -> Left $ noRemoteUUIDMsg r
|
||||||
u -> Right u
|
u -> Right u
|
||||||
go (Left e) = do
|
go (Left e) = do
|
||||||
m <- uuidMap
|
m <- uuidDescMap
|
||||||
return $ case M.keys (M.filter (== n) m) of
|
let descn = UUIDDesc (encodeBS n)
|
||||||
|
return $ case M.keys (M.filter (== descn) m) of
|
||||||
[u] -> Right u
|
[u] -> Right u
|
||||||
[] -> let u = toUUID n
|
[] -> let u = toUUID n
|
||||||
in case M.keys (M.filterWithKey (\k _ -> k == u) m) of
|
in case M.keys (M.filterWithKey (\k _ -> k == u) m) of
|
||||||
|
@ -189,7 +197,7 @@ prettyPrintUUIDs header uuids = do
|
||||||
descm <- uuidDescriptions
|
descm <- uuidDescriptions
|
||||||
prettyPrintUUIDsDescs header descm uuids
|
prettyPrintUUIDsDescs header descm uuids
|
||||||
|
|
||||||
prettyPrintUUIDsDescs :: String -> M.Map UUID RemoteName -> [UUID] -> Annex String
|
prettyPrintUUIDsDescs :: String -> UUIDDescMap -> [UUID] -> Annex String
|
||||||
prettyPrintUUIDsDescs header descm uuids =
|
prettyPrintUUIDsDescs header descm uuids =
|
||||||
prettyPrintUUIDsWith Nothing header descm
|
prettyPrintUUIDsWith Nothing header descm
|
||||||
(const Nothing)
|
(const Nothing)
|
||||||
|
@ -200,7 +208,7 @@ prettyPrintUUIDsWith
|
||||||
:: ToJSON' v
|
:: ToJSON' v
|
||||||
=> Maybe String
|
=> Maybe String
|
||||||
-> String
|
-> String
|
||||||
-> M.Map UUID RemoteName
|
-> UUIDDescMap
|
||||||
-> (v -> Maybe String)
|
-> (v -> Maybe String)
|
||||||
-> [(UUID, Maybe v)]
|
-> [(UUID, Maybe v)]
|
||||||
-> Annex String
|
-> Annex String
|
||||||
|
@ -209,7 +217,7 @@ prettyPrintUUIDsWith optfield header descm showval uuidvals = do
|
||||||
maybeShowJSON $ JSONChunk [(header, V.fromList $ map (jsonify hereu) uuidvals)]
|
maybeShowJSON $ JSONChunk [(header, V.fromList $ map (jsonify hereu) uuidvals)]
|
||||||
return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals
|
return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals
|
||||||
where
|
where
|
||||||
finddescription u = M.findWithDefault "" u descm
|
finddescription u = fromUUIDDesc $ M.findWithDefault mempty u descm
|
||||||
prettify hereu (u, optval)
|
prettify hereu (u, optval)
|
||||||
| not (null d) = addoptval $ fromUUID u ++ " -- " ++ d
|
| not (null d) = addoptval $ fromUUID u ++ " -- " ++ d
|
||||||
| otherwise = addoptval $ fromUUID u
|
| otherwise = addoptval $ fromUUID u
|
||||||
|
@ -237,9 +245,9 @@ prettyListUUIDs :: [UUID] -> Annex [String]
|
||||||
prettyListUUIDs uuids = do
|
prettyListUUIDs uuids = do
|
||||||
hereu <- getUUID
|
hereu <- getUUID
|
||||||
m <- uuidDescriptions
|
m <- uuidDescriptions
|
||||||
return $ map (prettify m hereu) uuids
|
return $ map (fromUUIDDesc . prettify m hereu) uuids
|
||||||
where
|
where
|
||||||
finddescription m u = M.findWithDefault "" u m
|
finddescription m u = M.findWithDefault mempty u m
|
||||||
prettify m hereu u
|
prettify m hereu u
|
||||||
| u == hereu = addName n "here"
|
| u == hereu = addName n "here"
|
||||||
| otherwise = n
|
| otherwise = n
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
module Types.UUID where
|
module Types.UUID where
|
||||||
|
|
||||||
|
@ -13,6 +13,7 @@ import qualified Data.ByteString as B
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import qualified Data.UUID as U
|
import qualified Data.UUID as U
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import Data.String
|
||||||
|
|
||||||
import Utility.FileSystemEncoding
|
import Utility.FileSystemEncoding
|
||||||
import qualified Utility.SimpleProtocol as Proto
|
import qualified Utility.SimpleProtocol as Proto
|
||||||
|
@ -56,7 +57,17 @@ instance ToUUID U.UUID where
|
||||||
isUUID :: String -> Bool
|
isUUID :: String -> Bool
|
||||||
isUUID = isJust . U.fromString
|
isUUID = isJust . U.fromString
|
||||||
|
|
||||||
type UUIDMap = M.Map UUID String
|
-- A description of a UUID.
|
||||||
|
newtype UUIDDesc = UUIDDesc B.ByteString
|
||||||
|
deriving (Eq, Monoid, Semigroup, IsString)
|
||||||
|
|
||||||
|
fromUUIDDesc :: UUIDDesc -> String
|
||||||
|
fromUUIDDesc (UUIDDesc d) = decodeBS d
|
||||||
|
|
||||||
|
toUUIDDesc :: String -> UUIDDesc
|
||||||
|
toUUIDDesc = UUIDDesc . encodeBS
|
||||||
|
|
||||||
|
type UUIDDescMap = M.Map UUID UUIDDesc
|
||||||
|
|
||||||
instance Proto.Serializable UUID where
|
instance Proto.Serializable UUID where
|
||||||
serialize = fromUUID
|
serialize = fromUUID
|
||||||
|
|
Loading…
Reference in a new issue