module Propellor.Gpg where

import System.IO
import System.Posix.IO
import System.Posix.Terminal
import Data.Maybe
import Control.Monad
import Control.Applicative
import Prelude

import Propellor.PrivData.Paths
import Propellor.Message
import Propellor.Git.Config
import Utility.SafeCommand
import Utility.Process
import Utility.Process.Transcript
import Utility.Process.NonConcurrent
import Utility.Monad
import Utility.Misc
import Utility.Tmp
import Utility.Env
import Utility.Env.Set
import Utility.Directory
import Utility.Split
import Utility.Exception

-- | When at a tty, set GPG_TTY to point to the tty device. This is needed
-- so that when gpg is run with stio connected to a pipe, it is still able
-- to display password prompts at the console.
--
-- This should not prevent gpg from using the GUI for prompting when one is
-- available.
setupGpgEnv :: IO ()
setupGpgEnv :: IO ()
setupGpgEnv = [Fd] -> IO ()
checkhandles [Fd
stdInput, Fd
stdOutput, Fd
stdError]
  where
	checkhandles :: [Fd] -> IO ()
checkhandles [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	checkhandles (Fd
h:[Fd]
hs) = do
		isterm <- Fd -> IO Bool
queryTerminal Fd
h
		if isterm
			then do
				v <- tryNonAsync $ getTerminalName h
				case v of
					Right FilePath
ttyname -> 
						-- do not overwrite
						FilePath -> FilePath -> Bool -> IO ()
setEnv FilePath
"GPG_TTY" FilePath
ttyname Bool
False
					Left SomeException
_ -> [Fd] -> IO ()
checkhandles [Fd]
hs
			else checkhandles hs

type KeyId = String

getGpgBin :: IO String
getGpgBin :: IO FilePath
getGpgBin = do
	gitGpgBin <- FilePath -> IO (Maybe FilePath)
getGitConfigValue FilePath
"gpg.program"
	case gitGpgBin of
		Maybe FilePath
Nothing -> FilePath -> FilePath -> IO FilePath
getEnvDefault FilePath
"GNUPGBIN" FilePath
"gpg"
		Just FilePath
b -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
b

-- Lists the keys in propellor's keyring.
listPubKeys :: IO [KeyId]
listPubKeys :: IO [FilePath]
listPubKeys = do
	keyring <- IO FilePath
privDataKeyring
	let listopts =
		[ FilePath
"--list-public-keys"
		, FilePath
"--with-colons"
		, FilePath
"--fixed-list-mode"
		] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath]
useKeyringOpts FilePath
keyring
	gpgbin <- getGpgBin
	parse . lines <$> readProcess gpgbin listopts
  where
	parse :: [FilePath] -> [FilePath]
