group, ungroup: New commands to indicate groups of repositories.

10 files changed, 174 insertions, 0 deletions

diff --git a/Annex.hs b/Annex.hs
index 32edeff5c..87edb7c13 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -45,6 +45,7 @@ import qualified Types.Remote
 import Types.Crypto
 import Types.BranchState
 import Types.TrustLevel
+import Types.Group
 import Types.Messages
 import Utility.State
 import qualified Utility.Matcher
@@ -92,6 +93,7 @@ data AnnexState = AnnexState
 	, shared :: Maybe SharedRepository
 	, forcetrust :: TrustMap
 	, trustmap :: Maybe TrustMap
+	, groupmap :: Maybe GroupMap
 	, ciphers :: M.Map StorableCipher Cipher
 	, lockpool :: M.Map FilePath Fd
 	, flags :: M.Map String Bool
@@ -118,6 +120,7 @@ newState gitrepo = AnnexState
 	, shared = Nothing
 	, forcetrust = M.empty
 	, trustmap = Nothing
+	, groupmap = Nothing
 	, ciphers = M.empty
 	, lockpool = M.empty
 	, flags = M.empty
diff --git a/Command/Group.hs b/Command/Group.hs
new file mode 100644
index 000000000..2952f2142
--- /dev/null
+++ b/Command/Group.hs
@@ -0,0 +1,35 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Group where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Group
+import Types.Group
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [command "group" (paramPair paramRemote paramDesc) seek "add a repository to a group"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start (name:g:[]) = do
+	showStart "group" name
+	u <- Remote.nameToUUID name
+	next $ perform u g
+start _ = error "Specify a repository and a group."
+
+perform :: UUID -> Group -> CommandPerform
+perform uuid g = do
+	s <- lookupGroups uuid
+	groupSet uuid (S.insert g s) 
+	next $ return True
diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs
new file mode 100644
index 000000000..2161cec91
--- /dev/null
+++ b/Command/Ungroup.hs
@@ -0,0 +1,35 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Ungroup where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Group
+import Types.Group
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [command "ungroup" (paramPair paramRemote paramDesc) seek "remove a repository from a group"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start (name:g:[]) = do
+	showStart "ungroup" name
+	u <- Remote.nameToUUID name
+	next $ perform u g
+start _ = error "Specify a repository and a group."
+
+perform :: UUID -> Group -> CommandPerform
+perform uuid g = do
+	s <- lookupGroups uuid
+	groupSet uuid (S.delete g s) 
+	next $ return True
diff --git a/GitAnnex.hs b/GitAnnex.hs
index c6fc5210f..9b84f5c46 100644
--- a/GitAnnex.hs
+++ b/GitAnnex.hs
@@ -55,6 +55,8 @@ import qualified Command.Trust
 import qualified Command.Untrust
 import qualified Command.Semitrust
 import qualified Command.Dead
+import qualified Command.Group
+import qualified Command.Ungroup
 import qualified Command.Sync
 import qualified Command.AddUrl
 import qualified Command.Import
@@ -92,6 +94,8 @@ cmds = concat
 	, Command.Untrust.def
 	, Command.Semitrust.def
 	, Command.Dead.def
+	, Command.Group.def
+	, Command.Ungroup.def
 	, Command.FromKey.def
 	, Command.DropKey.def
 	, Command.TransferKey.def
diff --git a/Logs/Group.hs b/Logs/Group.hs
new file mode 100644
index 000000000..9263c7760
--- /dev/null
+++ b/Logs/Group.hs
@@ -0,0 +1,52 @@
+{- git-annex group log
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Group (
+	groupSet,
+	lookupGroups,
+	groupMap,
+) where
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Time.Clock.POSIX
+
+import Common.Annex
+import qualified Annex.Branch
+import qualified Annex
+import Logs.UUIDBased
+import Types.Group
+
+{- Filename of group.log. -}
+groupLog :: FilePath
+groupLog = "group.log"
+
+{- Returns the groups of a given repo UUID. -}
+lookupGroups :: UUID -> Annex (S.Set Group)
+lookupGroups u = (fromMaybe S.empty . M.lookup u) <$> groupMap
+
+{- Changes the groups for a uuid in the groupLog. -}
+groupSet :: UUID -> S.Set Group -> Annex ()
+groupSet uuid@(UUID _) groups = do
+	ts <- liftIO getPOSIXTime
+	Annex.Branch.change groupLog $
+		showLog (unwords . S.toList) . changeLog ts uuid groups . 
+			parseLog (Just . S.fromList . words)
+	Annex.changeState $ \s -> s { Annex.groupmap = Nothing }
+groupSet NoUUID _ = error "unknown UUID; cannot modify group"
+
+{- Read the groupLog into a map. The map is cached for speed. -}
+groupMap :: Annex GroupMap
+groupMap = do
+	cached <- Annex.getState Annex.groupmap
+	case cached of
+		Just m -> return m
+		Nothing -> do
+			m <- simpleMap . parseLog (Just . S.fromList . words) <$>
+				Annex.Branch.get groupLog
+			Annex.changeState $ \s -> s { Annex.groupmap = Just m }
+			return m
diff --git a/Types/Group.hs b/Types/Group.hs
new file mode 100644
index 000000000..dd06cbfd7
--- /dev/null
+++ b/Types/Group.hs
@@ -0,0 +1,20 @@
+{- git-annex repo groups
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.Group (
+	Group,
+	GroupMap
+) where
+
+import Types.UUID
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+type Group = String
+
+type GroupMap = M.Map UUID (S.Set Group)
diff --git a/Usage.hs b/Usage.hs
index 04024b165..e411719b0 100644
--- a/Usage.hs
+++ b/Usage.hs
@@ -83,6 +83,8 @@ paramFormat :: String
 paramFormat = "FORMAT"
 paramFile :: String
 paramFile = "FILE"
+paramGroup :: String
+paramGroup = "GROUP"
 paramKeyValue :: String
 paramKeyValue = "K=V"
 paramNothing :: String
diff --git a/debian/changelog b/debian/changelog
index a82ef7ebc..57da10688 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+git-annex (3.20121002) UNRELEASED; urgency=low
+
+  * group, ungroup: New commands to indicate groups of repositories.
+
+ -- Joey Hess <joeyh@debian.org>  Mon, 01 Oct 2012 15:09:49 -0400
+
 git-annex (3.20121001) unstable; urgency=low
 
   * fsck: Now has an incremental mode. Start a new incremental fsck pass
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index c1bbb8259..50de5e389 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -248,6 +248,15 @@ subdirectories).
   Indicates that the repository has been irretrevably lost.
   (To undo, use semitrust.)
 
+* group repository groupname
+
+  Adds a repository to a group, such as "archival", "enduser", or "transfer".
+  The groupname must be a single word.
+
+* ungroup repository groupname
+
+  Removes a repository from a group.
+
 # REPOSITORY MAINTENANCE COMMANDS
 
 * fsck [path ...]
diff --git a/doc/internals.mdwn b/doc/internals.mdwn
index a69a747e5..26e1d2fc2 100644
--- a/doc/internals.mdwn
+++ b/doc/internals.mdwn
@@ -67,6 +67,14 @@ Example:
 
 Repositories not listed are semi-trusted.
 
+## `group.log`
+
+Used to group repositories together.
+
+The file format is one line per repository, with the uuid followed by a space,
+and then a space-separated list of groups this repository is part of,
+and finally a timestamp.
+
 ## `aaa/bbb/*.log`
 
 These log files record [[location_tracking]] information