Add tor uid when a tor key is cross-merge imported.

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
 
 type KeyDB = Map.Map KeyKey KeyData
 
+torhash key = maybe "" id $ derToBase32 <$> derRSA key
+
 keykey key =
     -- Note: The key's timestamp is included in it's fingerprint.
     --       Therefore, the same key with a different timestamp is
@@ -1084,9 +1086,12 @@ concatSort fname getp f = concat . sortByHint fname getp . map f
 flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
 flattenTop fname ispub (KeyData key sigs uids subkeys) =
     unk ispub key : 
-            ( concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
+            ( flattenAllUids fname ispub uids
              ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
 
+flattenAllUids fname ispub uids =
+    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
+
 flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
 flattenUid fname ispub (str,(sigs,om)) = 
     MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs
@@ -1377,11 +1382,38 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
         $ error "Key specification is ambiguous."
     let kk = head m0
         Just (KeyData top topsigs uids subs) = Map.lookup kk db
-    let subkk = keykey key
+        subkk = keykey key
         (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1))))
                                                [])
                                  (False,)
                                  (Map.lookup subkk subs)
+
+        istor = do
+            guard (tag == "tor")
+            return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
+
+    uids' <- flip (maybe $ return uids) istor $ \idstr -> do
+                let has_torid = do
+                     -- TODO: check for omitted real name field
+                     (sigtrusts,om) <- Map.lookup idstr uids
+                     listToMaybe $ do
+                         s <- (signatures $ Message (key:map (packet . fst) sigtrusts))
+                         signatures_over $ verify (Message [packet top]) s
+                flip (flip maybe $ const $ return uids) has_torid $ do
+                wkun <- doDecrypt (packet top)
+                flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do
+                g <- newGenIO :: IO SystemRandom
+                timestamp <- now
+                let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
+                    uid = UserIDPacket idstr
+                    sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
+                flip (maybe $ warn "Failed to make signature" >> return uids)
+                     (listToMaybe $ signatures_over sig_ov)
+                     $ \sig -> do
+                let om = Map.singleton fname (origin sig (-1))
+                    trust = Map.empty
+                return $ Map.insert idstr ([(MappedPacket sig om,trust)],om) uids
+
     let SubKey subkey_p subsigs = subkey
         wk = packet top
         (xs',minsig,ys') = findTag tag wk key subsigs
@@ -1391,11 +1423,13 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
             let subs' = Map.insert subkk
                                    (SubKey subkey_p $ xs'++[sig']++ys')
                                    subs
-            return $ Map.insert kk (KeyData top topsigs uids subs') db
+            return $ Map.insert kk (KeyData top topsigs uids' subs') db
     when is_new (warn $ fname ++ ": yield SecretKeyPacket "++show (fmap fst minsig,fingerprint key))
     case minsig of
         Nothing          -> doInsert Nothing db    -- we need to create a new sig
-        Just (True,sig)  -> return db              -- we can deduce is_new == False
+        Just (True,sig)  -> -- we can deduce is_new == False
+                            -- we may need to add a tor id
+                            return $ Map.insert kk (KeyData top topsigs uids' subs) db
         Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
 
 
@@ -2336,10 +2370,12 @@ sigpackets typ hashed unhashed = return $
         [] -- [MPI]
 
 keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
+ {-
  where
     vs = map (verify (Message [wkun])) (signatures (Message (wkun:uids)))
     ws = map signatures_over vs
     xs = filter null ws
+    -}
 
 keyFlags0 wkun uidsigs = concat
                       [ keyflags