factor out chooseOneName

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"