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. --- Hosts.hs | 93 ++++++++++++++++++++++----- kiki.cabal | 3 +- kiki.hs | 213 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 290 insertions(+), 19 deletions(-) diff --git a/Hosts.hs b/Hosts.hs index 669fd09..e53d441 100644 --- a/Hosts.hs +++ b/Hosts.hs @@ -12,11 +12,14 @@ module Hosts , encode , decode , diff + , plus + , filterAddrs + , namesForAddress ) where import Data.Maybe import Data.Monoid ( (<>) ) -import Data.List (foldl') +import Data.List as List (foldl', (\\) ) import Data.Ord import Data.Char (isSpace) import qualified Data.Map as Map @@ -77,9 +80,9 @@ empty = Hosts { lineCount = 0 parseHosts fname = do input <- L.readFile fname - decode input + return $ decode input -decode input = do +decode input = let ls = L.lines input ans = map (\l->(parseLine l,l)) ls hosts = foldl' upd empty ans @@ -96,7 +99,7 @@ decode input = do maybeInsert m x = maybe m (\x->Map.insert x count m) x - return hosts + in hosts hasName :: L.ByteString -> Hosts -> Bool @@ -112,8 +115,20 @@ scrubName f line = line' where oo = (.) . (.) (a,ws') = splitAt 2 ws ws'' = f ws' - line' = if null ws'' then "# " <> line - else L.concat (a ++ ws'') <> ign + line' = if null ws'' + then if length a==2 then "# " <> L.concat a <> ign + else line + else if length a==2 + then L.concat (a ++ ws'') <> ign + else let vs = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace + $ L.tail ign + where oo = (.) . (.) + (a',vs') = splitAt 2 vs + vs'' = L.concat vs' + vs''' = if L.take 1 vs'' `elem` ["#",""] + then vs'' + else "# " <> vs'' + in L.concat (a'++ws'') <> vs''' assignName addr name hosts = assignName0 False addr name hosts @@ -128,23 +143,13 @@ assignName0 iscannon addr name hosts = hosts' let hosts0 = -- remove name if it's present maybe hosts (removeName hosts) ns hosts1 = -- insert name, or add new line - maybe (newLine hosts0) (appendName hosts0) a + maybe (newLine hosts0) (appendName iscannon name hosts0) a in hosts1 removeName hosts nums = hosts { namenum = Map.delete name (namenum hosts) , numline = foldl' scrub (numline hosts) nums } where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m - appendName hosts num = hosts - { numline = Map.adjust (scrubName f) num (numline hosts) - , namenum = Map.alter (cons num) name (namenum hosts) - } - where f ws = if iscannon - then [name, " "] ++ ws - else let rs = reverse ws - (sp,rs') = span (L.any isSpace) rs - in reverse $ sp ++ [name," "] ++ rs' - cons v xs = Just $ maybe [v] (v:) xs newLine hosts = hosts { lineCount = cnt , numline = Map.insert cnt line $ numline hosts @@ -159,6 +164,17 @@ assignNewName addr name hosts = if hasName name hosts then hosts else assignName0 True addr name hosts +appendName iscannon name hosts num = hosts + { numline = Map.adjust (scrubName f) num (numline hosts) + , namenum = Map.alter (cons num) name (namenum hosts) + } + where f ws = if iscannon + then [name, " "] ++ ws + else let rs = reverse ws + (sp,rs') = span (L.any isSpace) rs + in reverse $ sp ++ [name," "] ++ rs' + cons v xs = Just $ maybe [v] (v:) xs + -- Returns a list of bytestrings intended to show the -- differences between the two host databases. It is -- assumed that no lines are deleted, only altered or @@ -175,3 +191,46 @@ diff as bs = cs [a,b] <- return $ map maybeToList [a,b] fmap ("- " <>) a ++ fmap ("+ " <>) b +namesForAddress :: SockAddr -> Hosts -> [L.ByteString] +namesForAddress addr hosts = snd $ _namesForAddress addr hosts + +_namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns + where + ns = maybe (-1,[]) id $ do + n <- Map.lookup addr addrnum + line <- Map.lookup n numline + return (n, snd $ parseLine line) + + +plus a b = Map.foldlWithKey' mergeAddr a (addrnum b) + where + mergeAddr a addr bnum = a' + where + (anum,ns) = _namesForAddress addr a + bs = maybe [] (List.\\ ns) $ do + line <- Map.lookup bnum (numline b) + return . snd $ parseLine line + a' = if anum/=(-1) then foldl' app a $ reverse bs + else newLine a + app a b = appendName True b a anum -- True to allow b to reassign cannonical name + newLine hosts = hosts + { lineCount = cnt + , numline = Map.insert cnt line $ numline hosts + , addrnum = Map.insert addr cnt $ addrnum hosts + , namenum = foldl' updnamenum (namenum hosts) bs + } + where cnt = lineCount hosts + 1 + line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs + cons v xs = Just $ maybe [v] (v:) xs + updnamenum m name = Map.alter (cons cnt) name m + +filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts +filterAddrs pred hosts = hosts' + where + als = Map.toList (addrnum hosts) + nl = foldl' f (numline hosts) als + f m (addr,num) = if pred addr + then m + else Map.adjust (scrubName $ const []) num m + lines = L.unlines . Map.elems $ nl + hosts' = decode lines diff --git a/kiki.cabal b/kiki.cabal index 7bd661e..de75d14 100644 --- a/kiki.cabal +++ b/kiki.cabal @@ -21,6 +21,7 @@ Executable kiki dataenc -any, text -any, pretty -any, pretty-show -any, bytestring -any, openpgp (==0.6.1), binary -any, unix, time, crypto-api, cryptocipher (>=0.3.7), - containers -any, process -any, filepath -any + containers -any, process -any, filepath -any, + network ghc-options: -O2 c-sources: dotlock.c 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