From 0727326d606771790f05bcc5eada9086e7784339 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Tue, 25 Jun 2019 10:55:00 -0400 Subject: Refactor function 'refreshCache' Just moving some local definitions up to the top level. Nothing should be changed. --- lib/Kiki.hs | 221 ++++++++++++++++++++++++++++-------------------------------- 1 file 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 import System.IO.Error import System.IO.Temp import System.Posix.Files +import System.Posix.Types (FileMode) import System.Posix.IO as Posix (createPipe) import System.Posix.User import System.Process @@ -322,10 +323,57 @@ importAndRefresh root cmn cipher = do when (not bUnprivileged) $ refreshCache rt rootdir -refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () -refreshCache rt rootdir = do +-- We find all cross-certified ipsec keys for the given cross-certified onion name. +installContact + :: (FilePath -> FilePath) + -> (L.ByteString, SockAddr, KeyData) + -> IO Char8.ByteString +installContact mkpath (contactname,addr,kd) = + Char8.concat <$> do + forM (take 1 ipsecs) $ \k -> do + flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do + write (mkpath cpath) pem + case sshs of + (sshkey:_) -> strongswanForContact addr contactname <$> sshKeyToHostname sshkey + _ -> error "fuck." + where + warn' x = warn x >> return Char8.empty + + their_master = packet $ keyMappedPacket kd :: Packet + + -- We find all cross-certified ipsec keys for the given cross-certified onion name. + ipsecs :: [Packet] + ipsecs = sortOn (Down . timestamp) + $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec" + -- ++ getSubkeys CrossSigned their_master (keySubKeys kd) "strongswan" + + sshs :: [Packet] + sshs = sortOn (Down . timestamp) + $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" + + cpath :: FilePath + cpath = interp (Map.singleton "onion" (Char8.unpack contactname)) "ipsec.d/certs/%(onion).pem" + - let getMkPathAndCommit destdir = do +write' :: (FilePath -> t -> IO b) -> FilePath -> t -> IO b +write' wr f bs = do + createDirectoryIfMissing True $ takeDirectory f + wr f bs + +write :: FilePath -> String -> IO () +write = write' writeFile + +writeL :: FilePath -> Char8.ByteString -> IO () +writeL = write' L.writeFile + +writeL077 :: FilePath -> Char8.ByteString -> IO FileMode +writeL077 f bs = do + old_umask <- setFileCreationMask 0o077 + writeL f bs + setFileCreationMask old_umask + +getMkPathAndCommit :: FilePath -> IO (FilePath -> FilePath, IO ()) +getMkPathAndCommit destdir = do let cachedir = takeDirectory destdir unslash ('/':xs) = xs unslash xs = xs @@ -355,9 +403,9 @@ refreshCache rt rootdir = do -- doesFileExist (mkpath pth) >>= flip when copyIt -- return (mkpath pth) return (mkpath, commit {-, readyReadBeforeWrite -}) - (mkpath, commit) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config") - -- Generete hosts file. +generateHostsFile :: (FilePath -> FilePath) -> KeyRingRuntime -> IO () +generateHostsFile mkpath rt = do let hostspath = mkpath "hosts" op = KeyRingOperation { opFiles = Map.fromList $ @@ -371,25 +419,57 @@ refreshCache rt rootdir = do KikiResult _ report <- runKeyRing op outputReport report - let write' wr f bs = do - createDirectoryIfMissing True $ takeDirectory f - wr f bs - write = write' writeFile - writeL = write' L.writeFile - writeL077 f bs = do - old_umask <- setFileCreationMask 0o077 - writeL f bs - setFileCreationMask old_umask +names :: KeyRingRuntime -> Maybe (SockAddr, ([Char8.ByteString], [Char8.ByteString])) +names rt = do wk <- rtWorkingKey rt + -- XXX unnecessary signature check + return $ getHostnames (rtKeyDB rt Map.! keykey wk) - let names = do wk <- rtWorkingKey rt - -- XXX unnecessary signature check - return $ getHostnames (rtKeyDB rt Map.! keykey wk) - bUnprivileged = False -- TODO +getssh :: (Char8.ByteString, t, KeyData) -> Char8.ByteString +getssh (contactname,addr,kd) = do + let their_master = packet $ keyMappedPacket kd + sshs :: [Packet] + sshs = sortOn (Down . timestamp) + $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" + blobs = mapMaybe sshblobFromPacketL sshs + taggedblobs = map (\b -> contactname <> " " <> b) blobs + Char8.unlines taggedblobs + + +writeIpsecConf :: FilePath -> SockAddr -> Char8.ByteString -> [Char8.ByteString] -> IO () +writeIpsecConf p wkaddr oname cons = + writeL p . Char8.unlines + $ [ "conn %default" + , " ikelifetime=60m" + , " keylife=20m" + , " rekeymargin=3m" + , " keyingtries=%forever" + , " keyexchange=ikev2" + , " dpddelay=10s" + , " dpdaction=restart" + , " left=%defaultroute" + , " leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128" + , " leftauth=pubkey" + , " leftid=" <> Char8.pack (showA wkaddr) + , " leftrsasigkey=" <> oname <> ".pem" + , " leftikeport=4500" + , " rightikeport=4500" + , " right=%any" + , " rightauth=pubkey" + , " type=tunnel" + , " auto=route" + , "" + ] ++ filter (not . Char8.null) cons + +refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () +refreshCache rt rootdir = do + (mkpath, commit) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config") + generateHostsFile mkpath rt + let bUnprivileged = False -- TODO oname = Char8.concat $ do - (_,(os,_)) <- maybeToList names - take 1 os + (_,(os,_)) <- maybeToList (names rt) + take 1 os fromMaybe (error "No working key.") $ do - (wkaddr,_) <- names + (wkaddr,_) <- names rt Just $ do if (oname == "") && (not bUnprivileged) then error "Missing tor key" else do -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir ".ssh" "id_rsa.pub" @@ -432,48 +512,6 @@ refreshCache rt rootdir = do error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)" _ -> unconditionally $ return rt' - {- - let writeSecret tag path warning = do - let my_ks :: [Packet] - my_ks = getSecret tag - case my_ks of - se0:_ -> do sc1 <- rtPassphrases rt (Unencrypted,S2K 100 "") $ MappedPacket se0 Map.empty - let sec = case sc1 of - KikiSuccess s -> s - _ -> se0 - report <- writeKeyToFile streaminfo { typ = PEMFile - , access = Sec - , spill = KF_All - } - (ArgFile path) - sec - let ctx = Just $ InputFileContext "secring.gpg" "pubring.gpg" - outputReport $ map (first $ resolveForReport ctx) - $ filter ((/=ExportedSubkey) . snd) report - _ -> warn warning - - writeSecret "ipsec" - (mkpath "ipsec.d/private/" ++ Char8.unpack oname++".pem") - "missing ipsec key?" - - -- TODO: probably we should add multiple entries for the case that there - -- are multiple secret master-keys each with distinct tor and ipsec keys. - writeL077 (mkpath "ipsec.secrets") - $ ": RSA /var/cache/kiki/config/ipsec.d/private/" <> oname <> ".pem" - - writeSecret "ssh-client" - (mkpath "root/.ssh/id_rsa") - "missing ssh-client key?" - - writeSecret "ssh-server" - (mkpath "ssh_host_rsa_key") - "missing ssh host key?" - - writeSecret "tor" - (mkpath "tor/private_key") - "missing tor key?" - -} - -- Finally, export public keys if they do not exist. either warn (write $ mkpath "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) @@ -493,64 +531,13 @@ refreshCache rt rootdir = do let (addr,(ns,_)) = getHostnames kd fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. - installContact :: (L.ByteString, SockAddr, KeyData) -> IO Char8.ByteString - installContact (contactname,addr,kd) = do - - let cpath = interp (Map.singleton "onion" (Char8.unpack contactname)) "ipsec.d/certs/%(onion).pem" - their_master = packet $ keyMappedPacket kd - -- We find all cross-certified ipsec keys for the given cross-certified onion name. - ipsecs :: [Packet] - ipsecs = sortOn (Down . timestamp) - $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec" - -- ++ getSubkeys CrossSigned their_master (keySubKeys kd) "strongswan" - sshs :: [Packet] - sshs = sortOn (Down . timestamp) - $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" - bss <- forM (take 1 ipsecs) $ \k -> do - let warn' x = warn x >> return Char8.empty - flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do - write (mkpath cpath) pem - case sshs of - (sshkey:_) -> strongswanForContact addr contactname <$> sshKeyToHostname sshkey - _ -> error "fuck." - return $ Char8.concat bss - known_hosts = L.concat $ map getssh onionkeys - getssh (contactname,addr,kd) = do - let their_master = packet $ keyMappedPacket kd - sshs :: [Packet] - sshs = sortOn (Down . timestamp) - $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" - blobs = mapMaybe sshblobFromPacketL sshs - taggedblobs = map (\b -> contactname <> " " <> b) blobs - Char8.unlines taggedblobs - writeL (mkpath "ssh_known_hosts") known_hosts - cons <- mapM installContact cs - writeL (mkpath "ipsec.conf") . Char8.unlines - $ [ "conn %default" - , " ikelifetime=60m" - , " keylife=20m" - , " rekeymargin=3m" - , " keyingtries=%forever" - , " keyexchange=ikev2" - , " dpddelay=10s" - , " dpdaction=restart" - , " left=%defaultroute" - , " leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128" - , " leftauth=pubkey" - , " leftid=" <> Char8.pack (showA wkaddr) - , " leftrsasigkey=" <> oname <> ".pem" - , " leftikeport=4500" - , " rightikeport=4500" - , " right=%any" - , " rightauth=pubkey" - , " type=tunnel" - , " auto=route" - , "" - ] ++ filter (not . Char8.null) cons + cons <- mapM (installContact mkpath) cs + + writeIpsecConf (mkpath "ipsec.conf") wkaddr oname cons commit sshKeyToHostname :: Packet -> IO Char8.ByteString -- cgit v1.2.3