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
|
{-# LANGUAGE ViewPatterns #-}
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
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 (24+8) $ fingerprint k
smallpr k = drop 24 $ fingerprint k
disjoint_fp ks = transpose grouped
where
grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
samepr a b = smallpr a == smallpr b
getBindings ::
[Packet]
-> [(Word8,
(Packet, Packet),
[String],
[SignatureSubpacket],
[Packet])]
getBindings pkts = do
let (keys,nonkeys) = partition isKey pkts
keys <- disjoint_fp keys
b <- fst $ verifyBindings keys pkts
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 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
"master-key " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n"
{-
, 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 ()
|
