summaryrefslogtreecommitdiff
path: root/lib/KeyRing
diff options
context:
space:
mode:
Diffstat (limited to 'lib/KeyRing')
-rw-r--r--lib/KeyRing/BuildKeyDB.hs109
-rw-r--r--lib/KeyRing/Types.hs125
2 files changed, 145 insertions, 89 deletions
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 8af8198..cd1bae9 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -185,8 +185,7 @@ buildKeyDB ctx grip0 keyring = do
185 db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed 185 db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed
186 where 186 where
187 mergeIt db f (_,dbtrans) 187 mergeIt db f (_,dbtrans)
188 = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) 188 = mergeKeyDB mergeKeyData db dbtrans
189 }
190 -- | reportTrans 189 -- | reportTrans
191 -- events, indexed by file 190 -- events, indexed by file
192 reportTrans :: [(FilePath, KikiReportAction)] 191 reportTrans :: [(FilePath, KikiReportAction)]
@@ -226,7 +225,7 @@ buildKeyDB ctx grip0 keyring = do
226 -- TODO: KikiCondition reporting for spill/fill usage mismatch? 225 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
227 -- TODO: parseSpec3 226 -- TODO: parseSpec3
228 let (topspec,subspec) = parseSpec grip usage 227 let (topspec,subspec) = parseSpec grip usage
229 ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db) 228 ms = map fst $ filterMatches topspec (kkData db)
230 cmd = initializer stream 229 cmd = initializer stream
231 return (n,subspec,ms,stream, cmd) 230 return (n,subspec,ms,stream, cmd)
232 231
@@ -338,7 +337,7 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma
338 case p of 337 case p of
339 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) 338 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
340 _ | isKey p && is_subkey p -> (top,p,ret p) 339 _ | isKey p && is_subkey p -> (top,p,ret p)
341 _ | isUserID p -> (top,p,ret p) 340 _ | isJust (isUserID p) -> (top,p,ret p)
342 _ | isTrust p -> (top,sub,updateTrust top sub prev p) 341 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
343 _ -> (top,sub,ret p) 342 _ -> (top,sub,ret p)
344 343
@@ -385,10 +384,14 @@ doImportG
385 -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) 384 -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
386doImportG transcode db m0 tags fname key = do 385doImportG transcode db m0 tags fname key = do
387 let kk = head m0 386 let kk = head m0
388 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) 387 {-
388 let Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db)
389 kdr <- insertSubkey transcode kk kd tags fname key 389 kdr <- insertSubkey transcode kk kd tags fname key
390 try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) } 390 try kdr $ \(kd',rrs) -> return $ KikiSuccess ( alterKeyDB (const $ Just kd') kk db
391 , rrs) 391 , rrs )
392 -}
393 let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key
394 transmuteAt go kk db
392 395
393 396
394iswallet :: FileType -> Bool 397iswallet :: FileType -> Bool
@@ -487,7 +490,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do
487 guard $ all (null . Hosts.namesForAddress addr) hostdbs0 490 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
488 return addr 491 return addr
489 where 492 where
490 gpgnames = map getHostnames $ Map.elems $ byKeyKey db 493 gpgnames = map getHostnames $ keyData db
491 494
492filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] 495filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
493filterMatches spec ks = filter (matchSpec spec . snd) ks 496filterMatches spec ks = filter (matchSpec spec . snd) ks
@@ -513,14 +516,13 @@ generateInternals ::
513 -> [(GenerateKeyParams,StreamInfo)] 516 -> [(GenerateKeyParams,StreamInfo)]
514 -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) 517 -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
515generateInternals transcode mwk db gens = do 518generateInternals transcode mwk db gens = do
516 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of 519 case mwk of
517 Just kd0 -> do
518 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
519 try kd $ \(kd,reportGens) -> do
520 let kk = keykey $ packet $ fromJust mwk
521 return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) }
522 , reportGens )
523 Nothing -> return $ KikiSuccess (db,[]) 520 Nothing -> return $ KikiSuccess (db,[])
521 Just mpkt -> do
522 let kk = keykey (packet mpkt)
523 transmuteAt (go kk) kk db
524 where
525 go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
524 526
525mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext 527mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
526 -> IO 528 -> IO
@@ -549,7 +551,7 @@ mergeHostFiles krd db ctx = do
549 551
550 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns 552 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
551 553
552 let gpgnames = map getHostnames $ Map.elems (byKeyKey db) 554 let gpgnames = map getHostnames $ keyData db
553 os = do 555 os = do
554 Hostnames addr ns _ _ <- gpgnames 556 Hostnames addr ns _ _ <- gpgnames
555 n <- ns 557 n <- ns
@@ -578,8 +580,7 @@ mergeHostFiles krd db ctx = do
578 580
579 -- 2. replace gpg annotations with those in U 581 -- 2. replace gpg annotations with those in U
580 -- forM use_db 582 -- forM use_db
581 db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db) 583 db' <- mapKeyDB (setHostnames addrs u1) db
582 <&> \m -> db { byKeyKey = m }
583 584
584 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[]) 585 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[])
585 586
@@ -625,7 +626,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
625 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets 626 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
626 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB 627 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
627 mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) 628 mergeit db adding@(n,(top,sub,ptt@(p,trustmap)))
628 | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) } 629 | isKey top = alterKeyDB update (keykey top) db
629 where 630 where
630 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty 631 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
631 update (Just kd) = dbInsertPacket kd filename adding 632 update (Just kd) = dbInsertPacket kd filename adding
@@ -947,8 +948,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops
947 uids0 = fmap zapIfHasName uids 948 uids0 = fmap zapIfHasName uids
948 fstuid = head $ do 949 fstuid = head $ do
949 p <- map packet $ flattenAllUids "" True uids 950 p <- map packet $ flattenAllUids "" True uids
950 guard $ isUserID p 951 maybeToList $ isUserID p
951 return $ uidkey p
952 uids1 = Map.adjust addnames fstuid uids0 952 uids1 = Map.adjust addnames fstuid uids0
953 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin 953 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
954 where 954 where
@@ -1068,15 +1068,15 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
1068 ,show (fingerprint top, fingerprint p)] 1068 ,show (fingerprint top, fingerprint p)]
1069 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p 1069 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
1070 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) 1070 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
1071 update (Just (KeyData key sigs uids subkeys)) | isUserID p 1071 update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p
1072 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) 1072 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids)
1073 subkeys 1073 subkeys
1074 update (Just (KeyData key sigs uids subkeys)) 1074 update (Just (KeyData key sigs uids subkeys))
1075 = case sub of 1075 = case sub of
1076 MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys 1076 MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
1077 UserIDPacket {} -> Just $ KeyData key 1077 UserIDPacket uid-> Just $ KeyData key
1078 sigs 1078 sigs
1079 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) 1079 (Map.alter (mergeUidSig n ptt) uid uids)
1080 subkeys 1080 subkeys
1081 _ | isKey sub -> Just $ KeyData key 1081 _ | isKey sub -> Just $ KeyData key
1082 sigs 1082 sigs
@@ -1351,15 +1351,6 @@ extractRSAKeyFields kvs = do
1351 nlen = S.length bs 1351 nlen = S.length bs
1352 1352
1353 1353
1354selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1355selectKey0 wantPublic (spec,mtag) db = do
1356 let Message ps = flattenKeys wantPublic $ byKeyKey db
1357 ys = snd $ seek_key spec ps
1358 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
1359 case ys of
1360 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
1361 [] -> Nothing
1362
1363-- TODO: Data.ByteString.Lazy now exports this. 1354-- TODO: Data.ByteString.Lazy now exports this.
1364toStrict :: L.ByteString -> S.ByteString 1355toStrict :: L.ByteString -> S.ByteString
1365toStrict = foldr1 (<>) . L.toChunks 1356toStrict = foldr1 (<>) . L.toChunks
@@ -1374,53 +1365,3 @@ packetFromPublicRSAKey notBefore n e =
1374 , v3_days_of_validity = Nothing 1365 , v3_days_of_validity = Nothing
1375 } 1366 }
1376 1367
1377flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
1378flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
1379 (prefilter . Map.assocs $ db)
1380 where
1381 prefilter = if isPublic then id else filter isSecret
1382 where
1383 isSecret (_,(KeyData
1384 (MappedPacket { packet=(SecretKeyPacket {})})
1385 _
1386 _
1387 _)) = True
1388 isSecret _ = False
1389
1390seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
1391seek_key (KeyGrip grip) sec = (pre, subs)
1392 where
1393 (pre,subs) = break pred sec
1394 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
1395 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
1396 pred _ = False
1397
1398seek_key (KeyTag key tag) ps
1399 | null bs = (ps, [])
1400 | null qs =
1401 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
1402 (as ++ (head bs : as'), bs')
1403 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1404 where
1405 (as,bs) = break (\p -> isSignaturePacket p
1406 && has_tag tag p
1407 && isJust (signature_issuer p)
1408 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
1409 ps
1410 (rs,qs) = break isKey (reverse as)
1411
1412 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
1413 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
1414
1415seek_key (KeyUidMatch pat) ps
1416 | null bs = (ps, [])
1417 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
1418 (as ++ (head bs : as'), bs')
1419 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1420 where
1421 (as,bs) = break (isInfixOf pat . uidStr) ps
1422 (rs,qs) = break isKey (reverse as)
1423
1424 uidStr (UserIDPacket s) = s
1425 uidStr _ = ""
1426
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
index 3c1f0a5..4a0b34e 100644
--- a/lib/KeyRing/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -3,12 +3,13 @@
3{-# LANGUAGE PatternSynonyms #-} 3{-# LANGUAGE PatternSynonyms #-}
4module KeyRing.Types where 4module KeyRing.Types where
5 5
6import Data.Bits
6import Data.Char (isLower,toLower) 7import Data.Char (isLower,toLower)
7import Data.Functor 8import Data.Functor
8import Data.List (groupBy,find) 9import Data.List (groupBy,find,isInfixOf)
9import Data.Map as Map (Map) 10import Data.Map as Map (Map)
10import qualified Data.Map as Map 11import qualified Data.Map as Map
11import Data.Maybe (maybeToList) 12import Data.Maybe (maybeToList,isJust,fromJust,mapMaybe)
12import Data.OpenPGP 13import Data.OpenPGP
13import Data.OpenPGP.Util 14import Data.OpenPGP.Util
14import Data.Time.Clock 15import Data.Time.Clock
@@ -335,9 +336,9 @@ isSecretKey (SecretKeyPacket {}) = True
335isSecretKey _ = False 336isSecretKey _ = False
336 337
337 338
338isUserID :: Packet -> Bool 339isUserID :: Packet -> Maybe String
339isUserID (UserIDPacket {}) = True 340isUserID (UserIDPacket str) = Just str
340isUserID _ = False 341isUserID _ = Nothing
341 342
342isTrust :: Packet -> Bool 343isTrust :: Packet -> Bool
343isTrust (TrustPacket {}) = True 344isTrust (TrustPacket {}) = True
@@ -408,3 +409,117 @@ data SingleKeySpec = FingerprintMatch String
408 | WorkingKeyMatch 409 | WorkingKeyMatch
409 deriving (Show,Eq,Ord) 410 deriving (Show,Eq,Ord)
410 411
412secretToPublic :: Packet -> Packet
413secretToPublic pkt@(SecretKeyPacket {}) =
414 PublicKeyPacket { version = version pkt
415 , timestamp = timestamp pkt
416 , key_algorithm = key_algorithm pkt
417 -- , ecc_curve = ecc_curve pkt
418 , key = let seckey = key pkt
419 pubs = public_key_fields (key_algorithm pkt)
420 in filter (\(k,v) -> k `elem` pubs) seckey
421 , is_subkey = is_subkey pkt
422 , v3_days_of_validity = Nothing
423 }
424secretToPublic pkt = pkt
425
426seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
427seek_key (KeyGrip grip) sec = (pre, subs)
428 where
429 (pre,subs) = break pred sec
430 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
431 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
432 pred _ = False
433
434seek_key (KeyTag key tag) ps
435 | null bs = (ps, [])
436 | null qs =
437 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
438 (as ++ (head bs : as'), bs')
439 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
440 where
441 (as,bs) = break (\p -> isSignaturePacket p
442 && has_tag tag p
443 && isJust (signature_issuer p)
444 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
445 ps
446 (rs,qs) = break isKey (reverse as)
447
448 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
449 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
450
451seek_key (KeyUidMatch pat) ps
452 | null bs = (ps, [])
453 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
454 (as ++ (head bs : as'), bs')
455 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
456 where
457 (as,bs) = break (isInfixOf pat . uidStr) ps
458 (rs,qs) = break isKey (reverse as)
459
460 uidStr (UserIDPacket s) = s
461 uidStr _ = ""
462
463usageString :: PGPKeyFlags -> String
464usageString flgs =
465 case flgs of
466 Special -> "special"
467 Vouch -> "vouch" -- signkey
468 Sign -> "sign"
469 VouchSign -> "vouch-sign"
470 Communication -> "communication"
471 VouchCommunication -> "vouch-communication"
472 SignCommunication -> "sign-communication"
473 VouchSignCommunication -> "vouch-sign-communication"
474 Storage -> "storage"
475 VouchStorage -> "vouch-storage"
476 SignStorage -> "sign-storage"
477 VouchSignStorage -> "vouch-sign-storage"
478 Encrypt -> "encrypt"
479 VouchEncrypt -> "vouch-encrypt"
480 SignEncrypt -> "sign-encrypt"
481 VouchSignEncrypt -> "vouch-sign-encrypt"
482
483usage :: SignatureSubpacket -> Maybe String
484usage (NotationDataPacket
485 { human_readable = True
486 , notation_name = "usage@"
487 , notation_value = u
488 }) = Just u
489usage _ = Nothing
490
491data PGPKeyFlags =
492 Special
493 | Vouch -- 0001 C -- Signkey
494 | Sign -- 0010 S
495 | VouchSign -- 0011
496 | Communication -- 0100 E
497 | VouchCommunication -- 0101
498 | SignCommunication -- 0110
499 | VouchSignCommunication -- 0111
500 | Storage -- 1000 E
501 | VouchStorage -- 1001
502 | SignStorage -- 1010
503 | VouchSignStorage -- 1011
504 | Encrypt -- 1100 E
505 | VouchEncrypt -- 1101
506 | SignEncrypt -- 1110
507 | VouchSignEncrypt -- 1111
508 deriving (Eq,Show,Read,Enum)
509
510-- XXX keyFlags and keyflags are different functions.
511keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
512keyflags flgs@(KeyFlagsPacket {}) =
513 Just . toEnum $
514 ( bit 0x1 certify_keys
515 .|. bit 0x2 sign_data
516 .|. bit 0x4 encrypt_communication
517 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
518 -- other flags:
519 -- split_key
520 -- authentication (ssh-client)
521 -- group_key
522 where
523 bit v f = if f flgs then v else 0
524keyflags _ = Nothing
525