summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Kiki.hs132
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
17import Data.ASN1.Types 18import Data.ASN1.Types
18import Data.Binary 19import Data.Binary
19import Data.Bool 20import Data.Bool
21import Data.Coerce
20import Data.Char 22import Data.Char
21import Data.Functor 23import Data.Functor
22import Data.List 24import 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
335data IpsecPeerConfig = IpsecPeerConfig 337data Peer = Peer
336 { contactname :: UidHostname 338 { contactname :: UidHostname
337 , addr :: SockAddr 339 , addr :: SockAddr
338 , kd :: KeyData 340 , kd :: KeyData
339 } 341 }
340 342
343newtype 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.
344installIpsecPeerCertificate 347installIpsecPeerCertificate :: FileWriter -> Peer -> IO IpsecPeerConfig
345 :: FileWriter 348installIpsecPeerCertificate fw p@Peer{kd} = IpsecPeerConfig <$>
346 -> IpsecPeerConfig
347 -> IO Char8.ByteString
348installIpsecPeerCertificate 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
373ipsecPath :: String -> UidHostname -> String 373ipsecPath :: String -> Char8.ByteString -> String
374ipsecPath theDirName (UidHostname theBaseName) = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem" 374ipsecPath theDirName theBaseName = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem"
375 375
376ipsecKeyPath :: UidHostname -> FilePath 376ipsecKeyPath :: MyIdentity -> FilePath
377ipsecKeyPath = ipsecPath "private" 377ipsecKeyPath (MyIdentity _ theBaseName) = ipsecPath "private" theBaseName
378 378
379ipsecCertPath :: UidHostname -> FilePath 379ipsecCertPath :: MyIdentity -> FilePath
380ipsecCertPath = ipsecPath "certs" 380ipsecCertPath (MyIdentity _ theBaseName) = ipsecPath "certs" theBaseName
381
382peerCertPath :: Peer -> FilePath
383peerCertPath (Peer (UidHostname theBaseName) _ _) = ipsecPath "certs" theBaseName
381 384
382makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter 385makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter
383makeFileWriter p c = 386makeFileWriter 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
456getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString 459getssh :: Peer -> Char8.ByteString
457getssh (contactname,_addr,kd) = do 460getssh (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 468data MyIdentity = MyIdentity {
466data IpsecConfig = IpsecConfig { 469 myGpgAddress :: SockAddr,
467 ourGpgAddress :: SockAddr, 470 myCertificateBasename :: Char8.ByteString
468 ourSigKey :: (),
469 peers :: [IpsecPeerConfig]
470} 471}
471 472
472installIpsecConf :: FileWriter -> SockAddr -> Char8.ByteString -> [IpsecPeerConfig] -> IO () 473installIpsecConf :: FileWriter -> MyIdentity -> [Peer] -> IO ()
473installIpsecConf fw wkaddr certBasename cs = do 474installIpsecConf 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
543rethrowKikiErrors :: KikiCondition a -> IO a 544rethrowKikiErrors :: KikiCondition a -> IO a
544rethrowKikiErrors BadPassphrase = 545rethrowKikiErrors BadPassphrase =
@@ -548,31 +549,32 @@ rethrowKikiErrors rt = unconditionally $ return rt
548newtype UidHostname = UidHostname Char8.ByteString 549newtype UidHostname = UidHostname Char8.ByteString
549newtype ResolvableHostname = ResolvableHostname Char8.ByteString 550newtype ResolvableHostname = ResolvableHostname Char8.ByteString
550 551
551writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> UidHostname -> SockAddr -> IO () 552listPeers :: KeyRingRuntime -> [Peer]
552writePublicKeyFiles rt fw grip oname wkaddr = do 553listPeers 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 564writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> MyIdentity -> IO ()
565writePublicKeyFiles 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
578sshKeyToHostname :: Packet -> IO Char8.ByteString 580sshKeyToHostname :: 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
587strongswanPeerConfiguration :: SockAddr -> UidHostname -> ResolvableHostname -> Char8.ByteString 589peerConnectionName :: Peer -> Char8.ByteString
588strongswanPeerConfiguration addr (UidHostname oname) (ResolvableHostname rightip) = Char8.unlines 590peerConnectionName (Peer (UidHostname x) _ _) = x
589 [ "conn " <> oname 591
590 , " right=" <> rightip 592peerCertificateName :: Peer -> Char8.ByteString
591 , " rightsubnet=" <> p (showA addr) <> "/128" 593peerCertificateName = (<> ".pem") . peerConnectionName
594
595peerAddress :: Peer -> Char8.ByteString
596peerAddress (Peer _ addr _) = Char8.pack $ showA addr
597
598strongswanPeerConfiguration :: Peer -> ResolvableHostname -> Char8.ByteString
599strongswanPeerConfiguration 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