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
|
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 [] = []
verifyBindings keys nonkeys = top ++ filter isSubkeySignature embedded
where
verified = do
sig <- signatures (Message nonkeys)
let v = verify (Message keys) sig
guard (not . null $ signatures_over v)
return v
(top,_) = 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
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 <- verifyBindings keys pkts -- nonkeys
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 [] = "subkey"
defaultkind (k:_) = k
kinds = map (\(_,_,k,_,_)->defaultkind k) as
kindwidth = maximum $ map length kinds
kindcol = min 20 kindwidth
sameMaster (_,(a,_),_,_,_) (_,(b,_),_,_,_) = fingerprint_material a==fingerprint_material b
gs = groupBy sameMaster 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 ++ repeat ' '
" "++smallpr top ++ ar ++ formkind++" "++ fingerprint sub ++"\n"
"gpg " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n"
main = do
pkts <- getPackets
putStrLn $ listKeys pkts
return ()
|
