105 lines
3.5 KiB
Haskell
105 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 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 Git.Remote.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
|