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
 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