summaryrefslogtreecommitdiff
path: root/lib/KeyRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/KeyRing.hs')
-rw-r--r--lib/KeyRing.hs47
1 files changed, 31 insertions, 16 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]