add a UUID type

Should have done this a long time ago.

Annex/Ssh.hs

@@ -45,9 +45,8 @@ git_annex_shell r command params
 		sshcmd uuid = unwords $
 			shellcmd : (map shellEscape $ toCommand shellopts) ++
 			uuidcheck uuid
-		uuidcheck uuid
-			| null uuid = []
-			| otherwise = ["--uuid", uuid]
+		uuidcheck NoUUID = []
+		uuidcheck (UUID u) = ["--uuid", u]
 
 {- Uses a supplied function (such as boolSystem) to run a git-annex-shell
  - command on a remote.

Annex/UUID.hs

@@ -30,7 +30,7 @@ configkey = "annex.uuid"
 {- Generates a UUID. There is a library for this, but it's not packaged,
  - so use the command line tool. -}
 genUUID :: IO UUID
-genUUID = pOpen ReadFromPipe command params hGetLine
+genUUID = pOpen ReadFromPipe command params $ liftM read . hGetLine
 	where
 		command = SysConfig.uuid
 		params = if command == "uuid"
@@ -50,20 +50,23 @@ getRepoUUID r = do
 	let c = cached g
 	let u = getUncachedUUID r
 	
-	if c /= u && u /= ""
+	if c /= u && u /= NoUUID
 		then do
 			updatecache g u
 			return u
 		else return c
 	where
-		cached g = Git.configGet g cachekey ""
-		updatecache g u = when (g /= r) $ setConfig cachekey u
+		cached g = read $ Git.configGet g cachekey ""
+		updatecache g u = when (g /= r) $ storeUUID cachekey u
 		cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid"
 
 getUncachedUUID :: Git.Repo -> UUID
-getUncachedUUID r = Git.configGet r configkey ""
+getUncachedUUID r = read $ Git.configGet r configkey ""
 
 {- Make sure that the repo has an annex.uuid setting. -}
 prepUUID :: Annex ()
-prepUUID = whenM (null <$> getUUID) $
-	setConfig configkey =<< liftIO genUUID
+prepUUID = whenM ((==) NoUUID <$> getUUID) $
+	storeUUID configkey =<< liftIO genUUID
+
+storeUUID :: String -> UUID -> Annex ()
+storeUUID configfield uuid = setConfig configfield (show uuid)

Command/ConfigList.hs

@@ -21,5 +21,5 @@ seek = [withNothing start]
 start :: CommandStart
 start = do
 	u <- getUUID
-	liftIO $ putStrLn $ "annex.uuid=" ++ u
+	liftIO $ putStrLn $ "annex.uuid=" ++ show u
 	stop

Command/Map.hs

@@ -62,7 +62,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
 		others = map (unreachable . uuidnode) $
 			filter (`notElem` ruuids) (M.keys umap)
 		trusted = map (trustworthy . uuidnode) ts
-		uuidnode u = Dot.graphNode u $ M.findWithDefault "" u umap
+		uuidnode u = Dot.graphNode (show u) $ M.findWithDefault "" u umap
 
 hostname :: Git.Repo -> String
 hostname r
@@ -76,7 +76,7 @@ basehostname r = head $ split "." $ hostname r
  - or the remote name if not. -}
 repoName :: M.Map UUID String -> Git.Repo -> String
 repoName umap r
-	| null repouuid = fallback
+	| repouuid == NoUUID = fallback
 	| otherwise = M.findWithDefault fallback repouuid umap
 	where
 		repouuid = getUncachedUUID r
@@ -86,8 +86,8 @@ repoName umap r
 nodeId :: Git.Repo -> String
 nodeId r =
 	case getUncachedUUID r of
-		"" -> Git.repoLocation r
-		u -> u
+		NoUUID -> Git.repoLocation r
+		UUID u -> u
 
 {- A node representing a repo. -}
 node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String

Logs/Location.hs

