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.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
|
||||||
|
|
|
@ -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,30 +277,14 @@ 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
|
{- Generating a key takes a long time, and
|
||||||
liftIO $ genSecretKey RSA "" userid maxRecommendedKeySize
|
- the removable drive may have been disconnected
|
||||||
results <- M.keys . M.filter (== userid) <$> liftIO secretKeys
|
- in the meantime. Check that it is still mounted
|
||||||
case results of
|
- before finishing. -}
|
||||||
[] -> error "Failed to generate gpg key!"
|
ifM (liftIO $ any (\d -> mountPoint d == mountPoint drive) <$> driveList)
|
||||||
(key:_) -> do
|
( getFinishAddDriveR drive (RepoKey key)
|
||||||
{- Generating a key takes a long time, and
|
, getAddDriveR
|
||||||
- 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])
|
|
||||||
)
|
)
|
||||||
|
|
||||||
getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
|
getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
|
||||||
|
|
47
Assistant/WebApp/Gpg.hs
Normal file
47
Assistant/WebApp/Gpg.hs
Normal 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
1
debian/changelog
vendored
|
@ -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
BIN
doc/assistant/repoinfo.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 7.4 KiB |
|
@ -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 #
|
||||||
|
|
|
@ -33,3 +33,5 @@
|
||||||
Repository information
|
Repository information
|
||||||
<p>
|
<p>
|
||||||
^{repoInfo}
|
^{repoInfo}
|
||||||
|
<p>
|
||||||
|
^{repoEncryption}
|
||||||
|
|
Loading…
Reference in a new issue