webapp: Display some additional information about a repository on its edit page.
This commit is contained in:
parent
3e396a3b89
commit
e3ea36174b
7 changed files with 73 additions and 16 deletions
|
@ -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
|
||||||
|
|
|
@ -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>|]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
2
debian/changelog
vendored
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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}
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue