From 674b7464b74cc1bfe6f609f833af406300828295 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sat, 13 Jul 2019 00:57:31 -0400 Subject: factor out chooseOneName --- lib/KeyRing/BuildKeyDB.hs | 9 ++++----- lib/Kiki.hs | 49 ++++++++++++++++++++++++++--------------------- 2 files changed, 31 insertions(+), 27 deletions(-) diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index c5754f1..0a90cbc 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -973,16 +973,15 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops return $ KeyData topmp topsigs uids1 subs where pred = addr `elem` outgoing_names - topk = packet topmp - addr = fingerdress topk + addr = fingerdress $ packet topmp names :: [Char8.ByteString] - names = Hosts.namesForAddress addr hosts + names = Hosts.namesForAddress addr hosts pred2 = gotNonOnions == namesWithoutGotOnions Hostnames _ gotOnions gotNonOnions cryptonomic = getHostnames kd - namesWithoutGotOnions = names \\ gotOnions - notations = map (NotationDataPacket True "hostname@" . Char8.unpack) namesWithoutGotOnions + namesWithoutGotOnions = names \\ gotOnions + notations = map (NotationDataPacket True "hostname@" . Char8.unpack) namesWithoutGotOnions isName (NotationDataPacket True "hostname@" _) = True isName _ = False uids0 = fmap zapIfHasName uids diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 4659e95..de1219a 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -334,11 +334,13 @@ importAndRefresh root cmn cipher = do -- Finally, we update /var/cache/kiki. when (not bUnprivileged) $ refreshCache rt rootdir -data Peer = Peer - { contactname :: UidHostname - , addr :: SockAddr - , kd :: KeyData - } +data Peer = + Peer + { peerContactName :: UidHostname + , peerHostnames :: Hostnames + , addr :: SockAddr + , kd :: KeyData + } newtype IpsecPeerConfig = IpsecPeerConfig Char8.ByteString -- Installs the cert file for the peer to the filesystem, and returns an @@ -380,7 +382,7 @@ ipsecCertPath :: MyIdentity -> FilePath ipsecCertPath (MyIdentity _ theBaseName) = ipsecPath "certs" theBaseName peerCertPath :: Peer -> FilePath -peerCertPath (Peer (UidHostname theBaseName) _ _) = ipsecPath "certs" theBaseName +peerCertPath = ipsecPath "certs" . coerce . peerContactName makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter makeFileWriter p c = @@ -456,14 +458,14 @@ generateHostsFile fw rt = do KikiResult _ report <- runKeyRing op outputReport report -getssh :: Peer -> Char8.ByteString -getssh (Peer (UidHostname contactname) _ kd) = Char8.unlines taggedblobs +getSshKnownHosts :: Peer -> Char8.ByteString +getSshKnownHosts peer@Peer{kd} = Char8.unlines taggedblobs where their_master = packet $ keyMappedPacket kd sshs :: [Packet] - sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" + sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys $ kd) "ssh-server" blobs = mapMaybe sshblobFromPacketL sshs - taggedblobs = map ((contactname <> " ") <>) blobs + taggedblobs = map ((coerce (peerContactName peer) <> " ") <>) blobs data MyIdentity = MyIdentity { myGpgAddress :: SockAddr, @@ -549,17 +551,20 @@ rethrowKikiErrors rt = unconditionally $ return rt newtype UidHostname = UidHostname Char8.ByteString newtype ResolvableHostname = ResolvableHostname Char8.ByteString +chooseOneName :: Hostnames -> Maybe UidHostname +chooseOneName (Hostnames _ (n:_) _ _) = Just $ coerce n +chooseOneName _ = Nothing + listPeers :: KeyRingRuntime -> [Peer] listPeers rt = map conv . filter notme . mapMaybe namedContact . Map.elems . byKeyKey . rtKeyDB $ rt where - conv = \(a,b,c) -> Peer (UidHostname a) b c - kk = keykey (fromJust $ rtWorkingKey rt) - notme (_,_,kd) = keykey (keyPacket kd) /= kk - namedContact kd = do - -- The getHostnames command requires a valid cross-signed tor key - -- for each onion name returned in (_,(ns,_)). - let Hostnames addr ns _ _ = getHostnames kd - fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. + conv = \(a,b,c,d) -> Peer a b c d + kk = keykey (fromJust $ rtWorkingKey rt) + notme (_,_,_,kd) = keykey (keyPacket kd) /= kk + namedContact kd = do + let h = getHostnames kd + n <- chooseOneName h + return (n, h, gpgipv6addr h, kd) writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> MyIdentity -> IO () writePublicKeyFiles rt fw grip myId = do @@ -570,7 +575,7 @@ writePublicKeyFiles rt fw grip myId = do either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket let cs = listPeers rt - known_hosts = L.concat $ map getssh $ cs + known_hosts = L.concat $ map getSshKnownHosts $ cs writeL fw "ssh_known_hosts" known_hosts @@ -587,16 +592,16 @@ sshKeyToHostname sshkey = do " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" peerConnectionName :: Peer -> Char8.ByteString -peerConnectionName (Peer (UidHostname x) _ _) = x +peerConnectionName = coerce . peerContactName peerCertificateName :: Peer -> Char8.ByteString peerCertificateName = (<> ".pem") . peerConnectionName peerAddress :: Peer -> Char8.ByteString -peerAddress (Peer _ addr _) = Char8.pack $ showA addr +peerAddress = Char8.pack . showA . addr strongswanPeerConfiguration :: Peer -> ResolvableHostname -> Char8.ByteString -strongswanPeerConfiguration peer@(Peer _ addr _) (ResolvableHostname rightip) = Char8.unlines +strongswanPeerConfiguration peer (ResolvableHostname rightip) = Char8.unlines [ "conn " <> peerConnectionName peer , " right=" <> rightip , " rightsubnet=" <> peerAddress peer <> "/128" -- cgit v1.2.3