export ipsec secret key to /var/cache/kiki

2 files changed, 47 insertions, 18 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index b3dc97e..a0d1e1a 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -98,7 +98,8 @@ module KeyRing
     , KeySpec(..)
     , getHostnames
     , secretPemFromPacket
-    , getCrossSignedSubkeys
+    , SubkeyStatus(..)
+    , getSubkeys
     ) where
 
 import System.Environment
@@ -2216,8 +2217,10 @@ rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
         , rsaCoefficient = coefficient }
 rsaPrivateKeyFromPacket _ = Nothing
 
+secretPemFromPacket :: Packet -> Maybe String
 secretPemFromPacket packet = pemFromPacket Sec packet
 
+pemFromPacket :: Access -> Packet -> Maybe String
 pemFromPacket Sec packet =
     case key_algorithm packet of
      RSA -> do
@@ -3419,24 +3422,36 @@ 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
 
-getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
-getCrossSignedSubkeys topk subs tag = do
+data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
+ deriving (Eq,Ord,Enum,Show,Read)
+
+getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
+getSubkeys ck topk subs tag = do
         SubKey k sigs <- Map.elems subs
         let subk = packet k
         let sigs' = do
+                -- require tag
                 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
-                guard (not . null $ signatures_over v)
-                let unhashed = unhashed_subpackets torsig
-                    subsigs = mapMaybe backsig unhashed
-                    -- This should consist only of 0x19 values
-                    -- subtypes = map signature_type subsigs
-                sig' <- signatures . Message $ [topk,subk]++subsigs
-                let v' = verify (Message [subk]) sig'
-                -- Require subkey's signature
-                guard . not . null $ signatures_over v'
+
+                -- require parent's signature
+                when (ck > Unsigned) $ do
+                    sig <- (signatures $ Message [topk,subk,torsig])
+                    let v = verify (Message [topk]) sig
+                    -- Require parent's signature
+                    guard (not . null $ signatures_over v)
+
+                -- require child's back signature
+                when (ck == CrossSigned ) $ do
+                    let unhashed = unhashed_subpackets torsig
+                        subsigs = mapMaybe backsig unhashed
+                        -- This should consist only of 0x19 values
+                        -- subtypes = map signature_type subsigs
+                    -- subtyp <- subtypes
+                    -- guard (subtyp == 0x19)
+                    sig' <- signatures . Message $ [topk,subk]++subsigs
+                    let v' = verify (Message [subk]) sig'
+                    -- Require subkey's signature
+                    guard . not . null $ signatures_over v'
                 return torsig
         guard (not $ null sigs')
         return subk
@@ -3467,7 +3482,7 @@ getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
     addr = fingerdress topk
     -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
     topk = packet topmp
-    torkeys = getCrossSignedSubkeys topk subs "tor"
+    torkeys = getSubkeys CrossSigned topk subs "tor"
 
     -- subkeyPacket (SubKey k _ ) = k
     onames :: [L.ByteString]
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 333369f..b1f7ad7 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -233,8 +233,22 @@ refreshCache rt rootdir = do
 
     callCommand ("rm -rf "++ mkpath "*") -- clean up, in case gpg altered the keyring.
 
+    flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do
+
+    let grip = fingerprint wk
+        wkkd = rtKeyDB rt Map.! keykey wk
+
+    either warn (write $ mkpath "ipsec.d/private/" ++ Char8.unpack oname++".pem") $ do
+        -- Note: no sig check here. That may be incautious...
+        let my_ipsecs :: [Packet]
+            my_ipsecs = sortOn (Down . timestamp)
+                         $ getSubkeys Unsigned wk (keySubKeys wkkd) "ipsec"
+        case my_ipsecs of
+            ipsec:_ -> maybe (Left "unsupported ipsec key type") Right
+                            $ secretPemFromPacket ipsec
+            _       -> Left "missing ipsec key?"
+
     -- Finally, export public keys if they do not exist.
-    flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
     either warn (write $ mkpath "root/.ssh/id_rsa.pub")
             $ show_ssh' "ssh-client" grip (rtKeyDB rt)
     either warn (write $ mkpath "ssh_host_rsa_key.pub")
@@ -259,7 +273,7 @@ refreshCache rt rootdir = do
                 -- 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"
+                         $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec"
             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