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.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