de6a297d36
This aims to future-proof gpg key generation. OpenPGP is in flux with a conflict over standards ongoing. It seems not unlikely that different systems will have different gpg commands that support different algorithms. This also simplifies the code by using the --quick-gen-key interface rather than the experimental batch interface. It seems less likely that --quick-gen-key will break than an experimental interface (whose documentation I can no longer find). --quick-gen-key is supported since gpg 2.1.0 (2014). Sponsored-by: Graham Spencer on Patreon
114 lines
3.7 KiB
Haskell
114 lines
3.7 KiB
Haskell
{- git-annex webapp gpg stuff
|
||
-
|
||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||
-
|
||
- Licensed under the GNU AGPL version 3 or higher.
|
||
-}
|
||
|
||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
||
|
||
module Assistant.WebApp.Gpg where
|
||
|
||
import Assistant.WebApp.Common
|
||
import Assistant.Gpg
|
||
import Utility.Gpg
|
||
import qualified Annex
|
||
import qualified Git.Command
|
||
import qualified Git.Remote.Remove
|
||
import qualified Git.Construct
|
||
import qualified Annex.Branch
|
||
import qualified Git.GCrypt
|
||
import qualified Remote.GCrypt as GCrypt
|
||
import Git.Types (RemoteName)
|
||
import Assistant.WebApp.MakeRemote
|
||
import Annex.SpecialRemote.Config
|
||
import Logs.Remote
|
||
|
||
import qualified Data.Map as M
|
||
|
||
gpgKeyDisplay :: KeyId -> Maybe UserId -> Widget
|
||
gpgKeyDisplay keyid userid = [whamlet|
|
||
<span title="key id #{keyid}">
|
||
<span .glyphicon .glyphicon-user>
|
||
\
|
||
$maybe name <- userid
|
||
#{name}
|
||
$nothing
|
||
key id #{keyid}
|
||
|]
|
||
|
||
genKeyModal :: Widget
|
||
genKeyModal = $(widgetFile "configurators/genkeymodal")
|
||
|
||
isGcryptInstalled :: IO Bool
|
||
isGcryptInstalled = inSearchPath "git-remote-gcrypt"
|
||
|
||
whenGcryptInstalled :: Handler Html -> Handler Html
|
||
whenGcryptInstalled a = ifM (liftIO isGcryptInstalled)
|
||
( a
|
||
, page "Need git-remote-gcrypt" (Just Configuration) $
|
||
$(widgetFile "configurators/needgcrypt")
|
||
)
|
||
|
||
withNewSecretKey :: (KeyId -> Handler Html) -> Handler Html
|
||
withNewSecretKey use = do
|
||
cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
|
||
userid <- liftIO $ newUserId cmd
|
||
liftIO $ genSecretKey cmd "" userid
|
||
results <- M.keys . M.filter (== userid) <$> liftIO (secretKeys cmd)
|
||
case results of
|
||
[] -> giveup "Failed to generate gpg key!"
|
||
(key:_) -> use key
|
||
|
||
{- Tries to find the name used in remote.log for a gcrypt repository
|
||
- with a given uuid.
|
||
-
|
||
- The gcrypt remote may not be on that is listed in the local remote.log
|
||
- (or the info may be out of date), so this actually fetches the git-annex
|
||
- branch from the gcrypt remote and merges it in, and then looks up
|
||
- the name.
|
||
-}
|
||
getGCryptRemoteName :: UUID -> String -> Annex RemoteName
|
||
getGCryptRemoteName u repoloc = do
|
||
tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> Annex.getGitRemotes
|
||
void $ inRepo $ Git.Command.runBool
|
||
[ Param "remote"
|
||
, Param "add"
|
||
, Param tmpremote
|
||
, Param $ Git.GCrypt.urlPrefix ++ repoloc
|
||
]
|
||
mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote])
|
||
( do
|
||
void Annex.Branch.forceUpdate
|
||
(lookupName <=< M.lookup u) <$> remoteConfigMap
|
||
, return Nothing
|
||
)
|
||
void $ inRepo $ Git.Remote.Remove.remove tmpremote
|
||
maybe missing return mname
|
||
where
|
||
missing = giveup $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
|
||
|
||
{- Checks to see if a repo is encrypted with gcrypt, and runs one action if
|
||
- it's not an another if it is.
|
||
-
|
||
- Since the probing requires gcrypt to be installed, a third action must
|
||
- be provided to run if it's not installed.
|
||
-}
|
||
checkGCryptRepoEncryption :: (Monad m, LiftAnnex m) => String -> m a -> m a -> m a -> m a
|
||
checkGCryptRepoEncryption location notencrypted notinstalled encrypted =
|
||
ifM (liftAnnex $ liftIO isGcryptInstalled)
|
||
( dispatch =<< liftAnnex (inRepo $ Git.GCrypt.probeRepo location)
|
||
, notinstalled
|
||
)
|
||
where
|
||
dispatch Git.GCrypt.Decryptable = encrypted
|
||
dispatch Git.GCrypt.NotEncrypted = notencrypted
|
||
dispatch Git.GCrypt.NotDecryptable =
|
||
giveup "This git repository is encrypted with a GnuPG key that you do not have."
|
||
|
||
{- Gets the UUID of the gcrypt repo at a location, which may not exist.
|
||
- Only works if the gcrypt repo was created as a git-annex remote. -}
|
||
probeGCryptRemoteUUID :: String -> Annex (Maybe UUID)
|
||
probeGCryptRemoteUUID repolocation = do
|
||
r <- inRepo $ Git.Construct.fromRemoteLocation repolocation False
|
||
GCrypt.getGCryptUUID False r
|