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

module Crypto where

import Val
import Hash
import Types

import qualified Crypto.PubKey.Ed25519 as Ed25519
import Crypto.Error
import Crypto.Random.Entropy
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

dummySignature :: Signature
dummySignature = OtherSignature (Val mempty)

class Signed t where
	getSignature :: t -> Signature
	hashExceptSignature :: t -> Hash
	mkSigned :: MySessionKey -> (Signature -> t) -> t
	mkSigned sk mk =
		let tmp = mk dummySignature
		in mk (sign sk tmp)

instance Hashable a => Signed (Activity a) where
	getSignature = activitySignature
	hashExceptSignature (Activity a mp mt _s) = hash $
		Tagged "Activity" [hash a, hash mp, hash mt]

instance Signed Control where
	getSignature = controlSignature
	hashExceptSignature (Control a _s) = hash $
		Tagged "Control" a

instance Hashable t => Signed (Message t) where
	getSignature (ActivityMessage a) = getSignature a
	getSignature (ControlMessage c) = getSignature c
	hashExceptSignature (ActivityMessage a) = hashExceptSignature a
	hashExceptSignature (ControlMessage c) = hashExceptSignature c

sign :: Signed v => MySessionKey -> v -> Signature
sign (MySessionKey sk pk) v = Ed25519Signature $ Val $ convert $
	Ed25519.sign sk pk (toSign v)

toSign :: Signed v => v -> B.ByteString
toSign = val . hashValue . hashExceptSignature

-- | Verifiy the signature of a Signed value.
verifySigned :: Signed v => SigVerifier -> v -> Bool
verifySigned (SigVerifier verifier) v =
	case getSignature v of
		Ed25519Signature (Val s) -> 
			case Ed25519.signature s of
				CryptoPassed sig -> verifier (toSign v) sig
				CryptoFailed _ -> False
		OtherSignature _ -> False

data SigVerifier = SigVerifier (B.ByteString -> Ed25519.Signature -> Bool)

mkSigVerifier :: PublicKey -> SigVerifier
mkSigVerifier (PublicKey (Val pk)) = 
	case Ed25519.publicKey pk of
		CryptoPassed pk' -> SigVerifier (Ed25519.verify pk')
		CryptoFailed _ -> mempty

instance Monoid SigVerifier where
	mempty = SigVerifier $ \_b _s -> False
	mappend (SigVerifier a) (SigVerifier b) =
		SigVerifier $ \d s -> b d s || a d s

data MySessionKey = MySessionKey Ed25519.SecretKey Ed25519.PublicKey

genMySessionKey :: IO MySessionKey
genMySessionKey = do
	-- Crypto.Random.Entropy may use rdrand, or /dev/random.
	-- Even if you don't trust rdrand to be free of backdoors, 
	-- it seems safe enough to use it for a session key that
	-- is only used for signing, not encryption.
	rand32 <- getEntropy 32 :: IO B.ByteString
	sk <- throwCryptoErrorIO $ Ed25519.secretKey rand32
	return $ MySessionKey sk (Ed25519.toPublic sk)

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"
	]