Compute base32/sha1/der (tor-style) hashes.

1 files changed, 45 insertions, 2 deletions

diff --git a/keys.hs b/keys.hs
index 104e6ef..14af106 100644
--- a/keys.hs
+++ b/keys.hs
@@ -6,6 +6,7 @@ module Main where
 import Data.Binary
 import Data.OpenPGP
 import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString      as S
 import Control.Monad
 import Text.Show.Pretty
 import Data.List
@@ -14,6 +15,37 @@ import Data.Ord
 import Data.Maybe
 import Data.Bits
 import qualified Data.Text as T
+import qualified Codec.Binary.Base32 as Base32
+import qualified Crypto.Hash.SHA1 as SHA1
+import Data.Char (toLower)
+import qualified Crypto.PubKey.RSA as RSA
+import Data.ASN1.Types
+import Data.ASN1.Encoding
+import Data.ASN1.BinaryEncoding
+
+data RSAPublicKey = RSAKey MPI MPI
+
+instance ASN1Object RSAPublicKey where
+    toASN1 (RSAKey (MPI n) (MPI e))
+                  = \xs -> Start Sequence
+                         : IntVal n
+                         : IntVal e
+                         : End Sequence
+                         : xs
+    fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
+        Right (RSAKey (MPI modulus) (MPI pubexp) , xs)
+    fromASN1 _ =
+        Left "fromASN1: RSAPublicKey: unexpected format"
+
+rsaKeyFromPacket p@(PublicKeyPacket {}) = do
+    n <- lookup 'n' $ key p
+    e <- lookup 'e' $ key p
+    return $ RSAKey n e
+rsaKeyFromPacket _ = Nothing
+
+derRSA rsa = do
+    k <- rsaKeyFromPacket rsa
+    return $ encodeASN1 DER (toASN1 k [])
 
 getPackets :: IO [Packet]
 getPackets = do
@@ -137,6 +169,7 @@ accBindings bs = as
 
 data UserIDRecord = UserIDRecord {
     uid_full :: String,
+    uid_realname :: T.Text,
     uid_user :: T.Text,
     uid_subdomain :: T.Text,
     uid_topdomain :: T.Text
@@ -148,6 +181,7 @@ isBracket _   = False
 
 parseUID str = UserIDRecord {
                     uid_full = str,
+                    uid_realname = realname,
                     uid_user = user,
                     uid_subdomain = subdomain,
                     uid_topdomain = topdomain
@@ -189,7 +223,11 @@ listKeys pkts = do
                         2 -> " <-- "
                         3 -> " <-> "
                 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
-            " " {- ++grip top -} ++ ar ++ formkind++" "++ fingerprint sub ++ "\n"
+                extra = 
+                    maybe "" 
+                          (map toLower . Base32.encode . S.unpack . SHA1.hashlazy) 
+                          (derRSA sub)
+            " " {- ++grip top -} ++ ar ++ formkind++" "++ fingerprint sub ++ " "++ extra ++"\n"
                -- ++ ppShow hashed
         uid = {- maybe "" id . listToMaybe $ -} do
             (keys,sigs) <- certs
@@ -200,7 +238,12 @@ listKeys pkts = do
             guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top)
             let UserIDPacket uid = user_id sig
                 parsed = parseUID uid
-            " " ++ " --> " ++ "@" ++ " " ++ uid_full parsed ++ "\n"
+                ar = maybe " --> " (const " <-> ") $ do
+                        guard (uid_topdomain parsed == "onion" )
+                        guard ( uid_realname parsed `elem` ["","Anonymous"])
+                        guard (     uid_user parsed == "root" )
+                        -- guard (uid_subdomain parsed == tor_address )
+            " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n"
         (_,sigs) = unzip certs
     "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n"