1 files changed, 72 insertions, 14 deletions

diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 0684830..6717c4b 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Kiki where
 
 import Control.Applicative
@@ -10,6 +11,7 @@ import Data.ASN1.Types
 import Data.Binary
 import Data.List
 import Data.Maybe
+import Data.Monoid
 import Data.OpenPGP
 import Data.OpenPGP.Util
 import Data.Ord
@@ -207,16 +209,23 @@ refreshCache rt rootdir = do
 
     let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth
 
-        write f bs = do
+        write' wr f bs = do
             createDirectoryIfMissing True $ takeDirectory f
-            writeFile f bs
+            wr f bs
+        write = write' writeFile
+        writeL = write' L.writeFile
 
-    let oname' = do wk <- rtWorkingKey rt
-                    -- XXX unnecessary signature check
-                    onionNameForContact (keykey wk) (rtKeyDB rt)
+    let names = do wk <- rtWorkingKey rt
+                   -- XXX unnecessary signature check
+                   return $ getHostnames (rtKeyDB rt Map.! keykey wk)
         bUnprivileged = False -- TODO
-    if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do
-    let oname = fromMaybe "" oname'
+        oname = Char8.concat $ do
+            (_,(os,_)) <- maybeToList names
+            take 1 os
+    fromMaybe (error "No working key.") $ do
+    (wkaddr,_) <- names
+    Just $ do
+    if (oname == "") && (not bUnprivileged) then error "Missing tor key" else do
     -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
     -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
     -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"
@@ -227,29 +236,78 @@ refreshCache rt rootdir = do
             $ show_ssh' "ssh-client" grip (rtKeyDB rt)
     either warn (write $ mkpath "ssh_host_rsa_key.pub")
         $ show_ssh' "ssh-server" grip (rtKeyDB rt)
-    either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem")
+    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)
         kk = keykey (fromJust $ rtWorkingKey rt)
         notme kd = keykey (keyPacket kd) /= kk
 
+        installConctact :: KeyData -> IO Char8.ByteString
         installConctact kd = do
             -- The getHostnames command requires a valid cross-signed tor key
             -- for each onion name returned in (_,(ns,_)).
-            let (_,(ns,_)) = getHostnames kd
+            let (addr,(ns,_)) = getHostnames kd
                 contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
-            flip (maybe $ return ()) contactname $ \contactname -> do
+            flip (maybe $ return Char8.empty) contactname $ \contactname -> do
 
             let cpath = interp (Map.singleton "onion" 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)
                          $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec"
-            forM_ (take 1 ipsecs) $ \k -> do
-            either warn (write $ mkpath cpath) $ pemFromPacket k
-
-    mapM_ installConctact cs
+            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
+            return $ Char8.concat bss
+
+    cons <- mapM installConctact 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
+            , "  leftikeport=4500"
+            , "  rightikeport=4500"
+            , "  right=%any"
+            , "  rightauth=pubkey"
+            , "  type=tunnel"
+            , "  auto=route"
+            , ""
+            ] ++ filter (not . Char8.null) cons
+    return ()
+
+strongswanForContact addr oname = Char8.unlines
+    [ "conn " <> p oname
+    , "  right=%" <> p oname <> ".ipv4"
+    , "  rightsubnet=" <> p (showA addr) <> "/128"
+    , "  rightauth=pubkey"
+    , "  rightid=" <> p (showA addr)
+    , "  rightrsasigkey=" <> p (oname) <> ".pem"
+    ]
+    where p = Char8.pack
+
+-- conn hiotuxliwisbp6mi.onion
+--   right=%hiotuxliwisbp6mi.onion.ipv4
+--   rightsubnet=fdcc:76c8:cb34:74e6:2aa3:cb39:abc8:d403/128
+--   rightauth=pubkey
+--   rightid=fdcc:76c8:cb34:74e6:2aa3:cb39:abc8:d403
+--   rightrsasigkey=hiotuxliwisbp6mi.onion.pem
+
+showA addr = if null bracket then pre else drop 1 pre
+    where (pre,bracket) = break (==']') (show addr)
 
 
 #if !MIN_VERSION_base(4,8,0)