parse = (FilePath -> Maybe FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([FilePath] -> Maybe FilePath
extract ([FilePath] -> Maybe FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
split FilePath
":")
	extract :: [FilePath] -> Maybe FilePath
extract (FilePath
"pub":FilePath
_:FilePath
_:FilePath
_:FilePath
f:[FilePath]
_) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f
	extract [FilePath]
_ = Maybe FilePath
forall a. Maybe a
Nothing

-- Lists all of the user's secret keys.
listSecretKeys :: IO [(KeyId, String)]
listSecretKeys :: IO [(FilePath, FilePath)]
listSecretKeys = do
	gpgbin <- IO FilePath
getGpgBin
	parse . lines <$> readProcess gpgbin
		[ "--list-secret-keys"
		, "--with-colons"
		, "--fixed-list-mode"
		]
  where
	parse :: [FilePath] -> [(FilePath, FilePath)]
parse = [(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract [] Maybe FilePath
forall a. Maybe a
Nothing ([[FilePath]] -> [(FilePath, FilePath)])
-> ([FilePath] -> [[FilePath]])
-> [FilePath]
-> [(FilePath, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
split FilePath
":")
	extract :: [(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract [(FilePath, FilePath)]
c (Just FilePath
keyid) ((FilePath
"uid":FilePath
_:FilePath
_:FilePath
_:FilePath
_:FilePath
_:FilePath
_:FilePath
_:FilePath
_:FilePath
userid:[FilePath]
_):[[FilePath]]
rest) =
		[(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract ((FilePath
keyid, FilePath
userid)(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
c) Maybe FilePath
forall a. Maybe a
Nothing [[FilePath]]
rest
	extract [(FilePath, FilePath)]
c (Just FilePath
keyid) rest :: [[FilePath]]
rest@((FilePath
"sec":[FilePath]
_):[[FilePath]]
_) =
		[(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract ((FilePath
keyid, FilePath
"")(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
c) Maybe FilePath
forall a. Maybe a
Nothing [[FilePath]]
rest
	extract [(FilePath, FilePath)]
c (Just FilePath
keyid) rest :: [[FilePath]]
rest@((FilePath
"pub":[FilePath]
_):[[FilePath]]
_) =
		[(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract ((FilePath
keyid, FilePath
"")(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
c) Maybe FilePath
forall a. Maybe a
Nothing [[FilePath]]
rest
	extract [(FilePath, FilePath)]
c (Just FilePath
keyid) ([FilePath]
_:[[FilePath]]
rest) =
		[(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract [(FilePath, FilePath)]
c (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
keyid) [[FilePath]]
rest
	extract [(FilePath, FilePath)]
c Maybe FilePath
_ [] = [(FilePath, FilePath)]
c
	extract [(FilePath, FilePath)]
c Maybe FilePath
_ ((FilePath
"sec":FilePath
_:FilePath
_:FilePath
_:FilePath
keyid:[FilePath]
_):[[FilePath]]
rest) =
		[(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract [(FilePath, FilePath)]
c (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
keyid) [[FilePath]]
rest
	extract [(FilePath, FilePath)]
c Maybe FilePath
k ([FilePath]
_:[[FilePath]]
rest) =
		[(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract [(FilePath, FilePath)]
c Maybe FilePath
k [[FilePath]]
rest

useKeyringOpts :: FilePath -> [String]
useKeyringOpts :: FilePath -> [FilePath]
useKeyringOpts FilePath
keyring =
	[ FilePath
"--options"
	, FilePath
"/dev/null"
	, FilePath
"--no-default-keyring"
	, FilePath
"--keyring", FilePath
keyring
	]

addKey :: KeyId -> IO ()
addKey :: FilePath -> IO ()
addKey FilePath
keyid = do
	gpgbin <- IO FilePath
getGpgBin
	keyring <- privDataKeyring
	exitBool =<< allM (uncurry actionMessage)
		[ ("adding key to propellor's keyring", addkeyring keyring gpgbin)
		, ("staging propellor's keyring", gitAdd keyring)
		, ("updating encryption of any privdata", reencryptPrivData)
		, ("configuring git commit signing to use key", gitconfig gpgbin)
		, ("committing changes", gitCommitKeyRing "add-key")
		]
  where
	addkeyring :: FilePath -> FilePath -> IO Bool
addkeyring FilePath
keyring' FilePath
gpgbin' = do
		Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
privDataDir
		FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
"sh"
			[ FilePath -> CommandParam
Param FilePath
"-c"
			, FilePath -> CommandParam
Param (FilePath -> CommandParam) -> FilePath -> CommandParam
forall a b. (a -> b) -> a -> b
$ FilePath
gpgbin' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" --export " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
keyid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" | gpg " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
				[FilePath] -> FilePath
unwords (FilePath -> [FilePath]
useKeyringOpts FilePath
keyring' [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"--import"])
			]

	gitconfig :: FilePath -> IO Bool
gitconfig FilePath
gpgbin' = IO Bool -> (IO Bool, IO Bool) -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM ((FilePath, Bool) -> Bool
forall a b. (a, b) -> b
snd ((FilePath, Bool) -> Bool) -> IO (FilePath, Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> Maybe FilePath -> IO (FilePath, Bool)
processTranscript FilePath
gpgbin' [FilePath
"--list-secret-keys", FilePath
keyid] Maybe FilePath
forall a. Maybe a
Nothing)
		( FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
"git"
			[ FilePath -> CommandParam
Param FilePath
"config"
			, FilePath -> CommandParam
Param FilePath
"user.signingkey"
			, FilePath -> CommandParam
Param FilePath
keyid
			]
		, do
			FilePath -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
warningMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot find a secret key for key " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
keyid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", so not configuring git user.signingkey to use this key."
			Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
		)

rmKey :: KeyId -> IO ()
rmKey :: FilePath -> IO ()
rmKey FilePath
keyid = do
	gpgbin <- IO FilePath
getGpgBin
	keyring <- privDataKeyring
	exitBool =<< allM (uncurry actionMessage)
		[ ("removing key from propellor's keyring", rmkeyring keyring gpgbin)
		, ("staging propellor's keyring", gitAdd keyring)
		, ("updating encryption of any privdata", reencryptPrivData)
		, ("configuring git commit signing to not use key", gitconfig)
		, ("committing changes", gitCommitKeyRing "rm-key")
		]
  where
	rmkeyring :: FilePath -> FilePath -> IO Bool
rmkeyring FilePath
keyring' FilePath
gpgbin' = FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
gpgbin' ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$
		((FilePath -> CommandParam) -> [FilePath] -> [CommandParam]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> CommandParam
Param (FilePath -> [FilePath]
useKeyringOpts FilePath
keyring')) [CommandParam] -> [CommandParam] -> [CommandParam]
forall a. [a] -> [a] -> [a]
++
		[ FilePath -> CommandParam
Param FilePath
"--batch"
		, FilePath -> CommandParam
Param FilePath
"--yes"
		, FilePath -> CommandParam
Param FilePath
"--delete-key", FilePath -> CommandParam
Param FilePath
keyid
		]

	gitconfig :: IO Bool
gitconfig = IO Bool -> (IO Bool, IO Bool) -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM ((FilePath, Bool) -> (FilePath, Bool) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (FilePath
keyidFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\n", Bool
True) ((FilePath, Bool) -> Bool) -> IO (FilePath, Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> Maybe FilePath -> IO (FilePath, Bool)
processTranscript FilePath
"git" [FilePath
"config", FilePath
"user.signingkey"] Maybe FilePath
forall a. Maybe a
Nothing)
		( FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
"git"
			[ FilePath -> CommandParam
Param FilePath
"config"
			, FilePath -> CommandParam
Param FilePath
"--unset"
			, FilePath -> CommandParam
Param FilePath
"user.signingkey"
			]
		, Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
		)

reencryptPrivData :: IO Bool
reencryptPrivData :: IO Bool
reencryptPrivData = do
	f <- IO FilePath
privDataFile
	ifM (doesFileExist f)
		( do
			gpgEncrypt f =<< gpgDecrypt f
			gitAdd f
		, return True
		)

gitAdd :: FilePath -> IO Bool
gitAdd :: FilePath -> IO Bool
gitAdd FilePath
f = FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
"git"
	[ FilePath -> CommandParam
Param FilePath
"add"
	, FilePath -> CommandParam
File FilePath
f
	]

gitCommitKeyRing :: String -> IO Bool
gitCommitKeyRing :: FilePath -> IO Bool
gitCommitKeyRing FilePath
action = do
	keyring <- IO FilePath
privDataKeyring
	privdata <- privDataFile
	-- Commit explicitly the keyring and privdata files, as other
	-- changes may be staged by the user and shouldn't be committed.
	tocommit <- filterM doesFileExist [ privdata, keyring]
	gitCommit (Just ("propellor " ++ action)) (map File tocommit)

-- Adds --gpg-sign if there's a keyring.
gpgSignParams :: [CommandParam] -> IO [CommandParam]
gpgSignParams :: [CommandParam] -> IO [CommandParam]
gpgSignParams [CommandParam]
ps = do
	keyring <- IO FilePath
privDataKeyring
	ifM (doesFileExist keyring)
		( return (ps ++ [Param "--gpg-sign"])
		, return ps
		)

-- Automatically sign the commit if there'a a keyring.
gitCommit :: Maybe String -> [CommandParam] -> IO Bool
gitCommit :: Maybe FilePath -> [CommandParam] -> IO Bool
gitCommit Maybe FilePath
msg [CommandParam]
ps = do
	let ps' :: [CommandParam]
ps' = FilePath -> CommandParam
Param FilePath
"commit" CommandParam -> [CommandParam] -> [CommandParam]
forall a. a -> [a] -> [a]
: [CommandParam]
ps [CommandParam] -> [CommandParam] -> [CommandParam]
forall a. [a] -> [a] -> [a]
++
		[CommandParam]
-> (FilePath -> [CommandParam]) -> Maybe FilePath -> [CommandParam]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
m -> [FilePath -> CommandParam
Param FilePath
"-m", FilePath -> CommandParam
Param FilePath
m]) Maybe FilePath
msg
	ps'' <- [CommandParam] -> IO [CommandParam]
gpgSignParams [CommandParam]
ps'
	boolSystemNonConcurrent "git" ps''

gpgDecrypt :: FilePath -> IO String
gpgDecrypt :: FilePath -> IO FilePath
gpgDecrypt FilePath
f = do
	gpgbin <- IO FilePath
getGpgBin
	ifM (doesFileExist f)
		( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing Nothing
		, return ""
		)

-- Encrypt file to all keys in propellor's keyring.
gpgEncrypt :: FilePath -> String -> IO ()
gpgEncrypt :: FilePath -> FilePath -> IO ()
gpgEncrypt FilePath
f FilePath
s = do
	gpgbin <- IO FilePath
getGpgBin
	keyids <- listPubKeys
	let opts =
		[ FilePath
"--default-recipient-self"
		, FilePath
"--armor"
		, FilePath
"--encrypt"
		, FilePath
"--trust-model", FilePath
"always"
		] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FilePath
k -> [FilePath
"--recipient", FilePath
k]) [FilePath]
keyids
	encrypted <- writeReadProcessEnv gpgbin opts Nothing (Just writer) Nothing
	viaTmp writeFile f encrypted
  where
	writer :: Handle -> IO ()
writer Handle
h = Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
s