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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
	checkhandles (Fd
h:[Fd]
hs) = do
		Bool
isterm <- Fd -> IO Bool
queryTerminal Fd
h
		if Bool
isterm
			then do
				Either SomeException FilePath
v <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryNonAsync forall a b. (a -> b) -> a -> b
$ Fd -> IO FilePath
getTerminalName Fd
h
				case Either SomeException FilePath
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 [Fd] -> IO ()
checkhandles [Fd]
hs

type KeyId = String

getGpgBin :: IO String
getGpgBin :: IO FilePath
getGpgBin = do
	Maybe FilePath
gitGpgBin <- FilePath -> IO (Maybe FilePath)
getGitConfigValue FilePath
"gpg.program"
	case Maybe FilePath
gitGpgBin of
		Maybe FilePath
Nothing -> FilePath -> FilePath -> IO FilePath
getEnvDefault FilePath
"GNUPGBIN" FilePath
"gpg"
		Just FilePath
b -> 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
	FilePath
keyring <- IO FilePath
privDataKeyring
	let listopts :: [FilePath]
listopts =
		[ FilePath
"--list-public-keys"
		, FilePath
"--with-colons"
		, FilePath
"--fixed-list-mode"
		] forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath]
useKeyringOpts FilePath
keyring
	FilePath
gpgbin <- IO FilePath
getGpgBin
	[FilePath] -> [FilePath]
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO FilePath
readProcess FilePath
gpgbin [FilePath]
listopts
  where
	parse :: [FilePath] -> [FilePath]
parse = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([FilePath] -> Maybe FilePath
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
split FilePath
":")
	extract :: [FilePath] -> Maybe FilePath
extract (FilePath
"pub":FilePath
_:FilePath
_:FilePath
_:FilePath
f:[FilePath]
_) = forall a. a -> Maybe a
Just FilePath
f
	extract [FilePath]
_ = forall a. Maybe a
Nothing

-- Lists all of the user's secret keys.
listSecretKeys :: IO [(KeyId, String)]
listSecretKeys :: IO [(FilePath, FilePath)]
listSecretKeys = do
	FilePath
gpgbin <- IO FilePath
getGpgBin
	[FilePath] -> [(FilePath, FilePath)]
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO FilePath
readProcess FilePath
gpgbin
		[ FilePath
"--list-secret-keys"
		, FilePath
"--with-colons"
		, FilePath
"--fixed-list-mode"
		]
  where
	parse :: [FilePath] -> [(FilePath, FilePath)]
parse = [(FilePath, FilePath)]
-> Maybe FilePath -> [[FilePath]] -> [(FilePath, FilePath)]
extract [] forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (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)forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
c) 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
"")forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
c) 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
"")forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
c) 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 (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 (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
	FilePath
gpgbin <- IO FilePath
getGpgBin
	FilePath
keyring <- IO FilePath
privDataKeyring
	forall a. Bool -> IO a
exitBool forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
FilePath -> m r -> m r
actionMessage)
		[ (FilePath
"adding key to propellor's keyring", FilePath -> FilePath -> IO Bool
addkeyring FilePath
keyring FilePath
gpgbin)
		, (FilePath
"staging propellor's keyring", FilePath -> IO Bool
gitAdd FilePath
keyring)
		, (FilePath
"updating encryption of any privdata", IO Bool
reencryptPrivData)
		, (FilePath
"configuring git commit signing to use key", FilePath -> IO Bool
gitconfig FilePath
gpgbin)
		, (FilePath
"committing changes", FilePath -> IO Bool
gitCommitKeyRing FilePath
"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 forall a b. (a -> b) -> a -> b
$ FilePath
gpgbin' forall a. [a] -> [a] -> [a]
++ FilePath
" --export " forall a. [a] -> [a] -> [a]
++ FilePath
keyid forall a. [a] -> [a] -> [a]
++ FilePath
" | gpg " forall a. [a] -> [a] -> [a]
++
				[FilePath] -> FilePath
unwords (FilePath -> [FilePath]
useKeyringOpts FilePath
keyring' forall a. [a] -> [a] -> [a]
++ [FilePath
"--import"])
			]

	gitconfig :: FilePath -> IO Bool
gitconfig FilePath
gpgbin' = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall a b. (a, b) -> b
snd 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] 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
			forall (m :: * -> *). MonadIO m => FilePath -> m ()
warningMessage forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot find a secret key for key " forall a. [a] -> [a] -> [a]
++ FilePath
keyid forall a. [a] -> [a] -> [a]
++ FilePath
", so not configuring git user.signingkey to use this key."
			forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
		)

