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

This commit is contained in:
Joey Hess 2013-04-25 16:42:17 -04:00
parent 3e396a3b89
commit e3ea36174b
7 changed files with 73 additions and 16 deletions

View file

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

View file

@ -5,7 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - 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 module Assistant.WebApp.Configurators.Edit where
@ -15,12 +15,18 @@ import Assistant.DaemonStatus
import Assistant.MakeRemote (uniqueRemoteName) import Assistant.MakeRemote (uniqueRemoteName)
import Assistant.WebApp.Configurators.XMPP (xmppNeeded) import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
import Assistant.ScanRemotes 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 Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import qualified Remote.List as Remote import qualified Remote.List as Remote
import Logs.UUID import Logs.UUID
import Logs.Group import Logs.Group
import Logs.PreferredContent import Logs.PreferredContent
import Logs.Remote
import Types.StandardGroups import Types.StandardGroups
import qualified Git import qualified Git
import qualified Git.Command import qualified Git.Command
@ -155,12 +161,12 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
checkdirectories input checkdirectories input
setRepoConfig uuid mremote curr input setRepoConfig uuid mremote curr input
redirect DashboardR 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 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 {- Makes a toplevel archive or public directory, so the user can
- get on with using it. This is done both when displaying the form, - 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, - 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 -> go d = liftAnnex $ inRepo $ \g ->
createDirectoryIfMissing True $ createDirectoryIfMissing True $
Git.repoPath g </> d 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>|]

View file

@ -16,8 +16,10 @@ import qualified Remote.S3 as S3
#endif #endif
import qualified Remote import qualified Remote
import Types.StandardGroups import Types.StandardGroups
import Types.Remote (RemoteConfig)
import Logs.PreferredContent import Logs.PreferredContent
import Logs.Remote import Logs.Remote
import qualified Utility.Url as Url
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M 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. -} {- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -}
escapeHeader :: String -> String escapeHeader :: String -> String
escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ') 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

View file

@ -163,19 +163,17 @@ repoList reposelector
selectedremote (Just (iscloud, _)) selectedremote (Just (iscloud, _))
| onlyCloud reposelector = iscloud | onlyCloud reposelector = iscloud
| otherwise = True | otherwise = True
findinfo m u = case M.lookup u m of findinfo m u = case M.lookup "type" =<< M.lookup u m of
Nothing -> Nothing Just "rsync" -> val True EnableRsyncR
Just c -> case M.lookup "type" c of Just "directory" -> val False EnableDirectoryR
Just "rsync" -> val True EnableRsyncR
Just "directory" -> val False EnableDirectoryR
#ifdef WITH_S3 #ifdef WITH_S3
Just "S3" -> val True EnableS3R Just "S3" -> val True EnableS3R
#endif #endif
Just "glacier" -> val True EnableGlacierR Just "glacier" -> val True EnableGlacierR
#ifdef WITH_WEBDAV #ifdef WITH_WEBDAV
Just "webdav" -> val True EnableWebDAVR Just "webdav" -> val True EnableWebDAVR
#endif #endif
_ -> Nothing _ -> Nothing
where where
val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u)) val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
list l = liftAnnex $ do list l = liftAnnex $ do

View file

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

2
debian/changelog vendored
View file

@ -35,6 +35,8 @@ git-annex (4.20130418) UNRELEASED; urgency=low
* webapp: Can now set up Internet Archive repositories. * webapp: Can now set up Internet Archive repositories.
* S3: Dropping content from the Internet Archive doesn't work, but * S3: Dropping content from the Internet Archive doesn't work, but
their API indicates it does. Always refuse to drop from there. 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 -- Joey Hess <joeyh@debian.org> Thu, 18 Apr 2013 16:22:48 -0400

View file

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