init-key now checks cross-certification before exporting ipsec keys.

2 files changed, 43 insertions, 25 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 53a1a34..0fbf2c2 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -99,6 +99,7 @@ module KeyRing
     , KeySpec(..)
     , getHostnames
     , secretPemFromPacket
+    , getCrossSignedSubkeys
     ) where
 
 import System.Environment
@@ -3328,27 +3329,12 @@ flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedP
 flattenUid fname ispub (str,(sigs,om)) =
     (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
 
-getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
-getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
- where
-    othernames = do
-        mp <- flattenAllUids "" True uids
-        let p = packet mp
-        guard $ isSignaturePacket p
-        uh <- unhashed_subpackets p
-        case uh of
-            NotationDataPacket True "hostname@" v
-              -> return $ Char8.pack v
-            _ -> mzero
-
-    addr = fingerdress topk
-    -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
-    topk = packet topmp
-    torkeys = do
+getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
+getCrossSignedSubkeys topk subs tag = do
         SubKey k sigs <- Map.elems subs
         let subk = packet k
         let sigs' = do
-                torsig <- filter (has_tag "tor") $ map (packet . fst) sigs
+                torsig <- filter (has_tag tag) $ map (packet . fst) sigs
                 sig <- (signatures $ Message [topk,subk,torsig])
                 let v = verify (Message [topk]) sig
                 -- Require parent's signature
@@ -3364,9 +3350,35 @@ getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
                 return torsig
         guard (not $ null sigs')
         return subk
+ where
     has_tag tag p = isSignaturePacket p
                     && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
                           , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
+
+
+-- |
+-- Returns (ip6 fingerprint address,(onion names,other host names))
+--
+-- Requires a validly cross-signed tor key for each onion name returned.
+-- (Signature checks are performed.)
+getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
+getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
+ where
+    othernames = do
+        mp <- flattenAllUids "" True uids
+        let p = packet mp
+        guard $ isSignaturePacket p
+        uh <- unhashed_subpackets p
+        case uh of
+            NotationDataPacket True "hostname@" v
+              -> return $ Char8.pack v
+            _ -> mzero
+
+    addr = fingerdress topk
+    -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
+    topk = packet topmp
+    torkeys = getCrossSignedSubkeys topk subs "tor"
+
     -- subkeyPacket (SubKey k _ ) = k
     onames :: [L.ByteString]
     onames = map ( (<> ".onion")
diff --git a/kiki.hs b/kiki.hs
index 865e551..4aa5885 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1573,6 +1573,7 @@ kiki "init-key" args = do
     let writeFileWARNING fname bs = do
         --TODO
         hPutStrLn stderr $ fname ++ ": DID NOT CHECK TRUST (TODO)"
+        writeFile fname bs
     flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
     gotc <- doesFileExist (sshcpathpub)
     when (not gotc) $ do
@@ -1596,18 +1597,21 @@ kiki "init-key" args = do
         notme kd = keykey (keyPacket kd) /= kk
 
         installConctact kd = do
+            -- The getHostnames command requires a valid cross-signed tor key
+            -- for each onion name returned in (_,(ns,_)).
             let (_,(ns,_)) = getHostnames kd
-                contactname = fmap Char8.unpack $ listToMaybe ns
+                contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
             flip (maybe $ return ()) contactname $ \contactname -> do
+
             let cpath = interp (Map.singleton "onion" contactname) contactipsec0
-                kspec = ( KeyGrip $ fingerprint $ keyPacket kd
-                        , Just "strongswan" )
-                mbk = selectPublicKey kspec $ Map.singleton (keykey $ keyPacket kd) kd
-            flip (maybe $ return ()) mbk $ \k -> do
+                their_master = packet $ keyMappedPacket kd
+                -- We find all cross-certified ipsec keys for the given cross-certified onion name.
+                ipsecs = sortOn (Down . timestamp)
+                         $ getCrossSignedSubkeys their_master (keySubKeys kd) "strongswan"
+            forM_ (take 1 ipsecs) $ \k -> do
             goti <- doesFileExist (cpath)
             when (not goti) $ do
-                either warn (writeFileWARNING $ cpath)
-                    $ pemFromPacket k
+                either warn (writeFile cpath) $ pemFromPacket k
 
     mapM_ installConctact cs
 
@@ -1850,6 +1854,8 @@ commands =
  , ( "tar", "import or export system key files in tar format" )
  ]
 
+-- |
+-- interpolate %var patterns in a string.
 interp vars raw = es >>= interp1
  where
     gs = groupBy (\_ c -> c/='%') raw