2 files changed, 59 insertions, 21 deletions

diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index d5b3457..468394f 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -19,7 +19,7 @@ import Data.OpenPGP
 import Data.OpenPGP.Util
 import Data.Ord
 import System.Directory
-import System.FilePath.Posix
+import System.FilePath.Posix as FilePath
 import System.IO
 import System.IO.Temp
 import System.IO.Error
@@ -38,6 +38,8 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.Map.Strict as Map
 import qualified SSHKey as SSH
+import Network.Socket -- (SockAddr)
+import ProcessUtils
 
 import GnuPGAgent (Query(..))
 import CommandLine
@@ -323,7 +325,7 @@ refreshCache rt rootdir = do
                 timeout = -1 -- TODO: set milisecond timeout on dotlock
             createDirectoryIfMissing True cachedir
             tmpdir <- createTempDirectory cachedir ("transaction." ++ takeBaseName destdir)
-            createSymbolicLink tmpdir (tmpdir ++ ".link")
+            createSymbolicLink (makeRelative cachedir tmpdir) (tmpdir ++ ".link")
             lock <- dotlock_create destdir 0
             T.mapM (flip dotlock_take timeout) lock
             let mkpath pth = tmpdir </> unslash (makeRelative destdir pth)
@@ -336,7 +338,7 @@ refreshCache rt rootdir = do
                     --       otherwise call readyReadBeforeWrite on them.
                     rename (tmpdir ++ ".link") destdir
                     er <- T.mapM dotlock_release lock
-                    void $ T.mapM removeDirectoryRecursive oldcommit
+                    void $ T.mapM removeDirectoryRecursive (FilePath.combine cachedir <$> oldcommit)
             -- Present transaction is Write only (or Write-Before-Read) which is fine.
             -- If ever Read-Before-Write is required, uncomment and use:
             -- let readyReadBeforeWrite pth = do
@@ -367,6 +369,10 @@ refreshCache rt rootdir = do
             wr f bs
         write = write' writeFile
         writeL = write' L.writeFile
+        writeL077 f bs = do
+            old_umask <- setFileCreationMask 0o077
+            writeL f bs
+            setFileCreationMask old_umask
 
     let names = do wk <- rtWorkingKey rt
                    -- XXX unnecessary signature check
@@ -436,6 +442,11 @@ refreshCache rt rootdir = do
                 (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?"
@@ -457,32 +468,57 @@ refreshCache rt rootdir = do
     either warn (write $ mkpath "ipsec.d/certs/" ++ Char8.unpack oname++".pem")
         $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
 
-    let cs = filter notme (Map.elems $ rtKeyDB rt)
+    let onionkeys = mapMaybe namedContact $ Map.elems $ rtKeyDB rt
+        cs = filter (\(_,_,kd) -> notme kd) onionkeys
         kk = keykey (fromJust $ rtWorkingKey rt)
         notme kd = keykey (keyPacket kd) /= kk
 
-        installConctact :: KeyData -> IO Char8.ByteString
-        installConctact kd = do
+        namedContact kd = do
             -- The getHostnames command requires a valid cross-signed tor key
             -- for each onion name returned in (_,(ns,_)).
             let (addr,(ns,_)) = getHostnames kd
-                contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
-            flip (maybe $ return Char8.empty) contactname $ \contactname -> do
+            fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name.
+
+        installConctact :: (L.ByteString, SockAddr, KeyData) -> IO Char8.ByteString
+        installConctact (contactname,addr,kd) = do
 
-            let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem"
+            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"
+                           -- ++ 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
-                    return $ strongswanForContact addr contactname
+                    case take 1 sshs of
+                        [sshkey] -> do
+                            (_,(sout,serr)) <- runExternal "(f=$(mktemp); cat > \"$f\"; ssh-keygen -l -f \"$f\" | (read _ hash _; echo -n $hash.ssh.cryptonomic.net) | tr -d ':')"
+                                                            (Just $ sshblobFromPacket sshkey)
+                            -- ssh-keygen -l -f /dev/stdin
+                            -- putStrLn $ "wtf="++show(sout,serr, sshblobFromPacket sshkey)
+                            return $ strongswanForContact addr contactname (Char8.fromChunks [sout])
+                        [] -> 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 installConctact cs
     writeL (mkpath "ipsec.conf") . Char8.unlines
           $ [ "conn %default"
@@ -497,7 +533,7 @@ refreshCache rt rootdir = do
             , "  leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128"
             , "  leftauth=pubkey"
             , "  leftid=" <> Char8.pack (showA wkaddr)
-            , "  leftrsasigkey=" <> oname
+            , "  leftrsasigkey=" <> oname <> ".pem"
             , "  leftikeport=4500"
             , "  rightikeport=4500"
             , "  right=%any"
@@ -508,13 +544,13 @@ refreshCache rt rootdir = do
             ] ++ filter (not . Char8.null) cons
     commit
 
-strongswanForContact addr oname = Char8.unlines
-    [ "conn " <> p oname
-    , "  right=%" <> p oname <> ".ipv4"
+strongswanForContact addr oname rightip = Char8.unlines
+    [ "conn " <> oname
+    , "  right=lan." <> rightip
     , "  rightsubnet=" <> p (showA addr) <> "/128"
     , "  rightauth=pubkey"
     , "  rightid=" <> p (showA addr)
-    , "  rightrsasigkey=" <> p (oname) <> ".pem"
+    , "  rightrsasigkey=" <> oname <> ".pem"
     ]
     where p = Char8.pack
 
@@ -578,11 +614,11 @@ interp vars raw = es >>= interp1
                             where (key,rest) = break (==')') str
     interp1 plain = plain
 
-sshblobFromPacket k = blob
- where
-    Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
-    bs = SSH.keyblob (n,e)
-    blob = Char8.unpack bs
+sshblobFromPacket k = Char8.unpack $ fromJust $ sshblobFromPacketL k
+
+sshblobFromPacketL k = do
+    RSAKey (MPI n) (MPI e) <- rsaKeyFromPacket k
+    return $ SSH.keyblob (n,e)
 
 {-
 replaceSshServerKeys root cmn = do
diff --git a/lib/ProcessUtils.hs b/lib/ProcessUtils.hs
index b89edb9..1a9cc04 100644
--- a/lib/ProcessUtils.hs
+++ b/lib/ProcessUtils.hs
@@ -126,10 +126,12 @@ readProcessWithErrorH cmd args stdin erH = do
 runExternal :: String -> Maybe String -> IO (Int,(S.ByteString,S.ByteString))
 runExternal cmd input = do
     cwd <- getCurrentDirectory
+    {-
     putStr $ takeFileName cwd ++ "> " ++ cmd
                     ++ case input of
                             Nothing -> "\n"
                             Just s  -> " <<EOF\n" ++ s ++ "EOF\n"
+    -}
     let p = (shell cmd) { std_in  = maybe Inherit (const CreatePipe) input
                         , std_out = CreatePipe
                         , std_err = CreatePipe }