summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Kiki.hs221
1 files changed, 104 insertions, 117 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 282fd48..e8ea5f5 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -26,6 +26,7 @@ import System.IO
26import System.IO.Error 26import System.IO.Error
27import System.IO.Temp 27import System.IO.Temp
28import System.Posix.Files 28import System.Posix.Files
29import System.Posix.Types (FileMode)
29import System.Posix.IO as Posix (createPipe) 30import System.Posix.IO as Posix (createPipe)
30import System.Posix.User 31import System.Posix.User
31import System.Process 32import System.Process
@@ -322,10 +323,57 @@ importAndRefresh root cmn cipher = do
322 when (not bUnprivileged) $ refreshCache rt rootdir 323 when (not bUnprivileged) $ refreshCache rt rootdir
323 324
324 325
325refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () 326-- We find all cross-certified ipsec keys for the given cross-certified onion name.
326refreshCache rt rootdir = do 327installContact
328 :: (FilePath -> FilePath)
329 -> (L.ByteString, SockAddr, KeyData)
330 -> IO Char8.ByteString
331installContact mkpath (contactname,addr,kd) =
332 Char8.concat <$> do
333 forM (take 1 ipsecs) $ \k -> do
334 flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do
335 write (mkpath cpath) pem
336 case sshs of
337 (sshkey:_) -> strongswanForContact addr contactname <$> sshKeyToHostname sshkey
338 _ -> error "fuck."
339 where
340 warn' x = warn x >> return Char8.empty
341
342 their_master = packet $ keyMappedPacket kd :: Packet
343
344 -- We find all cross-certified ipsec keys for the given cross-certified onion name.
345 ipsecs :: [Packet]
346 ipsecs = sortOn (Down . timestamp)
347 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec"
348 -- ++ getSubkeys CrossSigned their_master (keySubKeys kd) "strongswan"
349
350 sshs :: [Packet]
351 sshs = sortOn (Down . timestamp)
352 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server"
353
354 cpath :: FilePath
355 cpath = interp (Map.singleton "onion" (Char8.unpack contactname)) "ipsec.d/certs/%(onion).pem"
356
327 357
328 let getMkPathAndCommit destdir = do 358write' :: (FilePath -> t -> IO b) -> FilePath -> t -> IO b
359write' wr f bs = do
360 createDirectoryIfMissing True $ takeDirectory f
361 wr f bs
362
363write :: FilePath -> String -> IO ()
364write = write' writeFile
365
366writeL :: FilePath -> Char8.ByteString -> IO ()
367writeL = write' L.writeFile
368
369writeL077 :: FilePath -> Char8.ByteString -> IO FileMode
370writeL077 f bs = do
371 old_umask <- setFileCreationMask 0o077
372 writeL f bs
373 setFileCreationMask old_umask
374
375getMkPathAndCommit :: FilePath -> IO (FilePath -> FilePath, IO ())
376getMkPathAndCommit destdir = do
329 let cachedir = takeDirectory destdir 377 let cachedir = takeDirectory destdir
330 unslash ('/':xs) = xs 378 unslash ('/':xs) = xs
331 unslash xs = xs 379 unslash xs = xs
@@ -355,9 +403,9 @@ refreshCache rt rootdir = do
355 -- doesFileExist (mkpath pth) >>= flip when copyIt 403 -- doesFileExist (mkpath pth) >>= flip when copyIt
356 -- return (mkpath pth) 404 -- return (mkpath pth)
357 return (mkpath, commit {-, readyReadBeforeWrite -}) 405 return (mkpath, commit {-, readyReadBeforeWrite -})
358 (mkpath, commit) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config")
359 406
360 -- Generete hosts file. 407generateHostsFile :: (FilePath -> FilePath) -> KeyRingRuntime -> IO ()
408generateHostsFile mkpath rt = do
361 let hostspath = mkpath "hosts" 409 let hostspath = mkpath "hosts"
362 op = KeyRingOperation 410 op = KeyRingOperation
363 { opFiles = Map.fromList $ 411 { opFiles = Map.fromList $
@@ -371,25 +419,57 @@ refreshCache rt rootdir = do
371 KikiResult _ report <- runKeyRing op 419 KikiResult _ report <- runKeyRing op
372 outputReport report 420 outputReport report
373 421
374 let write' wr f bs = do 422names :: KeyRingRuntime -> Maybe (SockAddr, ([Char8.ByteString], [Char8.ByteString]))
375 createDirectoryIfMissing True $ takeDirectory f 423names rt = do wk <- rtWorkingKey rt
376 wr f bs 424 -- XXX unnecessary signature check
377 write = write' writeFile 425 return $ getHostnames (rtKeyDB rt Map.! keykey wk)
378 writeL = write' L.writeFile
379 writeL077 f bs = do
380 old_umask <- setFileCreationMask 0o077
381 writeL f bs
382 setFileCreationMask old_umask
383 426
384 let names = do wk <- rtWorkingKey rt 427getssh :: (Char8.ByteString, t, KeyData) -> Char8.ByteString
385 -- XXX unnecessary signature check 428getssh (contactname,addr,kd) = do
386 return $ getHostnames (rtKeyDB rt Map.! keykey wk) 429 let their_master = packet $ keyMappedPacket kd
387 bUnprivileged = False -- TODO 430 sshs :: [Packet]
431 sshs = sortOn (Down . timestamp)
432 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server"
433 blobs = mapMaybe sshblobFromPacketL sshs
434 taggedblobs = map (\b -> contactname <> " " <> b) blobs
435 Char8.unlines taggedblobs
436
437
438writeIpsecConf :: FilePath -> SockAddr -> Char8.ByteString -> [Char8.ByteString] -> IO ()
439writeIpsecConf p wkaddr oname cons =
440 writeL p . Char8.unlines
441 $ [ "conn %default"
442 , " ikelifetime=60m"
443 , " keylife=20m"
444 , " rekeymargin=3m"
445 , " keyingtries=%forever"
446 , " keyexchange=ikev2"
447 , " dpddelay=10s"
448 , " dpdaction=restart"
449 , " left=%defaultroute"
450 , " leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128"
451 , " leftauth=pubkey"
452 , " leftid=" <> Char8.pack (showA wkaddr)
453 , " leftrsasigkey=" <> oname <> ".pem"
454 , " leftikeport=4500"
455 , " rightikeport=4500"
456 , " right=%any"
457 , " rightauth=pubkey"
458 , " type=tunnel"
459 , " auto=route"
460 , ""
461 ] ++ filter (not . Char8.null) cons
462
463refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
464refreshCache rt rootdir = do
465 (mkpath, commit) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config")
466 generateHostsFile mkpath rt
467 let bUnprivileged = False -- TODO
388 oname = Char8.concat $ do 468 oname = Char8.concat $ do
389 (_,(os,_)) <- maybeToList names 469 (_,(os,_)) <- maybeToList (names rt)
390 take 1 os 470 take 1 os
391 fromMaybe (error "No working key.") $ do 471 fromMaybe (error "No working key.") $ do
392 (wkaddr,_) <- names 472 (wkaddr,_) <- names rt
393 Just $ do 473 Just $ do
394 if (oname == "") && (not bUnprivileged) then error "Missing tor key" else do 474 if (oname == "") && (not bUnprivileged) then error "Missing tor key" else do
395 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub" 475 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
@@ -432,48 +512,6 @@ refreshCache rt rootdir = do
432 error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)" 512 error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)"
433 _ -> unconditionally $ return rt' 513 _ -> unconditionally $ return rt'
434 514
435 {-
436 let writeSecret tag path warning = do
437 let my_ks :: [Packet]
438 my_ks = getSecret tag
439 case my_ks of
440 se0:_ -> do sc1 <- rtPassphrases rt (Unencrypted,S2K 100 "") $ MappedPacket se0 Map.empty
441 let sec = case sc1 of
442 KikiSuccess s -> s
443 _ -> se0
444 report <- writeKeyToFile streaminfo { typ = PEMFile
445 , access = Sec
446 , spill = KF_All
447 }
448 (ArgFile path)
449 sec
450 let ctx = Just $ InputFileContext "secring.gpg" "pubring.gpg"
451 outputReport $ map (first $ resolveForReport ctx)
452 $ filter ((/=ExportedSubkey) . snd) report
453 _ -> warn warning
454
455 writeSecret "ipsec"
456 (mkpath "ipsec.d/private/" ++ Char8.unpack oname++".pem")
457 "missing ipsec key?"
458
459 -- TODO: probably we should add multiple entries for the case that there
460 -- are multiple secret master-keys each with distinct tor and ipsec keys.
461 writeL077 (mkpath "ipsec.secrets")
462 $ ": RSA /var/cache/kiki/config/ipsec.d/private/" <> oname <> ".pem"
463
464 writeSecret "ssh-client"
465 (mkpath "root/.ssh/id_rsa")
466 "missing ssh-client key?"
467
468 writeSecret "ssh-server"
469 (mkpath "ssh_host_rsa_key")
470 "missing ssh host key?"
471
472 writeSecret "tor"
473 (mkpath "tor/private_key")
474 "missing tor key?"
475 -}
476
477 -- Finally, export public keys if they do not exist. 515 -- Finally, export public keys if they do not exist.
478 either warn (write $ mkpath "root/.ssh/id_rsa.pub") 516 either warn (write $ mkpath "root/.ssh/id_rsa.pub")
479 $ show_ssh' "ssh-client" grip (rtKeyDB rt) 517 $ show_ssh' "ssh-client" grip (rtKeyDB rt)
@@ -493,64 +531,13 @@ refreshCache rt rootdir = do
493 let (addr,(ns,_)) = getHostnames kd 531 let (addr,(ns,_)) = getHostnames kd
494 fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. 532 fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name.
495 533
496 installContact :: (L.ByteString, SockAddr, KeyData) -> IO Char8.ByteString
497 installContact (contactname,addr,kd) = do
498
499 let cpath = interp (Map.singleton "onion" (Char8.unpack contactname)) "ipsec.d/certs/%(onion).pem"
500 their_master = packet $ keyMappedPacket kd
501 -- We find all cross-certified ipsec keys for the given cross-certified onion name.
502 ipsecs :: [Packet]
503 ipsecs = sortOn (Down . timestamp)
504 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec"
505 -- ++ getSubkeys CrossSigned their_master (keySubKeys kd) "strongswan"
506 sshs :: [Packet]
507 sshs = sortOn (Down . timestamp)
508 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server"
509 bss <- forM (take 1 ipsecs) $ \k -> do
510 let warn' x = warn x >> return Char8.empty
511 flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do
512 write (mkpath cpath) pem
513 case sshs of
514 (sshkey:_) -> strongswanForContact addr contactname <$> sshKeyToHostname sshkey
515 _ -> error "fuck."
516 return $ Char8.concat bss
517
518 known_hosts = L.concat $ map getssh onionkeys 534 known_hosts = L.concat $ map getssh onionkeys
519 535
520 getssh (contactname,addr,kd) = do
521 let their_master = packet $ keyMappedPacket kd
522 sshs :: [Packet]
523 sshs = sortOn (Down . timestamp)
524 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server"
525 blobs = mapMaybe sshblobFromPacketL sshs
526 taggedblobs = map (\b -> contactname <> " " <> b) blobs
527 Char8.unlines taggedblobs
528
529 writeL (mkpath "ssh_known_hosts") known_hosts 536 writeL (mkpath "ssh_known_hosts") known_hosts
530 537
531 cons <- mapM installContact cs 538 cons <- mapM (installContact mkpath) cs
532 writeL (mkpath "ipsec.conf") . Char8.unlines 539
533 $ [ "conn %default" 540 writeIpsecConf (mkpath "ipsec.conf") wkaddr oname cons
534 , " ikelifetime=60m"
535 , " keylife=20m"
536 , " rekeymargin=3m"
537 , " keyingtries=%forever"
538 , " keyexchange=ikev2"
539 , " dpddelay=10s"
540 , " dpdaction=restart"
541 , " left=%defaultroute"
542 , " leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128"
543 , " leftauth=pubkey"
544 , " leftid=" <> Char8.pack (showA wkaddr)
545 , " leftrsasigkey=" <> oname <> ".pem"
546 , " leftikeport=4500"
547 , " rightikeport=4500"
548 , " right=%any"
549 , " rightauth=pubkey"
550 , " type=tunnel"
551 , " auto=route"
552 , ""
553 ] ++ filter (not . Char8.null) cons
554 commit 541 commit
555 542
556sshKeyToHostname :: Packet -> IO Char8.ByteString 543sshKeyToHostname :: Packet -> IO Char8.ByteString