{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-}

module Gpg where

import Val
import Hash
import Types
import Crypto

import Data.ByteArray (convert)
import qualified Data.ByteString as B
import System.IO
import System.Process
import System.Exit
import Data.List
import Control.Exception
import System.Directory

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. The key will be retrieved from a keyserver
-- if possible. 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.
gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO Bool
gpgVerify _ (UnSigned _) = return False
gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do	
	-- This relies on gpgSign using --clearsign, so on successful
	-- verification, the JSON encoded PublicKey is output to gpg's
	-- stdout.
	(Just hin, Just hout, _, pid) <- createProcess $
		(proc "gpg" (extraopts ++ ["--verify", "--output", "-"]))
			{ std_in = CreatePipe
			, std_out = CreatePipe
			}
	B.hPut hin sig
	hClose hin
	hSetBinaryMode hout True
	signeddata <- B.hGetContents hout
	st <- waitForProcess pid
	return $ case st of
		ExitFailure _ -> False
		ExitSuccess -> val (hashValue (hash pk)) == signeddata
  where
	extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
		then gpgopts
		else map ("--keyserver=" ++) defaultKeyServers ++ gpgopts

-- | Default keyservers to use.
defaultKeyServers :: [String]
defaultKeyServers =
	[ "pool.sks-keyservers.net"
	, "pgpkeys.mit.edu"
	]