summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Kiki.hs44
1 files changed, 24 insertions, 20 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 7fc96b3..e624ba6 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -333,7 +333,7 @@ importAndRefresh root cmn cipher = do
333 when (not bUnprivileged) $ refreshCache rt rootdir 333 when (not bUnprivileged) $ refreshCache rt rootdir
334 334
335data IpsecPeerConfig = IpsecPeerConfig 335data IpsecPeerConfig = IpsecPeerConfig
336 { contactname :: Char8.ByteString 336 { contactname :: UidHostname
337 , addr :: SockAddr 337 , addr :: SockAddr
338 , kd :: KeyData 338 , kd :: KeyData
339 } 339 }
@@ -351,8 +351,8 @@ installIpsecPeerCertificate fw IpsecPeerConfig{..} =
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 <- sshKeyToHostname sshkey 354 theirHostname <- ResolvableHostname <$> sshKeyToHostname sshkey
355 write fw (ipsecCertPath theirHostname) pem 355 write fw (ipsecCertPath contactname) pem
356 return $ strongswanPeerConfiguration addr contactname theirHostname 356 return $ strongswanPeerConfiguration addr contactname theirHostname
357 _ -> error "fuck." 357 _ -> error "fuck."
358 where 358 where
@@ -370,13 +370,13 @@ 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 -> Char8.ByteString -> String 373ipsecPath :: String -> UidHostname -> String
374ipsecPath theDirName theBaseName = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem" 374ipsecPath theDirName (UidHostname theBaseName) = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem"
375 375
376ipsecKeyPath :: Char8.ByteString -> FilePath 376ipsecKeyPath :: UidHostname -> FilePath
377ipsecKeyPath = ipsecPath "private" 377ipsecKeyPath = ipsecPath "private"
378 378
379ipsecCertPath :: Char8.ByteString -> FilePath 379ipsecCertPath :: UidHostname -> FilePath
380ipsecCertPath = ipsecPath "certs" 380ipsecCertPath = ipsecPath "certs"
381 381
382makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter 382makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter
@@ -453,11 +453,6 @@ generateHostsFile fw rt = do
453 KikiResult _ report <- runKeyRing op 453 KikiResult _ report <- runKeyRing op
454 outputReport report 454 outputReport report
455 455
456names :: KeyRingRuntime -> Maybe Hostnames
457names rt = do wk <- rtWorkingKey rt
458 -- XXX unnecessary signature check
459 return $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk)
460
461getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString 456getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString
462getssh (contactname,_addr,kd) = do 457getssh (contactname,_addr,kd) = do
463 let their_master = packet $ keyMappedPacket kd 458 let their_master = packet $ keyMappedPacket kd
@@ -468,6 +463,11 @@ getssh (contactname,_addr,kd) = do
468 taggedblobs = map (\b -> contactname <> " " <> b) blobs 463 taggedblobs = map (\b -> contactname <> " " <> b) blobs
469 Char8.unlines taggedblobs 464 Char8.unlines taggedblobs
470 465
466data IpsecConfig = IpsecConfig {
467 ourGpgAddress :: SockAddr,
468 ourSigKey :: (),
469 peers :: [IpsecPeerConfig]
470}
471 471
472installIpsecConf :: FileWriter -> SockAddr -> Char8.ByteString -> [IpsecPeerConfig] -> IO () 472installIpsecConf :: FileWriter -> SockAddr -> Char8.ByteString -> [IpsecPeerConfig] -> IO ()
473installIpsecConf fw wkaddr certBasename cs = do 473installIpsecConf fw wkaddr certBasename cs = do
@@ -500,11 +500,12 @@ refreshCache rt rootdir = do
500 fw <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config") 500 fw <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config")
501 generateHostsFile fw rt 501 generateHostsFile fw rt
502 fromMaybe (error "No working key.") $ do 502 fromMaybe (error "No working key.") $ do
503 Hostnames wkaddr onames _ _ <- names rt 503 wk <- rtWorkingKey rt
504 Hostnames wkaddr onames _ _ <- Just $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk)
504 Just $ do 505 Just $ do
505 let oname = Char8.concat $ take 1 onames 506 let oname = UidHostname $ Char8.concat $ take 1 onames
506 bUnprivileged = False -- TODO 507
507 if (oname == "") && (not bUnprivileged) then error "Missing tor key" else do 508 -- if (oname == "") then error "Missing tor key" else do
508 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub" 509 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
509 -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" 510 -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
510 -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" 511 -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"
@@ -544,7 +545,10 @@ rethrowKikiErrors BadPassphrase =
544 error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)" 545 error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)"
545rethrowKikiErrors rt = unconditionally $ return rt 546rethrowKikiErrors rt = unconditionally $ return rt
546 547
547writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> Char8.ByteString -> SockAddr -> IO () 548newtype UidHostname = UidHostname Char8.ByteString
549newtype ResolvableHostname = ResolvableHostname Char8.ByteString
550
551writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> UidHostname -> SockAddr -> IO ()
548writePublicKeyFiles rt fw grip oname wkaddr = do 552writePublicKeyFiles rt fw grip oname wkaddr = do
549 553
550 -- Finally, export public keys if they do not exist. 554 -- Finally, export public keys if they do not exist.
@@ -554,7 +558,7 @@ writePublicKeyFiles rt fw grip oname wkaddr = do
554 558
555 let onionkeys = mapMaybe namedContact $ Map.elems $ byKeyKey $ rtKeyDB rt 559 let onionkeys = mapMaybe namedContact $ Map.elems $ byKeyKey $ rtKeyDB rt
556 cs = filter (\(_,_,kd) -> notme kd) onionkeys 560 cs = filter (\(_,_,kd) -> notme kd) onionkeys
557 cs' = cs <&> \(a,b,c) -> IpsecPeerConfig a b c 561 cs' = cs <&> \(a,b,c) -> IpsecPeerConfig (UidHostname a) b c
558 kk = keykey (fromJust $ rtWorkingKey rt) 562 kk = keykey (fromJust $ rtWorkingKey rt)
559 notme kd = keykey (keyPacket kd) /= kk 563 notme kd = keykey (keyPacket kd) /= kk
560 564
@@ -580,8 +584,8 @@ sshKeyToHostname sshkey = do
580 "f=$(mktemp) && cat > \"$f\" && ssh-keygen -r _ -f \"$f\" |" ++ 584 "f=$(mktemp) && cat > \"$f\" && ssh-keygen -r _ -f \"$f\" |" ++
581 " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" 585 " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r"
582 586
583strongswanPeerConfiguration :: SockAddr -> Char8.ByteString -> Char8.ByteString -> Char8.ByteString 587strongswanPeerConfiguration :: SockAddr -> UidHostname -> ResolvableHostname -> Char8.ByteString
584strongswanPeerConfiguration addr oname rightip = Char8.unlines 588strongswanPeerConfiguration addr (UidHostname oname) (ResolvableHostname rightip) = Char8.unlines
585 [ "conn " <> oname 589 [ "conn " <> oname
586 , " right=" <> rightip 590 , " right=" <> rightip
587 , " rightsubnet=" <> p (showA addr) <> "/128" 591 , " rightsubnet=" <> p (showA addr) <> "/128"