1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
-- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes
-- Copyright © 2012-2020 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
module Codec.Encryption.OpenPGP.SerializeForSigs
( putPKPforFingerprinting
, putPartialSigforSigning
, putSigTrailer
, putUforSigning
, putUIDforSigning
, putUAtforSigning
, putKeyforSigning
, putSigforSigning
, payloadForSig
) where
import Control.Lens ((^.))
import Crypto.Number.Serialize (i2osp)
import Data.Binary (put)
import Data.Binary.Put
( Put
, putByteString
, putLazyByteString
, putWord16be
, putWord32be
, putWord8
, runPut
)
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Text.Encoding (encodeUtf8)
import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), pubkeyToMPIs)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
putPKPforFingerprinting :: Pkt -> Put
putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) =
mapM_ putMPIforFingerprinting (pubkeyToMPIs pk)
putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V4 _ _ _ _)) = do
putWord8 0x99
let bs = runPut $ put pkp
putWord16be . fromIntegral $ BL.length bs
putLazyByteString bs
putPKPforFingerprinting _ =
error "This should never happen (putPKPforFingerprinting)"
putMPIforFingerprinting :: MPI -> Put
putMPIforFingerprinting (MPI i) =
let bs = i2osp i
in putByteString bs
putPartialSigforSigning :: Pkt -> Put
putPartialSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ _ _)) = do
putWord8 4
put st
put pka
put ha
let hb = runPut $ mapM_ put hashed
putWord16be . fromIntegral . BL.length $ hb
putLazyByteString hb
putPartialSigforSigning _ =
error "This should never happen (putPartialSigforSigning)"
putSigTrailer :: Pkt -> Put
putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do
putWord8 0x04
putWord8 0xff
putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs
-- this +6 seems like a bug in RFC4880
putSigTrailer _ = error "This should never happen (putSigTrailer)"
putUforSigning :: Pkt -> Put
putUforSigning u@(UserIdPkt _) = putUIDforSigning u
putUforSigning u@(UserAttributePkt _) = putUAtforSigning u
putUforSigning _ = error "This should never happen (putUforSigning)"
putUIDforSigning :: Pkt -> Put
putUIDforSigning (UserIdPkt u) = do
putWord8 0xB4
let bs = encodeUtf8 u
putWord32be . fromIntegral . B.length $ bs
putByteString bs
putUIDforSigning _ = error "This should never happen (putUIDforSigning)"
putUAtforSigning :: Pkt -> Put
putUAtforSigning (UserAttributePkt us) = do
putWord8 0xD1
let bs = runPut (mapM_ put us)
putWord32be . fromIntegral . BL.length $ bs
putLazyByteString bs
putUAtforSigning _ = error "This should never happen (putUAtforSigning)"
putSigforSigning :: Pkt -> Put
putSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ left16 mpis)) = do
putWord8 0x88
let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis)
putWord32be . fromIntegral . BL.length $ bs
putLazyByteString bs
putSigforSigning _ = error "Non-V4 not implemented."
putKeyforSigning :: Pkt -> Put
putKeyforSigning (PublicKeyPkt pkp) = putKeyForSigning' pkp
putKeyforSigning (PublicSubkeyPkt pkp) = putKeyForSigning' pkp
putKeyforSigning (SecretKeyPkt pkp _) = putKeyForSigning' pkp
putKeyforSigning (SecretSubkeyPkt pkp _) = putKeyForSigning' pkp
putKeyforSigning x =
error
("This should never happen (putKeyforSigning) " ++
show (pktTag x) ++ "/" ++ show x)
putKeyForSigning' :: PKPayload -> Put
putKeyForSigning' pkp = do
putWord8 0x99
let bs = runPut $ put pkp
putWord16be . fromIntegral . BL.length $ bs
putLazyByteString bs
payloadForSig :: SigType -> PktStreamContext -> ByteString
payloadForSig BinarySig state = fromPkt (lastLD state) ^. literalDataPayload
payloadForSig CanonicalTextSig state = payloadForSig BinarySig state
payloadForSig StandaloneSig _ = BL.empty
payloadForSig GenericCert state =
kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)
payloadForSig PersonaCert state = payloadForSig GenericCert state
payloadForSig CasualCert state = payloadForSig GenericCert state
payloadForSig PositiveCert state = payloadForSig GenericCert state
payloadForSig SubkeyBindingSig state =
kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well
payloadForSig PrimaryKeyBindingSig state =
kandKPayload (lastPrimaryKey state) (lastSubkey state)
payloadForSig SignatureDirectlyOnAKey state =
runPut (putKeyforSigning (lastPrimaryKey state))
payloadForSig KeyRevocationSig state =
payloadForSig SignatureDirectlyOnAKey state
payloadForSig SubkeyRevocationSig state =
kandKPayload (lastPrimaryKey state) (lastSubkey state)
payloadForSig CertRevocationSig state =
kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures
payloadForSig st _ = error ("I dunno how to " ++ show st)
kandUPayload :: Pkt -> Pkt -> ByteString
kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u])
kandKPayload :: Pkt -> Pkt -> ByteString
kandKPayload k1 k2 =
runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2])
|
