webapp: Show encryption information when editing a remote.

This commit is contained in:
Joey Hess 2013-09-17 20:02:42 -04:00
parent dc15450df6
commit 3d88559e58
7 changed files with 84 additions and 33 deletions

View file

@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators.Edit where
import Assistant.WebApp.Common import Assistant.WebApp.Common
import Assistant.WebApp.Utility import Assistant.WebApp.Utility
import Assistant.WebApp.Gpg
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.MakeRemote (uniqueRemoteName) import Assistant.MakeRemote (uniqueRemoteName)
import Assistant.WebApp.Configurators.XMPP (xmppNeeded) import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
@ -33,6 +34,9 @@ import qualified Git.Command
import qualified Git.Config import qualified Git.Config
import qualified Annex import qualified Annex
import Git.Remote import Git.Remote
import Remote.Helper.Encryptable (extractCipher)
import Types.Crypto
import Utility.Gpg
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
@ -187,8 +191,9 @@ editForm new uuid = page "Edit repository" (Just Configuration) $ do
redirect DashboardR redirect DashboardR
_ -> do _ -> do
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
repoInfo <- getRepoInfo mremote . M.lookup uuid config <- liftAnnex $ M.lookup uuid <$> readRemoteLog
<$> liftAnnex readRemoteLog let repoInfo = getRepoInfo mremote config
let repoEncryption = getRepoEncryption mremote config
$(widgetFile "configurators/editrepository") $(widgetFile "configurators/editrepository")
{- Makes any directory associated with the repository. -} {- Makes any directory associated with the repository. -}
@ -221,3 +226,20 @@ getGitRepoInfo :: Git.Repo -> Widget
getGitRepoInfo r = do getGitRepoInfo r = do
let loc = Git.repoLocation r let loc = Git.repoLocation r
[whamlet|git repository located at <tt>#{loc}</tt>|] [whamlet|git repository located at <tt>#{loc}</tt>|]
getRepoEncryption :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
getRepoEncryption (Just _) (Just c) = case extractCipher c of
Nothing ->
[whamlet|not encrypted|]
(Just (SharedCipher _)) ->
[whamlet|encrypted: encryption key stored in git repository|]
(Just (EncryptedCipher _ _ (KeyIds { keyIds = ks }))) -> do
knownkeys <- liftIO secretKeys
[whamlet|
encrypted using gpg key:
<ul style="list-style: none">
$forall k <- ks
<li>
^{gpgKeyDisplay k (M.lookup k knownkeys)}
|]
getRepoEncryption _ _ = [whamlet||] -- local repo

View file

@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators.Local where
import Assistant.WebApp.Common import Assistant.WebApp.Common
import Assistant.WebApp.OtherRepos import Assistant.WebApp.OtherRepos
import Assistant.WebApp.Gpg
import Assistant.MakeRemote import Assistant.MakeRemote
import Assistant.Sync import Assistant.Sync
import Init import Init
@ -276,13 +277,7 @@ genKeyModal :: Widget
genKeyModal = $(widgetFile "configurators/genkeymodal") genKeyModal = $(widgetFile "configurators/genkeymodal")
getGenKeyForDriveR :: RemovableDrive -> Handler Html getGenKeyForDriveR :: RemovableDrive -> Handler Html
getGenKeyForDriveR drive = do getGenKeyForDriveR drive = withNewSecretKey $ \key -> do
userid <- liftIO $ newUserId
liftIO $ genSecretKey RSA "" userid maxRecommendedKeySize
results <- M.keys . M.filter (== userid) <$> liftIO secretKeys
case results of
[] -> error "Failed to generate gpg key!"
(key:_) -> do
{- Generating a key takes a long time, and {- Generating a key takes a long time, and
- the removable drive may have been disconnected - the removable drive may have been disconnected
- in the meantime. Check that it is still mounted - in the meantime. Check that it is still mounted
@ -292,16 +287,6 @@ getGenKeyForDriveR drive = do
, getAddDriveR , getAddDriveR
) )
newUserId :: IO UserId
newUserId = do
oldkeys <- secretKeys
username <- myUserName
let basekeyname = username ++ " git-annex"
return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
( basekeyname
: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
)
getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
getFinishAddDriveR drive = go getFinishAddDriveR drive = go
where where

47
Assistant/WebApp/Gpg.hs Normal file
View file

@ -0,0 +1,47 @@
{- git-annex webapp gpg stuff
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
module Assistant.WebApp.Gpg where
import Assistant.WebApp.Common
import Utility.Gpg
import Utility.UserInfo
import qualified Data.Map as M
gpgKeyDisplay :: KeyId -> Maybe UserId -> Widget
gpgKeyDisplay keyid userid = [whamlet|
<span title="key id #{keyid}">
<i .icon-user></i> #
^{displayname}
|]
where
displayname = case userid of
Just name | not (null name) -> [whamlet|#{name}|]
_ -> [whamlet|key id #{keyid}|]
{- Generates a gpg user id that is not used by any existing secret key -}
newUserId :: IO UserId
newUserId = do
oldkeys <- secretKeys
username <- myUserName
let basekeyname = username ++ "'s git-annex encryption key"
return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
( basekeyname
: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
)
withNewSecretKey :: (KeyId -> Handler Html) -> Handler Html
withNewSecretKey use = do
userid <- liftIO $ newUserId
liftIO $ genSecretKey RSA "" userid maxRecommendedKeySize
results <- M.keys . M.filter (== userid) <$> liftIO secretKeys
case results of
[] -> error "Failed to generate gpg key!"
(key:_) -> use key

1
debian/changelog vendored
View file

@ -17,6 +17,7 @@ git-annex (4.20130912) UNRELEASED; urgency=low
* status: In local mode, displays information about variance from configured * status: In local mode, displays information about variance from configured
numcopies levels. (--fast avoids calculating these) numcopies levels. (--fast avoids calculating these)
* gcrypt: Ensure that signing key is set to one of the participants keys. * gcrypt: Ensure that signing key is set to one of the participants keys.
* webapp: Show encryption information when editing a remote.
-- Joey Hess <joeyh@debian.org> Thu, 12 Sep 2013 12:14:46 -0400 -- Joey Hess <joeyh@debian.org> Thu, 12 Sep 2013 12:14:46 -0400

BIN
doc/assistant/repoinfo.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 7.4 KiB

View file

@ -16,13 +16,7 @@
<p> <p>
<a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR drive (RepoKey keyid)}"> <a .btn onclick="$('#setupmodal').modal('show');" href="@{FinishAddDriveR drive (RepoKey keyid)}">
<i .icon-ok-sign></i> Encrypt repository # <i .icon-ok-sign></i> Encrypt repository #
to to ^{gpgKeyDisplay keyid (Just name)}
<span title="key id #{keyid}">
<i .icon-user></i> #
$if null name
key id #{keyid}
$else
#{name}
<p> <p>
<a .btn onclick="$('#genkeymodal').modal('show');" href="@{GenKeyForDriveR drive}"> <a .btn onclick="$('#genkeymodal').modal('show');" href="@{GenKeyForDriveR drive}">
<i .icon-plus-sign></i> Encrypt repository # <i .icon-plus-sign></i> Encrypt repository #

View file

@ -33,3 +33,5 @@
Repository information Repository information
<p> <p>
^{repoInfo} ^{repoInfo}
<p>
^{repoEncryption}