diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/Kiki.hs | 132 |
1 files changed, 71 insertions, 61 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 32add1b..4659e95 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs | |||
@@ -1,3 +1,4 @@ | |||
1 | {-# LANGUAGE NamedFieldPuns #-} | ||
1 | {-# LANGUAGE RecordWildCards #-} | 2 | {-# LANGUAGE RecordWildCards #-} |
2 | {-# LANGUAGE ViewPatterns #-} | 3 | {-# LANGUAGE ViewPatterns #-} |
3 | {-# LANGUAGE CPP #-} | 4 | {-# LANGUAGE CPP #-} |
@@ -17,6 +18,7 @@ import Data.ASN1.Encoding | |||
17 | import Data.ASN1.Types | 18 | import Data.ASN1.Types |
18 | import Data.Binary | 19 | import Data.Binary |
19 | import Data.Bool | 20 | import Data.Bool |
21 | import Data.Coerce | ||
20 | import Data.Char | 22 | import Data.Char |
21 | import Data.Functor | 23 | import Data.Functor |
22 | import Data.List | 24 | import Data.List |
@@ -332,28 +334,26 @@ importAndRefresh root cmn cipher = do | |||
332 | -- Finally, we update /var/cache/kiki. | 334 | -- Finally, we update /var/cache/kiki. |
333 | when (not bUnprivileged) $ refreshCache rt rootdir | 335 | when (not bUnprivileged) $ refreshCache rt rootdir |
334 | 336 | ||
335 | data IpsecPeerConfig = IpsecPeerConfig | 337 | data Peer = Peer |
336 | { contactname :: UidHostname | 338 | { contactname :: UidHostname |
337 | , addr :: SockAddr | 339 | , addr :: SockAddr |
338 | , kd :: KeyData | 340 | , kd :: KeyData |
339 | } | 341 | } |
340 | 342 | ||
343 | newtype IpsecPeerConfig = IpsecPeerConfig Char8.ByteString | ||
341 | -- Installs the cert file for the peer to the filesystem, and returns an | 344 | -- Installs the cert file for the peer to the filesystem, and returns an |
342 | -- ipsec.conf snippet configuring the peer and referencing the installed cert | 345 | -- ipsec.conf snippet configuring the peer and referencing the installed cert |
343 | -- file. | 346 | -- file. |
344 | installIpsecPeerCertificate | 347 | installIpsecPeerCertificate :: FileWriter -> Peer -> IO IpsecPeerConfig |
345 | :: FileWriter | 348 | installIpsecPeerCertificate fw p@Peer{kd} = IpsecPeerConfig <$> |
346 | -> IpsecPeerConfig | ||
347 | -> IO Char8.ByteString | ||
348 | installIpsecPeerCertificate fw IpsecPeerConfig{..} = | ||
349 | fromMaybe "" <$> do | 349 | fromMaybe "" <$> do |
350 | forM (listToMaybe ipsecs) $ \k -> do | 350 | forM (listToMaybe ipsecs) $ \k -> do |
351 | flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do | 351 | flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do |
352 | case sshs of | 352 | case sshs of |
353 | (sshkey:_) -> do | 353 | (sshkey:_) -> do |
354 | theirHostname <- ResolvableHostname <$> sshKeyToHostname sshkey | 354 | theirHostname <- ResolvableHostname <$> sshKeyToHostname sshkey |
355 | write fw (ipsecCertPath contactname) pem | 355 | write fw (peerCertPath p) pem |
356 | return $ strongswanPeerConfiguration addr contactname theirHostname | 356 | return $ strongswanPeerConfiguration p theirHostname |
357 | _ -> error "fuck." | 357 | _ -> error "fuck." |
358 | where | 358 | where |
359 | warn' x = warn x >> return Char8.empty | 359 | warn' x = warn x >> return Char8.empty |
@@ -370,14 +370,17 @@ installIpsecPeerCertificate fw IpsecPeerConfig{..} = | |||
370 | sshs = sortOn (Down . timestamp) | 370 | sshs = sortOn (Down . timestamp) |
371 | $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" | 371 | $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" |
372 | 372 | ||
373 | ipsecPath :: String -> UidHostname -> String | 373 | ipsecPath :: String -> Char8.ByteString -> String |
374 | ipsecPath theDirName (UidHostname theBaseName) = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem" | 374 | ipsecPath theDirName theBaseName = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem" |
375 | 375 | ||
376 | ipsecKeyPath :: UidHostname -> FilePath | 376 | ipsecKeyPath :: MyIdentity -> FilePath |
377 | ipsecKeyPath = ipsecPath "private" | 377 | ipsecKeyPath (MyIdentity _ theBaseName) = ipsecPath "private" theBaseName |
378 | 378 | ||
379 | ipsecCertPath :: UidHostname -> FilePath | 379 | ipsecCertPath :: MyIdentity -> FilePath |
380 | ipsecCertPath = ipsecPath "certs" | 380 | ipsecCertPath (MyIdentity _ theBaseName) = ipsecPath "certs" theBaseName |
381 | |||
382 | peerCertPath :: Peer -> FilePath | ||
383 | peerCertPath (Peer (UidHostname theBaseName) _ _) = ipsecPath "certs" theBaseName | ||
381 | 384 | ||
382 | makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter | 385 | makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter |
383 | makeFileWriter p c = | 386 | makeFileWriter p c = |
@@ -453,25 +456,23 @@ generateHostsFile fw rt = do | |||
453 | KikiResult _ report <- runKeyRing op | 456 | KikiResult _ report <- runKeyRing op |
454 | outputReport report | 457 | outputReport report |
455 | 458 | ||
456 | getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString | 459 | getssh :: Peer -> Char8.ByteString |
457 | getssh (contactname,_addr,kd) = do | 460 | getssh (Peer (UidHostname contactname) _ kd) = Char8.unlines taggedblobs |
458 | let their_master = packet $ keyMappedPacket kd | 461 | where |
459 | sshs :: [Packet] | 462 | their_master = packet $ keyMappedPacket kd |
460 | sshs = sortOn (Down . timestamp) | 463 | sshs :: [Packet] |
461 | $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" | 464 | sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" |
462 | blobs = mapMaybe sshblobFromPacketL sshs | 465 | blobs = mapMaybe sshblobFromPacketL sshs |
463 | taggedblobs = map (\b -> contactname <> " " <> b) blobs | 466 | taggedblobs = map ((contactname <> " ") <>) blobs |
464 | Char8.unlines taggedblobs | 467 | |
465 | 468 | data MyIdentity = MyIdentity { | |
466 | data IpsecConfig = IpsecConfig { | 469 | myGpgAddress :: SockAddr, |
467 | ourGpgAddress :: SockAddr, | 470 | myCertificateBasename :: Char8.ByteString |
468 | ourSigKey :: (), | ||
469 | peers :: [IpsecPeerConfig] | ||
470 | } | 471 | } |
471 | 472 | ||
472 | installIpsecConf :: FileWriter -> SockAddr -> Char8.ByteString -> [IpsecPeerConfig] -> IO () | 473 | installIpsecConf :: FileWriter -> MyIdentity -> [Peer] -> IO () |
473 | installIpsecConf fw wkaddr certBasename cs = do | 474 | installIpsecConf fw (MyIdentity wkaddr certBasename) cs = do |
474 | snippets <- mapM (installIpsecPeerCertificate fw) cs | 475 | snippets <- mapM (coerce . installIpsecPeerCertificate fw) cs |
475 | writeL fw "ipsec.conf" . Char8.unlines | 476 | writeL fw "ipsec.conf" . Char8.unlines |
476 | $ [ "conn %default" | 477 | $ [ "conn %default" |
477 | , " ikelifetime=60m" | 478 | , " ikelifetime=60m" |
@@ -503,9 +504,8 @@ refreshCache rt rootdir = do | |||
503 | wk <- rtWorkingKey rt | 504 | wk <- rtWorkingKey rt |
504 | Hostnames wkaddr onames _ _ <- Just $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk) | 505 | Hostnames wkaddr onames _ _ <- Just $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk) |
505 | Just $ do | 506 | Just $ do |
506 | let oname = UidHostname $ Char8.concat $ take 1 onames | 507 | let oname = Char8.concat $ take 1 onames |
507 | 508 | if (oname == "") then error "Missing tor key" else do | |
508 | -- if (oname == "") then error "Missing tor key" else do | ||
509 | -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub" | 509 | -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub" |
510 | -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" | 510 | -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" |
511 | -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" | 511 | -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" |
@@ -513,6 +513,7 @@ refreshCache rt rootdir = do | |||
513 | flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do | 513 | flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do |
514 | 514 | ||
515 | let grip = fingerprint wk | 515 | let grip = fingerprint wk |
516 | myId = MyIdentity wkaddr oname | ||
516 | exportOp = passphrases <> pemSecrets | 517 | exportOp = passphrases <> pemSecrets |
517 | <> minimalOp False | 518 | <> minimalOp False |
518 | (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt) | 519 | (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt) |
@@ -520,7 +521,7 @@ refreshCache rt rootdir = do | |||
520 | where | 521 | where |
521 | passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } | 522 | passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } |
522 | pemSecrets = mempty { opFiles = Map.fromList | 523 | pemSecrets = mempty { opFiles = Map.fromList |
523 | [ send "ipsec" (ipsecKeyPath oname) "missing ipsec key?" | 524 | [ send "ipsec" (ipsecKeyPath myId) "missing ipsec key?" |
524 | , send "ssh-client" ("root/.ssh/id_rsa") "missing ssh-client key?" | 525 | , send "ssh-client" ("root/.ssh/id_rsa") "missing ssh-client key?" |
525 | , send "ssh-server" ("ssh_host_rsa_key") "missing ssh host key?" | 526 | , send "ssh-server" ("ssh_host_rsa_key") "missing ssh host key?" |
526 | , send "tor" ("tor/private_key") "missing tor key?" | 527 | , send "tor" ("tor/private_key") "missing tor key?" |
@@ -538,7 +539,7 @@ refreshCache rt rootdir = do | |||
538 | outputReport report | 539 | outputReport report |
539 | -- outputReport $ map (first $ resolveForReport ctx) $ filter ((/=ExportedSubkey) . snd) report | 540 | -- outputReport $ map (first $ resolveForReport ctx) $ filter ((/=ExportedSubkey) . snd) report |
540 | rt'' <- rethrowKikiErrors rt' | 541 | rt'' <- rethrowKikiErrors rt' |
541 | writePublicKeyFiles rt'' fw grip oname wkaddr | 542 | writePublicKeyFiles rt'' fw grip myId |
542 | 543 | ||
543 | rethrowKikiErrors :: KikiCondition a -> IO a | 544 | rethrowKikiErrors :: KikiCondition a -> IO a |
544 | rethrowKikiErrors BadPassphrase = | 545 | rethrowKikiErrors BadPassphrase = |
@@ -548,31 +549,32 @@ rethrowKikiErrors rt = unconditionally $ return rt | |||
548 | newtype UidHostname = UidHostname Char8.ByteString | 549 | newtype UidHostname = UidHostname Char8.ByteString |
549 | newtype ResolvableHostname = ResolvableHostname Char8.ByteString | 550 | newtype ResolvableHostname = ResolvableHostname Char8.ByteString |
550 | 551 | ||
551 | writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> UidHostname -> SockAddr -> IO () | 552 | listPeers :: KeyRingRuntime -> [Peer] |
552 | writePublicKeyFiles rt fw grip oname wkaddr = do | 553 | listPeers rt = map conv . filter notme . mapMaybe namedContact . Map.elems . byKeyKey . rtKeyDB $ rt |
553 | 554 | where | |
554 | -- Finally, export public keys if they do not exist. | 555 | conv = \(a,b,c) -> Peer (UidHostname a) b c |
555 | either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) | 556 | kk = keykey (fromJust $ rtWorkingKey rt) |
556 | either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) | 557 | notme (_,_,kd) = keykey (keyPacket kd) /= kk |
557 | either warn (write fw $ ipsecCertPath oname) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket | 558 | namedContact kd = do |
558 | |||
559 | let onionkeys = mapMaybe namedContact $ Map.elems $ byKeyKey $ rtKeyDB rt | ||
560 | cs = filter (\(_,_,kd) -> notme kd) onionkeys | ||
561 | cs' = cs <&> \(a,b,c) -> IpsecPeerConfig (UidHostname a) b c | ||
562 | kk = keykey (fromJust $ rtWorkingKey rt) | ||
563 | notme kd = keykey (keyPacket kd) /= kk | ||
564 | |||
565 | namedContact kd = do | ||
566 | -- The getHostnames command requires a valid cross-signed tor key | 559 | -- The getHostnames command requires a valid cross-signed tor key |
567 | -- for each onion name returned in (_,(ns,_)). | 560 | -- for each onion name returned in (_,(ns,_)). |
568 | let Hostnames addr ns _ _ = getHostnames kd | 561 | let Hostnames addr ns _ _ = getHostnames kd |
569 | fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. | 562 | fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. |
570 | 563 | ||
571 | known_hosts = L.concat $ map getssh onionkeys | 564 | writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> MyIdentity -> IO () |
565 | writePublicKeyFiles rt fw grip myId = do | ||
566 | |||
567 | -- Finally, export public keys if they do not exist. | ||
568 | either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) | ||
569 | either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) | ||
570 | either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket | ||
571 | |||
572 | let cs = listPeers rt | ||
573 | known_hosts = L.concat $ map getssh $ cs | ||
572 | 574 | ||
573 | writeL fw "ssh_known_hosts" known_hosts | 575 | writeL fw "ssh_known_hosts" known_hosts |
574 | 576 | ||
575 | installIpsecConf fw wkaddr (Char8.pack $ takeBaseName $ ipsecCertPath oname) cs' | 577 | installIpsecConf fw myId cs |
576 | fileWriterCommit fw | 578 | fileWriterCommit fw |
577 | 579 | ||
578 | sshKeyToHostname :: Packet -> IO Char8.ByteString | 580 | sshKeyToHostname :: Packet -> IO Char8.ByteString |
@@ -584,16 +586,24 @@ sshKeyToHostname sshkey = do | |||
584 | "f=$(mktemp) && cat > \"$f\" && ssh-keygen -r _ -f \"$f\" |" ++ | 586 | "f=$(mktemp) && cat > \"$f\" && ssh-keygen -r _ -f \"$f\" |" ++ |
585 | " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" | 587 | " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" |
586 | 588 | ||
587 | strongswanPeerConfiguration :: SockAddr -> UidHostname -> ResolvableHostname -> Char8.ByteString | 589 | peerConnectionName :: Peer -> Char8.ByteString |
588 | strongswanPeerConfiguration addr (UidHostname oname) (ResolvableHostname rightip) = Char8.unlines | 590 | peerConnectionName (Peer (UidHostname x) _ _) = x |
589 | [ "conn " <> oname | 591 | |
590 | , " right=" <> rightip | 592 | peerCertificateName :: Peer -> Char8.ByteString |
591 | , " rightsubnet=" <> p (showA addr) <> "/128" | 593 | peerCertificateName = (<> ".pem") . peerConnectionName |
594 | |||
595 | peerAddress :: Peer -> Char8.ByteString | ||
596 | peerAddress (Peer _ addr _) = Char8.pack $ showA addr | ||
597 | |||
598 | strongswanPeerConfiguration :: Peer -> ResolvableHostname -> Char8.ByteString | ||
599 | strongswanPeerConfiguration peer@(Peer _ addr _) (ResolvableHostname rightip) = Char8.unlines | ||
600 | [ "conn " <> peerConnectionName peer | ||
601 | , " right=" <> rightip | ||
602 | , " rightsubnet=" <> peerAddress peer <> "/128" | ||
592 | , " rightauth=pubkey" | 603 | , " rightauth=pubkey" |
593 | , " rightid=" <> p (showA addr) | 604 | , " rightid=" <> peerAddress peer |
594 | , " rightsigkey=" <> oname <> ".pem" | 605 | , " rightsigkey=" <> peerCertificateName peer |
595 | ] | 606 | ] |
596 | where p = Char8.pack | ||
597 | 607 | ||
598 | -- conn hiotuxliwisbp6mi.onion | 608 | -- conn hiotuxliwisbp6mi.onion |
599 | -- right=%hiotuxliwisbp6mi.onion.ipv4 | 609 | -- right=%hiotuxliwisbp6mi.onion.ipv4 |