generate known_hosts + fixes to trasactional symlink code.

1 files changed, 21 insertions, 8 deletions

diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 8d99499..cfff667 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -17,7 +17,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
@@ -228,7 +228,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)
@@ -241,7 +241,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
@@ -370,6 +370,19 @@ refreshCache rt rootdir = do
                     return $ strongswanForContact addr contactname
             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"
@@ -461,11 +474,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
     let homepass' = cmn { cap_homespec = fmap root (cap_homespec cmn) }