diff options
author | Andrew Cady <d@jerkface.net> | 2019-07-13 00:57:31 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2019-07-13 00:57:31 -0400 |
commit | 674b7464b74cc1bfe6f609f833af406300828295 (patch) | |
tree | c668bec089c9d19b002bdef815938a51aa251475 /lib/Kiki.hs | |
parent | db7738d3d3ea80011fdf6f355d1f06009214e032 (diff) |
factor out chooseOneName
Diffstat (limited to 'lib/Kiki.hs')
-rw-r--r-- | lib/Kiki.hs | 49 |
1 files changed, 27 insertions, 22 deletions
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 | |||
334 | -- Finally, we update /var/cache/kiki. | 334 | -- Finally, we update /var/cache/kiki. |
335 | when (not bUnprivileged) $ refreshCache rt rootdir | 335 | when (not bUnprivileged) $ refreshCache rt rootdir |
336 | 336 | ||
337 | data Peer = Peer | 337 | data Peer = |
338 | { contactname :: UidHostname | 338 | Peer |
339 | , addr :: SockAddr | 339 | { peerContactName :: UidHostname |
340 | , kd :: KeyData | 340 | , peerHostnames :: Hostnames |
341 | } | 341 | , addr :: SockAddr |
342 | , kd :: KeyData | ||
343 | } | ||
342 | 344 | ||
343 | newtype IpsecPeerConfig = IpsecPeerConfig Char8.ByteString | 345 | newtype IpsecPeerConfig = IpsecPeerConfig Char8.ByteString |
344 | -- Installs the cert file for the peer to the filesystem, and returns an | 346 | -- Installs the cert file for the peer to the filesystem, and returns an |
@@ -380,7 +382,7 @@ ipsecCertPath :: MyIdentity -> FilePath | |||
380 | ipsecCertPath (MyIdentity _ theBaseName) = ipsecPath "certs" theBaseName | 382 | ipsecCertPath (MyIdentity _ theBaseName) = ipsecPath "certs" theBaseName |
381 | 383 | ||
382 | peerCertPath :: Peer -> FilePath | 384 | peerCertPath :: Peer -> FilePath |
383 | peerCertPath (Peer (UidHostname theBaseName) _ _) = ipsecPath "certs" theBaseName | 385 | peerCertPath = ipsecPath "certs" . coerce . peerContactName |
384 | 386 | ||
385 | makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter | 387 | makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter |
386 | makeFileWriter p c = | 388 | makeFileWriter p c = |
@@ -456,14 +458,14 @@ generateHostsFile fw rt = do | |||
456 | KikiResult _ report <- runKeyRing op | 458 | KikiResult _ report <- runKeyRing op |
457 | outputReport report | 459 | outputReport report |
458 | 460 | ||
459 | getssh :: Peer -> Char8.ByteString | 461 | getSshKnownHosts :: Peer -> Char8.ByteString |
460 | getssh (Peer (UidHostname contactname) _ kd) = Char8.unlines taggedblobs | 462 | getSshKnownHosts peer@Peer{kd} = Char8.unlines taggedblobs |
461 | where | 463 | where |
462 | their_master = packet $ keyMappedPacket kd | 464 | their_master = packet $ keyMappedPacket kd |
463 | sshs :: [Packet] | 465 | sshs :: [Packet] |
464 | sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" | 466 | sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys $ kd) "ssh-server" |
465 | blobs = mapMaybe sshblobFromPacketL sshs | 467 | blobs = mapMaybe sshblobFromPacketL sshs |
466 | taggedblobs = map ((contactname <> " ") <>) blobs | 468 | taggedblobs = map ((coerce (peerContactName peer) <> " ") <>) blobs |
467 | 469 | ||
468 | data MyIdentity = MyIdentity { | 470 | data MyIdentity = MyIdentity { |
469 | myGpgAddress :: SockAddr, | 471 | myGpgAddress :: SockAddr, |
@@ -549,17 +551,20 @@ rethrowKikiErrors rt = unconditionally $ return rt | |||
549 | newtype UidHostname = UidHostname Char8.ByteString | 551 | newtype UidHostname = UidHostname Char8.ByteString |
550 | newtype ResolvableHostname = ResolvableHostname Char8.ByteString | 552 | newtype ResolvableHostname = ResolvableHostname Char8.ByteString |
551 | 553 | ||
554 | chooseOneName :: Hostnames -> Maybe UidHostname | ||
555 | chooseOneName (Hostnames _ (n:_) _ _) = Just $ coerce n | ||
556 | chooseOneName _ = Nothing | ||
557 | |||
552 | listPeers :: KeyRingRuntime -> [Peer] | 558 | listPeers :: KeyRingRuntime -> [Peer] |
553 | listPeers rt = map conv . filter notme . mapMaybe namedContact . Map.elems . byKeyKey . rtKeyDB $ rt | 559 | listPeers rt = map conv . filter notme . mapMaybe namedContact . Map.elems . byKeyKey . rtKeyDB $ rt |
554 | where | 560 | where |
555 | conv = \(a,b,c) -> Peer (UidHostname a) b c | 561 | conv = \(a,b,c,d) -> Peer a b c d |
556 | kk = keykey (fromJust $ rtWorkingKey rt) | 562 | kk = keykey (fromJust $ rtWorkingKey rt) |
557 | notme (_,_,kd) = keykey (keyPacket kd) /= kk | 563 | notme (_,_,_,kd) = keykey (keyPacket kd) /= kk |
558 | namedContact kd = do | 564 | namedContact kd = do |
559 | -- The getHostnames command requires a valid cross-signed tor key | 565 | let h = getHostnames kd |
560 | -- for each onion name returned in (_,(ns,_)). | 566 | n <- chooseOneName h |
561 | let Hostnames addr ns _ _ = getHostnames kd | 567 | return (n, h, gpgipv6addr h, kd) |
562 | fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. | ||
563 | 568 | ||
564 | writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> MyIdentity -> IO () | 569 | writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> MyIdentity -> IO () |
565 | writePublicKeyFiles rt fw grip myId = do | 570 | writePublicKeyFiles rt fw grip myId = do |
@@ -570,7 +575,7 @@ writePublicKeyFiles rt fw grip myId = do | |||
570 | either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket | 575 | either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket |
571 | 576 | ||
572 | let cs = listPeers rt | 577 | let cs = listPeers rt |
573 | known_hosts = L.concat $ map getssh $ cs | 578 | known_hosts = L.concat $ map getSshKnownHosts $ cs |
574 | 579 | ||
575 | writeL fw "ssh_known_hosts" known_hosts | 580 | writeL fw "ssh_known_hosts" known_hosts |
576 | 581 | ||
@@ -587,16 +592,16 @@ sshKeyToHostname sshkey = do | |||
587 | " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" | 592 | " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" |
588 | 593 | ||
589 | peerConnectionName :: Peer -> Char8.ByteString | 594 | peerConnectionName :: Peer -> Char8.ByteString |
590 | peerConnectionName (Peer (UidHostname x) _ _) = x | 595 | peerConnectionName = coerce . peerContactName |
591 | 596 | ||
592 | peerCertificateName :: Peer -> Char8.ByteString | 597 | peerCertificateName :: Peer -> Char8.ByteString |
593 | peerCertificateName = (<> ".pem") . peerConnectionName | 598 | peerCertificateName = (<> ".pem") . peerConnectionName |
594 | 599 | ||
595 | peerAddress :: Peer -> Char8.ByteString | 600 | peerAddress :: Peer -> Char8.ByteString |
596 | peerAddress (Peer _ addr _) = Char8.pack $ showA addr | 601 | peerAddress = Char8.pack . showA . addr |
597 | 602 | ||
598 | strongswanPeerConfiguration :: Peer -> ResolvableHostname -> Char8.ByteString | 603 | strongswanPeerConfiguration :: Peer -> ResolvableHostname -> Char8.ByteString |
599 | strongswanPeerConfiguration peer@(Peer _ addr _) (ResolvableHostname rightip) = Char8.unlines | 604 | strongswanPeerConfiguration peer (ResolvableHostname rightip) = Char8.unlines |
600 | [ "conn " <> peerConnectionName peer | 605 | [ "conn " <> peerConnectionName peer |
601 | , " right=" <> rightip | 606 | , " right=" <> rightip |
602 | , " rightsubnet=" <> peerAddress peer <> "/128" | 607 | , " rightsubnet=" <> peerAddress peer <> "/128" |