module Codec.Encryption.OpenPGP.Signatures
( verifySigWith
, verifyAgainstKeyring
, verifyAgainstKeys
, verifyTKWith
, signUserIDwithRSA
, crossSignSubkeyWithRSA
, signDataWithRSA
) where
import Control.Error.Util (hush)
import Control.Lens ((^.), _1)
import Control.Monad (liftM2)
import Crypto.Error (eitherCryptoError)
import Crypto.Hash (hashWith)
import qualified Crypto.Hash.Algorithms as CHA
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Data.Bifunctor (first)
import Data.Binary.Put (runPut)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Either (isRight, lefts, rights)
import Data.Function (on)
import Data.IxSet.Typed ((@=))
import qualified Data.IxSet.Typed as IxSet
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import Data.Time.Clock (UTCTime(..), diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Internal
( PktStreamContext(..)
, emptyPSC
, issuer
)
import Codec.Encryption.OpenPGP.Ontology
( isRevocationKeySSP
, isRevokerP
, isSubkeyBindingSig
, isSubkeyRevocation
)
import Codec.Encryption.OpenPGP.SerializeForSigs
( payloadForSig
, putKeyforSigning
, putPartialSigforSigning
, putSigTrailer
, putUforSigning
)
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
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 (not . null . snd) . checkUidSigs $ key ^. tkUIDs
let uats = filter (not . null . snd) . checkUAtSigs $ key ^. tkUAts
let subs = concatMap checkSub $ key ^. tkSubs
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 =
isRight
(vsf
(SignaturePkt sp)
emptyPSC
{ lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)
, lastSubkey = sk
}
mt)
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))
_ -> 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 =
dsaVerify pub mpis hd pkey bs
verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs =
ecdsaVerify pub mpis hd pkey bs
verify'' (EdDSA, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs =
ed25519Verify pub mpis hd (i2osp (unEPoint pkey)) bs
verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs =
rsaVerify pub mpis hd pkey bs
verify'' _ _ _ _ _ = Left "unimplemented key type"
dsaVerify pub (r :| [s]) hd pkey bs =
if DSA.verify hd pkey (dsaMPIsToSig r s) bs
then Right pub
else Left ("DSA verification failed: " ++ show (hd, pkey, r, s, bs))
dsaVerify _ _ _ _ _ = Left "cannot verify DSA signature of wrong shape"
ecdsaVerify pub (r :| [s]) hd pkey bs =
if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs
then Right pub
else Left ("ECDSA verification failed: " ++ show (hd, pkey, r, s, bs))
ecdsaVerify _ _ _ _ _ = Left "cannot verify ECDSA signature of wrong shape"
ed25519Verify pub (r :| [s]) hd pkey bs =
either
(Left .
(("Ed25519 verification failed: " ++ show (hd, pkey, r, s, bs) ++ ": ") ++) .
show)
return $ do
ep <- cf2es (Ed25519.publicKey (B.drop 1 pkey))
es <- cf2es (Ed25519.signature ((B.append `on` i2osp . unMPI) r s))
let prehash = crazyHash hd bs :: B.ByteString
if Ed25519.verify ep prehash es
then Right pub
else Left ("does not verify")
ed25519Verify _ _ _ _ _ =
Left "cannot verify Ed25519 signature of wrong shape"
cf2es = either (Left . show) return . eitherCryptoError
rsaVerify pub mpis hd pkey bs =
if P15.verify (Just hd) pkey bs (rsaMPItoSig mpis)
then Right pub
else Left ("DSA verification failed: " ++ show (hd, pkey, mpis, bs))
dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)
ecdsaMPIsToSig r s = ECDSA.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
crazyHash h = BA.convert . hashWith h
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
signUserIDwithRSA ::
PKPayload
-> UserId
-> [SigSubPacket]
-> [SigSubPacket]
-> RSATypes.PrivateKey
-> Either String SignaturePayload
signUserIDwithRSA pkp uid hsigsubs usigsubs prv = do
uidsig <-
first
show
(P15.sign
Nothing
(Just CHA.SHA512)
prv
(BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload)))
return (uidsigp' uidsig)
where
uidpayload =
runPut
(sequence_
[putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)])
uidsigp =
SigV4 PositiveCert RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0])
uidsigp' us =
SigV4
PositiveCert
RSA
SHA512
hsigsubs
usigsubs
(fromIntegral (os2ip (B.take 2 us)))
(NE.fromList [MPI (os2ip us)])
crossSignSubkeyWithRSA ::
PKPayload
-> PKPayload
-> [SigSubPacket]
-> [SigSubPacket]
-> [SigSubPacket]
-> [SigSubPacket]
-> RSATypes.PrivateKey
-> RSATypes.PrivateKey
-> Either String SignaturePayload
crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do
embsig <-
first
show
(P15.sign
Nothing
(Just CHA.SHA512)
ssb
(BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload)))
subsig <-
first
show
(P15.sign
Nothing
(Just CHA.SHA512)
prv
(BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload)))
return (subsigp' (embsigp' embsig) subsig)
where
subkeypayload =
runPut
(sequence_
[ putKeyforSigning (PublicKeyPkt pkp)
, putKeyforSigning (PublicSubkeyPkt subpkp)
])
embsigp =
SigV4
PrimaryKeyBindingSig
RSA
SHA512
embhsigsubs
embusigsubs
0
(NE.fromList [MPI 0])
embsigp' es =
SigV4
PrimaryKeyBindingSig
RSA
SHA512
embhsigsubs
embusigsubs
(fromIntegral (os2ip (B.take 2 es)))
(NE.fromList [MPI (os2ip es)])
subsigp =
SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0])
sspes es = SigSubPacket False (EmbeddedSignature es)
subsigp' es ss =
SigV4
SubkeyBindingSig
RSA
SHA512
subhsigsubs
(sspes es : subusigsubs)
(fromIntegral (os2ip (B.take 2 ss)))
(NE.fromList [MPI (os2ip ss)])
signDataWithRSA ::
SigType
-> RSATypes.PrivateKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either String SignaturePayload
signDataWithRSA st prv has uhas payload =
sp st <$>
first
show
(P15.sign
Nothing
(Just CHA.SHA512)
prv
(BL.toStrict (finalPayload (SignaturePkt (sp0 st)) payload)))
where
sp0 st = SigV4 st RSA SHA512 has [] 0 (NE.fromList [MPI 0])
sp st ss =
SigV4
st
RSA
SHA512
has
uhas
(fromIntegral (os2ip (B.take 2 ss)))
(NE.fromList [MPI (os2ip ss)])