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
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 ->
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
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
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
[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)
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
)
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
""
)
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