diff options
Diffstat (limited to 'lib/Transforms.hs')
-rw-r--r-- | lib/Transforms.hs | 738 |
1 files changed, 738 insertions, 0 deletions
diff --git a/lib/Transforms.hs b/lib/Transforms.hs new file mode 100644 index 0000000..093d594 --- /dev/null +++ b/lib/Transforms.hs | |||
@@ -0,0 +1,738 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE TupleSections #-} | ||
3 | {-# LANGUAGE ViewPatterns #-} | ||
4 | {-# LANGUAGE OverloadedStrings #-} | ||
5 | module Transforms where | ||
6 | |||
7 | import Control.Monad | ||
8 | import Data.Char | ||
9 | import Data.List | ||
10 | import Data.Maybe | ||
11 | import Data.Ord | ||
12 | import Data.OpenPGP | ||
13 | import Data.OpenPGP.Util | ||
14 | import Data.Word (Word8) | ||
15 | import Types | ||
16 | import FunctorToMaybe | ||
17 | import GnuPGAgent ( key_nbits ) | ||
18 | import PacketTranscoder | ||
19 | import qualified Data.Traversable as Traversable | ||
20 | import qualified Data.ByteString as S | ||
21 | import qualified Data.ByteString.Lazy as L | ||
22 | import qualified Data.ByteString.Lazy.Char8 as Char8 | ||
23 | import qualified Data.Map.Strict as Map | ||
24 | #if defined(VERSION_memory) | ||
25 | import qualified Data.ByteString.Char8 as S8 | ||
26 | import Data.ByteArray.Encoding | ||
27 | #elif defined(VERSION_dataenc) | ||
28 | import qualified Codec.Binary.Base32 as Base32 | ||
29 | import qualified Codec.Binary.Base64 as Base64 | ||
30 | #endif | ||
31 | #if !defined(VERSION_cryptonite) | ||
32 | import qualified Crypto.Hash.SHA1 as SHA1 | ||
33 | import qualified Crypto.Types.PubKey.ECC as ECC | ||
34 | #else | ||
35 | import qualified Crypto.Hash as Vincent | ||
36 | import Data.ByteArray (convert) | ||
37 | import qualified Crypto.PubKey.ECC.Types as ECC | ||
38 | #endif | ||
39 | import Data.ASN1.BinaryEncoding ( DER(..) ) | ||
40 | import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 | ||
41 | , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) ) | ||
42 | import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' ) | ||
43 | import qualified Data.Text as T ( Text, unpack, pack, | ||
44 | strip, reverse, drop, break, dropAround, length ) | ||
45 | import Data.Text.Encoding ( encodeUtf8 ) | ||
46 | import Data.Bits ( (.|.), (.&.), Bits, shiftR ) | ||
47 | |||
48 | type TrustMap = Map.Map FilePath Packet | ||
49 | type SigAndTrust = ( MappedPacket | ||
50 | , TrustMap ) -- trust packets | ||
51 | data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show | ||
52 | |||
53 | -- | This is a GPG Identity which includes a master key and all its UIDs and | ||
54 | -- subkeys and associated signatures. | ||
55 | data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key | ||
56 | , keySigAndTrusts :: [SigAndTrust] -- sigs on main key | ||
57 | , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids | ||
58 | , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys | ||
59 | } deriving Show | ||
60 | type KeyDB = Map.Map KeyKey KeyData | ||
61 | |||
62 | |||
63 | |||
64 | data KeyRingRuntime = KeyRingRuntime | ||
65 | { rtPubring :: FilePath | ||
66 | -- ^ Path to the file represented by 'HomePub' | ||
67 | , rtSecring :: FilePath | ||
68 | -- ^ Path to the file represented by 'HomeSec' | ||
69 | , rtGrip :: Maybe String | ||
70 | -- ^ Fingerprint or portion of a fingerprint used | ||
71 | -- to identify the working GnuPG identity used to | ||
72 | -- make signatures. | ||
73 | , rtWorkingKey :: Maybe Packet | ||
74 | -- ^ The master key of the working GnuPG identity. | ||
75 | , rtKeyDB :: KeyDB | ||
76 | -- ^ The common information pool where files spilled | ||
77 | -- their content and from which they received new | ||
78 | -- content. | ||
79 | , rtRingAccess :: Map.Map InputFile Access | ||
80 | -- ^ The 'Access' values used for files of type | ||
81 | -- 'KeyRingFile'. If 'AutoAccess' was specified | ||
82 | -- for a file, this 'Map.Map' will indicate the | ||
83 | -- detected value that was used by the algorithm. | ||
84 | , rtPassphrases :: PacketTranscoder | ||
85 | } | ||
86 | |||
87 | |||
88 | -- | Roster-entry level actions | ||
89 | data PacketUpdate = InducerSignature String [SignatureSubpacket] | ||
90 | | SubKeyDeletion KeyKey KeyKey | ||
91 | |||
92 | data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) | ||
93 | |||
94 | instance ASN1Object RSAPublicKey where | ||
95 | -- PKCS #1 RSA Public Key | ||
96 | toASN1 (RSAKey (MPI n) (MPI e)) | ||
97 | = \xs -> Start Sequence | ||
98 | : IntVal n | ||
99 | : IntVal e | ||
100 | : End Sequence | ||
101 | : xs | ||
102 | fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) = | ||
103 | Right (RSAKey (MPI n) (MPI e), xs) | ||
104 | |||
105 | fromASN1 _ = | ||
106 | Left "fromASN1: RSAPublicKey: unexpected format" | ||
107 | |||
108 | |||
109 | -- | This type is used to describe events triggered by 'runKeyRing'. In | ||
110 | -- addition to normal feedback (e.g. 'NewPacket'), it also may indicate | ||
111 | -- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a | ||
112 | -- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with | ||
113 | -- many inputs and outputs, an operation may be partially (or even mostly) | ||
114 | -- successful even when I/O failures occured. In this situation, the files may | ||
115 | -- not have all the information they were intended to store, but they will be | ||
116 | -- in a valid format for GnuPG or kiki to operate on in the future. | ||
117 | data KikiReportAction = | ||
118 | NewPacket String | ||
119 | | MissingPacket String | ||
120 | | ExportedSubkey | ||
121 | | GeneratedSubkeyFile | ||
122 | | NewWalletKey String | ||
123 | | YieldSignature | ||
124 | | YieldSecretKeyPacket String | ||
125 | | UnableToUpdateExpiredSignature | ||
126 | | WarnFailedToMakeSignature | ||
127 | | FailedExternal Int | ||
128 | | ExternallyGeneratedFile | ||
129 | | UnableToExport KeyAlgorithm String | ||
130 | | FailedFileWrite | ||
131 | | HostsDiff L.ByteString | ||
132 | | DeletedPacket String | ||
133 | deriving (Eq,Show) | ||
134 | |||
135 | type KikiReport = [ (FilePath, KikiReportAction) ] | ||
136 | |||
137 | data UserIDRecord = UserIDRecord { | ||
138 | uid_full :: String, | ||
139 | uid_realname :: T.Text, | ||
140 | uid_user :: T.Text, | ||
141 | uid_subdomain :: T.Text, | ||
142 | uid_topdomain :: T.Text | ||
143 | } | ||
144 | deriving Show | ||
145 | |||
146 | data PGPKeyFlags = | ||
147 | Special | ||
148 | | Vouch -- 0001 C -- Signkey | ||
149 | | Sign -- 0010 S | ||
150 | | VouchSign -- 0011 | ||
151 | | Communication -- 0100 E | ||
152 | | VouchCommunication -- 0101 | ||
153 | | SignCommunication -- 0110 | ||
154 | | VouchSignCommunication -- 0111 | ||
155 | | Storage -- 1000 E | ||
156 | | VouchStorage -- 1001 | ||
157 | | SignStorage -- 1010 | ||
158 | | VouchSignStorage -- 1011 | ||
159 | | Encrypt -- 1100 E | ||
160 | | VouchEncrypt -- 1101 | ||
161 | | SignEncrypt -- 1110 | ||
162 | | VouchSignEncrypt -- 1111 | ||
163 | deriving (Eq,Show,Read,Enum) | ||
164 | |||
165 | |||
166 | |||
167 | -- Functions | ||
168 | |||
169 | unk :: Bool -> MappedPacket -> MappedPacket | ||
170 | unk isPublic = if isPublic then toPacket secretToPublic else id | ||
171 | where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} | ||
172 | |||
173 | |||
174 | unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] | ||
175 | unsig fname isPublic (sig,trustmap) = | ||
176 | sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) | ||
177 | where | ||
178 | f n _ = n==fname -- && trace ("fname=n="++show n) True | ||
179 | asMapped n p = let m = mappedPacket fname p | ||
180 | in m { locations = fmap (\x->x {originalNum=n}) (locations m) } | ||
181 | |||
182 | smallpr k = drop 24 $ fingerprint k | ||
183 | |||
184 | backsig :: SignatureSubpacket -> Maybe Packet | ||
185 | backsig (EmbeddedSignaturePacket s) = Just s | ||
186 | backsig _ = Nothing | ||
187 | |||
188 | |||
189 | isSubkeySignature (SubkeySignature {}) = True | ||
190 | isSubkeySignature _ = False | ||
191 | |||
192 | |||
193 | has_tag tag p = isSignaturePacket p | ||
194 | && or [ tag `elem` mapMaybe usage (hashed_subpackets p) | ||
195 | , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] | ||
196 | |||
197 | |||
198 | |||
199 | verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) | ||
200 | where | ||
201 | verified = do | ||
202 | sig <- signatures (Message nonkeys) | ||
203 | let v = verify (Message keys) sig | ||
204 | guard (not . null $ signatures_over v) | ||
205 | return v | ||
206 | (top,othersigs) = partition isSubkeySignature verified | ||
207 | embedded = do | ||
208 | sub <- top | ||
209 | let sigover = signatures_over sub | ||
210 | unhashed = sigover >>= unhashed_subpackets | ||
211 | subsigs = mapMaybe backsig unhashed | ||
212 | -- This should consist only of 0x19 values | ||
213 | -- subtypes = map signature_type subsigs | ||
214 | -- trace ("subtypes = "++show subtypes) (return ()) | ||
215 | -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) | ||
216 | sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) | ||
217 | let v = verify (Message [subkey sub]) sig | ||
218 | guard (not . null $ signatures_over v) | ||
219 | return v | ||
220 | |||
221 | |||
222 | disjoint_fp ks = {- concatMap group2 $ -} transpose grouped | ||
223 | where | ||
224 | grouped = groupBy samepr . sortBy (comparing smallpr) $ ks | ||
225 | samepr a b = smallpr a == smallpr b | ||
226 | |||
227 | {- | ||
228 | -- useful for testing | ||
229 | group2 :: [a] -> [[a]] | ||
230 | group2 (x:y:ys) = [x,y]:group2 ys | ||
231 | group2 [x] = [[x]] | ||
232 | group2 [] = [] | ||
233 | -} | ||
234 | |||
235 | |||
236 | |||
237 | subkeyMappedPacket :: SubKey -> MappedPacket | ||
238 | subkeyMappedPacket (SubKey k _ ) = k | ||
239 | |||
240 | getBindings :: | ||
241 | [Packet] | ||
242 | -> | ||
243 | ( [([Packet],[SignatureOver])] -- other signatures with key sets | ||
244 | -- that were used for the verifications | ||
245 | , [(Word8, | ||
246 | (Packet, Packet), -- (topkey,subkey) | ||
247 | [String], -- usage flags | ||
248 | [SignatureSubpacket], -- hashed data | ||
249 | [Packet])] -- binding signatures | ||
250 | ) | ||
251 | getBindings pkts = (sigs,bindings) | ||
252 | where | ||
253 | (sigs,concat->bindings) = unzip $ do | ||
254 | let (keys,_) = partition isKey pkts | ||
255 | keys <- disjoint_fp keys | ||
256 | let (bs,sigs) = verifyBindings keys pkts | ||
257 | return . ((keys,sigs),) $ do | ||
258 | b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs | ||
259 | i <- map signature_issuer (signatures_over b) | ||
260 | i <- maybeToList i | ||
261 | who <- maybeToList $ find_key fingerprint (Message keys) i | ||
262 | let (code,claimants) = | ||
263 | case () of | ||
264 | _ | who == topkey b -> (1,[]) | ||
265 | _ | who == subkey b -> (2,[]) | ||
266 | _ -> (0,[who]) | ||
267 | let hashed = signatures_over b >>= hashed_subpackets | ||
268 | kind = guard (code==1) >> hashed >>= maybeToList . usage | ||
269 | return (code,(topkey b,subkey b), kind, hashed,claimants) | ||
270 | |||
271 | |||
272 | -- Returned data is simmilar to getBindings but the Word8 codes | ||
273 | -- are ORed together. | ||
274 | accBindings :: | ||
275 | Bits t => | ||
276 | [(t, (Packet, Packet), [a], [a1], [a2])] | ||
277 | -> [(t, (Packet, Packet), [a], [a1], [a2])] | ||
278 | accBindings bs = as | ||
279 | where | ||
280 | gs = groupBy samePair . sortBy (comparing bindingPair) $ bs | ||
281 | as = map (foldl1 combine) gs | ||
282 | bindingPair (_,p,_,_,_) = pub2 p | ||
283 | where | ||
284 | pub2 (a,b) = (pub a, pub b) | ||
285 | pub a = fingerprint_material a | ||
286 | samePair a b = bindingPair a == bindingPair b | ||
287 | combine (ac,p,akind,ahashed,aclaimaints) | ||
288 | (bc,_,bkind,bhashed,bclaimaints) | ||
289 | = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) | ||
290 | |||
291 | sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] | ||
292 | sortByHint fname f = sortBy (comparing gethint) | ||
293 | where | ||
294 | gethint = maybe defnum originalNum . Map.lookup fname . locations . f | ||
295 | defnum = -1 | ||
296 | |||
297 | concatSort :: | ||
298 | FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] | ||
299 | concatSort fname getp f = concat . sortByHint fname getp . map f | ||
300 | |||
301 | flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] | ||
302 | flattenUid fname ispub (str,(sigs,om)) = | ||
303 | (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs | ||
304 | |||
305 | flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] | ||
306 | flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs | ||
307 | |||
308 | flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] | ||
309 | flattenAllUids fname ispub uids = | ||
310 | concatSort fname head (flattenUid fname ispub) (Map.assocs uids) | ||
311 | |||
312 | flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] | ||
313 | flattenTop fname ispub (KeyData key sigs uids subkeys) = | ||
314 | unk ispub key : | ||
315 | ( flattenAllUids fname ispub uids | ||
316 | ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) | ||
317 | |||
318 | |||
319 | sigpackets :: | ||
320 | Monad m => | ||
321 | Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet | ||
322 | sigpackets typ hashed unhashed = return $ | ||
323 | signaturePacket | ||
324 | 4 -- version | ||
325 | typ -- 0x18 subkey binding sig, or 0x19 back-signature | ||
326 | RSA | ||
327 | SHA1 | ||
328 | hashed | ||
329 | unhashed | ||
330 | 0 -- Word16 -- Left 16 bits of the signed hash value | ||
331 | [] -- [MPI] | ||
332 | |||
333 | |||
334 | |||
335 | keyFlags :: t -> [Packet] -> [SignatureSubpacket] | ||
336 | keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) | ||
337 | |||
338 | -- XXX keyFlags and keyflags are different functions. | ||
339 | keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags | ||
340 | keyflags flgs@(KeyFlagsPacket {}) = | ||
341 | Just . toEnum $ | ||
342 | ( bit 0x1 certify_keys | ||
343 | .|. bit 0x2 sign_data | ||
344 | .|. bit 0x4 encrypt_communication | ||
345 | .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags | ||
346 | -- other flags: | ||
347 | -- split_key | ||
348 | -- authentication (ssh-client) | ||
349 | -- group_key | ||
350 | where | ||
351 | bit v f = if f flgs then v else 0 | ||
352 | keyflags _ = Nothing | ||
353 | |||
354 | |||
355 | |||
356 | secretToPublic :: Packet -> Packet | ||
357 | secretToPublic pkt@(SecretKeyPacket {}) = | ||
358 | PublicKeyPacket { version = version pkt | ||
359 | , timestamp = timestamp pkt | ||
360 | , key_algorithm = key_algorithm pkt | ||
361 | -- , ecc_curve = ecc_curve pkt | ||
362 | , key = let seckey = key pkt | ||
363 | pubs = public_key_fields (key_algorithm pkt) | ||
364 | in filter (\(k,v) -> k `elem` pubs) seckey | ||
365 | , is_subkey = is_subkey pkt | ||
366 | , v3_days_of_validity = Nothing | ||
367 | } | ||
368 | secretToPublic pkt = pkt | ||
369 | |||
370 | |||
371 | |||
372 | uidkey :: Packet -> String | ||
373 | uidkey (UserIDPacket str) = str | ||
374 | |||
375 | usageString :: PGPKeyFlags -> String | ||
376 | usageString flgs = | ||
377 | case flgs of | ||
378 | Special -> "special" | ||
379 | Vouch -> "vouch" -- signkey | ||
380 | Sign -> "sign" | ||
381 | VouchSign -> "vouch-sign" | ||
382 | Communication -> "communication" | ||
383 | VouchCommunication -> "vouch-communication" | ||
384 | SignCommunication -> "sign-communication" | ||
385 | VouchSignCommunication -> "vouch-sign-communication" | ||
386 | Storage -> "storage" | ||
387 | VouchStorage -> "vouch-storage" | ||
388 | SignStorage -> "sign-storage" | ||
389 | VouchSignStorage -> "vouch-sign-storage" | ||
390 | Encrypt -> "encrypt" | ||
391 | VouchEncrypt -> "vouch-encrypt" | ||
392 | SignEncrypt -> "sign-encrypt" | ||
393 | VouchSignEncrypt -> "vouch-sign-encrypt" | ||
394 | |||
395 | |||
396 | |||
397 | usage :: SignatureSubpacket -> Maybe String | ||
398 | usage (NotationDataPacket | ||
399 | { human_readable = True | ||
400 | , notation_name = "usage@" | ||
401 | , notation_value = u | ||
402 | }) = Just u | ||
403 | usage _ = Nothing | ||
404 | |||
405 | |||
406 | ifSecret :: Packet -> t -> t -> t | ||
407 | ifSecret (SecretKeyPacket {}) t f = t | ||
408 | ifSecret _ t f = f | ||
409 | |||
410 | |||
411 | showPacket :: Packet -> String | ||
412 | showPacket p | isKey p = (if is_subkey p | ||
413 | then showPacket0 p | ||
414 | else ifSecret p "---Secret" "---Public") | ||
415 | ++ " "++fingerprint p | ||
416 | ++ " "++show (key_algorithm p) | ||
417 | ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" } | ||
418 | | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) | ||
419 | -- | isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p) | ||
420 | | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p | ||
421 | | otherwise = showPacket0 p | ||
422 | where | ||
423 | sigusage p = | ||
424 | case take 1 (tagStrings p) of | ||
425 | [] -> "" | ||
426 | tag:_ -> " "++show tag -- "("++tag++")" | ||
427 | where | ||
428 | tagStrings p = usage_tags ++ flags | ||
429 | where | ||
430 | usage_tags = mapMaybe usage xs | ||
431 | flags = mapMaybe (fmap usageString . keyflags) xs | ||
432 | xs = hashed_subpackets p | ||
433 | |||
434 | |||
435 | showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p) | ||
436 | where | ||
437 | dropSuffix :: String -> String -> String | ||
438 | dropSuffix _ [] = "" | ||
439 | dropSuffix suff (x:xs) | (x:xs)==suff = "" | ||
440 | | otherwise = x:dropSuffix suff xs | ||
441 | |||
442 | |||
443 | |||
444 | makeInducerSig | ||
445 | :: Packet | ||
446 | -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver | ||
447 | -- torsig g topk wkun uid timestamp extras = todo | ||
448 | makeInducerSig topk wkun uid extras | ||
449 | = CertificationSignature (secretToPublic topk) | ||
450 | uid | ||
451 | (sigpackets 0x13 | ||
452 | subpackets | ||
453 | subpackets_unh) | ||
454 | where | ||
455 | subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] | ||
456 | tsign | ||
457 | ++ extras | ||
458 | subpackets_unh = [IssuerPacket (fingerprint wkun)] | ||
459 | tsign = if keykey wkun == keykey topk | ||
460 | then [] -- tsign doesnt make sense for self-signatures | ||
461 | else [ TrustSignaturePacket 1 120 | ||
462 | , RegularExpressionPacket regex] | ||
463 | -- <[^>]+[@.]asdf\.nowhere>$ | ||
464 | regex = "<[^>]+[@.]"++hostname++">$" | ||
465 | -- regex = username ++ "@" ++ hostname | ||
466 | -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String | ||
467 | hostname = subdomain' pu ++ "\\." ++ topdomain' pu | ||
468 | pu = parseUID uidstr where UserIDPacket uidstr = uid | ||
469 | subdomain' = escape . T.unpack . uid_subdomain | ||
470 | topdomain' = escape . T.unpack . uid_topdomain | ||
471 | escape s = concatMap echar s | ||
472 | where | ||
473 | echar '|' = "\\|" | ||
474 | echar '*' = "\\*" | ||
475 | echar '+' = "\\+" | ||
476 | echar '?' = "\\?" | ||
477 | echar '.' = "\\." | ||
478 | echar '^' = "\\^" | ||
479 | echar '$' = "\\$" | ||
480 | echar '\\' = "\\\\" | ||
481 | echar '[' = "\\[" | ||
482 | echar ']' = "\\]" | ||
483 | echar c = [c] | ||
484 | |||
485 | |||
486 | keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] | ||
487 | keyFlags0 wkun uidsigs = concat | ||
488 | [ keyflags | ||
489 | , preferredsym | ||
490 | , preferredhash | ||
491 | , preferredcomp | ||
492 | , features ] | ||
493 | |||
494 | where | ||
495 | subs = concatMap hashed_subpackets uidsigs | ||
496 | keyflags = filterOr isflags subs $ | ||
497 | KeyFlagsPacket { certify_keys = True | ||
498 | , sign_data = True | ||
499 | , encrypt_communication = False | ||
500 | , encrypt_storage = False | ||
501 | , split_key = False | ||
502 | , authentication = False | ||
503 | , group_key = False | ||
504 | } | ||
505 | preferredsym = filterOr ispreferedsym subs $ | ||
506 | PreferredSymmetricAlgorithmsPacket | ||
507 | [ AES256 | ||
508 | , AES192 | ||
509 | , AES128 | ||
510 | , CAST5 | ||
511 | , TripleDES | ||
512 | ] | ||
513 | preferredhash = filterOr ispreferedhash subs $ | ||
514 | PreferredHashAlgorithmsPacket | ||
515 | [ SHA256 | ||
516 | , SHA1 | ||
517 | , SHA384 | ||
518 | , SHA512 | ||
519 | , SHA224 | ||
520 | ] | ||
521 | preferredcomp = filterOr ispreferedcomp subs $ | ||
522 | PreferredCompressionAlgorithmsPacket | ||
523 | [ ZLIB | ||
524 | , BZip2 | ||
525 | , ZIP | ||
526 | ] | ||
527 | features = filterOr isfeatures subs $ | ||
528 | FeaturesPacket { supports_mdc = True | ||
529 | } | ||
530 | |||
531 | filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs | ||
532 | |||
533 | isflags (KeyFlagsPacket {}) = True | ||
534 | isflags _ = False | ||
535 | ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True | ||
536 | ispreferedsym _ = False | ||
537 | ispreferedhash (PreferredHashAlgorithmsPacket {}) = True | ||
538 | ispreferedhash _ = False | ||
539 | ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True | ||
540 | ispreferedcomp _ = False | ||
541 | isfeatures (FeaturesPacket {}) = True | ||
542 | isfeatures _ = False | ||
543 | |||
544 | |||
545 | |||
546 | keyPacket :: KeyData -> Packet | ||
547 | keyPacket (KeyData k _ _ _) = packet k | ||
548 | |||
549 | |||
550 | rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey | ||
551 | rsaKeyFromPacket p | isKey p = do | ||
552 | n <- lookup 'n' $ key p | ||
553 | e <- lookup 'e' $ key p | ||
554 | return $ RSAKey n e | ||
555 | |||
556 | rsaKeyFromPacket _ = Nothing | ||
557 | |||
558 | |||
559 | torhash :: Packet -> String | ||
560 | torhash key = fromMaybe "" $ derToBase32 <$> derRSA key | ||
561 | |||
562 | torUIDFromKey :: Packet -> String | ||
563 | torUIDFromKey key = "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>" | ||
564 | |||
565 | derToBase32 :: L.ByteString -> String | ||
566 | derToBase32 = map toLower . base32 . sha1 | ||
567 | where | ||
568 | sha1 :: L.ByteString -> S.ByteString | ||
569 | #if !defined(VERSION_cryptonite) | ||
570 | sha1 = SHA1.hashlazy | ||
571 | #else | ||
572 | sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) | ||
573 | #endif | ||
574 | #if defined(VERSION_memory) | ||
575 | base32 = S8.unpack . convertToBase Base32 | ||
576 | #elif defined(VERSION_dataenc) | ||
577 | base32 = Base32.encode . S.unpack | ||
578 | #endif | ||
579 | |||
580 | derRSA :: Packet -> Maybe L.ByteString | ||
581 | derRSA rsa = do | ||
582 | k <- rsaKeyFromPacket rsa | ||
583 | return $ encodeASN1 DER (toASN1 k []) | ||
584 | |||
585 | try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b) | ||
586 | try x body = | ||
587 | case functorToEither x of | ||
588 | Left e -> return e | ||
589 | Right x -> body x | ||
590 | |||
591 | |||
592 | |||
593 | |||
594 | performManipulations :: | ||
595 | (PacketDecrypter) | ||
596 | -> KeyRingRuntime | ||
597 | -> Maybe MappedPacket | ||
598 | -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) | ||
599 | -> IO (KikiCondition (KeyRingRuntime,KikiReport)) | ||
600 | performManipulations doDecrypt rt wk manip = do | ||
601 | let db = rtKeyDB rt | ||
602 | performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd | ||
603 | r <- Traversable.mapM performAll db | ||
604 | try (sequenceA r) $ \db -> do | ||
605 | return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db) | ||
606 | where | ||
607 | perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) | ||
608 | perform kd (InducerSignature uid subpaks) = do | ||
609 | try kd $ \(kd,report) -> do | ||
610 | flip (maybe $ return NoWorkingKey) wk $ \wk' -> do | ||
611 | wkun' <- doDecrypt wk' | ||
612 | try wkun' $ \wkun -> do | ||
613 | let flgs = if keykey (keyPacket kd) == keykey wkun | ||
614 | then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs) | ||
615 | else [] | ||
616 | sigOver = makeInducerSig (keyPacket kd) | ||
617 | wkun | ||
618 | (UserIDPacket uid) | ||
619 | $ flgs ++ subpaks | ||
620 | om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid | ||
621 | toMappedPacket om p = (mappedPacket "" p) {locations=om} | ||
622 | selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard | ||
623 | . (== keykey whosign) | ||
624 | . keykey)) vs | ||
625 | keys = map keyPacket $ Map.elems (rtKeyDB rt) | ||
626 | overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) | ||
627 | vs :: [ ( Packet -- signature | ||
628 | , Maybe SignatureOver -- Nothing means non-verified | ||
629 | , Packet ) -- key who signed | ||
630 | ] | ||
631 | vs = do | ||
632 | x <- maybeToList $ Map.lookup uid (keyUids kd) | ||
633 | sig <- map (packet . fst) (fst x) | ||
634 | o <- overs sig | ||
635 | k <- keys | ||
636 | let ov = verify (Message [k]) $ o | ||
637 | signatures_over ov | ||
638 | return (sig,Just ov,k) | ||
639 | additional new_sig = do | ||
640 | new_sig <- maybeToList new_sig | ||
641 | guard (null $ selfsigs) | ||
642 | signatures_over new_sig | ||
643 | sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) | ||
644 | let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) | ||
645 | f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x | ||
646 | , om `Map.union` snd x ) | ||
647 | -- XXX: Shouldn't this signature generation show up in the KikiReport ? | ||
648 | return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) | ||
649 | |||
650 | perform kd (SubKeyDeletion topk subk) = do | ||
651 | try kd $ \(kd,report) -> do | ||
652 | let kk = keykey $ packet $ keyMappedPacket kd | ||
653 | kd' | kk /= topk = kd | ||
654 | | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd } | ||
655 | pred k _ = k /= subk | ||
656 | ps = concat $ maybeToList $ do | ||
657 | SubKey mp sigs <- Map.lookup subk (keySubKeys kd) | ||
658 | return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs | ||
659 | ctx = InputFileContext (rtSecring rt) (rtPubring rt) | ||
660 | rings = [HomeSec, HomePub] >>= resolveInputFile ctx | ||
661 | return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) | ||
662 | |||
663 | isBracket :: Char -> Bool | ||
664 | isBracket '<' = True | ||
665 | isBracket '>' = True | ||
666 | isBracket _ = False | ||
667 | |||
668 | |||
669 | parseUID :: String -> UserIDRecord | ||
670 | parseUID str = UserIDRecord { | ||
671 | uid_full = str, | ||
672 | uid_realname = realname, | ||
673 | uid_user = user, | ||
674 | uid_subdomain = subdomain, | ||
675 | uid_topdomain = topdomain | ||
676 | } | ||
677 | where | ||
678 | text = T.pack str | ||
679 | (T.strip-> realname, T.dropAround isBracket-> email) | ||
680 | = T.break (=='<') text | ||
681 | (user, T.drop 1-> hostname) = T.break (=='@') email | ||
682 | ( T.reverse -> topdomain, | ||
683 | T.reverse . T.drop 1 -> subdomain) | ||
684 | = T.break (=='.') . T.reverse $ hostname | ||
685 | |||
686 | -- | resolveTransform | ||
687 | resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | ||
688 | resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops | ||
689 | where | ||
690 | ops = map (\u -> InducerSignature u []) us | ||
691 | us = filter torStyle $ Map.keys umap | ||
692 | torStyle str = and [ uid_topdomain parsed == "onion" | ||
693 | , uid_realname parsed `elem` ["","Anonymous"] | ||
694 | , uid_user parsed == "root" | ||
695 | , fmap (match . fst) (lookup (packet k) torbindings) | ||
696 | == Just True ] | ||
697 | where parsed = parseUID str | ||
698 | match = (==subdom) . take (fromIntegral len) | ||
699 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | ||
700 | subdom = Char8.unpack subdom0 | ||
701 | len = T.length (uid_subdomain parsed) | ||
702 | torbindings = getTorKeys (map packet $ flattenTop "" True kd) | ||
703 | getTorKeys pub = do | ||
704 | xs <- groupBindings pub | ||
705 | (_,(top,sub),us,_,_) <- xs | ||
706 | guard ("tor" `elem` us) | ||
707 | let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub | ||
708 | return (top,(torhash,sub)) | ||
709 | |||
710 | groupBindings pub = gs | ||
711 | where (_,bindings) = getBindings pub | ||
712 | bindings' = accBindings bindings | ||
713 | code (c,(m,s),_,_,_) = (fingerprint_material m,-c) | ||
714 | ownerkey (_,(a,_),_,_,_) = a | ||
715 | sameMaster (ownerkey->a) (ownerkey->b) | ||
716 | = fingerprint_material a==fingerprint_material b | ||
717 | gs = groupBy sameMaster (sortBy (comparing code) bindings') | ||
718 | |||
719 | |||
720 | -- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | ||
721 | resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk | ||
722 | where | ||
723 | topk = keykey $ packet k -- key to master of key to be deleted | ||
724 | subk = do | ||
725 | (k,sub) <- Map.toList submap | ||
726 | guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) | ||
727 | return k | ||
728 | |||
729 | -- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | ||
730 | resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk | ||
731 | where | ||
732 | topk = keykey $ packet k -- key to master of key to be deleted | ||
733 | subk = do | ||
734 | (k,SubKey p sigs) <- Map.toList submap | ||
735 | -- TODO: This should warn/fail when there are multiple matches. | ||
736 | take 1 $ filter (has_tag tag) $ map (packet . fst) sigs | ||
737 | return k | ||
738 | |||