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.Utility
import Assistant.WebApp.Gpg
import Assistant.DaemonStatus
import Assistant.MakeRemote (uniqueRemoteName)
import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
@ -33,6 +34,9 @@ import qualified Git.Command
import qualified Git.Config
import qualified Annex
import Git.Remote
import Remote.Helper.Encryptable (extractCipher)
import Types.Crypto
import Utility.Gpg
import qualified Data.Text as T
import qualified Data.Map as M
@ -187,8 +191,9 @@ editForm new uuid = page "Edit repository" (Just Configuration) $ do
redirect DashboardR
_ -> do
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
repoInfo <- getRepoInfo mremote . M.lookup uuid
<$> liftAnnex readRemoteLog
config <- liftAnnex $ M.lookup uuid <$> readRemoteLog
let repoInfo = getRepoInfo mremote config
let repoEncryption = getRepoEncryption mremote config
$(widgetFile "configurators/editrepository")
{- Makes any directory associated with the repository. -}
@ -221,3 +226,20 @@ getGitRepoInfo :: Git.Repo -> Widget
getGitRepoInfo r = do
let loc = Git.repoLocation r
[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.OtherRepos
import Assistant.WebApp.Gpg
import Assistant.MakeRemote
import Assistant.Sync
import Init
@ -276,30 +277,14 @@ genKeyModal :: Widget
genKeyModal = $(widgetFile "configurators/genkeymodal")
getGenKeyForDriveR :: RemovableDrive -> Handler Html
getGenKeyForDriveR drive = 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
- the removable drive may have been disconnected
- in the meantime. Check that it is still mounted
- before finishing. -}
ifM (liftIO $ any (\d -> mountPoint d == mountPoint drive) <$> driveList)
( getFinishAddDriveR drive (RepoKey key)
, 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])
getGenKeyForDriveR drive = withNewSecretKey $ \key -> do
{- Generating a key takes a long time, and
- the removable drive may have been disconnected
- in the meantime. Check that it is still mounted
- before finishing. -}
ifM (liftIO $ any (\d -> mountPoint d == mountPoint drive) <$> driveList)
( getFinishAddDriveR drive (RepoKey key)
, getAddDriveR
)
getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html