summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--keys.hs34
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 @@
3{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE OverloadedStrings #-}
4module Main where 4module Main where
5 5
6import Debug.Trace
6import Data.Binary 7import Data.Binary
7import Data.OpenPGP 8import Data.OpenPGP
8import qualified Data.ByteString.Lazy as L 9import qualified Data.ByteString.Lazy as L
10import qualified Data.ByteString.Lazy.Char8 as Char8
9import qualified Data.ByteString as S 11import qualified Data.ByteString as S
10import Control.Monad 12import Control.Monad
11import Text.Show.Pretty 13import Text.Show.Pretty
@@ -15,6 +17,7 @@ import Data.Ord
15import Data.Maybe 17import Data.Maybe
16import Data.Bits 18import Data.Bits
17import qualified Data.Text as T 19import qualified Data.Text as T
20import Data.Text.Encoding
18import qualified Codec.Binary.Base32 as Base32 21import qualified Codec.Binary.Base32 as Base32
19import qualified Crypto.Hash.SHA1 as SHA1 22import qualified Crypto.Hash.SHA1 as SHA1
20import Data.Char (toLower) 23import Data.Char (toLower)
@@ -191,11 +194,12 @@ parseUID str = UserIDRecord {
191 (T.strip-> realname, T.dropAround isBracket-> email) 194 (T.strip-> realname, T.dropAround isBracket-> email)
192 = T.break (=='<') text 195 = T.break (=='<') text
193 (user, T.tail-> hostname) = T.break (=='@') email 196 (user, T.tail-> hostname) = T.break (=='@') email
194 (T.reverse-> topdomain,T.reverse-> subdomain) 197 ( T.reverse -> topdomain,
195 = T.break (=='.') 198 T.reverse . T.drop 1 -> subdomain)
196 . T.reverse $ hostname 199 = T.break (=='.') . T.reverse $ hostname
197 200
198 201
202derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
199 203
200listKeys pkts = do 204listKeys pkts = do
201 let (certs,bs) = getBindings pkts 205 let (certs,bs) = getBindings pkts
@@ -223,12 +227,15 @@ listKeys pkts = do
223 2 -> " <-- " 227 2 -> " <-- "
224 3 -> " <-> " 228 3 -> " <-> "
225 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' 229 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
226 extra = 230 " " {- ++grip top -}
227 maybe "" 231 ++ ar ++ formkind ++" "++ fingerprint sub ++ "\n"
228 (map toLower . Base32.encode . S.unpack . SHA1.hashlazy) 232 -- ++ ppShow hashed
229 (derRSA sub) 233 torkeys = do
230 " " {- ++grip top -} ++ ar ++ formkind++" "++ fingerprint sub ++ " "++ extra ++"\n" 234 (code,(top,sub), kind, hashed,claimants) <- subs
231 -- ++ ppShow hashed 235 guard ("tor" `elem` kind)
236 guard (code .&. 0x2 /= 0)
237 der <- maybeToList $ derRSA sub
238 return $ derToBase32 der
232 uid = {- maybe "" id . listToMaybe $ -} do 239 uid = {- maybe "" id . listToMaybe $ -} do
233 (keys,sigs) <- certs 240 (keys,sigs) <- certs
234 sig <- sigs 241 sig <- sigs
@@ -242,7 +249,12 @@ listKeys pkts = do
242 guard (uid_topdomain parsed == "onion" ) 249 guard (uid_topdomain parsed == "onion" )
243 guard ( uid_realname parsed `elem` ["","Anonymous"]) 250 guard ( uid_realname parsed `elem` ["","Anonymous"])
244 guard ( uid_user parsed == "root" ) 251 guard ( uid_user parsed == "root" )
245 -- guard (uid_subdomain parsed == tor_address ) 252 let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
253 len = L.length subdom0
254 subdom = Char8.unpack subdom0
255 match = ( (==subdom) . take (fromIntegral len))
256 guard (len >= 16)
257 listToMaybe $ filter match torkeys
246 " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n" 258 " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n"
247 (_,sigs) = unzip certs 259 (_,sigs) = unzip certs
248 "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n" 260 "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n"