1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
module Gpg where
import Types
import UI
import System.Process
import Data.List.Split
import System.IO
import System.Exit
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Text as T
-- | Pick gpg secret key to back up.
--
-- If there is only one gpg secret key,
-- the choice is obvious. Otherwise prompt the user with a list.
getKeyToBackup :: UI -> IO SecretKeySource
getKeyToBackup ui = go =<< listSecretKeys
where
go [] = do
showError ui "You have no gpg secret keys to back up."
error "Aborting on no gpg secret keys."
go [(_, kid)] = selected kid
go l = maybe (error "Canceled") selected
=<< promptKeyId ui "Pick gpg secret key"
"Pick gpg secret key to back up:" l
selected = return . GpgKey
listSecretKeys :: IO [(Name, KeyId)]
listSecretKeys = map mk . parse . lines <$> readProcess "gpg"
["--batch", "--with-colons", "--list-secret-keys", "--fixed-list-mode"] ""
where
parse = extract [] Nothing . map (splitOn ":")
extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) =
extract ((userid, keyid):c) Nothing rest
extract c (Just keyid) rest@(("sec":_):_) =
extract (("", keyid):c) Nothing rest
extract c (Just keyid) (_:rest) =
extract c (Just keyid) rest
extract c _ [] = c
extract c _ (("sec":_:_:_:keyid:_):rest) =
extract c (Just keyid) rest
extract c k (_:rest) =
extract c k rest
mk (userid, keyid) = (Name (BU8.fromString userid), KeyId (T.pack keyid))
getSecretKey :: KeyId -> IO SecretKey
getSecretKey (KeyId kid) = do
(_, Just hout, _, ph) <- createProcess (proc "gpg" ps)
{ std_out = CreatePipe }
secretkey <- SecretKey <$> B.hGetContents hout
exitcode <- waitForProcess ph
case exitcode of
ExitSuccess -> return secretkey
_ -> error "gpg --export-secret-key failed"
where
ps = ["--batch", "--export-secret-key", T.unpack kid]
writeSecretKey :: SecretKey -> IO ()
writeSecretKey (SecretKey b) = do
(Just hin, _, _, ph) <- createProcess (proc "gpg" ps)
{ std_in = CreatePipe }
B.hPut hin b
hClose hin
exitcode <- waitForProcess ph
case exitcode of
ExitSuccess -> return ()
_ -> error "gpg --import failed"
where
ps = ["--batch", "--import"]
|
