add per-remote-type info

Now `git annex info $remote` shows info specific to the type of the remote,
for example, it shows the rsync url.

Remote types that support encryption or chunking also include that in their
info.

This commit was sponsored by Ævar Arnfjörð Bjarmason.

Command/Info.hs

@@ -125,7 +125,8 @@ fileInfo file k = showCustom (unwords ["info", file]) $ do
 
 remoteInfo :: Remote -> Annex ()
 remoteInfo r = showCustom (unwords ["info", Remote.name r]) $ do
-	evalStateT (mapM_ showStat (remote_stats r)) emptyStatInfo
+	info <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r
+	evalStateT (mapM_ showStat (remote_stats r ++ info)) emptyStatInfo
 	return True
 
 selStats :: [Stat] -> [Stat] -> Annex [Stat]
@@ -179,16 +180,21 @@ file_stats f k =
 	]
 
 remote_stats :: Remote -> [Stat]
-remote_stats r =
+remote_stats r = map (\s -> s r)
-	[ remote_name r
+	[ remote_name
-	, remote_description r
+	, remote_description
-	, remote_uuid r
+	, remote_uuid
-	, remote_cost r
+	, remote_cost
+	, remote_type
 	]
 
 stat :: String -> (String -> StatState String) -> Stat
 stat desc a = return $ Just (desc, a desc)
 
+-- The json simply contains the same string that is displayed.
+simpleStat :: String -> StatState String -> Stat
+simpleStat desc getval = stat desc $ json id getval
+
 nostat :: Stat
 nostat = return Nothing
 
@@ -209,7 +215,7 @@ showStat s = maybe noop calc =<< s
 		lift . showRaw =<< a
 
 repository_mode :: Stat
-repository_mode = stat "repository mode" $ json id $ lift $
+repository_mode = simpleStat "repository mode" $ lift $
 	ifM isDirect 
 		( return "direct", return "indirect" )
 
@@ -223,32 +229,36 @@ remote_list level = stat n $ nojson $ lift $ do
 	n = showTrustLevel level ++ " repositories"
 	
 dir_name :: FilePath -> Stat
-dir_name dir = stat "directory" $ json id $ pure dir
+dir_name dir = simpleStat "directory" $ pure dir
 
 file_name :: FilePath -> Stat
-file_name file = stat "file" $ json id $ pure file
+file_name file = simpleStat "file" $ pure file
 
 remote_name :: Remote -> Stat
-remote_name r = stat "remote" $ json id $ pure (Remote.name r)
+remote_name r = simpleStat "remote" $ pure (Remote.name r)
 
 remote_description :: Remote -> Stat
-remote_description r = stat "description" $ json id $ lift $
+remote_description r = simpleStat "description" $ lift $
 	Remote.prettyUUID (Remote.uuid r)
 
 remote_uuid :: Remote -> Stat
-remote_uuid r = stat "uuid" $ json id $ pure $
+remote_uuid r = simpleStat "uuid" $ pure $
 	fromUUID $ Remote.uuid r
 
 remote_cost :: Remote -> Stat
-remote_cost r = stat "cost" $ json id $ pure $
+remote_cost r = simpleStat "cost" $ pure $
 	show $ Remote.cost r
 
+remote_type :: Remote -> Stat
+remote_type r = simpleStat "type" $ pure $
+	Remote.typename $ Remote.remotetype r
+
 local_annex_keys :: Stat
 local_annex_keys = stat "local annex keys" $ json show $
 	countKeys <$> cachedPresentData
 
 local_annex_size :: Stat
-local_annex_size = stat "local annex size" $ json id $
+local_annex_size = simpleStat "local annex size" $
 	showSizeKeys <$> cachedPresentData
 
 known_annex_files :: Stat
@@ -256,7 +266,7 @@ known_annex_files = stat "annexed files in working tree" $ json show $
 	countKeys <$> cachedReferencedData
 
 known_annex_size :: Stat
-known_annex_size = stat "size of annexed files in working tree" $ json id $
+known_annex_size = simpleStat "size of annexed files in working tree" $
 	showSizeKeys <$> cachedReferencedData
 
 tmp_size :: Stat
@@ -266,13 +276,13 @@ bad_data_size :: Stat
 bad_data_size = staleSize "bad keys size" gitAnnexBadDir
 
 key_size :: Key -> Stat
-key_size k = stat "size" $ json id $ pure $ showSizeKeys $ foldKeys [k]
+key_size k = simpleStat "size" $ pure $ showSizeKeys $ foldKeys [k]
 
 key_name :: Key -> Stat
-key_name k = stat "key" $ json id $ pure $ key2file k
+key_name k = simpleStat "key" $ pure $ key2file k
 
 bloom_info :: Stat
-bloom_info = stat "bloom filter size" $ json id $ do
+bloom_info = simpleStat "bloom filter size" $ do
 	localkeys <- countKeys <$> cachedPresentData
 	capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
 	let note = aside $
@@ -305,7 +315,7 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do
 		]
 
 disk_size :: Stat
