diff options
-rw-r--r-- | lib/Kiki.hs | 61 |
1 files changed, 33 insertions, 28 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs index af62a97..7bf0e3d 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs | |||
@@ -324,19 +324,22 @@ importAndRefresh root cmn cipher = do | |||
324 | 324 | ||
325 | when (not bUnprivileged) $ refreshCache rt rootdir | 325 | when (not bUnprivileged) $ refreshCache rt rootdir |
326 | 326 | ||
327 | 327 | -- Installs the cert file for the peer to the filesystem, and returns an | |
328 | -- We find all cross-certified ipsec keys for the given cross-certified onion name. | 328 | -- ipsec.conf snippet configuring the peer and referencing the installed cert |
329 | installContact | 329 | -- file. |
330 | installIpsecPeerCertificate | ||
330 | :: (FilePath -> FilePath) | 331 | :: (FilePath -> FilePath) |
331 | -> (L.ByteString, SockAddr, KeyData) | 332 | -> (L.ByteString, SockAddr, KeyData) |
332 | -> IO Char8.ByteString | 333 | -> IO Char8.ByteString |
333 | installContact mkpath (contactname,addr,kd) = | 334 | installIpsecPeerCertificate mkpath (contactname,addr,kd) = |
334 | Char8.concat <$> do | 335 | Char8.concat <$> do |
335 | forM (take 1 ipsecs) $ \k -> do | 336 | forM (take 1 ipsecs) $ \k -> do |
336 | flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do | 337 | flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do |
337 | write (mkpath cpath) pem | ||
338 | case sshs of | 338 | case sshs of |
339 | (sshkey:_) -> strongswanForContact addr contactname <$> sshKeyToHostname sshkey | 339 | (sshkey:_) -> do |
340 | theirHostname <- sshKeyToHostname sshkey | ||
341 | write (mkpath $ ipsecCertPath theirHostname) pem | ||
342 | return $ strongswanPeerConfiguration addr contactname theirHostname | ||
340 | _ -> error "fuck." | 343 | _ -> error "fuck." |
341 | where | 344 | where |
342 | warn' x = warn x >> return Char8.empty | 345 | warn' x = warn x >> return Char8.empty |
@@ -353,9 +356,14 @@ installContact mkpath (contactname,addr,kd) = | |||
353 | sshs = sortOn (Down . timestamp) | 356 | sshs = sortOn (Down . timestamp) |
354 | $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" | 357 | $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" |
355 | 358 | ||
356 | cpath :: FilePath | 359 | ipsecPath :: String -> Char8.ByteString -> String |
357 | cpath = interp (Map.singleton "onion" (Char8.unpack contactname)) "ipsec.d/certs/%(onion).pem" | 360 | ipsecPath theDirName theBaseName = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem" |
361 | |||
362 | ipsecKeyPath :: Char8.ByteString -> FilePath | ||
363 | ipsecKeyPath = ipsecPath "private" | ||
358 | 364 | ||
365 | ipsecCertPath :: Char8.ByteString -> FilePath | ||
366 | ipsecCertPath = ipsecPath "certs" | ||
359 | 367 | ||
360 | write' :: (FilePath -> t -> IO b) -> FilePath -> t -> IO b | 368 | write' :: (FilePath -> t -> IO b) -> FilePath -> t -> IO b |
361 | write' wr f bs = do | 369 | write' wr f bs = do |
@@ -426,8 +434,8 @@ names rt = do wk <- rtWorkingKey rt | |||
426 | -- XXX unnecessary signature check | 434 | -- XXX unnecessary signature check |
427 | return $ getHostnames (rtKeyDB rt Map.! keykey wk) | 435 | return $ getHostnames (rtKeyDB rt Map.! keykey wk) |
428 | 436 | ||
429 | getssh :: (Char8.ByteString, t, KeyData) -> Char8.ByteString | 437 | getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString |
430 | getssh (contactname,addr,kd) = do | 438 | getssh (contactname,_addr,kd) = do |
431 | let their_master = packet $ keyMappedPacket kd | 439 | let their_master = packet $ keyMappedPacket kd |
432 | sshs :: [Packet] | 440 | sshs :: [Packet] |
433 | sshs = sortOn (Down . timestamp) | 441 | sshs = sortOn (Down . timestamp) |
@@ -437,9 +445,10 @@ getssh (contactname,addr,kd) = do | |||
437 | Char8.unlines taggedblobs | 445 | Char8.unlines taggedblobs |
438 | 446 | ||
439 | 447 | ||
440 | writeIpsecConf :: FilePath -> SockAddr -> Char8.ByteString -> [Char8.ByteString] -> IO () | 448 | installIpsecConf :: (FilePath -> FilePath) -> SockAddr -> Char8.ByteString -> [(Char8.ByteString, SockAddr, KeyData)] -> IO () |
441 | writeIpsecConf p wkaddr oname cons = | 449 | installIpsecConf mkpath wkaddr (certBasename) cs = do |
442 | writeL p . Char8.unlines | 450 | snippets <- mapM (installIpsecPeerCertificate mkpath) cs |
451 | writeL (mkpath "ipsec.conf") . Char8.unlines | ||
443 | $ [ "conn %default" | 452 | $ [ "conn %default" |
444 | , " ikelifetime=60m" | 453 | , " ikelifetime=60m" |
445 | , " keylife=20m" | 454 | , " keylife=20m" |
@@ -452,7 +461,7 @@ writeIpsecConf p wkaddr oname cons = | |||
452 | , " leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128" | 461 | , " leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128" |
453 | , " leftauth=pubkey" | 462 | , " leftauth=pubkey" |
454 | , " leftid=" <> Char8.pack (showA wkaddr) | 463 | , " leftid=" <> Char8.pack (showA wkaddr) |
455 | , " leftrsasigkey=" <> oname <> ".pem" | 464 | , " leftrsasigkey=" <> certBasename |
456 | , " leftikeport=4500" | 465 | , " leftikeport=4500" |
457 | , " rightikeport=4500" | 466 | , " rightikeport=4500" |
458 | , " right=%any" | 467 | , " right=%any" |
@@ -460,7 +469,7 @@ writeIpsecConf p wkaddr oname cons = | |||
460 | , " type=tunnel" | 469 | , " type=tunnel" |
461 | , " auto=route" | 470 | , " auto=route" |
462 | , "" | 471 | , "" |
463 | ] ++ filter (not . Char8.null) cons | 472 | ] ++ filter (not . Char8.null) snippets |
464 | 473 | ||
465 | refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () | 474 | refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () |
466 | refreshCache rt rootdir = do | 475 | refreshCache rt rootdir = do |
@@ -483,7 +492,7 @@ refreshCache rt rootdir = do | |||
483 | where | 492 | where |
484 | passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } | 493 | passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } |
485 | pemSecrets = mempty { opFiles = Map.fromList | 494 | pemSecrets = mempty { opFiles = Map.fromList |
486 | [ send "ipsec" (mkpath "ipsec.d/private/" ++ Char8.unpack oname++".pem") "missing ipsec key?" | 495 | [ send "ipsec" (mkpath $ ipsecKeyPath oname) "missing ipsec key?" |
487 | , send "ssh-client" (mkpath "root/.ssh/id_rsa") "missing ssh-client key?" | 496 | , send "ssh-client" (mkpath "root/.ssh/id_rsa") "missing ssh-client key?" |
488 | , send "ssh-server" (mkpath "ssh_host_rsa_key") "missing ssh host key?" | 497 | , send "ssh-server" (mkpath "ssh_host_rsa_key") "missing ssh host key?" |
489 | , send "tor" (mkpath "tor/private_key") "missing tor key?" | 498 | , send "tor" (mkpath "tor/private_key") "missing tor key?" |
@@ -512,12 +521,9 @@ writePublicKeyFiles :: KeyRingRuntime -> (FilePath -> FilePath) -> String -> Cha | |||
512 | writePublicKeyFiles rt mkpath grip oname wkaddr commit = do | 521 | writePublicKeyFiles rt mkpath grip oname wkaddr commit = do |
513 | 522 | ||
514 | -- Finally, export public keys if they do not exist. | 523 | -- Finally, export public keys if they do not exist. |
515 | either warn (write $ mkpath "root/.ssh/id_rsa.pub") | 524 | either warn (write $ mkpath "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) |
516 | $ show_ssh' "ssh-client" grip (rtKeyDB rt) | 525 | either warn (write $ mkpath "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) |
517 | either warn (write $ mkpath "ssh_host_rsa_key.pub") | 526 | either warn (write $ mkpath $ ipsecCertPath oname) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket |
518 | $ show_ssh' "ssh-server" grip (rtKeyDB rt) | ||
519 | either warn (write $ mkpath "ipsec.d/certs/" ++ Char8.unpack oname++".pem") | ||
520 | $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket | ||
521 | 527 | ||
522 | let onionkeys = mapMaybe namedContact $ Map.elems $ rtKeyDB rt | 528 | let onionkeys = mapMaybe namedContact $ Map.elems $ rtKeyDB rt |
523 | cs = filter (\(_,_,kd) -> notme kd) onionkeys | 529 | cs = filter (\(_,_,kd) -> notme kd) onionkeys |
@@ -534,9 +540,7 @@ writePublicKeyFiles rt mkpath grip oname wkaddr commit = do | |||
534 | 540 | ||
535 | writeL (mkpath "ssh_known_hosts") known_hosts | 541 | writeL (mkpath "ssh_known_hosts") known_hosts |
536 | 542 | ||
537 | cons <- mapM (installContact mkpath) cs | 543 | installIpsecConf mkpath wkaddr (Char8.pack $ takeBaseName $ ipsecCertPath oname) cs |
538 | |||
539 | writeIpsecConf (mkpath "ipsec.conf") wkaddr oname cons | ||
540 | commit | 544 | commit |
541 | 545 | ||
542 | sshKeyToHostname :: Packet -> IO Char8.ByteString | 546 | sshKeyToHostname :: Packet -> IO Char8.ByteString |
@@ -545,10 +549,11 @@ sshKeyToHostname sshkey = do | |||
545 | return $ Char8.fromChunks [sout] | 549 | return $ Char8.fromChunks [sout] |
546 | where | 550 | where |
547 | shellScript = | 551 | shellScript = |
548 | "f=$(mktemp) && cat > \"$f\" && ssh-keygen -r _ -f \"$f\" | (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net)" | 552 | "f=$(mktemp) && cat > \"$f\" && ssh-keygen -r _ -f \"$f\" |" ++ |
553 | " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" | ||
549 | 554 | ||
550 | strongswanForContact :: SockAddr -> Char8.ByteString -> Char8.ByteString -> Char8.ByteString | 555 | strongswanPeerConfiguration :: SockAddr -> Char8.ByteString -> Char8.ByteString -> Char8.ByteString |
551 | strongswanForContact addr oname rightip = Char8.unlines | 556 | strongswanPeerConfiguration addr oname rightip = Char8.unlines |
552 | [ "conn " <> oname | 557 | [ "conn " <> oname |
553 | , " right=" <> rightip | 558 | , " right=" <> rightip |
554 | , " rightsubnet=" <> p (showA addr) <> "/128" | 559 | , " rightsubnet=" <> p (showA addr) <> "/128" |