From 81e29ffa385270cf0b104ebd72975921158ecb17 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 2 Jan 2014 03:56:55 -0500 Subject: Experimental --hosts feature for import/export aliases from hosts file. --- kiki.hs | 213 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 212 insertions(+), 1 deletion(-) (limited to 'kiki.hs') diff --git a/kiki.hs b/kiki.hs index 0ecfa1c..2433d4e 100644 --- a/kiki.hs +++ b/kiki.hs @@ -75,6 +75,8 @@ import DotLock -- import Codec.Crypto.ECC.Base -- hecc package import Text.Printf import qualified CryptoCoins as CryptoCoins +import qualified Hosts +import Network.Socket -- (SockAddr) -- instance Default S.ByteString where def = S.empty @@ -1188,6 +1190,7 @@ flattenTop fname ispub (KeyData key sigs uids subkeys) = ( flattenAllUids fname ispub uids ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) +flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] flattenAllUids fname ispub uids = concatSort fname head (flattenUid fname ispub) (Map.assocs uids) @@ -1936,6 +1939,140 @@ signature_time ov = case if null cs then ds else cs of creationTime (SignatureCreationTimePacket t) = [t] creationTime _ = [] +-- We return into IO in case we want to make a signature here. +setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData +setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = + -- TODO: we are removing the origin from the UID OriginMap, + -- when we should be removing origins from the locations + -- field of the sig's MappedPacket records. + -- Call getHostnames and compare to see if no-op. + if not (pred addr) || names0 == names \\ onions + then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) + , " file: "++show (map Char8.unpack names) + , " pred: "++show (pred addr)]) -} + (return kd) + else do + -- We should be sure to remove origins so that the data is written + -- (but only if something changed). + -- Filter all hostnames present in uids + -- Write notations into first uid + {- + trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) + , " file: "++show (map Char8.unpack names) ]) $ do + -} + return $ KeyData topmp topsigs uids1 subs + where + topk = packet topmp + addr = fingerdress topk + names :: [Char8.ByteString] + names = Hosts.namesForAddress addr hosts + (_,(onions,names0)) = getHostnames kd + notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions) + isName (NotationDataPacket True "hostname@" _) = True + isName _ = False + uids0 = fmap zapIfHasName uids + fstuid = head $ do + p <- map packet $ flattenAllUids "" True uids + guard $ isUserID p + return $ uidkey p + uids1 = Map.adjust addnames fstuid uids0 + addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin + where + (ss,ts) = splitAt 1 sigs + f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm) + else (sig, tm) + where p' = (packet sig) { unhashed_subpackets=uh } + uh = unhashed_subpackets (packet sig) ++ notations + zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin + else (sigs,om) + where + (bs, sigs') = unzip $ map unhash sigs + + unhash (sig,tm) = ( not (null ns) + , ( sig { packet = p', locations = Map.empty } + , tm ) ) + where + psig = packet sig + p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } + else psig + uh = unhashed_subpackets $ psig + (ns,ps) = partition isName uh + +socketFamily (SockAddrInet _ _) = AF_INET +socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +socketFamily (SockAddrUnix _) = AF_UNIX + + +hasFingerDress :: KeyDB -> SockAddr -> Bool +hasFingerDress db addr | socketFamily addr/=AF_INET6 = False +hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) + where + (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr + g' = map toUpper g + +fingerdress :: Packet -> SockAddr +fingerdress topk = maybe zero id $ Hosts.inet_pton addr_str + where + zero = SockAddrInet 0 0 + addr_str = colons $ "fd" ++ (drop 10 $ map toLower $ fingerprint topk) + colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs + colons xs = xs + + +{- +onionName :: KeyData -> (SockAddr,L.ByteString) +onionName kd = (addr,name) + where + (addr,(name:_,_)) = getHostnames kd +-} + +getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) +getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) + where + othernames = do + mp <- flattenAllUids "" True uids + let p = packet mp + guard $ isSignaturePacket p + uh <- unhashed_subpackets p + case uh of + NotationDataPacket True "hostname@" v + -> return $ Char8.pack v + _ -> mzero + + addr = fingerdress topk + name = maybe "" id $ listToMaybe onames -- TODO: more than one tor key? + topk = packet topmp + torkeys = do + SubKey k sigs <- Map.elems subs + let subk = packet k + let sigs' = do + torsig <- filter (has_tag "tor") $ map (packet . fst) sigs + sig <- (signatures $ Message [topk,subk,torsig]) + let v = verify (Message [topk]) sig + -- Require parent's signature + guard (not . null $ signatures_over v) + let unhashed = unhashed_subpackets torsig + subsigs = mapMaybe backsig unhashed + -- This should consist only of 0x19 values + -- subtypes = map signature_type subsigs + sig' <- signatures . Message $ [topk,subk]++subsigs + let v' = verify (Message [subk]) sig' + -- Require subkey's signature + guard . not . null $ signatures_over v' + return torsig + guard (not $ null sigs') + return $ subk + has_tag tag p = isSignaturePacket p + && or [ tag `elem` mapMaybe usage (hashed_subpackets p) + , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] + subkeyPacket (SubKey k _ ) = k + onames :: [L.ByteString] + onames = map ( (<> ".onion") + . Char8.pack + . take 16 + . torhash ) + torkeys + kiki_usage = do putStr . unlines $ ["kiki - a pgp key editing utility" @@ -2047,7 +2184,10 @@ main = do , ("--show-wip",1) , ("--help",0) ] - argspec = map fst sargspec ++ ["--keyrings","--keypairs","--wallets"] + argspec = map fst sargspec ++ ["--keyrings" + ,"--keypairs" + ,"--wallets" + ,"--hosts"] -- "--bitcoin-keypairs" -- Disabled. We shouldn't accept private key -- data on the command line. @@ -2211,8 +2351,79 @@ main = do -- return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db Traversable.mapM (signTorIds wkun keys) use_db ret_db <- return $ fmap (const use_db) ret_db + + ret_db <- flip (maybe $ return ret_db) ret_db $ \db -> do + let hns = maybe [] id $ Map.lookup "--hosts" margs + hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns + + let gpgnames = map getHostnames $ Map.elems db + os = do + (addr,(ns,_)) <- gpgnames + n <- ns + return (addr,n) + setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os + -- we ensure .onion names are set properly + hostdbs = map setOnions hostdbs0 + outgoing_names = do + (addr,(_,gns)) <- gpgnames + guard . not $ null gns + guard $ all (null . Hosts.namesForAddress addr) hostdbs0 + return addr + -- putStrLn $ "hostdbs = " ++ show hostdbs + + -- 1. let U = union all the host dbs + -- preserving whitespace and comments of the first + let u0 = foldl' Hosts.plus Hosts.empty hostdbs + -- we filter U to be only finger-dresses + u1 = Hosts.filterAddrs (hasFingerDress db) u0 + + let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h + {- + putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}" + putStrLn $ "--> " ++ show (nf (head hostdbs)) + putStrLn $ "u0 = {\n" ++ show u0 ++ "}" + putStrLn $ "--> " ++ show (nf u0) + putStrLn $ "u1 = {\n" ++ show u1 ++ "}" + putStrLn $ "--> " ++ show (nf u1) + -} + + -- 2. replace gpg annotations with those in U + -- forM use_db + db' <- Traversable.mapM (setHostnames (\a -> not $ elem a outgoing_names) u1) db + + -- 3. add hostnames from gpg for addresses not in U + let u = foldl' f u1 ans + ans = reverse $ do + (addr,(_,ns)) <- gpgnames + guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0 + n <- ns + return (addr,n) + f h (addr,n) = Hosts.assignNewName addr n h + + {- + putStrLn $ "u = {\n" ++ show u ++ "}" + putStrLn $ "--> " ++ show (nf u) + -} + + -- 4. for each host db H, union H with U and write it out as H' + -- only if there is a non-empty diff + forM_ (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do + let h = h1 `Hosts.plus` u + d = Hosts.diff h0 h + fnamecolon = Char8.pack fname <> ": " + {- + putStrLn $ "h = {\n" ++ show h ++ "}" + putStrLn $ "--> " ++ show (nf h) + -} + Char8.hPutStrLn stderr $ Char8.unlines (map (fnamecolon <>) d) + when (not $ null d) $ L.writeFile fname $ Hosts.encode h + return () + + return (Just db') flip (maybe $ return ()) ret_db . const $ do + + -- On last pass, interpret --show-* commands. let shspec = Map.fromList [("--show-wk", const $ show_wk secfile grip) ,("--show-all",const $ show_all) -- cgit v1.2.3