-disk_size = stat "available local disk space" $ json id $ lift $
+disk_size = simpleStat "available local disk space" $ lift $
 	calcfree
 		<$> (annexDiskReserve <$> Annex.getGitConfig)
 		<*> inRepo (getDiskFree . gitAnnexDir)

Remote/Bup.hs

@@ -73,6 +73,7 @@ gen r u c gc = do
 		, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
 		, readonly = False
 		, mkUnavailable = return Nothing
+		, getInfo = return [("repo", buprepo)]
 		}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this buprepo)

Remote/Ddar.hs

@@ -70,6 +70,7 @@ gen r u c gc = do
 		, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
 		, readonly = False
 		, mkUnavailable = return Nothing
+		, getInfo = return [("repo", ddarrepo)]
 		}
 	ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
 	specialcfg = (specialRemoteCfg c)

Remote/Directory.hs

@@ -67,7 +67,8 @@ gen r u c gc = do
 			availability = LocallyAvailable,
 			remotetype = remote,
 			mkUnavailable = gen r u c $
-				gc { remoteAnnexDirectory = Just "/dev/null" }
+				gc { remoteAnnexDirectory = Just "/dev/null" },
+			getInfo = return [("directory", dir)]
 		}
   where
 	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc

Remote/External.hs

@@ -68,6 +68,7 @@ gen r u c gc = do
 			remotetype = remote,
 			mkUnavailable = gen r u c $
 				gc { remoteAnnexExternalType = Just "!dne!" }
+			, getInfo = return [("externaltype", externaltype)]
 		}
   where
 	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)

Remote/GCrypt.hs

@@ -121,6 +121,7 @@ gen' r u c gc = do
 		, availability = availabilityCalc r
 		, remotetype = remote
 		, mkUnavailable = return Nothing
+		, getInfo = return $ gitRepoInfo r
 	}
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store this rsyncopts)

Remote/Git.hs

@@ -159,6 +159,7 @@ gen r u c gc
 			, availability = availabilityCalc r
 			, remotetype = remote
 			, mkUnavailable = unavailable r u c gc
+			, getInfo = return $ gitRepoInfo r
 			}
 
 unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)

Remote/Glacier.hs

@@ -66,7 +66,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			readonly = False,
 			availability = GloballyAvailable,
 			remotetype = remote,
-			mkUnavailable = return Nothing
+			mkUnavailable = return Nothing,
+			getInfo = return [("glacier vault", getVault c)]
 		}
 	specialcfg = (specialRemoteCfg c)
 		-- Disabled until jobList gets support for chunks.

Remote/Helper/Chunked.hs

