{- 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 Data.List
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)

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 -> return $ GpgSigned pk sig
		ExitFailure _ -> error "gpg failed"

-- | 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.
--
-- The gpg key will be retrieved from a keyserver if necessary.
--
-- Gpg outputs to stderr information about who signed the
-- data, so that will be visible to the user when eg, prompting
-- them if they want to accept a connection from that person.
--
-- This relies on gpgSign using --clearsign, so on successful
-- verification, the JSON encoded PublicKey is output to gpg's
-- stdout.
gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO (Maybe GpgKeyId)
gpgVerify _ (UnSigned _) = return Nothing
gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
	(statusreadh, statuswriteh) <- createPipe
	statuswritefd <- handleToFd statuswriteh
	(Just hin, Just hout, _, pid) <- createProcess $
		(proc "gpg" (verifyopts statuswritefd))
			{ std_in = CreatePipe
			, std_out = CreatePipe
			}
	closeFd statuswritefd
	B.hPut hin sig
	hClose hin
	hSetBinaryMode hout True
	(signeddata, gpgkeyid) <- B.hGetContents hout
		`concurrently` (parseStatusFd <$> hGetContents statusreadh)
	st <- waitForProcess pid
	let norm = filter (not . B.null) . B8.lines
	let pkissigned = norm (val (hashValue (hash pk))) == norm signeddata
	return $ if st == ExitSuccess && pkissigned
		then gpgkeyid
		else Nothing
  where
	extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
		then gpgopts
		else concatMap (\s -> ["--keyserver", s]) defaultKeyServers
			++ gpgopts
	verifyopts statuswritefd = extraopts ++
		[ "--status-fd", show statuswritefd
		, "--verify"
		, "--output", "-"
		]

-- | Default keyservers to use. Note that only gpg 1 needs this;
-- gpg 2 has a default keyserver.
defaultKeyServers :: [String]
defaultKeyServers =
	[ "pool.sks-keyservers.net"
	, "pgpkeys.mit.edu"
	]

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