Added <-> on tor uids that match cross-certifying tor keys.

1 files changed, 23 insertions, 11 deletions

diff --git a/keys.hs b/keys.hs
index 14af106..db17cf4 100644
--- a/keys.hs
+++ b/keys.hs
@@ -3,9 +3,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 
+import Debug.Trace
 import Data.Binary
 import Data.OpenPGP
 import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.ByteString      as S
 import Control.Monad
 import Text.Show.Pretty
@@ -15,6 +17,7 @@ import Data.Ord
 import Data.Maybe
 import Data.Bits
 import qualified Data.Text as T
+import Data.Text.Encoding
 import qualified Codec.Binary.Base32 as Base32
 import qualified Crypto.Hash.SHA1 as SHA1
 import Data.Char (toLower)
@@ -191,11 +194,12 @@ parseUID str = UserIDRecord {
     (T.strip-> realname, T.dropAround isBracket-> email) 
                               = T.break (=='<') text
     (user, T.tail-> hostname) = T.break (=='@') email
-    (T.reverse-> topdomain,T.reverse-> subdomain) 
-                              = T.break (=='.') 
-                                . T.reverse $ hostname
+    ( T.reverse            -> topdomain,
+      T.reverse . T.drop 1 -> subdomain)
+                              = T.break (=='.') . T.reverse $ hostname
 
-        
+
+derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
 
 listKeys pkts = do
     let (certs,bs) = getBindings pkts
@@ -223,12 +227,15 @@ listKeys pkts = do
                         2 -> " <-- "
                         3 -> " <-> "
                 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
-                extra = 
-                    maybe "" 
-                          (map toLower . Base32.encode . S.unpack . SHA1.hashlazy) 
-                          (derRSA sub)
-            " " {- ++grip top -} ++ ar ++ formkind++" "++ fingerprint sub ++ " "++ extra ++"\n"
-               -- ++ ppShow hashed
+            " " {- ++grip top -} 
+                ++ ar ++ formkind ++" "++ fingerprint sub ++ "\n"
+                -- ++ ppShow hashed
+        torkeys = do
+            (code,(top,sub), kind, hashed,claimants) <- subs
+            guard ("tor" `elem` kind)
+            guard (code .&. 0x2 /= 0)
+            der <- maybeToList $ derRSA sub
+            return $ derToBase32 der
         uid = {- maybe "" id . listToMaybe $ -} do
             (keys,sigs) <- certs
             sig <- sigs
@@ -242,7 +249,12 @@ listKeys pkts = do
                         guard (uid_topdomain parsed == "onion" )
                         guard ( uid_realname parsed `elem` ["","Anonymous"])
                         guard (     uid_user parsed == "root" )
-                        -- guard (uid_subdomain parsed == tor_address )
+                        let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
+                            len = L.length subdom0
+                            subdom = Char8.unpack subdom0
+                            match = ( (==subdom) . take (fromIntegral len))
+                        guard (len >= 16)
+                        listToMaybe $ filter match torkeys
             " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n"
         (_,sigs) = unzip certs
     "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n"