@@ -8,6 +8,7 @@
 module Remote.Helper.Chunked (
 	ChunkSize,
 	ChunkConfig(..),
+	describeChunkConfig,
 	getChunkConfig,
 	storeChunks,
 	removeChunks,
@@ -34,6 +35,14 @@ data ChunkConfig
 	| LegacyChunks ChunkSize
 	deriving (Show)
 
+describeChunkConfig :: ChunkConfig -> String
+describeChunkConfig NoChunks = "none"
+describeChunkConfig (UnpaddedChunks sz) = describeChunkSize sz ++ "chunks"
+describeChunkConfig (LegacyChunks sz) = describeChunkSize sz ++ " chunks (old style)"
+
+describeChunkSize :: ChunkSize -> String
+describeChunkSize sz = roughSize storageUnits False (fromIntegral sz)
+
 noChunks :: ChunkConfig -> Bool
 noChunks NoChunks = True
 noChunks _ = False

Remote/Helper/Encryptable.hs

@@ -16,6 +16,7 @@ module Remote.Helper.Encryptable (
 	cipherKey,
 	storeCipher,
 	extractCipher,
+	describeEncryption,
 ) where
 
 import qualified Data.Map as M
@@ -157,3 +158,10 @@ extractCipher c = case (M.lookup "cipher" c,
 	_ -> Nothing
   where
 	readkeys = KeyIds . split ","
+
+describeEncryption :: RemoteConfig -> String
+describeEncryption c = case extractCipher c of
+	Nothing -> "not encrypted"
+	(Just (SharedCipher _)) -> "encrypted (encryption key stored in git repository)"
+	(Just (EncryptedCipher _ _ (KeyIds { keyIds = ks }))) ->
+		"encrypted (to gpg keys: " ++ unwords ks ++ ")"

Remote/Helper/Git.hs

@@ -30,3 +30,8 @@ guardUsable :: Git.Repo -> Annex a -> Annex a -> Annex a
 guardUsable r fallback a
 	| Git.repoIsLocalUnknown r = fallback
 	| otherwise = a
+
+gitRepoInfo :: Git.Repo -> [(String, String)]
+gitRepoInfo r =
+	[ ("repository location", Git.repoLocation r)
+	]

Remote/Helper/Special.hs

@@ -168,6 +168,12 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
 			(cost baser)
 			(const $ cost baser + encryptedRemoteCostAdj)
 			(extractCipher c)
+		, getInfo = do
+			l <- getInfo baser
+			return $ l ++
+				[ ("encryption", describeEncryption c)
+				, ("chunking", describeChunkConfig (chunkConfig cfg))
+				]
 		}
 	cip = cipherKey c
 	gpgopts = getGpgEncParams encr

Remote/Hook.hs

@@ -60,7 +60,8 @@ gen r u c gc = do
 			availability = GloballyAvailable,
 			remotetype = remote,
 			mkUnavailable = gen r u c $
-				gc { remoteAnnexHookType = Just "!dne!" }
+				gc { remoteAnnexHookType = Just "!dne!" },
+			getInfo = return [("hooktype", hooktype)]
 		}
   where
 	hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc

Remote/Rsync.hs

@@ -83,6 +83,7 @@ gen r u c gc = do
 			, availability = if islocal then LocallyAvailable else GloballyAvailable
 			, remotetype = remote
 			, mkUnavailable = return Nothing
+			, getInfo = return [("url", url)]
 			}
   where
 	specialcfg = (specialRemoteCfg c)

Remote/S3.hs

@@ -71,7 +71,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			readonly = False,
 			availability = GloballyAvailable,
 			remotetype = remote,
-			mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
+			mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc,
+			getInfo = return [("bucket", fromMaybe "unknown" (getBucket c))]
 		}
 
 s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)

Remote/Tahoe.hs

@@ -84,7 +84,8 @@ gen r u c gc = do
 		readonly = False,
 		availability = GloballyAvailable,
 		remotetype = remote,
-		mkUnavailable = return Nothing
+		mkUnavailable = return Nothing,
+		getInfo = return []
 	}
 
 tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)

Remote/Web.hs

@@ -62,7 +62,8 @@ gen r _ c gc =
 		readonly = True,
 		availability = GloballyAvailable,
 		remotetype = remote,
-		mkUnavailable = return Nothing
+		mkUnavailable = return Nothing,
+		getInfo = return []
 	}
 
 downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool

Remote/WebDAV.hs

@@ -71,7 +71,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			readonly = False,
 			availability = GloballyAvailable,
 			remotetype = remote,
-			mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
+			mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc,
+			getInfo = return [("url", fromMaybe "unknown" (M.lookup "url" c))]
 		}
 		chunkconfig = getChunkConfig c
 

Types/Remote.hs

@@ -98,7 +98,9 @@ data RemoteA a = Remote {
 	remotetype :: RemoteTypeA a,
 	-- For testing, makes a version of this remote that is not
 	-- available for use. All its actions should fail.
-	mkUnavailable :: a (Maybe (RemoteA a))
+	mkUnavailable :: a (Maybe (RemoteA a)),
+	-- Information about the remote, for git annex info to display.
+	getInfo :: a [(String, String)]
 }
 
 instance Show (RemoteA a) where

doc/git-annex.mdwn

@@ -679,8 +679,8 @@ subdirectories).
 * `info [directory|file|remote ...]`
 
   Displays statistics and other information for the specified item,
-  which can be a directory, or a file, or a remote (specified by name or
+  which can be a directory, or a file, or a remote.
-  UUID). When no item is specified, displays statistics and information
+  When no item is specified, displays statistics and information
   for the repository as a whole.
 
   When a directory is specified, the file matching options can be used