webapp: Display some additional information about a repository on its edit page.

Assistant/WebApp/Configurators/AWS.hs

@@ -208,3 +208,8 @@ makeAWSRemote remotetype (AWSCreds ak sk) name setup config = do
 	hostname = case filter isAlphaNum name of
 		[] -> "aws"
 		n -> n
+
+getRepoInfo :: RemoteConfig -> Widget
+getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
+  where
+	bucket = fromMaybe "" $ M.lookup "bucket" c

Assistant/WebApp/Configurators/Edit.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
 
 module Assistant.WebApp.Configurators.Edit where
 
@@ -15,12 +15,18 @@ import Assistant.DaemonStatus
 import Assistant.MakeRemote (uniqueRemoteName)
 import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
 import Assistant.ScanRemotes
+import qualified Assistant.WebApp.Configurators.AWS as AWS
+import qualified Assistant.WebApp.Configurators.IA as IA
+#ifdef WITH_S3
+import qualified Remote.S3 as S3
+#endif
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Remote.List as Remote
 import Logs.UUID
 import Logs.Group
 import Logs.PreferredContent
+import Logs.Remote
 import Types.StandardGroups
 import qualified Git
 import qualified Git.Command
@@ -155,12 +161,12 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
 			checkdirectories input
 			setRepoConfig uuid mremote curr input
 			redirect DashboardR
-		_ -> showform form enctype curr
-  where
-	showform form enctype curr = do
+		_ -> do
 			let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
+			m <- liftAnnex readRemoteLog
+			let repoInfo = getRepoInfo mremote (M.lookup uuid m)
 			$(widgetFile "configurators/editrepository")
-
+  where
 	{- Makes a toplevel archive or public directory, so the user can
 	 - get on with using it. This is done both when displaying the form,
 	 - as well as after it's posted, because the user may not post the form,
@@ -175,3 +181,21 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
 		go d = liftAnnex $ inRepo $ \g ->
 			createDirectoryIfMissing True $
 				Git.repoPath g </> d
+
+getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
+getRepoInfo (Just r) (Just c) = case M.lookup "type" c of
+	Just "S3"
+#ifdef WITH_S3
+		| S3.isIA c -> IA.getRepoInfo c
+#endif
+		| otherwise -> AWS.getRepoInfo c
+	Just t
+		| t /= "git" -> [whamlet|#{t} remote|]
+	_ -> getGitRepoInfo $ Remote.repo r
+getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r)
+getRepoInfo _ _ = [whamlet|git repository|]
+
+getGitRepoInfo :: Git.Repo -> Widget
+getGitRepoInfo r = do
+	let loc = Git.repoLocation r
+	[whamlet|git repository located at <tt>#{loc}</tt>|]

Assistant/WebApp/Configurators/IA.hs

@@ -16,8 +16,10 @@ import qualified Remote.S3 as S3
 #endif
 import qualified Remote
 import Types.StandardGroups
+import Types.Remote (RemoteConfig)
 import Logs.PreferredContent
 import Logs.Remote
+import qualified Utility.Url as Url
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -163,3 +165,22 @@ escapeBucket = map toLower . replace " " ""
 {- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -}
 escapeHeader :: String -> String
 escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')
+
+getRepoInfo :: RemoteConfig -> Widget
+getRepoInfo c = do
+	exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url []
+	[whamlet|
+<a href="#{url}">
+  Internet Archive page
+$if (not exists)
+  <p>
+    The page will only appear once some files #
+    have been uploaded, and the Internet Archive has processed them.
+|]
+  where
+  	bucket = fromMaybe "" $ M.lookup "bucket" c
+#ifdef WITH_S3
+	url = S3.iaItemUrl bucket
+#else
+	url = ""
+#endif

Assistant/WebApp/RepoList.hs

@@ -163,9 +163,7 @@ repoList reposelector
 	selectedremote (Just (iscloud, _))
 		| onlyCloud reposelector = iscloud
 		| otherwise = True
-	findinfo m u = case M.lookup u m of
-		Nothing -> Nothing
-		Just c -> case M.lookup "type" c of
+	findinfo m u = case M.lookup "type" =<< M.lookup u m of
 		Just "rsync" -> val True EnableRsyncR
 		Just "directory" -> val False EnableDirectoryR
 #ifdef WITH_S3

Remote/S3.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Remote.S3 (remote, iaHost, isIAHost) where
+module Remote.S3 (remote, iaHost, isIA, isIAHost, iaItemUrl) where
 
 import Network.AWS.AWSConnection
 import Network.AWS.S3Object
@@ -283,3 +283,6 @@ isIA c = maybe False isIAHost (M.lookup "host" c)
 
 isIAHost :: HostName -> Bool
 isIAHost h = ".archive.org" `isSuffixOf` map toLower h
+
+iaItemUrl :: String -> String
+iaItemUrl bucket = "http://archive.org/details/" ++ bucket

debian/changelog

@@ -35,6 +35,8 @@ git-annex (4.20130418) UNRELEASED; urgency=low
   * webapp: Can now set up Internet Archive repositories.
   * S3: Dropping content from the Internet Archive doesn't work, but
     their API indicates it does. Always refuse to drop from there.
+  * webapp: Display some additional information about a repository on its edit
+    page.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 18 Apr 2013 16:22:48 -0400
 

templates/configurators/editrepository.hamlet

@@ -29,3 +29,7 @@
     <p>
       In a hurry? Feel free to skip this step! You can always come back #
       and configure this repository later.
+  <h3>
+    Repository information
+  <p>
+    ^{repoInfo}