diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index c5a22d27e6..f86db8193f 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index ae03d06658..a2b055371d 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/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 + _ -> do + let istransfer = repoGroup curr == RepoGroupStandard TransferGroup + m <- liftAnnex readRemoteLog + let repoInfo = getRepoInfo mremote (M.lookup uuid m) + $(widgetFile "configurators/editrepository") where - showform form enctype curr = do - let istransfer = repoGroup curr == RepoGroupStandard TransferGroup - $(widgetFile "configurators/editrepository") - {- 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 #{loc}|] diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index 8e91956227..ff7f741e89 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/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| + + Internet Archive page +$if (not exists) +

+ 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 diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs index 6b35fdf98a..f7d10468b8 100644 --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -163,19 +163,17 @@ 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 - Just "rsync" -> val True EnableRsyncR - Just "directory" -> val False EnableDirectoryR + 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 - Just "S3" -> val True EnableS3R + Just "S3" -> val True EnableS3R #endif - Just "glacier" -> val True EnableGlacierR + Just "glacier" -> val True EnableGlacierR #ifdef WITH_WEBDAV - Just "webdav" -> val True EnableWebDAVR + Just "webdav" -> val True EnableWebDAVR #endif - _ -> Nothing + _ -> Nothing where val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u)) list l = liftAnnex $ do diff --git a/Remote/S3.hs b/Remote/S3.hs index 7df1c2df38..5db5b705da 100644 --- a/Remote/S3.hs +++ b/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 diff --git a/debian/changelog b/debian/changelog index 31c53be58d..c61579885e 100644 --- a/debian/changelog +++ b/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 Thu, 18 Apr 2013 16:22:48 -0400 diff --git a/templates/configurators/editrepository.hamlet b/templates/configurators/editrepository.hamlet index 2639228920..cb48c59732 100644 --- a/templates/configurators/editrepository.hamlet +++ b/templates/configurators/editrepository.hamlet @@ -29,3 +29,7 @@

In a hurry? Feel free to skip this step! You can always come back # and configure this repository later. +

+ Repository information +

+ ^{repoInfo}