From ba3249708c52d0c5cf85ed5eb13dd7191b6b990b Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 20 Apr 2014 23:41:29 -0400 Subject: /etc/hosts file merging --- KeyRing.hs | 254 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 250 insertions(+), 4 deletions(-) (limited to 'KeyRing.hs') diff --git a/KeyRing.hs b/KeyRing.hs index 5149da4..c6aa6a4 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -57,10 +57,13 @@ import qualified Data.Traversable as Traversable (mapM,forM,sequence) #if ! MIN_VERSION_base(4,6,0) import GHC.Exts ( Down(..) ) #endif +import Network.Socket -- (SockAddr) +import qualified Data.ByteString.Lazy.Char8 as Char8 -import qualified CryptoCoins as CryptoCoins +import qualified Hosts +import qualified CryptoCoins import Base58 import FunctorToMaybe import DotLock @@ -95,6 +98,7 @@ type PassWordFile = InputFile data FileType = KeyRingFile (Maybe PassWordFile) | PEMFile UsageTag | WalletFile -- (Maybe UsageTag) + | Hosts -- | RefType is perhaps not a good name for this... -- It is sort of like a read/write flag, although @@ -308,6 +312,7 @@ data KikiReportAction = | ExternallyGeneratedFile | UnableToExport KeyAlgorithm String | FailedFileWrite + | HostsDiff ByteString deriving Show data KikiResult a = KikiResult @@ -683,9 +688,114 @@ importPEMKey doDecrypt db' tup = do try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) + +mergeHostFiles :: KeyRingOperation -> KeyDB + -> FilePath + -> FilePath + -> IO + (KikiCondition + ( ( Map.Map [Char8.ByteString] KeyData + , ( [Hosts.Hosts] + , [Hosts.Hosts] + , Hosts.Hosts + , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] + , [SockAddr])) + , [(FilePath,KikiReportAction)])) +mergeHostFiles krd db secring pubring = do + let hns = files ishosts + ishosts Hosts = True + ishosts _ = False + files istyp = do + (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) + guard (istyp ftyp) + resolveInputFile secring pubring f + + 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 + + return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) + +writeHostsFiles + :: KeyRingOperation + -> [Char] + -> [Char] + -> ([Hosts.Hosts], + [Hosts.Hosts], + Hosts.Hosts, + [(SockAddr, (t1, [Char8.ByteString]))], + [SockAddr]) + -> IO [(FilePath, KikiReportAction)] +writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do + let hns = files ishosts + ishosts Hosts = True + ishosts _ = False + files istyp = do + (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) + guard (istyp ftyp) + resolveInputFile secring pubring f + + -- 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 + + -- 4. for each host db H, union H with U and write it out as H' + -- only if there is a non-empty diff + rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do + let h = h1 `Hosts.plus` u + d = Hosts.diff h0 h + rs = map ((fname,) . HostsDiff) d + when (not $ null d) $ L.writeFile fname $ Hosts.encode h + return rs + return $ concat rss + + buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) -> FilePath -> FilePath -> Maybe String -> KeyRingOperation - -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket) + -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket, + ([Hosts.Hosts], + [Hosts.Hosts], + Hosts.Hosts, + [(SockAddr, ([ByteString], [ByteString]))], + [SockAddr]) ) ,[(FilePath,KikiReportAction)])) buildKeyDB doDecrypt secring pubring grip0 keyring = do let @@ -754,7 +864,10 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports try db $ \(db,reportPEMs) -> do - return $ KikiSuccess ( (db, grip, mwk), reportWallets ++ reportPEMs ) + r <- mergeHostFiles keyring db secring pubring + try r $ \((db,hs),reportHosts) -> do + + return $ KikiSuccess ( (db, grip, mwk, hs), reportWallets ++ reportPEMs ) torhash key = maybe "" id $ derToBase32 <$> derRSA key @@ -1372,7 +1485,7 @@ runKeyRing operation = do -- merge all keyrings, PEM files, and wallets bresult <- buildKeyDB decrypt secring pubring grip0 operation - try' bresult $ \((db,grip,wk),report_imports) -> do + try' bresult $ \((db,grip,wk,hs),report_imports) -> do externals_ret <- initializeMissingPEMFiles operation secring pubring grip @@ -1402,6 +1515,8 @@ runKeyRing operation = do r <- writePEMKeys decrypt (rtKeyDB rt) exports try' r $ \report_pems -> do + + import_hosts <- writeHostsFiles operation secring pubring hs return $ KikiResult (KikiSuccess rt) $ concat [ report_imports @@ -2005,6 +2120,137 @@ flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedP flattenUid fname ispub (str,(sigs,om)) = (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs +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 + +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 + +-- 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 + +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 + +backsig (EmbeddedSignaturePacket s) = Just s +backsig _ = Nothing + +socketFamily (SockAddrInet _ _) = AF_INET +socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +socketFamily (SockAddrUnix _) = AF_UNIX + + + +{-----------------------------------------------} {- -- cgit v1.2.3