{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} 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 qualified Text.Show.Pretty as PP import Text.PrettyPrint as PP import Data.List import Data.OpenPGP.CryptoAPI 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) import qualified Crypto.PubKey.RSA as RSA import Crypto.Random (newGenIO,SystemRandom) import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding import Control.Applicative import System.Environment import System.Directory import System.Exit import ControlMaybe import Data.Char import Control.Arrow (second) import Data.Traversable import System.Console.CmdArgs 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 p@(SecretKeyPacket {}) = 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 input <- L.getContents case decodeOrFail input of Right (_,_,Message pkts) -> return pkts Left (_,_,_) -> return [] isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False isUserID (UserIDPacket {}) = True isUserID _ = False isEmbeddedSignature (EmbeddedSignaturePacket {}) = True isEmbeddedSignature _ = False isCertificationSig (CertificationSignature {}) = True isCertificationSig _ = True issuer (IssuerPacket issuer) = Just issuer issuer _ = Nothing backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False usage (NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = u }) = Just u usage _ = Nothing verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) where verified = do sig <- signatures (Message nonkeys) let v = verify (Message keys) sig guard (not . null $ signatures_over v) return v (top,othersigs) = partition isSubkeySignature verified embedded = do sub <- top let sigover = signatures_over sub unhashed = sigover >>= unhashed_subpackets subsigs = mapMaybe backsig unhashed sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) let v = verify (Message [subkey sub]) sig guard (not . null $ signatures_over v) return v grip k = drop 32 $ fingerprint k smallpr k = drop 24 $ fingerprint k disjoint_fp ks = {- concatMap group2 $ -} transpose grouped where grouped = groupBy samepr . sortBy (comparing smallpr) $ ks samepr a b = smallpr a == smallpr b {- -- useful for testing group2 :: [a] -> [[a]] group2 (x:y:ys) = [x,y]:group2 ys group2 [x] = [[x]] group2 [] = [] -} verifyBindingsEx :: [Packet] -> ([SignatureOver], [SignatureOver]) -- ^ (binding signatures, other signatures) verifyBindingsEx pkts = bicat . unzip $ do let (keys,_) = partition isKey pkts keys <- disjoint_fp keys return $ verifyBindings keys pkts where bicat (xs,ys) = (concat xs,concat ys) getBindings :: [Packet] -> ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets -- that were used for the verifications , [(Word8, (Packet, Packet), -- (topkey,subkey) [String], -- usage flags [SignatureSubpacket], -- hashed data [Packet])] -- ^ binding signatures ) getBindings pkts = (sigs,bindings) where (sigs,concat->bindings) = unzip $ do let (keys,nonkeys) = partition isKey pkts keys <- disjoint_fp keys let (bs,sigs) = verifyBindings keys pkts return . ((keys,sigs),) $ do b <- bs i <- map signature_issuer (signatures_over b) i <- maybeToList i who <- maybeToList $ find_key fingerprint (Message keys) i let (code,claimants) = case () of _ | who == topkey b -> (1,[]) _ | who == subkey b -> (2,[]) _ -> (0,[who]) let hashed = signatures_over b >>= hashed_subpackets kind = guard (code==1) >> hashed >>= maybeToList . usage return (code,(topkey b,subkey b), kind, hashed,claimants) -- Returned data is simmilar to getBindings but the Word8 codes -- are ORed together. accBindings :: Bits t => [(t, (Packet, Packet), [a], [a1], [a2])] -> [(t, (Packet, Packet), [a], [a1], [a2])] accBindings bs = as where gs = groupBy samePair . sortBy (comparing bindingPair) $ bs as = map (foldl1 combine) gs bindingPair (_,p,_,_,_) = pub2 p where pub2 (a,b) = (pub a, pub b) pub a = fingerprint_material a samePair a b = bindingPair a == bindingPair b combine (ac,p,akind,ahashed,aclaimaints) (bc,_,bkind,bhashed,bclaimaints) = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) data UserIDRecord = UserIDRecord { uid_full :: String, uid_realname :: T.Text, uid_user :: T.Text, uid_subdomain :: T.Text, uid_topdomain :: T.Text } deriving Show isBracket '<' = True isBracket '>' = True isBracket _ = False parseUID str = UserIDRecord { uid_full = str, uid_realname = realname, uid_user = user, uid_subdomain = subdomain, uid_topdomain = topdomain } where text = T.pack str (T.strip-> realname, T.dropAround isBracket-> email) = T.break (=='<') text (user, T.tail-> hostname) = T.break (=='@') email ( T.reverse -> topdomain, T.reverse . T.drop 1 -> subdomain) = T.break (=='.') . T.reverse $ hostname derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy fpmatch grip key = (==) Nothing (fmap (backend (fingerprint key)) grip >>= guard . not) where backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) listKeys pkts = listKeysFiltered Nothing pkts listKeysFiltered grip pkts = do let (certs,bs) = getBindings pkts as = accBindings bs defaultkind (k:_) hs = k defaultkind [] hs = maybe "subkey" id ( listToMaybe . mapMaybe (fmap usageString . keyflags) $ hs) kinds = map (\(_,_,k,h,_)->defaultkind k h) as kindwidth = maximum $ map length kinds kindcol = min 20 kindwidth code (c,(m,s),_,_,_) = (fingerprint_material m,-c) ownerkey (_,(a,_),_,_,_) = a sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True matchgrip _ = False gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) subs <- gs let (code,(top,sub), kind, hashed,claimants):_ = subs subkeys = do (code,(top,sub), kind, hashed,claimants) <- subs let ar = case code of 0 -> " ??? " 1 -> " --> " 2 -> " <-- " 3 -> " <-> " formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' -- torhash = maybe "" id $ derToBase32 <$> derRSA sub concat [ " " -- , grip top , ar , formkind , " " , fingerprint sub -- , " " ++ torhash , "\n" ] -- ++ ppShow hashed torkeys = do (code,(top,sub), kind, hashed,claimants) <- subs guard ("tor" `elem` kind) guard (code .&. 0x2 /= 0) maybeToList $ derToBase32 <$> derRSA sub uid = {- maybe "" id . listToMaybe $ -} do (keys,sigs) <- certs sig <- sigs guard (isCertificationSig sig) guard (topkey sig == top) sig_over <- signatures_over sig guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top) let UserIDPacket uid = user_id sig parsed = parseUID uid ar = maybe " --> " (const " <-> ") $ do guard (uid_topdomain parsed == "onion" ) guard ( uid_realname parsed `elem` ["","Anonymous"]) guard ( uid_user parsed == "root" ) 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 ++" ...\n" ++ subkeys ++ "\n" data PGPKeyFlags = Special | Vouch -- Signkey | Sign | VouchSign | Communication | VouchCommunication | SignCommunication | VouchSignCommunication | Storage | VouchStorage | SignStorage | VouchSignStorage | Encrypt | VouchEncrypt | SignEncrypt | VouchSignEncrypt deriving (Eq,Show,Read,Enum) usageString flgs = case flgs of Special -> "special" Vouch -> "vouch" -- signkey Sign -> "sign" VouchSign -> "vouch-sign" Communication -> "communication" VouchCommunication -> "vouch-communication" SignCommunication -> "sign-communication" VouchSignCommunication -> "vouch-sign-communication" Storage -> "storage" VouchStorage -> "vouch-storage" SignStorage -> "sign-storage" VouchSignStorage -> "vouch-sign-storage" Encrypt -> "encrypt" VouchEncrypt -> "vouch-encrypt" SignEncrypt -> "sign-encrypt" VouchSignEncrypt -> "vouch-sign-encrypt" keyflags flgs@(KeyFlagsPacket {}) = Just . toEnum $ ( bit 0x1 certify_keys .|. bit 0x2 sign_data .|. bit 0x4 encrypt_communication .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags -- other flags: -- split_key -- authentication (ssh-client) -- group_key where bit v f = if f flgs then v else 0 keyflags _ = Nothing modifyUID (UserIDPacket str) = UserIDPacket str' where (fstname,rst) = break (==' ') str str' = mod fstname ++ rst mod "Bob" = "Bob Fucking" mod x = x modifyUID other = other todo = error "unimplemented" -- TODO: switch to System.Environment.lookupEnv -- when linking against newer base libraries. lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) unmaybe def = fmap (maybe def id) expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) | otherwise = c:cs expandPath path [] = [] readPacketsFromFile :: FilePath -> IO Message readPacketsFromFile fname = do input <- L.readFile fname return $ case decodeOrFail input of Right (_,_,msg ) -> msg Left (_,_,_) -> Message [] parseOptionFile fname = do xs <- fmap lines (readFile fname) let ys = filter notComment xs notComment ('#':_) = False notComment cs = not (all isSpace cs) return ys {- options_from_file :: (forall a. [String] -> Term a -> IO (Either EvalExit a)) -> Term b -> (String,String,Term (Maybe String)) -> ([String],Term (Maybe String)) -> IO [String] options_from_file unwrapCmd term (homevar,appdir,home) (optfile_alts,options_file) = doit where homedir = envhomedir <$> home envhomedir opt = do gnupghome <- lookupEnv homevar >>= \d -> return $ d >>= guard . (/="") >> d home <- flip fmap getHomeDirectory $ \d -> fmap (const d) $ guard (d/="") let homegnupg = (++('/':appdir)) <$> home let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val doit = do args <- getArgs {- let wants_help = not . null $ filter cryForHelp args where cryForHelp "--help" = True cryForHelp "--version" = True cryForHelp x = and (zipWith (==) x "--help=") -} (o,h) <- do val <- unwrapCmd args (liftA2 (,) options_file homedir) case val of Left e -> return (Nothing,Nothing) Right (o,h) -> (o,) <$> h ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> let optfiles = map (second ((h++"/")++)) (maybe optfile_alts' (:[]) o') optfile_alts' = zip (False:repeat True) optfile_alts o' = fmap (False,) o in filterM (doesFileExist . snd) optfiles args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do let h' = fromJust h newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname let toArgs = toHead ("--"++) . words toHead f (x:xs) = f x : xs toHead f [] = [] voidTerm = fmap (const ()) appendArgs as [] = return as appendArgs as (configline:cs) = do let xs = toArgs configline w <-unwrap (xs++as) (voidTerm term,defTI) case w of Left _ -> appendArgs as cs Right _ -> appendArgs (xs++as) cs -- TODO: check errors if forgive = False appendArgs args newargs return args runWithOptionsFile :: (Term (IO b), TermInfo) -> IO b runWithOptionsFile (term,ti) = do as <- options_from_file unwrapCmd term ("GNUPGHOME",".gnupg",opt_homedir) (["keys.conf","gpg.conf-2","gpg.conf"] ,opt_options) q <- eval as (term , ti) q where unwrapCmd args term = unwrap args (term,defTI) runChoiceWithOptionsFile :: (Term (IO b), TermInfo) -> [(Term (IO b), TermInfo)] -> IO b runChoiceWithOptionsFile (realterm,ti) choices = do as <- options_from_file unwrapCmd realterm ("GNUPGHOME",".gnupg",opt_homedir) (["keys.conf","gpg.conf-2","gpg.conf"] ,opt_options) -- putStrLn $ "as = " ++ show as q <- evalChoice as (realterm , ti) choices q where unwrapCmd args t = unwrapChoice args (realterm <:> t,ti) (map (neuter t) choices) neuter term (t,ti) = (t <:> term, ti) data Command = List | Autosign deriving (Eq,Show,Read,Enum) capitolizeFirstLetter (x:xs) = toUpper x : xs capitolizeFirstLetter xs = xs instance ArgVal Command where converter = ( maybe (Left $ text "unknown command") Right . fmap fst . listToMaybe . reads . capitolizeFirstLetter . map toLower , text . map toLower . show ) class AutoMaybe a instance AutoMaybe Command instance (ArgVal a, AutoMaybe a) => ArgVal (Maybe a) where converter = ( toRight Just . fst converter , maybe (text "(unspecified)") id . fmap (snd converter) ) toRight f (Right x) = Right (f x) toRight f (Left y) = Left y cmd :: Term Command cmd = required . pos 0 Nothing $ posInfo { posName = "command" , posDoc = "What action to perform." } a <:> b = flip const <$> a <*> b infixr 2 <:> selectAction cmd actions = actions !! fromEnum cmd cmdInfo :: ArgVal cmd => cmd -> String -> Term a -> (cmd, (Term a, TermInfo)) cmdInfo cmd doc action = ( cmd , ( action , defTI { termName = print cmd , termDoc = doc } ) ) where print = show . snd converter cmdlist :: (Command, (Term (IO ()), TermInfo)) cmdlist = cmdInfo List "list key pairs for which secrets are known" $ (>>= putStrLn . listKeys . unMessage) <$> secret_packets where unMessage (Message pkts) = pkts cmdautosign = cmdInfo Autosign "auto-sign tor-style uids" $ pure (putStrLn "autosign") multiCommand :: TermInfo -> [(Command, (Term a, TermInfo))] -> ( (Term a, TermInfo) , [(Term a, TermInfo)] ) multiCommand ti choices = ( ( selectAction <$> cmd <*> sequenceA (map strip choices) , ti ) , map snd choices ) where selectAction cmd choices = fromJust $ lookup (cmd::Command) choices strip (cmd,(action,_)) = fmap (cmd,) action -} data Arguments = List { homedir :: Maybe FilePath } | WorkingKey { homedir :: Maybe FilePath } | AutoSign { homedir :: Maybe FilePath, input :: FilePath, output :: FilePath} deriving (Show, Data, Typeable) #define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) main = do args <- cmdArgs $ modes [ List HOMEOPTION &= help "List key pairs in the secret keyring." &= auto , WorkingKey HOMEOPTION &= help "Shows the current working key set that will be used to make signatures." , AutoSign HOMEOPTION (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile) &= (help . concat) [ "Copies the first file to the second while adding" , " signatures for tor-style uids that match" , " cross-certified keys." ] ] &= program "keys" &= summary "keys - a pgp key editing utility" doCmd args where envhomedir opt = do gnupghome <- lookupEnv homevar >>= \d -> return $ d >>= guard . (/="") >> d home <- flip fmap getHomeDirectory $ \d -> fmap (const d) $ guard (d/="") let homegnupg = (++('/':appdir)) <$> home let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val homevar = "GNUPGHOME" appdir = ".gnupg" optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] getHomeDir cmd = do homedir <- envhomedir (homedir cmd) flip (maybe (error "Could not determine home directory.")) homedir $ \homedir -> do -- putStrLn $ "homedir = " ++show homedir let secring = homedir ++ "/" ++ "secring.gpg" -- putStrLn $ "secring = " ++ show secring workingkey <- getWorkingKey homedir return (homedir,secring,workingkey) getWorkingKey homedir = do let o = Nothing h = Just homedir args = ["hi"] ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> let optfiles = map (second ((h++"/")++)) (maybe optfile_alts' (:[]) o') optfile_alts' = zip (False:repeat True) optfile_alts o' = fmap (False,) o in filterM (doesFileExist . snd) optfiles args <- flip (maybe $ return []) ofile $ \(forgive,fname) -> parseOptionFile fname let config = map (topair . words) args where topair (x:xs) = (x,xs) return $ lookup "default-key" config >>= listToMaybe getPGPEnviron cmd = do (homedir,secring,grip) <- getHomeDir cmd (Message sec) <- readPacketsFromFile secring let (keys,_) = partition (\k -> case k of { SecretKeyPacket {} -> True ; _ -> False }) sec return (homedir,sec, grip `mplus` fmap fingerprint (listToMaybe keys)) getTorKeys pub = do xs <- groupBindings pub (_,(top,sub),us,_,_) <- xs guard ("tor" `elem` us) let torhash = maybe "" id $ derToBase32 <$> derRSA sub return (top,(torhash,sub)) uidScan pub = scanl (\(mkey,u) w -> case () of _ | isMaster w -> (w,u) _ | isUserID w -> (mkey,w) _ | otherwise -> (mkey,u) ) (w0,w0) ws where w0:ws = pub isMaster k@(PublicKeyPacket {}) = not $ is_subkey k isMaster _ = False signSelfAuthTorKeys g sec grip xs = ys where keys = filter isKey sec selfkey = find_key fingerprint (Message keys) (fromJust grip) mainpubkey = fst (head xs) uid:xs' = map snd xs (sigs, xs'') = span isSignaturePacket xs' overs sig = signatures $ Message (keys++[uid,sig]) vs :: [ ( Packet -- signature , Maybe SignatureOver) -- Nothing means non-verified ] vs = do sig <- sigs let vs = overs sig >>= return . verify (Message keys) ws = filter (not . null . signatures_over) vs ws' = if null ws then [Nothing] else map Just ws v <- ws' return (sig,v) has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs sigs' = if has_self then sigs -- else sigs ++ (filter isSignaturePacket $ signatures_over new_sig) -- else trace ("new_sig = "++ show (filter isSignaturePacket $ signatures_over new_sig)) sigs -- else trace ("selfkey "++ show (fmap fingerprint selfkey)) sigs else trace (traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ signatures_over new_sig -- else trace (traceSig (mainpubkey) (uid) ([last sigs])) sigs ++ signatures_over new_sig traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey) ,"new_sig topkey:"++ (show . fingerprint $ newtop) ,"new_sig user_id:"++ (show newuid) ,"new_sig |over| = " ++ (show . length $ new_sig) ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig) ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig) ,"new_sig type: " ++ (show . map signature_type $ new_sig) -- ,"new_sig signature:" ++ (show . concatMap signature $ new_sig) ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) ]) new_sig = fst $ sign (Message (maybeToList selfkey)) (CertificationSignature mainpubkey uid []) --fromJust selfkey, uid]) SHA1 (fromJust grip) timestamp g timestamp = trace "TODO: timestamp" 23420 ys = uid:sigs'++xs'' doCmd cmd@(List {}) = do (homedir,secring,grip) <- getHomeDir cmd (Message sec) <- readPacketsFromFile secring putStrLn $ listKeys sec doCmd cmd@(WorkingKey {}) = do (homedir,secring,grip) <- getHomeDir cmd (Message sec) <- readPacketsFromFile secring putStrLn $ listKeysFiltered grip sec return () doCmd cmd@(AutoSign {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip) (Message pub) <- readPacketsFromFile (input cmd) putStrLn $ listKeys pub -- forM_ (zip [1..] pub) $ \(i,k) -> do -- putStrLn $ show i ++ ": " ++ show k let torbindings = getTorKeys pub keyed = uidScan pub marked = zipWith doit keyed pub doit (mkey,u) packet = (isTorID packet, (mkey,u,packet)) where isTorID (UserIDPacket str) = and [ uid_topdomain parsed == "onion" , uid_realname parsed `elem` ["","Anonymous"] , uid_user parsed == "root" , fmap (match . fst) (lookup mkey torbindings) == Just True ] where parsed = parseUID str match = ( (==subdom) . take (fromIntegral len)) subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] subdom = Char8.unpack subdom0 len = T.length (uid_subdomain parsed) isTorID _ = False g <- newGenIO let xs:xss = groupBy (\_ (b,_)->not b) marked pub' = map (snd . cleanup) xs ++ concatMap (signSelfAuthTorKeys (g::SystemRandom) sec grip) (map (map cleanup) xss) cleanup (_,(topkey,_,pkt)) = (topkey,pkt) putStrLn $ "-------- signed ------> " putStrLn $ listKeys (sec++pub') {- putStrLn $ "------------------- forM_ (zip [1..] marked) $ \\(i,(flag,(_,u,p)))" forM_ (zip [1..] marked) $ \(i,(flag,(_,u,p))) -> do putStrLn $ show i ++ ": " ++ show (flag, p) let marked2 = groupBy (\_ (b,_)->b) (map (\(b,(k,u,v))->(b,(fingerprint k,u,v))) marked) putStrLn $ "------------------- marked2 ..." forM_ marked2 $ \v -> do putStrLn $ show v -} {- putStrLn $ "TOR ID = " ++ show (cursor uidz) putStrLn $ "parsed = " ++ show parsed -- forM_ (zip [1..] sec) $ \(i,k) -> do -- putStrLn $ show i ++ ": " ++ show k putStrLn $ "tor bindings = " ++ show torbindings putStrLn $ "should_sign = " ++ show should_sign -} putStrLn $ "-------------------" -- extract all tor keys into base32 hash keyed map -- use 'signatures' to get signed keys only -- zipperSpan to tor-style UserIDPacket -- zipperSpan to SignaturePacket with usage@=tor -- check the back sig -- If it's good, then -- VOUCH for this UID: -- add a new SignaturePacket after the last SignaturePacket -- for the tor-style UserIDPacket return () groupBindings pub = let (sigs,bindings) = getBindings pub bindings' = accBindings bindings code (c,(m,s),_,_,_) = (fingerprint_material m,-c) ownerkey (_,(a,_),_,_,_) = a sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b -- matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True -- matchgrip _ = False gs = {- filter matchgrip $ -} groupBy sameMaster (sortBy (comparing code) bindings') in gs