rmKey :: KeyId -> IO ()
rmKey :: FilePath -> IO ()
rmKey FilePath
keyid = do
	FilePath
gpgbin <- IO FilePath
getGpgBin
	FilePath
keyring <- IO FilePath
privDataKeyring
	forall a. Bool -> IO a
exitBool forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
FilePath -> m r -> m r
actionMessage)
		[ (FilePath
"removing key from propellor's keyring", FilePath -> FilePath -> IO Bool
rmkeyring FilePath
keyring FilePath
gpgbin)
		, (FilePath
"staging propellor's keyring", FilePath -> IO Bool
gitAdd FilePath
keyring)
		, (FilePath
"updating encryption of any privdata", IO Bool
reencryptPrivData)
		, (FilePath
"configuring git commit signing to not use key", IO Bool
gitconfig)
		, (FilePath
"committing changes", FilePath -> IO Bool
gitCommitKeyRing FilePath
"rm-key")
		]
  where
	rmkeyring :: FilePath -> FilePath -> IO Bool
rmkeyring FilePath
keyring' FilePath
gpgbin' = FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
gpgbin' forall a b. (a -> b) -> a -> b
$
		(forall a b. (a -> b) -> [a] -> [b]
map FilePath -> CommandParam
Param (FilePath -> [FilePath]
useKeyringOpts FilePath
keyring')) 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 = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall a. Eq a => a -> a -> Bool
(==) (FilePath
keyidforall a. [a] -> [a] -> [a]
++FilePath
"\n", Bool
True) 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"] 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"
			]
		, forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
		)

reencryptPrivData :: IO Bool
reencryptPrivData :: IO Bool
reencryptPrivData = do
	FilePath
f <- IO FilePath
privDataFile
	forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
f)
		( do
			FilePath -> FilePath -> IO ()
gpgEncrypt FilePath
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
gpgDecrypt FilePath
f
			FilePath -> IO Bool
gitAdd FilePath
f
		, forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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
	FilePath
keyring <- IO FilePath
privDataKeyring
	FilePath
privdata <- IO FilePath
privDataFile
	-- Commit explicitly the keyring and privdata files, as other
	-- changes may be staged by the user and shouldn't be committed.
	[FilePath]
tocommit <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist [ FilePath
privdata, FilePath
keyring]
	Maybe FilePath -> [CommandParam] -> IO Bool
gitCommit (forall a. a -> Maybe a
Just (FilePath
"propellor " forall a. [a] -> [a] -> [a]
++ FilePath
action)) (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> CommandParam
File [FilePath]
tocommit)

-- Adds --gpg-sign if there's a keyring.
gpgSignParams :: [CommandParam] -> IO [CommandParam]
gpgSignParams :: [CommandParam] -> IO [CommandParam]
gpgSignParams [CommandParam]
ps = do
	FilePath
keyring <- IO FilePath
privDataKeyring
	forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
keyring)
		( forall (m :: * -> *) a. Monad m => a -> m a
return ([CommandParam]
ps forall a. [a] -> [a] -> [a]
++ [FilePath -> CommandParam
Param FilePath
"--gpg-sign"])
		, forall (m :: * -> *) a. Monad m => a -> m a
return [CommandParam]
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" forall a. a -> [a] -> [a]
: [CommandParam]
ps forall a. [a] -> [a] -> [a]
++
		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
	[CommandParam]
ps'' <- [CommandParam] -> IO [CommandParam]
gpgSignParams [CommandParam]
ps'
	FilePath -> [CommandParam] -> IO Bool
boolSystemNonConcurrent FilePath
"git" [CommandParam]
ps''

gpgDecrypt :: FilePath -> IO String
gpgDecrypt :: FilePath -> IO FilePath
gpgDecrypt FilePath
f = do
	FilePath
gpgbin <- IO FilePath
getGpgBin
	forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
f)
		( FilePath
-> [FilePath]
-> Maybe [(FilePath, FilePath)]
-> Maybe (Handle -> IO ())
-> Maybe (Handle -> IO ())
-> IO FilePath
writeReadProcessEnv FilePath
gpgbin [FilePath
"--decrypt", FilePath
f] forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
		, forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
""
		)

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