@@ -29,16 +29,15 @@ import Logs.Presence
 
 {- Log a change in the presence of a key's value in a repository. -}
 logChange :: Git.Repo -> Key -> UUID -> LogStatus -> Annex ()
-logChange repo key u s
-	| null u = error $
+logChange _ key (UUID u) s = addLog (logFile key) =<< logNow s u
+logChange repo _ NoUUID _ = error $
 	"unknown UUID for " ++ Git.repoDescribe repo ++ 
 	" (have you run git annex init there?)"
-	| otherwise = addLog (logFile key) =<< logNow s u
 
 {- Returns a list of repository UUIDs that, according to the log, have
  - the value of a key. -}
 keyLocations :: Key -> Annex [UUID]
-keyLocations = currentLog . logFile
+keyLocations key = map read <$> (currentLog . logFile) key
 
 {- Finds all keys that have location log information.
  - (There may be duplicate keys in the list.) -}

Logs/Trust.hs

@@ -53,13 +53,12 @@ parseTrust s
 
 {- Changes the trust level for a uuid in the trustLog. -}
 trustSet :: UUID -> TrustLevel -> Annex ()
-trustSet uuid level = do
-	when (null uuid) $
-		error "unknown UUID; cannot modify trust level"
+trustSet uuid@(UUID _) level = do
 	ts <- liftIO $ getPOSIXTime
 	Annex.Branch.change trustLog $
 		showLog show . changeLog ts uuid level . parseLog parseTrust
 	Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
+trustSet NoUUID _ = error "unknown UUID; cannot modify trust level"
 
 {- Partitions a list of UUIDs to those matching a TrustLevel and not. -}
 trustPartition :: TrustLevel -> [UUID] -> Annex ([UUID], [UUID])

Logs/UUIDBased.hs

@@ -50,9 +50,9 @@ showLog :: (a -> String) -> Log a -> String
 showLog shower = unlines . map showpair . M.toList
 	where
 		showpair (k, LogEntry (Date p) v) =
-			unwords [k, shower v, tskey ++ show p]
+			unwords [show k, shower v, tskey ++ show p]
 		showpair (k, LogEntry Unknown v) =
-			unwords [k, shower v]
+			unwords [show k, shower v]
 
 parseLog :: (String -> Maybe a) -> String -> Log a
 parseLog parser = M.fromListWith best . catMaybes . map pair . lines
@@ -61,7 +61,7 @@ parseLog parser = M.fromListWith best . catMaybes . map pair . lines
 			| null ws = Nothing
 			| otherwise = case parser $ unwords info of
 				Nothing -> Nothing
-				Just v -> Just (u, LogEntry c v)
+				Just v -> Just (read u, LogEntry c v)
 			where
 				ws = words line
 				u = head ws
@@ -103,8 +103,8 @@ prop_TimeStamp_sane = Unknown < Date 1
 prop_addLog_sane :: Bool
 prop_addLog_sane = newWins && newestWins
 	where
-		newWins = addLog "foo" (LogEntry (Date 1) "new") l == l2
-		newestWins = addLog "foo" (LogEntry (Date 1) "newest") l2 /= l2
+		newWins = addLog (UUID "foo") (LogEntry (Date 1) "new") l == l2
+		newestWins = addLog (UUID "foo") (LogEntry (Date 1) "newest") l2 /= l2
 
-		l = M.fromList [("foo", LogEntry (Date 0) "old")]
-		l2 = M.fromList [("foo", LogEntry (Date 1) "new")]
+		l = M.fromList [(UUID "foo", LogEntry (Date 0) "old")]
+		l2 = M.fromList [(UUID "foo", LogEntry (Date 1) "new")]

Logs/Web.hs

@@ -21,7 +21,7 @@ type URLString = String
 
 -- Dummy uuid for the whole web. Do not alter.
 webUUID :: UUID
-webUUID = "00000000-0000-0000-0000-000000000001"
+webUUID = UUID "00000000-0000-0000-0000-000000000001"
 
 {- The urls for a key are stored in remote/web/hash/key.log 
  - in the git-annex branch. -}

Remote.hs

@@ -100,7 +100,7 @@ byName' n = do
 		then return $ Left $ "there is no git remote named \"" ++ n ++ "\""
 		else return $ Right $ head match
 	where
-		matching r = n == name r || n == uuid r
+		matching r = n == name r || read n == uuid r
 
 {- Looks up a remote by name (or by UUID, or even by description),
  - and returns its UUID. Finds even remotes that are not configured in
@@ -115,12 +115,13 @@ nameToUUID n = do
 	where
 		byDescription = do
 			m <- uuidMap
-			case M.lookup n $ transform swap m of
+			case M.lookup wantuuid $ transform swap m of
 				Just u -> return $ Just u
-				Nothing -> return $ M.lookup n $ transform double m
+				Nothing -> return $ M.lookup wantuuid $ transform double m
 		transform a = M.fromList . map a . M.toList
 		swap (a, b) = (b, a)
-		double (a, _) = (a, a)
+		double (a, _) = (show a, a)
+		wantuuid = read n
 
 {- Pretty-prints a list of UUIDs of remotes, for human display.
  -
@@ -143,8 +144,8 @@ prettyPrintUUIDs desc uuids = do
 		remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> genList
 		findlog m u = M.findWithDefault "" u m
 		prettify m here u
-			| not (null d) = u ++ " -- " ++ d
-			| otherwise = u
+			| not (null d) = show u ++ " -- " ++ d
+			| otherwise = show u
 			where
 				ishere = here == u
 				n = findlog m u
@@ -153,7 +154,7 @@ prettyPrintUUIDs desc uuids = do
 					| ishere = addname n "here"
 					| otherwise = n
 		jsonify m here u = toJSObject
-			[ ("uuid", toJSON u)
+			[ ("uuid", toJSON $ show u)
 			, ("description", toJSON $ findlog m u)
 			, ("here", toJSON $ here == u)
 			]

Remote/Bup.hs

@@ -161,13 +161,13 @@ storeBupUUID u buprepo = do
 		then do
 			showAction "storing uuid"
 			onBupRemote r boolSystem "git"
-				[Params $ "config annex.uuid " ++ u]
+				[Params $ "config annex.uuid " ++ show u]
 					>>! error "ssh failed"
 		else liftIO $ do
 			r' <- Git.configRead r
 			let olduuid = Git.configGet r' "annex.uuid" ""
 			when (olduuid == "") $
-				Git.run r' "config" [Param "annex.uuid", Param u]
+				Git.run r' "config" [Param "annex.uuid", Param $ show u]
 
 onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
 onBupRemote r a command params = do
@@ -192,8 +192,8 @@ getBupUUID r u
 	| otherwise = liftIO $ do
 		ret <- try $ Git.configRead r
 		case ret of
-			Right r' -> return (Git.configGet r' "annex.uuid" "", r')
-			Left _ -> return ("", r)
+			Right r' -> return (read $ Git.configGet r' "annex.uuid" "", r')
+			Left _ -> return (NoUUID, r)
 
 {- Converts a bup remote path spec into a Git.Repo. There are some
  - differences in path representation between git and bup. -}

Remote/Git.hs

@@ -60,7 +60,7 @@ gen r u _ = do
 	r' <- case (cheap, notignored, u) of
 		(_, False, _) -> return r
 		(True, _, _) -> tryGitConfigRead r
-		(False, _, "") -> tryGitConfigRead r
+		(False, _, NoUUID) -> tryGitConfigRead r
 		_ -> return r
 
 	u' <- getRepoUUID r'

Remote/Helper/Special.hs

@@ -32,7 +32,7 @@ gitConfigSpecialRemote u c k v = do
 	g <- gitRepo
 	liftIO $ do
 		Git.run g "config" [Param (configsetting $ "annex-"++k), Param v]
-		Git.run g "config" [Param (configsetting "annex-uuid"), Param u]
+		Git.run g "config" [Param (configsetting "annex-uuid"), Param $ show u]
 	where
 		remotename = fromJust (M.lookup "name" c)
 		configsetting s = "remote." ++ remotename ++ "." ++ s

Remote/S3real.hs

@@ -64,7 +64,7 @@ s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
 s3Setup u c = handlehost $ M.lookup "host" c
 	where
 		remotename = fromJust (M.lookup "name" c)
-		defbucket = remotename ++ "-" ++ u
+		defbucket = remotename ++ "-" ++ show u
 		defaults = M.fromList
 			[ ("datacenter", "US")
 			, ("storageclass", "STANDARD")

Types.hs

@@ -9,7 +9,7 @@ module Types (
 	Annex,
 	Backend,
 	Key,
-	UUID
+	UUID(..)
 ) where
 
 import Annex

Types/Remote.hs

@@ -15,6 +15,7 @@ import Data.Ord
 
 import qualified Git
 import Types.Key
+import Types.UUID
 
 type RemoteConfig = M.Map String String
 
@@ -25,15 +26,15 @@ data RemoteType a = RemoteType {
 	-- enumerates remotes of this type
 	enumerate :: a [Git.Repo],
 	-- generates a remote of this type
-	generate :: Git.Repo -> String -> Maybe RemoteConfig -> a (Remote a),
+	generate :: Git.Repo -> UUID -> Maybe RemoteConfig -> a (Remote a),
 	-- initializes or changes a remote
-	setup :: String -> RemoteConfig -> a RemoteConfig
+	setup :: UUID -> RemoteConfig -> a RemoteConfig
 }
 
 {- An individual remote. -}
 data Remote a = Remote {
 	-- each Remote has a unique uuid
-	uuid :: String,
+	uuid :: UUID,
 	-- each Remote has a human visible name
 	name :: String,
 	-- Remotes have a use cost; higher is more expensive

Types/UUID.hs

@@ -7,5 +7,15 @@
 
 module Types.UUID where
 
--- might be nice to have a newtype, but lots of stuff treats uuids as strings
-type UUID = String
+-- A UUID is either an arbitrary opaque string, or UUID info may be missing.
+data UUID = NoUUID | UUID String
+	deriving (Eq, Ord)
+
+instance Show UUID where
+	show (UUID u) = u
+	show NoUUID = ""
+
+instance Read UUID where
+	readsPrec _ s
+		| null s = [(NoUUID, "")]
+		| otherwise = [(UUID s, "")]

git-annex-shell.hs

@@ -45,9 +45,9 @@ options = commonOptions ++
 	where
 		check expected = do
 			u <- getUUID
-			when (u /= expected) $ error $
+			when (u /= read expected) $ error $
 				"expected repository UUID " ++ expected
-					++ " but found UUID " ++ u
+					++ " but found UUID " ++ show u
 
 header :: String
 header = "Usage: git-annex-shell [-c] command [parameters ...] [option ..]"

test.hs

@@ -614,7 +614,7 @@ checklocationlog f expected = do
 	case r of
 		Just (k, _) -> do
 			uuids <- annexeval $ Logs.Location.keyLocations k
-			assertEqual ("bad content in location log for " ++ f ++ " key " ++ (show k) ++ " uuid " ++ thisuuid)
+			assertEqual ("bad content in location log for " ++ f ++ " key " ++ (show k) ++ " uuid " ++ show thisuuid)
 				expected (thisuuid `elem` uuids)
 		_ -> assertFailure $ f ++ " failed to look up key"