958312885f
Complicated by such repositories potentially being repos that should have an annex.uuid, but it failed to be gotten, perhaps due to the past ssh repo setup bugs. This is handled now by an Upgrade Repository button.
106 lines
3.5 KiB
Haskell
106 lines
3.5 KiB
Haskell
{- git-annex webapp gpg stuff
|
||
-
|
||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||
-
|
||
- 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 Git.Command
|
||
import qualified Git.Remote
|
||
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 Logs.Remote
|
||
|
||
import qualified Data.Map as M
|
||
|
||
gpgKeyDisplay :: KeyId -> Maybe UserId -> Widget
|
||
gpgKeyDisplay keyid userid = [whamlet|
|
||
<span title="key id #{keyid}">
|
||
<i .icon-user></i> #
|
||
$maybe name <- userid
|
||
#{name}
|
||
$nothing
|
||
key id #{keyid}
|
||
|]
|
||
|
||
genKeyModal :: Widget
|
||
genKeyModal = $(widgetFile "configurators/genkeymodal")
|
||
|
||
isGcryptInstalled :: IO Bool
|
||
isGcryptInstalled = inPath "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
|
||
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
|
||
|
||
{- 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 <$> gitRepo
|
||
void $ inRepo $ Git.Command.runBool
|
||
[Params "remote add", Param tmpremote, Param $ Git.GCrypt.urlPrefix ++ repoloc]
|
||
mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote])
|
||
( do
|
||
void Annex.Branch.forceUpdate
|
||
(M.lookup "name" <=< M.lookup u) <$> readRemoteLog
|
||
, return Nothing
|
||
)
|
||
void $ inRepo $ Git.Remote.remove tmpremote
|
||
maybe missing return mname
|
||
where
|
||
missing = error $ "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 =
|
||
error "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
|
||
GCrypt.getGCryptUUID False r
|