summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.hs44
1 files changed, 40 insertions, 4 deletions
diff --git a/kiki.hs b/kiki.hs
index 54cacc3..65a793c 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -933,6 +933,8 @@ data KeyData = KeyData MappedPacket -- main key
933 933
934type KeyDB = Map.Map KeyKey KeyData 934type KeyDB = Map.Map KeyKey KeyData
935 935
936torhash key = maybe "" id $ derToBase32 <$> derRSA key
937
936keykey key = 938keykey key =
937 -- Note: The key's timestamp is included in it's fingerprint. 939 -- Note: The key's timestamp is included in it's fingerprint.
938 -- Therefore, the same key with a different timestamp is 940 -- Therefore, the same key with a different timestamp is
@@ -1084,9 +1086,12 @@ concatSort fname getp f = concat . sortByHint fname getp . map f
1084flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] 1086flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
1085flattenTop fname ispub (KeyData key sigs uids subkeys) = 1087flattenTop fname ispub (KeyData key sigs uids subkeys) =
1086 unk ispub key : 1088 unk ispub key :
1087 ( concatSort fname head (flattenUid fname ispub) (Map.assocs uids) 1089 ( flattenAllUids fname ispub uids
1088 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) 1090 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
1089 1091
1092flattenAllUids fname ispub uids =
1093 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
1094
1090flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] 1095flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
1091flattenUid fname ispub (str,(sigs,om)) = 1096flattenUid fname ispub (str,(sigs,om)) =
1092 MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs 1097 MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs
@@ -1377,11 +1382,38 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
1377 $ error "Key specification is ambiguous." 1382 $ error "Key specification is ambiguous."
1378 let kk = head m0 1383 let kk = head m0
1379 Just (KeyData top topsigs uids subs) = Map.lookup kk db 1384 Just (KeyData top topsigs uids subs) = Map.lookup kk db
1380 let subkk = keykey key 1385 subkk = keykey key
1381 (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1)))) 1386 (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1))))
1382 []) 1387 [])
1383 (False,) 1388 (False,)
1384 (Map.lookup subkk subs) 1389 (Map.lookup subkk subs)
1390
1391 istor = do
1392 guard (tag == "tor")
1393 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
1394
1395 uids' <- flip (maybe $ return uids) istor $ \idstr -> do
1396 let has_torid = do
1397 -- TODO: check for omitted real name field
1398 (sigtrusts,om) <- Map.lookup idstr uids
1399 listToMaybe $ do
1400 s <- (signatures $ Message (key:map (packet . fst) sigtrusts))
1401 signatures_over $ verify (Message [packet top]) s
1402 flip (flip maybe $ const $ return uids) has_torid $ do
1403 wkun <- doDecrypt (packet top)
1404 flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do
1405 g <- newGenIO :: IO SystemRandom
1406 timestamp <- now
1407 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
1408 uid = UserIDPacket idstr
1409 sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
1410 flip (maybe $ warn "Failed to make signature" >> return uids)
1411 (listToMaybe $ signatures_over sig_ov)
1412 $ \sig -> do
1413 let om = Map.singleton fname (origin sig (-1))
1414 trust = Map.empty
1415 return $ Map.insert idstr ([(MappedPacket sig om,trust)],om) uids
1416
1385 let SubKey subkey_p subsigs = subkey 1417 let SubKey subkey_p subsigs = subkey
1386 wk = packet top 1418 wk = packet top
1387 (xs',minsig,ys') = findTag tag wk key subsigs 1419 (xs',minsig,ys') = findTag tag wk key subsigs
@@ -1391,11 +1423,13 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
1391 let subs' = Map.insert subkk 1423 let subs' = Map.insert subkk
1392 (SubKey subkey_p $ xs'++[sig']++ys') 1424 (SubKey subkey_p $ xs'++[sig']++ys')
1393 subs 1425 subs
1394 return $ Map.insert kk (KeyData top topsigs uids subs') db 1426 return $ Map.insert kk (KeyData top topsigs uids' subs') db
1395 when is_new (warn $ fname ++ ": yield SecretKeyPacket "++show (fmap fst minsig,fingerprint key)) 1427 when is_new (warn $ fname ++ ": yield SecretKeyPacket "++show (fmap fst minsig,fingerprint key))
1396 case minsig of 1428 case minsig of
1397 Nothing -> doInsert Nothing db -- we need to create a new sig 1429 Nothing -> doInsert Nothing db -- we need to create a new sig
1398 Just (True,sig) -> return db -- we can deduce is_new == False 1430 Just (True,sig) -> -- we can deduce is_new == False
1431 -- we may need to add a tor id
1432 return $ Map.insert kk (KeyData top topsigs uids' subs) db
1399 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag 1433 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
1400 1434
1401 1435
@@ -2336,10 +2370,12 @@ sigpackets typ hashed unhashed = return $
2336 [] -- [MPI] 2370 [] -- [MPI]
2337 2371
2338keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) 2372keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
2373 {-
2339 where 2374 where
2340 vs = map (verify (Message [wkun])) (signatures (Message (wkun:uids))) 2375 vs = map (verify (Message [wkun])) (signatures (Message (wkun:uids)))
2341 ws = map signatures_over vs 2376 ws = map signatures_over vs
2342 xs = filter null ws 2377 xs = filter null ws
2378 -}
2343 2379
2344keyFlags0 wkun uidsigs = concat 2380keyFlags0 wkun uidsigs = concat
2345 [ keyflags 2381 [ keyflags