diff options
Diffstat (limited to 'keys.hs')
-rw-r--r-- | keys.hs | 141 |
1 files changed, 141 insertions, 0 deletions
@@ -0,0 +1,141 @@ | |||
1 | module Main where | ||
2 | |||
3 | import Data.Binary | ||
4 | import Data.OpenPGP | ||
5 | import qualified Data.ByteString.Lazy as L | ||
6 | import Control.Monad | ||
7 | import Text.Show.Pretty | ||
8 | import Data.List | ||
9 | import Data.OpenPGP.CryptoAPI | ||
10 | import Data.Ord | ||
11 | import Data.Maybe | ||
12 | import Data.Bits | ||
13 | |||
14 | getPackets :: IO [Packet] | ||
15 | getPackets = do | ||
16 | input <- L.getContents | ||
17 | case decodeOrFail input of | ||
18 | Right (_,_,Message pkts) -> return pkts | ||
19 | Left (_,_,_) -> return [] | ||
20 | |||
21 | |||
22 | isKey (PublicKeyPacket {}) = True | ||
23 | isKey (SecretKeyPacket {}) = True | ||
24 | isKey _ = False | ||
25 | |||
26 | isUserID (UserIDPacket {}) = True | ||
27 | isUserID _ = False | ||
28 | |||
29 | isEmbeddedSignature (EmbeddedSignaturePacket {}) = True | ||
30 | isEmbeddedSignature _ = False | ||
31 | |||
32 | issuer (IssuerPacket issuer) = Just issuer | ||
33 | issuer _ = Nothing | ||
34 | backsig (EmbeddedSignaturePacket s) = Just s | ||
35 | backsig _ = Nothing | ||
36 | |||
37 | isSubkeySignature (SubkeySignature {}) = True | ||
38 | isSubkeySignature _ = False | ||
39 | |||
40 | usage (NotationDataPacket | ||
41 | { human_readable = True | ||
42 | , notation_name = "usage@" | ||
43 | , notation_value = u | ||
44 | }) = Just u | ||
45 | usage _ = Nothing | ||
46 | |||
47 | verifyBindings keys [] = [] | ||
48 | verifyBindings keys nonkeys = top ++ filter isSubkeySignature embedded | ||
49 | where | ||
50 | verified = do | ||
51 | sig <- signatures (Message nonkeys) | ||
52 | let v = verify (Message keys) sig | ||
53 | guard (not . null $ signatures_over v) | ||
54 | return v | ||
55 | (top,_) = partition isSubkeySignature verified | ||
56 | embedded = do | ||
57 | sub <- top | ||
58 | let sigover = signatures_over sub | ||
59 | unhashed = sigover >>= unhashed_subpackets | ||
60 | subsigs = mapMaybe backsig unhashed | ||
61 | sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) | ||
62 | let v = verify (Message [subkey sub]) sig | ||
63 | guard (not . null $ signatures_over v) | ||
64 | return v | ||
65 | |||
66 | smallpr k = drop 24 $ fingerprint k | ||
67 | |||
68 | disjoint_fp ks = transpose grouped | ||
69 | where | ||
70 | grouped = groupBy samepr . sortBy (comparing smallpr) $ ks | ||
71 | samepr a b = smallpr a == smallpr b | ||
72 | |||
73 | getBindings :: | ||
74 | [Packet] | ||
75 | -> [(Word8, | ||
76 | (Packet, Packet), | ||
77 | [String], | ||
78 | [SignatureSubpacket], | ||
79 | [Packet])] | ||
80 | getBindings pkts = do | ||
81 | let (keys,nonkeys) = partition isKey pkts | ||
82 | keys <- disjoint_fp (keys) | ||
83 | b <- verifyBindings keys pkts -- nonkeys | ||
84 | i <- map signature_issuer (signatures_over b) | ||
85 | i <- maybeToList i | ||
86 | who <- maybeToList $ find_key fingerprint (Message keys) i | ||
87 | let (code,claimants) = | ||
88 | case () of | ||
89 | _ | who == topkey b -> (1,[]) | ||
90 | _ | who == subkey b -> (2,[]) | ||
91 | _ -> (0,[who]) | ||
92 | let hashed = signatures_over b >>= hashed_subpackets | ||
93 | kind = guard (code==1) >> hashed >>= maybeToList . usage | ||
94 | return (code,(topkey b,subkey b), kind, hashed,claimants) | ||
95 | |||
96 | accBindings :: | ||
97 | Bits t => | ||
98 | [(t, (Packet, Packet), [a], [a1], [a2])] | ||
99 | -> [(t, (Packet, Packet), [a], [a1], [a2])] | ||
100 | accBindings bs = as | ||
101 | where | ||
102 | gs = groupBy samePair . sortBy (comparing bindingPair) $ bs | ||
103 | as = map (foldl1 combine) gs | ||
104 | bindingPair (_,p,_,_,_) = pub2 p | ||
105 | where | ||
106 | pub2 (a,b) = (pub a, pub b) | ||
107 | pub a = fingerprint_material a | ||
108 | samePair a b = bindingPair a == bindingPair b | ||
109 | combine (ac,p,akind,ahashed,aclaimaints) | ||
110 | (bc,_,bkind,bhashed,bclaimaints) | ||
111 | = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) | ||
112 | |||
113 | listKeys pkts = do | ||
114 | let bs = getBindings pkts | ||
115 | as = accBindings bs | ||
116 | defaultkind [] = "subkey" | ||
117 | defaultkind (k:_) = k | ||
118 | kinds = map (\(_,_,k,_,_)->defaultkind k) as | ||
119 | kindwidth = maximum $ map length kinds | ||
120 | kindcol = min 20 kindwidth | ||
121 | sameMaster (_,(a,_),_,_,_) (_,(b,_),_,_,_) = fingerprint_material a==fingerprint_material b | ||
122 | gs = groupBy sameMaster as | ||
123 | subs <- gs | ||
124 | let (code,(top,sub), kind, hashed,claimants):_ = subs | ||
125 | subkeys = do | ||
126 | (code,(top,sub), kind, hashed,claimants) <- subs | ||
127 | let ar = case code of | ||
128 | 0 -> " ??? " | ||
129 | 1 -> " --> " | ||
130 | 2 -> " <-- " | ||
131 | 3 -> " <-> " | ||
132 | formkind = take kindcol $ defaultkind kind ++ repeat ' ' | ||
133 | " "++smallpr top ++ ar ++ formkind++" "++ fingerprint sub ++"\n" | ||
134 | "gpg " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n" | ||
135 | |||
136 | |||
137 | |||
138 | main = do | ||
139 | pkts <- getPackets | ||
140 | putStrLn $ listKeys pkts | ||
141 | return () | ||