-- Verify.hs: OpenPGP (RFC4880) signature verification
-- Copyright © 2012  Clint Adams
-- This software is released under the terms of the ISC license.
-- (See the LICENSE file).

module Data.Conduit.OpenPGP.Verify (
   conduitVerify
) where

import qualified Crypto.Cipher.DSA as DSA
import qualified Crypto.Cipher.RSA as RSA

import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Conduit
import Data.Either (lefts, rights)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Serialize.Put (runPut)

import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID)
import Codec.Encryption.OpenPGP.Internal (countBits, integerToBEBS)
import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer)
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Internal (PacketStreamContext(..), payloadForSig, asn1Prefix, hash, issuer)

conduitVerify :: MonadResource m => Keyring -> Conduit Packet m (Either String PKPayload)
conduitVerify kr = conduitState (PacketStreamContext (Marker B.empty) (Marker B.empty) (Marker B.empty) (Marker B.empty) (Marker B.empty)) push close
    where
        push state ld@(LiteralData {}) = return $ StateProducing (state { lastLD = ld }) []
        push state uid@(UserId _) = return $ StateProducing (state { lastUIDorUAt = uid }) []
        push state uat@(UserAttribute _) = return $ StateProducing (state { lastUIDorUAt = uat }) []
        push state pk@(PublicKey _) = return $ StateProducing (state { lastPrimaryKey = pk }) []
        push state pk@(PublicSubkey _) = return $ StateProducing (state { lastSubkey = pk }) []
        push state sk@(SecretKey _ _) = return $ StateProducing (state { lastPrimaryKey = sk }) []
        push state sk@(SecretSubkey _ _) = return $ StateProducing (state { lastSubkey = sk }) []
        push state sig@(Signature (SigV4 {})) = return $ StateProducing state { lastSig = sig } [verifySig kr sig state]
        push state (OnePassSignature _ _ _ _ _ False) = return $ StateProducing state []
        push state _ = return $ StateProducing state []
        close _ = return []
        normLineEndings = id  -- FIXME

verifySig :: Keyring -> Packet -> PacketStreamContext -> Either String PKPayload -- FIXME: this should be more informative
verifySig kr sig@(Signature (SigV4 st _ _ _ _ _ _)) state = verify kr sig (payloadForSig st state)
verifySig _ _ _ = Left "This should never happen."

verify :: Keyring -> Packet -> ByteString -> Either String PKPayload
verify kr sig payload = do
    i <- maybe (Left "issuer not found") Right (issuer sig)
    tpkset <- maybe (Left "pubkey not found") Right (Map.lookup i kr)
    let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> tkPKP x:map subPKP (tkSubs x)) (Set.toAscList tpkset))
    let results = map (\pkp -> verify' sig pkp (hashalgo sig) (finalPayload sig payload)) allrelevantpkps
    case rights results of
        [] -> Left (concatMap (++"/") (lefts results))
        [r] -> Right r -- FIXME: this should also check expiration time and flags of the signing key
        _ -> Left "multiple successes; unexpected condition"
    where
        subPKP (pack, _, _) = subPKP' pack
        subPKP' (PublicSubkey p) = p
        subPKP' (SecretSubkey p _) = p
        verify' (Signature s) (pub@(PubV4 _ _ pkey)) ha pl = verify'' (pkaAndMPIs s) ha pub pkey pl
        verify' _ _ _ _ = error "This should never happen."
        verify'' (DSA,mpis) ha pub (DSAPubKey pkey) bs = verify''' (dsaVerify mpis ha pkey bs) pub
        verify'' (RSA,mpis) ha pub (RSAPubKey pkey) bs = verify''' (rsaVerify mpis ha pkey bs) pub
        verify'' _ _ _ _ _ = Left "unimplemented key type"
	verify''' f pub = case f of
                               Left _ -> Left "invalid signature"
                               Right False -> Left "verification failed"
                               Right True -> Right pub
	dsaVerify mpis ha pkey bs = DSA.verify (dsaMPIsToSig mpis) (dsaTruncate pkey . hash ha) pkey bs
	rsaVerify mpis ha pkey bs = RSA.verify (hash ha) (asn1Prefix ha) pkey bs (rsaMPItoSig mpis)
        dsaMPIsToSig mpis = (unMPI (mpis !! 0), unMPI (mpis !! 1))
        rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis))
        finalPayload s pl = B.concat [pl, sigbit s, trailer s]
        sigbit s = runPut $ putPartialSigforSigning s
        hashalgo :: Packet -> HashAlgorithm
        hashalgo (Signature (SigV4 _ _ ha _ _ _ _)) = ha
        hashalgo _ = error "This should never happen."
        trailer :: Packet -> ByteString
        trailer s@(Signature (SigV4 {})) = runPut $ putSigTrailer s
        trailer _ = B.empty
        dsaTruncate pkey bs = if countBits bs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits
        dsaQLen pk = (\(_,_,z) -> countBits (integerToBEBS z)) (DSA.public_params pk)
	pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis)
	pkaAndMPIs _ = error "This should never happen."