diff options
author | Andrew Cady <d@jerkface.net> | 2019-06-25 10:55:00 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-07-01 07:08:53 -0400 |
commit | 0727326d606771790f05bcc5eada9086e7784339 (patch) | |
tree | a91a7df720f2e19e8d972cd79958e359ed7fd758 /lib/Kiki.hs | |
parent | bea1757d3d4b032935ba8c495a7efcf629216b9d (diff) |
Refactor function 'refreshCache'
Just moving some local definitions up to the top level. Nothing should be
changed.
Diffstat (limited to 'lib/Kiki.hs')
-rw-r--r-- | lib/Kiki.hs | 221 |
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 | |||
26 | import System.IO.Error | 26 | import System.IO.Error |
27 | import System.IO.Temp | 27 | import System.IO.Temp |
28 | import System.Posix.Files | 28 | import System.Posix.Files |
29 | import System.Posix.Types (FileMode) | ||
29 | import System.Posix.IO as Posix (createPipe) | 30 | import System.Posix.IO as Posix (createPipe) |
30 | import System.Posix.User | 31 | import System.Posix.User |
31 | import System.Process | 32 | import 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 | ||
325 | refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () | 326 | -- We find all cross-certified ipsec keys for the given cross-certified onion name. |
326 | refreshCache rt rootdir = do | 327 | installContact |
328 | :: (FilePath -> FilePath) | ||
329 | -> (L.ByteString, SockAddr, KeyData) | ||
330 | -> IO Char8.ByteString | ||
331 | installContact 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 | 358 | write' :: (FilePath -> t -> IO b) -> FilePath -> t -> IO b |
359 | write' wr f bs = do | ||
360 | createDirectoryIfMissing True $ takeDirectory f | ||
361 | wr f bs | ||
362 | |||
363 | write :: FilePath -> String -> IO () | ||
364 | write = write' writeFile | ||
365 | |||
366 | writeL :: FilePath -> Char8.ByteString -> IO () | ||
367 | writeL = write' L.writeFile | ||
368 | |||
369 | writeL077 :: FilePath -> Char8.ByteString -> IO FileMode | ||
370 | writeL077 f bs = do | ||
371 | old_umask <- setFileCreationMask 0o077 | ||
372 | writeL f bs | ||
373 | setFileCreationMask old_umask | ||
374 | |||
375 | getMkPathAndCommit :: FilePath -> IO (FilePath -> FilePath, IO ()) | ||
376 | getMkPathAndCommit 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. | 407 | generateHostsFile :: (FilePath -> FilePath) -> KeyRingRuntime -> IO () |
408 | generateHostsFile 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 | 422 | names :: KeyRingRuntime -> Maybe (SockAddr, ([Char8.ByteString], [Char8.ByteString])) |
375 | createDirectoryIfMissing True $ takeDirectory f | 423 | names 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 | 427 | getssh :: (Char8.ByteString, t, KeyData) -> Char8.ByteString |
385 | -- XXX unnecessary signature check | 428 | getssh (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 | |||
438 | writeIpsecConf :: FilePath -> SockAddr -> Char8.ByteString -> [Char8.ByteString] -> IO () | ||
439 | writeIpsecConf 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 | |||
463 | refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () | ||
464 | refreshCache 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 | ||
556 | sshKeyToHostname :: Packet -> IO Char8.ByteString | 543 | sshKeyToHostname :: Packet -> IO Char8.ByteString |