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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
module Main where
import Data.Binary
import Data.OpenPGP
import qualified Data.ByteString.Lazy as L
import Control.Monad
import Text.Show.Pretty
import Data.List
import Data.OpenPGP.CryptoAPI
import Data.Ord
import Data.Maybe
import Data.Bits
getPackets :: IO [Packet]
getPackets = do
input <- L.getContents
case decodeOrFail input of
Right (_,_,Message pkts) -> return pkts
Left (_,_,_) -> return []
isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _ = False
isUserID (UserIDPacket {}) = True
isUserID _ = False
isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
isEmbeddedSignature _ = False
isCertificationSig (CertificationSignature {}) = True
isCertificationSig _ = True
issuer (IssuerPacket issuer) = Just issuer
issuer _ = Nothing
backsig (EmbeddedSignaturePacket s) = Just s
backsig _ = Nothing
isSubkeySignature (SubkeySignature {}) = True
isSubkeySignature _ = False
usage (NotationDataPacket
{ human_readable = True
, notation_name = "usage@"
, notation_value = u
}) = Just u
usage _ = Nothing
verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
where
verified = do
sig <- signatures (Message nonkeys)
let v = verify (Message keys) sig
guard (not . null $ signatures_over v)
return v
(top,othersigs) = partition isSubkeySignature verified
embedded = do
sub <- top
let sigover = signatures_over sub
unhashed = sigover >>= unhashed_subpackets
subsigs = mapMaybe backsig unhashed
sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
let v = verify (Message [subkey sub]) sig
guard (not . null $ signatures_over v)
return v
grip k = drop 32 $ fingerprint k
smallpr k = drop 24 $ fingerprint k
disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
where
grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
samepr a b = smallpr a == smallpr b
{-
-- useful for testing
group2 :: [a] -> [[a]]
group2 (x:y:ys) = [x,y]:group2 ys
group2 [x] = [[x]]
group2 [] = []
-}
getBindings ::
[Packet]
->
( [([Packet],[SignatureOver])] -- ^ other signatures with key sets
-- that were used for the verifications
, [(Word8,
(Packet, Packet),
[String],
[SignatureSubpacket],
[Packet])] -- ^ binding signatures
)
getBindings pkts = (sigs,bindings)
where
(sigs,concat->bindings) = unzip $ do
let (keys,nonkeys) = partition isKey pkts
keys <- disjoint_fp keys
let (bs,sigs) = verifyBindings keys pkts
return . ((keys,sigs),) $ do
b <- bs
i <- map signature_issuer (signatures_over b)
i <- maybeToList i
who <- maybeToList $ find_key fingerprint (Message keys) i
let (code,claimants) =
case () of
_ | who == topkey b -> (1,[])
_ | who == subkey b -> (2,[])
_ -> (0,[who])
let hashed = signatures_over b >>= hashed_subpackets
kind = guard (code==1) >> hashed >>= maybeToList . usage
return (code,(topkey b,subkey b), kind, hashed,claimants)
accBindings ::
Bits t =>
[(t, (Packet, Packet), [a], [a1], [a2])]
-> [(t, (Packet, Packet), [a], [a1], [a2])]
accBindings bs = as
where
gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
as = map (foldl1 combine) gs
bindingPair (_,p,_,_,_) = pub2 p
where
pub2 (a,b) = (pub a, pub b)
pub a = fingerprint_material a
samePair a b = bindingPair a == bindingPair b
combine (ac,p,akind,ahashed,aclaimaints)
(bc,_,bkind,bhashed,bclaimaints)
= (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
listKeys pkts = do
let (certs,bs) = getBindings pkts
as = accBindings bs
defaultkind (k:_) hs = k
defaultkind [] hs = maybe "subkey"
id
( listToMaybe
. mapMaybe (fmap usageString . keyflags)
$ hs)
kinds = map (\(_,_,k,h,_)->defaultkind k h) as
kindwidth = maximum $ map length kinds
kindcol = min 20 kindwidth
code (c,_,_,_,_) = -c
ownerkey (_,(a,_),_,_,_) = a
sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
gs = groupBy sameMaster (sortBy (comparing code) as)
subs <- gs
let (code,(top,sub), kind, hashed,claimants):_ = subs
subkeys = do
(code,(top,sub), kind, hashed,claimants) <- subs
let ar = case code of
0 -> " ??? "
1 -> " --> "
2 -> " <-- "
3 -> " <-> "
formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
" "++grip top ++ ar ++ formkind++" "++ fingerprint sub ++ "\n"
-- ++ ppShow hashed
uid = maybe "" id . listToMaybe $ do
(keys,sigs) <- certs
sig <- sigs
guard (isCertificationSig sig)
guard (topkey sig == top)
sig_over <- signatures_over sig
guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top)
let UserIDPacket uid = user_id sig
return uid
(_,sigs) = unzip certs
unlines
[ uid
, "master-key " ++ fingerprint top ++ "\n" ++ subkeys ]
{-
, KeyFlagsPacket
{ certify_keys = False
, sign_data = True
, encrypt_communication = True
, encrypt_storage = True
, split_key = False
, authentication = True
, group_key = False
}
-}
data PGPKeyFlags =
Special
| Vouch
| Sign
| VouchSign
| Communication
| VouchCommunication
| SignCommunication
| VouchSignCommunication
| Storage
| VouchStorage
| SignStorage
| VouchSignStorage
| Encrypt
| VouchEncrypt
| SignEncrypt
| VouchSignEncrypt
deriving (Eq,Show,Read,Enum)
usageString flgs =
case flgs of
Special -> "special"
Vouch -> "vouch"
Sign -> "sign"
VouchSign -> "vouch-sign"
Communication -> "communication"
VouchCommunication -> "vouch-communication"
SignCommunication -> "sign-communication"
VouchSignCommunication -> "vouch-sign-communication"
Storage -> "storage"
VouchStorage -> "vouch-storage"
SignStorage -> "sign-storage"
VouchSignStorage -> "vouch-sign-storage"
Encrypt -> "encrypt"
VouchEncrypt -> "vouch-encrypt"
SignEncrypt -> "sign-encrypt"
VouchSignEncrypt -> "vouch-sign-encrypt"
keyflags flgs@(KeyFlagsPacket {}) =
Just . toEnum $
( bit 0x1 certify_keys
.|. bit 0x2 sign_data
.|. bit 0x4 encrypt_communication
.|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
where
bit v f = if f flgs then v else 0
keyflags _ = Nothing
main = do
pkts <- getPackets
putStrLn $ listKeys pkts
return ()
|
