summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/KeyRing.hs47
-rw-r--r--lib/Kiki.hs18
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
98 , KeySpec(..) 98 , KeySpec(..)
99 , getHostnames 99 , getHostnames
100 , secretPemFromPacket 100 , secretPemFromPacket
101 , getCrossSignedSubkeys 101 , SubkeyStatus(..)
102 , getSubkeys
102 ) where 103 ) where
103 104
104import System.Environment 105import System.Environment
@@ -2216,8 +2217,10 @@ rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
2216 , rsaCoefficient = coefficient } 2217 , rsaCoefficient = coefficient }
2217rsaPrivateKeyFromPacket _ = Nothing 2218rsaPrivateKeyFromPacket _ = Nothing
2218 2219
2220secretPemFromPacket :: Packet -> Maybe String
2219secretPemFromPacket packet = pemFromPacket Sec packet 2221secretPemFromPacket packet = pemFromPacket Sec packet
2220 2222
2223pemFromPacket :: Access -> Packet -> Maybe String
2221pemFromPacket Sec packet = 2224pemFromPacket Sec packet =
2222 case key_algorithm packet of 2225 case key_algorithm packet of
2223 RSA -> do 2226 RSA -> do
@@ -3419,24 +3422,36 @@ flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedP
3419flattenUid fname ispub (str,(sigs,om)) = 3422flattenUid fname ispub (str,(sigs,om)) =
3420 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs 3423 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
3421 3424
3422getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet] 3425data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
3423getCrossSignedSubkeys topk subs tag = do 3426 deriving (Eq,Ord,Enum,Show,Read)
3427
3428getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
3429getSubkeys ck topk subs tag = do
3424 SubKey k sigs <- Map.elems subs 3430 SubKey k sigs <- Map.elems subs
3425 let subk = packet k 3431 let subk = packet k
3426 let sigs' = do 3432 let sigs' = do
3433 -- require tag
3427 torsig <- filter (has_tag tag) $ map (packet . fst) sigs 3434 torsig <- filter (has_tag tag) $ map (packet . fst) sigs
3428 sig <- (signatures $ Message [topk,subk,torsig]) 3435
3429 let v = verify (Message [topk]) sig 3436 -- require parent's signature
3430 -- Require parent's signature 3437 when (ck > Unsigned) $ do
3431 guard (not . null $ signatures_over v) 3438 sig <- (signatures $ Message [topk,subk,torsig])
3432 let unhashed = unhashed_subpackets torsig 3439 let v = verify (Message [topk]) sig
3433 subsigs = mapMaybe backsig unhashed 3440 -- Require parent's signature
3434 -- This should consist only of 0x19 values 3441 guard (not . null $ signatures_over v)
3435 -- subtypes = map signature_type subsigs 3442
3436 sig' <- signatures . Message $ [topk,subk]++subsigs 3443 -- require child's back signature
3437 let v' = verify (Message [subk]) sig' 3444 when (ck == CrossSigned ) $ do
3438 -- Require subkey's signature 3445 let unhashed = unhashed_subpackets torsig
3439 guard . not . null $ signatures_over v' 3446 subsigs = mapMaybe backsig unhashed
3447 -- This should consist only of 0x19 values
3448 -- subtypes = map signature_type subsigs
3449 -- subtyp <- subtypes
3450 -- guard (subtyp == 0x19)
3451 sig' <- signatures . Message $ [topk,subk]++subsigs
3452 let v' = verify (Message [subk]) sig'
3453 -- Require subkey's signature
3454 guard . not . null $ signatures_over v'
3440 return torsig 3455 return torsig
3441 guard (not $ null sigs') 3456 guard (not $ null sigs')
3442 return subk 3457 return subk
@@ -3467,7 +3482,7 @@ getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
3467 addr = fingerdress topk 3482 addr = fingerdress topk
3468 -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key? 3483 -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
3469 topk = packet topmp 3484 topk = packet topmp
3470 torkeys = getCrossSignedSubkeys topk subs "tor" 3485 torkeys = getSubkeys CrossSigned topk subs "tor"
3471 3486
3472 -- subkeyPacket (SubKey k _ ) = k 3487 -- subkeyPacket (SubKey k _ ) = k
3473 onames :: [L.ByteString] 3488 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
233 233
234 callCommand ("rm -rf "++ mkpath "*") -- clean up, in case gpg altered the keyring. 234 callCommand ("rm -rf "++ mkpath "*") -- clean up, in case gpg altered the keyring.
235 235
236 flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do
237
238 let grip = fingerprint wk
239 wkkd = rtKeyDB rt Map.! keykey wk
240
241 either warn (write $ mkpath "ipsec.d/private/" ++ Char8.unpack oname++".pem") $ do
242 -- Note: no sig check here. That may be incautious...
243 let my_ipsecs :: [Packet]
244 my_ipsecs = sortOn (Down . timestamp)
245 $ getSubkeys Unsigned wk (keySubKeys wkkd) "ipsec"
246 case my_ipsecs of
247 ipsec:_ -> maybe (Left "unsupported ipsec key type") Right
248 $ secretPemFromPacket ipsec
249 _ -> Left "missing ipsec key?"
250
236 -- Finally, export public keys if they do not exist. 251 -- Finally, export public keys if they do not exist.
237 flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
238 either warn (write $ mkpath "root/.ssh/id_rsa.pub") 252 either warn (write $ mkpath "root/.ssh/id_rsa.pub")
239 $ show_ssh' "ssh-client" grip (rtKeyDB rt) 253 $ show_ssh' "ssh-client" grip (rtKeyDB rt)
240 either warn (write $ mkpath "ssh_host_rsa_key.pub") 254 either warn (write $ mkpath "ssh_host_rsa_key.pub")
@@ -259,7 +273,7 @@ refreshCache rt rootdir = do
259 -- We find all cross-certified ipsec keys for the given cross-certified onion name. 273 -- We find all cross-certified ipsec keys for the given cross-certified onion name.
260 ipsecs :: [Packet] 274 ipsecs :: [Packet]
261 ipsecs = sortOn (Down . timestamp) 275 ipsecs = sortOn (Down . timestamp)
262 $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec" 276 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec"
263 bss <- forM (take 1 ipsecs) $ \k -> do 277 bss <- forM (take 1 ipsecs) $ \k -> do
264 let warn' x = warn x >> return Char8.empty 278 let warn' x = warn x >> return Char8.empty
265 flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do 279 flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do