summaryrefslogtreecommitdiffhomepage
path: root/Gpg.hs
blob: 7d98d5c71e1ac4a4f68529719e11b9b92780faee (plain)
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
{- Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module Gpg where

import Val
import Hash
import Types
import Crypto

import Data.ByteArray (convert)
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as B8
import System.IO
import System.Posix.IO hiding (createPipe)
import System.Process
import System.Exit
import Control.Exception
import System.Directory
import Control.Concurrent.Async

newtype GpgKeyId = GpgKeyId String
	deriving (Show)

newtype GpgSign = GpgSign Bool

myPublicKey :: MySessionKey -> GpgSign -> IO (PerhapsSigned PublicKey)
myPublicKey (MySessionKey _ epk) (GpgSign gpgsign) = do
	let pk = PublicKey (Val $ convert epk)
	if gpgsign
		then gpgSign pk
		else return (UnSigned pk)

-- | Sign a debug-me session PublicKey with gpg.
gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey)
gpgSign pk = do
	putStrLn "Using gpg to sign the debug-me session key."
	-- Write it to a temp file because gpg sometimes is unhappy
	-- about password prompting when stdin is not connected to
	-- the console.
	tmpdir <- getTemporaryDirectory
	(tmpfile, tmph) <- openTempFile tmpdir "debug-me.tmp"
	B.hPut tmph $ val $ hashValue $ hash pk
	hClose tmph
	(_, Just hout, _, pid) <- createProcess $
		(proc "gpg" ["--output", "-", "--clearsign", "-a", tmpfile])
			{ std_out = CreatePipe
			}
	hSetBinaryMode hout True
	sig <- GpgSig . Val <$> B.hGetContents hout
	st <- waitForProcess pid
	_ <- try (removeFile tmpfile) :: IO (Either IOException ())
	case st of
		ExitSuccess -> do
			-- Verify the just signed data to determine
			-- the gpg public key used to sign it. The gpg 
			-- public key is included in the GpgSigned data.
			v <- fst <$> gpgVerifyClearSigned sig
			case v of
				Just (gpgkeyid, _) -> do
					pubkey <- gpgExportPublicKey gpgkeyid
					return $ GpgSigned pk sig pubkey
				Nothing -> error "gpg sign verification failed"
		ExitFailure _ -> error "gpg sign failed"

-- | Export gpg public key in minimal form.
gpgExportPublicKey :: GpgKeyId -> IO GpgKeyExport
gpgExportPublicKey (GpgKeyId gpgkeyid) = do
	(_, Just hout, _, pid) <- createProcess $
		(proc "gpg" opts)
			{ std_out = CreatePipe
			}
	hSetBinaryMode hout True
	b <- B.hGetContents hout
	st <- waitForProcess pid
	if st == ExitSuccess
		then return $ GpgKeyExport $ Val b
		else error "gpg --export failed"
  where
	opts =
		[ "-a"
		, "--export-options", "no-export-attributes,export-minimal"
		, "--export", gpgkeyid
		]

gpgImportPublicKey :: GpgKeyExport -> IO ()
gpgImportPublicKey (GpgKeyExport (Val b)) = do
	(Just hin, Just hout, Just herr, pid) <- createProcess $
		(proc "gpg" [ "--import"] )
			{ std_in = CreatePipe
			, std_out = CreatePipe
			, std_err = CreatePipe
			}
	hSetBinaryMode hin True
	B.hPut hin b
	hClose hin
	_ <- B.hGetContents hout
		`concurrently` B.hGetContents herr
	_ <- waitForProcess pid
	return ()

-- | Verify the gpg signature and return the keyid that signed it.
-- Also makes sure that the gpg signed data is the hash of the 
-- debug-me PublicKey.
gpgVerify :: PerhapsSigned PublicKey -> IO (Maybe GpgKeyId, SignInfoDesc)
gpgVerify (UnSigned _) = return (Nothing, mempty)
gpgVerify (GpgSigned pk gpgsig keyexport) = do
	gpgImportPublicKey keyexport
	go =<< gpgVerifyClearSigned gpgsig
  where
	go (Nothing, s) = return (Nothing, s)
	go (Just (gpgkeyid, signeddata), s) = do
		let norm = filter (not . B.null) . B8.lines
		let pkissigned = norm signeddata == norm (val (hashValue (hash pk)))
		return $ if pkissigned
			then (Just gpgkeyid, s)
			else (Nothing, s)

type SignInfoDesc = B.ByteString

-- | Verify a clearsigned GpgSig, returning the key id used to sign it,
-- and the data that was signed.
--
-- Gpg outputs to stderr information about who signed the
-- data, and that is returned also.
gpgVerifyClearSigned :: GpgSig -> IO (Maybe (GpgKeyId, B.ByteString), SignInfoDesc)
gpgVerifyClearSigned (GpgSig (Val sig)) = do
	(statusreadh, statuswriteh) <- createPipe
	statuswritefd <- handleToFd statuswriteh
	(Just hin, Just hout, Just herr, pid) <- createProcess $
		(proc "gpg" (verifyopts statuswritefd))
			{ std_in = CreatePipe
			, std_out = CreatePipe
			, std_err = CreatePipe
			}
	closeFd statuswritefd
	B.hPut hin sig
	hClose hin
	hSetBinaryMode hout True
	((signeddata, sigdesc), mgpgkeyid) <- B.hGetContents hout
		`concurrently` B.hGetContents herr
		`concurrently` (parseStatusFd <$> hGetContents statusreadh)
	st <- waitForProcess pid
	let siginfo = if st == ExitSuccess
		then case mgpgkeyid of
			Just gpgkeyid -> Just (gpgkeyid, signeddata)
			Nothing -> Nothing
		else Nothing
	return (siginfo, sigdesc)
  where
	verifyopts statuswritefd =
		[ "--status-fd", show statuswritefd
		, "--verify"
		, "--output", "-"
		]

parseStatusFd :: String -> Maybe GpgKeyId
parseStatusFd = go . map words . lines
  where
	go [] = Nothing
	go ((_:"VALIDSIG":_:_:_:_:_:_:_:_:_:keyid:_):_) = Just (GpgKeyId keyid)
	go (_:rest) = go rest