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

    {-# LANGUAGE CPP #-}

    module Codec.Encryption.OpenPGP.Signatures (
       verifySigWith
     , verifyAgainstKeyring
     , verifyAgainstKeys
     , verifyTKWith
    ) where

    #if !MIN_VERSION_base(4,8,0)
    import Control.Applicative ((<$>), (<*>))
    #endif
    import Control.Error.Util (hush)
    import Control.Lens ((^.), _1)
    import Control.Monad (liftM2)

    import qualified Crypto.Hash.Algorithms as CHA
    import Crypto.Number.Serialize (i2osp)
    import qualified Crypto.PubKey.DSA as DSA
    import qualified Crypto.PubKey.RSA.PKCS15 as P15

    import Data.ByteString.Lazy (ByteString)
    import qualified Data.ByteString.Lazy as BL
    import Data.Either (lefts, rights)
    import Data.IxSet.Typed ((@=))
    import qualified Data.IxSet.Typed as IxSet
    import Data.List.NonEmpty (NonEmpty(..))
    import Data.Text (Text)
    import Data.Time.Clock (UTCTime(..), diffUTCTime)
    import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
    import Data.Binary.Put (runPut)

    import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
    import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), issuer, emptyPSC, truncatingVerify)
    import Codec.Encryption.OpenPGP.Ontology (isRevokerP, isRevocationKeySSP, isSubkeyBindingSig, isSubkeyRevocation)

    import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig)
    import Codec.Encryption.OpenPGP.Types
    import Data.Conduit.OpenPGP.Keyring.Instances ()

    verifySigWith :: (Pkt -> Maybe UTCTime -> ByteString -> Either String Verification) -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here?
    verifySigWith vf sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do
        v <- vf sig mt (payloadForSig st state)
        _ <- mapM_ (checkIssuer (eightOctetKeyID (v^.verificationSigner)) . _sspPayload) hs
        return v
        where
            checkIssuer :: Either String EightOctetKeyId -> SigSubPacketPayload -> Either String Bool
            checkIssuer (Right signer) (Issuer i) = if signer == i then Right True else Left "issuer subpacket does not match"
            checkIssuer (Left err) (Issuer _) = Left $ "issuer subpacket cannot be checked (" ++ err ++ ")"
            checkIssuer _ _ = Right True
    verifySigWith _ _ _ _ = Left "This should never happen (verifySigWith)."

    verifyTKWith :: (Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification) -> Maybe UTCTime -> TK -> Either String TK
    verifyTKWith vsf mt key = do
        revokers <- checkRevokers key
        revs <- checkKeyRevocations revokers key
        let uids = filter (\(_, sps) -> sps /= []) . checkUidSigs $ key^.tkUIDs -- FIXME: check revocations here?
        let uats = filter (\(_, sps) -> sps /= []) . checkUAtSigs $ key^.tkUAts -- FIXME: check revocations here?
        let subs = concatMap checkSub $ key^.tkSubs -- FIXME: check revocations here?
        return (TK (key^.tkKey) revs uids uats subs)
        where
            checkRevokers = Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkRevs
            checkKeyRevocations :: [(PubKeyAlgorithm, TwentyOctetFingerprint)] -> TK -> Either String [SignaturePayload]
            checkKeyRevocations rs k = Prelude.sequence . concatMap (filterRevs rs) . rights . map (liftM2 fmap (,) vSig) $ k^.tkRevs
            checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]
            checkUidSigs = map (\(uid, sps) -> (uid, (rights . map (\sp -> fmap (const sp) (vUid (uid, sp)))) sps))
            checkUAtSigs :: [([UserAttrSubPacket], [SignaturePayload])] -> [([UserAttrSubPacket], [SignaturePayload])]
            checkUAtSigs = map (\(uat, sps) -> (uat, (rights . map (\sp -> fmap (const sp) (vUAt (uat, sp)))) sps))
            checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])]
            checkSub (pkt, sps) = if revokedSub pkt sps then [] else checkSub' pkt sps
            revokedSub :: Pkt -> [SignaturePayload] -> Bool
            revokedSub _ [] = False
            revokedSub p sigs = any (vSubSig p) (filter isSubkeyRevocation sigs)
            checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]
            checkSub' p sps = let goodsigs = filter (vSubSig p) (filter isSubkeyBindingSig sps) in if null goodsigs then [] else [(p, goodsigs)]
            getHasheds (SigV4 _ _ _ ha _ _ _) = ha
            getHasheds _ = []
            filterRevs :: [(PubKeyAlgorithm, TwentyOctetFingerprint)] -> (SignaturePayload, Verification) -> [Either String SignaturePayload]
            filterRevs vokers spv = case spv of
                                         (s@(SigV4 SignatureDirectlyOnAKey _ _ _ _ _ _), _) -> [Right s]
                                         (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) -> if (v^.verificationSigner == key ^. tkKey._1) || any (\(p,f) -> p == pka && f == fingerprint (v^.verificationSigner)) vokers then [Left "Key revoked"] else [Right s]
                                         _ -> []
            vUid :: (Text, SignaturePayload) -> Either String Verification
            vUid (uid, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastUIDorUAt = UserIdPkt uid } mt
            vUAt :: ([UserAttrSubPacket], SignaturePayload) -> Either String Verification
            vUAt (uat, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastUIDorUAt = UserAttributePkt uat } mt
            vSig :: SignaturePayload -> Either String Verification
            vSig sp = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1) } mt
            vSubSig :: Pkt -> SignaturePayload -> Bool
            vSubSig sk sp = case vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastSubkey = sk} mt of
                                    Left _ -> False
                                    Right _ -> True
            verifyRevoker :: SignaturePayload -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)]
            verifyRevoker sp = do
                _ <- vSig sp
                return (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) . filter isRevocationKeySSP $ getHasheds sp)

    verifyAgainstKeyring :: Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification
    verifyAgainstKeyring kr sig mt payload = do
        i <- maybe (Left "issuer not found") Right (issuer sig)
        potentialmatches <- if IxSet.null (kr @= i) then Left "pubkey not found" else Right (kr @= i)
        verifyAgainstKeys (IxSet.toList potentialmatches) sig mt payload

    verifyAgainstKeys :: [TK] -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification
    verifyAgainstKeys ks sig mt payload = do
        let allrelevantpkps = filter (\x -> ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == Just True) (concatMap (\x -> (x ^. tkKey._1):map subPKP (_tkSubs x)) ks)
        let results = map (\pkp -> verify' sig pkp (hashalgo sig) (BL.toStrict (finalPayload sig payload))) allrelevantpkps
        case rights results of
            [] -> Left (concatMap (++"/") (lefts results))
            [r] -> do _ <- isSignatureExpired sig mt
                      return (Verification r ((_signaturePayload . fromPkt) sig)) -- FIXME: this should also check expiration time and flags of the signing key
            _ -> Left "multiple successes; unexpected condition"
        where
            subPKP (pack, _) = subPKP' pack
            subPKP' (PublicSubkeyPkt p) = p
            subPKP' (SecretSubkeyPkt p _) = p
            subPKP' _ = error "This should never happen (subPKP')"
            verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA1 pl = verify'' (pkaAndMPIs s) CHA.SHA1 pub pkey pl
            verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) RIPEMD160 pl = verify'' (pkaAndMPIs s) CHA.RIPEMD160 pub pkey pl
            verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA256 pl = verify'' (pkaAndMPIs s) CHA.SHA256 pub pkey pl
            verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA384 pl = verify'' (pkaAndMPIs s) CHA.SHA384 pub pkey pl
            verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA512 pl = verify'' (pkaAndMPIs s) CHA.SHA512 pub pkey pl
            verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA224 pl = verify'' (pkaAndMPIs s) CHA.SHA224 pub pkey pl
            verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) DeprecatedMD5 pl = verify'' (pkaAndMPIs s) CHA.MD5 pub pkey pl
            verify' _ _ _ _ = error "This should never happen (verify')."
            verify'' (DSA,mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = verify''' (dsaVerify mpis hd pkey bs) pub
            verify'' (RSA,mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = verify''' (rsaVerify mpis hd pkey bs) pub
            verify'' _ _ _ _ _ = Left "unimplemented key type"
            verify''' f pub = if f then Right pub else Left "verification failed"
            dsaVerify (r:|[s]) hd pkey = truncatingVerify hd pkey (dsaMPIsToSig r s)
            dsaVerify _ _ _ = const False -- FIXME: this should be some sort of Either chain?
            rsaVerify mpis hd pkey bs = P15.verify (Just hd) pkey bs (rsaMPItoSig mpis)
            dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)
            rsaMPItoSig (s:|[]) = i2osp (unMPI s)
            hashalgo :: Pkt -> HashAlgorithm
            hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha
            hashalgo _ = error "This should never happen (hashalgo)."
            pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis)
            pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)."
            isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool
            isSignatureExpired _ Nothing = return False
            isSignatureExpired s (Just t) = if any (expiredBefore t) ((\(SigV4 _ _ _ h _ _ _) -> h) . _signaturePayload . fromPkt $ s) then Left "signature expired" else return True
            expiredBefore :: UTCTime -> SigSubPacket -> Bool
            expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) < 0
            expiredBefore _ _ = False

    finalPayload :: Pkt -> ByteString -> ByteString
    finalPayload s pl = BL.concat [pl, sigbit, trailer s]
        where
            sigbit = runPut $ putPartialSigforSigning s
            trailer :: Pkt -> ByteString
            trailer (SignaturePkt SigV4{}) = runPut $ putSigTrailer s
            trailer _ = BL.empty