summaryrefslogtreecommitdiff
path: root/keys.hs
diff options
context:
space:
mode:
Diffstat (limited to 'keys.hs')
-rw-r--r--keys.hs76
1 files changed, 54 insertions, 22 deletions
diff --git a/keys.hs b/keys.hs
index e5966ca..c0b5baa 100644
--- a/keys.hs
+++ b/keys.hs
@@ -1,4 +1,5 @@
1{-# LANGUAGE ViewPatterns #-} 1{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE TupleSections #-}
2module Main where 3module Main where
3 4
4import Data.Binary 5import Data.Binary
@@ -30,6 +31,9 @@ isUserID _ = False
30isEmbeddedSignature (EmbeddedSignaturePacket {}) = True 31isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
31isEmbeddedSignature _ = False 32isEmbeddedSignature _ = False
32 33
34isCertificationSig (CertificationSignature {}) = True
35isCertificationSig _ = True
36
33issuer (IssuerPacket issuer) = Just issuer 37issuer (IssuerPacket issuer) = Just issuer
34issuer _ = Nothing 38issuer _ = Nothing
35backsig (EmbeddedSignaturePacket s) = Just s 39backsig (EmbeddedSignaturePacket s) = Just s
@@ -63,37 +67,53 @@ verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersig
63 guard (not . null $ signatures_over v) 67 guard (not . null $ signatures_over v)
64 return v 68 return v
65 69
66grip k = drop (24+8) $ fingerprint k 70grip k = drop 32 $ fingerprint k
67 71
68smallpr k = drop 24 $ fingerprint k 72smallpr k = drop 24 $ fingerprint k
69 73
70disjoint_fp ks = transpose grouped 74disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
71 where 75 where
72 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks 76 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
73 samepr a b = smallpr a == smallpr b 77 samepr a b = smallpr a == smallpr b
74 78
79 {-
80 -- useful for testing
81 group2 :: [a] -> [[a]]
82 group2 (x:y:ys) = [x,y]:group2 ys
83 group2 [x] = [[x]]
84 group2 [] = []
85 -}
86
75getBindings :: 87getBindings ::
76 [Packet] 88 [Packet]
77 -> [(Word8, 89 ->
90 ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets
91 -- that were used for the verifications
92 , [(Word8,
78 (Packet, Packet), 93 (Packet, Packet),
79 [String], 94 [String],
80 [SignatureSubpacket], 95 [SignatureSubpacket],
81 [Packet])] 96 [Packet])] -- ^ binding signatures
82getBindings pkts = do 97 )
83 let (keys,nonkeys) = partition isKey pkts 98getBindings pkts = (sigs,bindings)
84 keys <- disjoint_fp keys 99 where
85 b <- fst $ verifyBindings keys pkts 100 (sigs,concat->bindings) = unzip $ do
86 i <- map signature_issuer (signatures_over b) 101 let (keys,nonkeys) = partition isKey pkts
87 i <- maybeToList i 102 keys <- disjoint_fp keys
88 who <- maybeToList $ find_key fingerprint (Message keys) i 103 let (bs,sigs) = verifyBindings keys pkts
89 let (code,claimants) = 104 return . ((keys,sigs),) $ do
90 case () of 105 b <- bs
91 _ | who == topkey b -> (1,[]) 106 i <- map signature_issuer (signatures_over b)
92 _ | who == subkey b -> (2,[]) 107 i <- maybeToList i
93 _ -> (0,[who]) 108 who <- maybeToList $ find_key fingerprint (Message keys) i
94 let hashed = signatures_over b >>= hashed_subpackets 109 let (code,claimants) =
95 kind = guard (code==1) >> hashed >>= maybeToList . usage 110 case () of
96 return (code,(topkey b,subkey b), kind, hashed,claimants) 111 _ | who == topkey b -> (1,[])
112 _ | who == subkey b -> (2,[])
113 _ -> (0,[who])
114 let hashed = signatures_over b >>= hashed_subpackets
115 kind = guard (code==1) >> hashed >>= maybeToList . usage
116 return (code,(topkey b,subkey b), kind, hashed,claimants)
97 117
98accBindings :: 118accBindings ::
99 Bits t => 119 Bits t =>
@@ -113,7 +133,7 @@ accBindings bs = as
113 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) 133 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
114 134
115listKeys pkts = do 135listKeys pkts = do
116 let bs = getBindings pkts 136 let (certs,bs) = getBindings pkts
117 as = accBindings bs 137 as = accBindings bs
118 defaultkind (k:_) hs = k 138 defaultkind (k:_) hs = k
119 defaultkind [] hs = maybe "subkey" 139 defaultkind [] hs = maybe "subkey"
@@ -140,7 +160,19 @@ listKeys pkts = do
140 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' 160 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
141 " "++grip top ++ ar ++ formkind++" "++ fingerprint sub ++ "\n" 161 " "++grip top ++ ar ++ formkind++" "++ fingerprint sub ++ "\n"
142 -- ++ ppShow hashed 162 -- ++ ppShow hashed
143 "master-key " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n" 163 uid = maybe "" id . listToMaybe $ do
164 (keys,sigs) <- certs
165 sig <- sigs
166 guard (isCertificationSig sig)
167 guard (topkey sig == top)
168 sig_over <- signatures_over sig
169 guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top)
170 let UserIDPacket uid = user_id sig
171 return uid
172 (_,sigs) = unzip certs
173 unlines
174 [ uid
175 , "master-key " ++ fingerprint top ++ "\n" ++ subkeys ]
144 176
145 177
146{- 178{-