webapp: Show encryption information when editing a remote.
This commit is contained in:
parent
dc15450df6
commit
3d88559e58
7 changed files with 84 additions and 33 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue