3 files changed, 90 insertions, 26 deletions

diff --git a/cokiki.hs b/cokiki.hs
index 54cc4ba..b6d94a0 100644
--- a/cokiki.hs
+++ b/cokiki.hs
@@ -20,6 +20,7 @@ import System.IO
 import System.Posix.User
 import CommandLine
 import Data.OpenPGP (SymmetricAlgorithm(Unencrypted))
+import qualified Hosts
 
 usage = unlines
     [ "cokiki <command> [--chroot=ROOTDIR]"
@@ -42,17 +43,20 @@ usage = unlines
     , "COMMANDS"
     , ""
     , "  ssh-client   Modify system ssh configuration to respect"
-    , "               /var/cache/kiki/ssh_known_hosts."
+    , "               /var/cache/kiki/config/ssh_known_hosts."
     , ""
     , "  ssh-server   Modify system ssh configuration to use the"
     , "               kiki-managed host key at"
-    , "               /var/cache/kiki/ssh_host_rsa_key."
+    , "               /var/cache/kiki/config/ssh_host_rsa_key."
     , ""
     , "  strongswan   Modify /etc/ipsec.conf to include settings from"
-    , "               /var/cache/kiki/ipsec.conf."
+    , "               /var/cache/kiki/config/ipsec.conf."
     , ""
     , "  tor          Modify /etc/tor/torrc to configure a tor hidden"
     , "               service for email (smtp), ssh, and http ports."
+    , ""
+    , "  hosts        Merge hostnames from /var/cache/kiki/config/hosts"
+    , "               into system file /etc/hosts."
     ]
 
 main = do
@@ -63,6 +67,7 @@ main = do
                 ["ssh-server"] -> Just $ sshServer  uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                 ["strongswan"] -> Just $ strongswan uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                 ["tor"]        -> Just $ configureTor uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
+                ["hosts"]      -> Just $ configureHosts uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
                 _ -> Nothing
         spec = uncurry fancy Kiki.kikiOptions ""
         errorQuit msg = do
@@ -78,6 +83,7 @@ main = do
 maybeReadFile :: FilePath -> IO (Maybe L.ByteString)
 maybeReadFile path = do
     doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path)
+
 myWriteFile f bs = do
     createDirectoryIfMissing True (takeDirectory f)
     hPutStrLn stderr $ "Writing "++f
@@ -133,17 +139,29 @@ sshServer uid root cmn = whenRoot uid root cmn $ do
     Kiki.importAndRefresh root cmn Unencrypted
 
 strongswan uid root cmn = whenRoot uid root cmn $ do
+    -- (1) /etc/ipsec.conf    <--  'include /var/cache/kiki/config/ipsec.conf'
     -- Parsing as if ssh config, that's not right, but good enough for now.
     ipsecconf <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ipsec.conf")
     let p:gs = groupBy (\_ d -> not $ sshIsDirective "include" d) $ ["#"]:ipsecconf
         got = filter (\(d:ds) -> elem "/var/cache/kiki/config/ipsec.conf" d) gs
     case got of
-        _:_ -> do hPutStrLn stderr "ipsec already configured."
+        _:_ -> do hPutStrLn stderr "ipsec.conf already configured."
         [] -> do let ipsecconf' = drop 1 $ ipsecconf ++ [stmt]
                      stmt = ["include", " ", "/var/cache/kiki/config/ipsec.conf"]
                  hPutStrLn stderr "adding include directive"
                  myWriteFile (root "/etc/ipsec.conf") $ unparseSshConfig ipsecconf'
-    -- etc/ipsec.conf    <--  'include /var/cache/kiki/ipsec.conf'
+
+    -- (2) /etc/ipsec.secrets/ <- include /var/cache/kiki/config/ipsec.secrets
+    -- Parsing as if ssh config, that's not right, but good enough for now.
+    ipsecconf <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ipsec.secrets")
+    let p:gs = groupBy (\_ d -> not $ sshIsDirective "include" d) $ ["#"]:ipsecconf
+        got = filter (\(d:ds) -> elem "/var/cache/kiki/config/ipsec.secrets" d) gs
+    case got of
+        _:_ -> do hPutStrLn stderr "ipsec.secrets already configured."
+        [] -> do let ipsecconf' = drop 1 $ ipsecconf ++ [stmt]
+                     stmt = ["include", " ", "/var/cache/kiki/config/ipsec.secrets"]
+                 hPutStrLn stderr "adding include directive"
+                 myWriteFile (root "/etc/ipsec.secrets") $ unparseSshConfig ipsecconf'
     Kiki.importAndRefresh root cmn Unencrypted
 
 configureTor uid root cmn = whenRoot uid root cmn $ do
@@ -201,6 +219,14 @@ configureTor uid root cmn = whenRoot uid root cmn $ do
     Kiki.importAndRefresh root cmn Unencrypted
     return ()
 
+configureHosts uid root cmn = whenRoot uid root cmn $ do
+    Kiki.importAndRefresh root cmn Unencrypted
+    hosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/etc/hosts")
+    kikihosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/var/cache/kiki/config/hosts")
+    let hosts' = hosts `Hosts.plus` kikihosts
+    case Hosts.diff hosts hosts' of
+        [] -> hPutStrLn stderr "kiki hosts are already merged."
+        _ -> myWriteFile (root "/etc/hosts") $ Hosts.encode hosts'
 
 parseSshConfig :: L.ByteString -> [[L.ByteString]]
 parseSshConfig bs = map tokenize $ L8.lines bs
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 }