From 4cf92a7c195667490a76509bda75da2112434082 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 4 Oct 2013 11:52:36 -0400 Subject: Work on autosign functionality --- keys.hs | 173 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 164 insertions(+), 9 deletions(-) diff --git a/keys.hs b/keys.hs index b5d1986..6fdd408 100644 --- a/keys.hs +++ b/keys.hs @@ -27,6 +27,7 @@ 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 @@ -138,15 +139,23 @@ disjoint_fp ks = {- concatMap group2 $ -} transpose grouped 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), - [String], - [SignatureSubpacket], + (Packet, Packet), -- (topkey,subkey) + [String], -- usage flags + [SignatureSubpacket], -- hashed data [Packet])] -- ^ binding signatures ) getBindings pkts = (sigs,bindings) @@ -169,6 +178,8 @@ getBindings pkts = (sigs,bindings) 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])] @@ -194,6 +205,7 @@ data UserIDRecord = UserIDRecord { uid_subdomain :: T.Text, uid_topdomain :: T.Text } + deriving Show isBracket '<' = True isBracket '>' = True @@ -295,7 +307,7 @@ listKeysFiltered grip pkts = do data PGPKeyFlags = Special - | Vouch + | Vouch -- Signkey | Sign | VouchSign | Communication @@ -315,7 +327,7 @@ data PGPKeyFlags = usageString flgs = case flgs of Special -> "special" - Vouch -> "vouch" + Vouch -> "vouch" -- signkey Sign -> "sign" VouchSign -> "vouch-sign" Communication -> "communication" @@ -506,7 +518,6 @@ cmd = required . pos 0 Nothing $ posInfo a <:> b = flip const <$> a <*> b infixr 2 <:> - selectAction cmd actions = actions !! fromEnum cmd cmdInfo :: ArgVal cmd => @@ -607,6 +618,81 @@ main = do 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 @@ -620,10 +706,79 @@ main = do return () doCmd cmd@(AutoSign {}) = do - (homedir,secring,grip) <- getHomeDir cmd - (Message sec) <- readPacketsFromFile secring + ( 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 $ "Inspecting packets..." 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 + -- cgit v1.2.3