From 3f29bdc88a068ec3eab91a8bac12757e3a106ceb Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 13 Jul 2019 21:18:22 -0400 Subject: Finished encapsulation of KeyDB. --- lib/KeyRing/BuildKeyDB.hs | 109 ++++++++++------------------------------ lib/KeyRing/Types.hs | 125 ++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 145 insertions(+), 89 deletions(-) (limited to 'lib/KeyRing') 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 db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed where mergeIt db f (_,dbtrans) - = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) - } + = mergeKeyDB mergeKeyData db dbtrans -- | reportTrans -- events, indexed by file reportTrans :: [(FilePath, KikiReportAction)] @@ -226,7 +225,7 @@ buildKeyDB ctx grip0 keyring = do -- TODO: KikiCondition reporting for spill/fill usage mismatch? -- TODO: parseSpec3 let (topspec,subspec) = parseSpec grip usage - ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db) + ms = map fst $ filterMatches topspec (kkData db) cmd = initializer stream return (n,subspec,ms,stream, cmd) @@ -338,7 +337,7 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma case p of _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) _ | isKey p && is_subkey p -> (top,p,ret p) - _ | isUserID p -> (top,p,ret p) + _ | isJust (isUserID p) -> (top,p,ret p) _ | isTrust p -> (top,sub,updateTrust top sub prev p) _ -> (top,sub,ret p) @@ -385,10 +384,14 @@ doImportG -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) doImportG transcode db m0 tags fname key = do let kk = head m0 - Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) + {- + let Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) kdr <- insertSubkey transcode kk kd tags fname key - try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) } - , rrs) + try kdr $ \(kd',rrs) -> return $ KikiSuccess ( alterKeyDB (const $ Just kd') kk db + , rrs ) + -} + let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key + transmuteAt go kk db iswallet :: FileType -> Bool @@ -487,7 +490,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do guard $ all (null . Hosts.namesForAddress addr) hostdbs0 return addr where - gpgnames = map getHostnames $ Map.elems $ byKeyKey db + gpgnames = map getHostnames $ keyData db filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec . snd) ks @@ -513,14 +516,13 @@ generateInternals :: -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) generateInternals transcode mwk db gens = do - case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of - Just kd0 -> do - kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens - try kd $ \(kd,reportGens) -> do - let kk = keykey $ packet $ fromJust mwk - return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) } - , reportGens ) + case mwk of Nothing -> return $ KikiSuccess (db,[]) + Just mpkt -> do + let kk = keykey (packet mpkt) + transmuteAt (go kk) kk db + where + go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext -> IO @@ -549,7 +551,7 @@ mergeHostFiles krd db ctx = do hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns - let gpgnames = map getHostnames $ Map.elems (byKeyKey db) + let gpgnames = map getHostnames $ keyData db os = do Hostnames addr ns _ _ <- gpgnames n <- ns @@ -578,8 +580,7 @@ mergeHostFiles krd db ctx = do -- 2. replace gpg annotations with those in U -- forM use_db - db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db) - <&> \m -> db { byKeyKey = m } + db' <- mapKeyDB (setHostnames addrs u1) db return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[]) @@ -625,7 +626,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) - | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) } + | isKey top = alterKeyDB update (keykey top) db where update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty update (Just kd) = dbInsertPacket kd filename adding @@ -947,8 +948,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops uids0 = fmap zapIfHasName uids fstuid = head $ do p <- map packet $ flattenAllUids "" True uids - guard $ isUserID p - return $ uidkey p + maybeToList $ isUserID p uids1 = Map.adjust addnames fstuid uids0 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin where @@ -1068,15 +1068,15 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) ,show (fingerprint top, fingerprint p)] update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) - update (Just (KeyData key sigs uids subkeys)) | isUserID p - = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) + update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p + = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids) subkeys update (Just (KeyData key sigs uids subkeys)) = case sub of MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys - UserIDPacket {} -> Just $ KeyData key + UserIDPacket uid-> Just $ KeyData key sigs - (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) + (Map.alter (mergeUidSig n ptt) uid uids) subkeys _ | isKey sub -> Just $ KeyData key sigs @@ -1351,15 +1351,6 @@ extractRSAKeyFields kvs = do nlen = S.length bs -selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectKey0 wantPublic (spec,mtag) db = do - let Message ps = flattenKeys wantPublic $ byKeyKey db - ys = snd $ seek_key spec ps - flip (maybe (listToMaybe ys)) mtag $ \tag -> do - case ys of - y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 - [] -> Nothing - -- TODO: Data.ByteString.Lazy now exports this. toStrict :: L.ByteString -> S.ByteString toStrict = foldr1 (<>) . L.toChunks @@ -1374,53 +1365,3 @@ packetFromPublicRSAKey notBefore n e = , v3_days_of_validity = Nothing } -flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message -flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) - (prefilter . Map.assocs $ db) - where - prefilter = if isPublic then id else filter isSecret - where - isSecret (_,(KeyData - (MappedPacket { packet=(SecretKeyPacket {})}) - _ - _ - _)) = True - isSecret _ = False - -seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) -seek_key (KeyGrip grip) sec = (pre, subs) - where - (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred p@(PublicKeyPacket {}) = matchpr grip p == grip - pred _ = False - -seek_key (KeyTag key tag) ps - | null bs = (ps, []) - | null qs = - let (as', bs') = seek_key (KeyTag key tag) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (\p -> isSignaturePacket p - && has_tag tag p - && isJust (signature_issuer p) - && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) - ps - (rs,qs) = break isKey (reverse as) - - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -seek_key (KeyUidMatch pat) ps - | null bs = (ps, []) - | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (isInfixOf pat . uidStr) ps - (rs,qs) = break isKey (reverse as) - - uidStr (UserIDPacket s) = s - uidStr _ = "" - 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 @@ {-# LANGUAGE PatternSynonyms #-} module KeyRing.Types where +import Data.Bits import Data.Char (isLower,toLower) import Data.Functor -import Data.List (groupBy,find) +import Data.List (groupBy,find,isInfixOf) import Data.Map as Map (Map) import qualified Data.Map as Map -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList,isJust,fromJust,mapMaybe) import Data.OpenPGP import Data.OpenPGP.Util import Data.Time.Clock @@ -335,9 +336,9 @@ isSecretKey (SecretKeyPacket {}) = True isSecretKey _ = False -isUserID :: Packet -> Bool -isUserID (UserIDPacket {}) = True -isUserID _ = False +isUserID :: Packet -> Maybe String +isUserID (UserIDPacket str) = Just str +isUserID _ = Nothing isTrust :: Packet -> Bool isTrust (TrustPacket {}) = True @@ -408,3 +409,117 @@ data SingleKeySpec = FingerprintMatch String | WorkingKeyMatch deriving (Show,Eq,Ord) +secretToPublic :: Packet -> Packet +secretToPublic pkt@(SecretKeyPacket {}) = + PublicKeyPacket { version = version pkt + , timestamp = timestamp pkt + , key_algorithm = key_algorithm pkt + -- , ecc_curve = ecc_curve pkt + , key = let seckey = key pkt + pubs = public_key_fields (key_algorithm pkt) + in filter (\(k,v) -> k `elem` pubs) seckey + , is_subkey = is_subkey pkt + , v3_days_of_validity = Nothing + } +secretToPublic pkt = pkt + +seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) +seek_key (KeyGrip grip) sec = (pre, subs) + where + (pre,subs) = break pred sec + pred p@(SecretKeyPacket {}) = matchpr grip p == grip + pred p@(PublicKeyPacket {}) = matchpr grip p == grip + pred _ = False + +seek_key (KeyTag key tag) ps + | null bs = (ps, []) + | null qs = + let (as', bs') = seek_key (KeyTag key tag) (tail bs) in + (as ++ (head bs : as'), bs') + | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) + where + (as,bs) = break (\p -> isSignaturePacket p + && has_tag tag p + && isJust (signature_issuer p) + && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) + ps + (rs,qs) = break isKey (reverse as) + + has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) + || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) + +seek_key (KeyUidMatch pat) ps + | null bs = (ps, []) + | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in + (as ++ (head bs : as'), bs') + | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) + where + (as,bs) = break (isInfixOf pat . uidStr) ps + (rs,qs) = break isKey (reverse as) + + uidStr (UserIDPacket s) = s + uidStr _ = "" + +usageString :: PGPKeyFlags -> String +usageString flgs = + case flgs of + Special -> "special" + Vouch -> "vouch" -- signkey + Sign -> "sign" + VouchSign -> "vouch-sign" + Communication -> "communication" + VouchCommunication -> "vouch-communication" + SignCommunication -> "sign-communication" + VouchSignCommunication -> "vouch-sign-communication" + Storage -> "storage" + VouchStorage -> "vouch-storage" + SignStorage -> "sign-storage" + VouchSignStorage -> "vouch-sign-storage" + Encrypt -> "encrypt" + VouchEncrypt -> "vouch-encrypt" + SignEncrypt -> "sign-encrypt" + VouchSignEncrypt -> "vouch-sign-encrypt" + +usage :: SignatureSubpacket -> Maybe String +usage (NotationDataPacket + { human_readable = True + , notation_name = "usage@" + , notation_value = u + }) = Just u +usage _ = Nothing + +data PGPKeyFlags = + Special + | Vouch -- 0001 C -- Signkey + | Sign -- 0010 S + | VouchSign -- 0011 + | Communication -- 0100 E + | VouchCommunication -- 0101 + | SignCommunication -- 0110 + | VouchSignCommunication -- 0111 + | Storage -- 1000 E + | VouchStorage -- 1001 + | SignStorage -- 1010 + | VouchSignStorage -- 1011 + | Encrypt -- 1100 E + | VouchEncrypt -- 1101 + | SignEncrypt -- 1110 + | VouchSignEncrypt -- 1111 + deriving (Eq,Show,Read,Enum) + +-- XXX keyFlags and keyflags are different functions. +keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags +keyflags flgs@(KeyFlagsPacket {}) = + Just . toEnum $ + ( bit 0x1 certify_keys + .|. bit 0x2 sign_data + .|. bit 0x4 encrypt_communication + .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags + -- other flags: + -- split_key + -- authentication (ssh-client) + -- group_key + where + bit v f = if f flgs then v else 0 +keyflags _ = Nothing + -- cgit v1.2.3