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. --- kiki.hs | 40 +++++++------- lib/KeyDB.hs | 110 +++++++++++++++++++++++++++++++++++-- lib/KeyRing.hs | 22 ++++---- lib/KeyRing/BuildKeyDB.hs | 109 +++++++++---------------------------- lib/KeyRing/Types.hs | 125 ++++++++++++++++++++++++++++++++++++++++-- lib/Kiki.hs | 4 +- lib/PacketTranscoder.hs | 2 +- lib/Transforms.hs | 135 +++------------------------------------------- 8 files changed, 293 insertions(+), 254 deletions(-) diff --git a/kiki.hs b/kiki.hs index 2379e74..b3cc880 100644 --- a/kiki.hs +++ b/kiki.hs @@ -225,38 +225,37 @@ show_wk :: FilePath -> Maybe [Char] -> KeyDB -> IO () show_wk secring_file grip db = do -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db) - let sec_db = Map.filter gripmatch (byKeyKey db) - gripmatch (KeyData p _ _ _) = + let gripmatch (KeyData p _ _ _) = Map.member secring_file (locations p) || Map.member "&secret" (locations p) - Message sec = flattenKeys False sec_db + Message sec = flattenFiltered False gripmatch db putStrLn $ listKeysFiltered (maybeToList grip) sec debug_dump :: FilePath -> p -> KeyDB -> IO () debug_dump secring_file grip db = do - let sec_db = Map.filter gripmatch (byKeyKey db) - gripmatch (KeyData p _ _ _) = + let gripmatch (KeyData p _ _ _) = Map.member secring_file (locations p) || Map.member "&secret" (locations p) - Message sec = flattenKeys False sec_db + Message sec = flattenFiltered False gripmatch db mapM_ print sec show_all :: KeyDB -> IO () show_all db = do - let Message packets = flattenKeys True (byKeyKey db) + let Message packets = flattenFiltered True (const True) db putStrLn $ listKeys packets show_packets :: (Eq a, IsString a) => [a] -> KeyDB -> IO () show_packets puborsec db = do - let Message packets = flattenKeys (case puborsec of { "sec":_ -> False; _ -> True }) - (byKeyKey db) + let Message packets = flattenFiltered (case puborsec of { "sec":_ -> False; _ -> True }) + (const True) + db forM_ packets $ putStrLn . showPacket show_whose_key :: Maybe RSAPublicKey -> KeyDB -> IO () show_whose_key input_key db = flip (maybe $ return ()) input_key $ \input_key -> do - let ks = whoseKey input_key (byKeyKey db) + let ks = whoseKey input_key db case ks of [KeyData k _ uids _] -> do putStrLn $ fingerprint (packet k) @@ -291,7 +290,7 @@ show_id :: String -> p -> KeyDB -> IO () show_id keyspec wkgrip db = do let s = parseSpec "" keyspec let ps = do - (_,k) <- filterMatches (fst s) (Map.toList $ byKeyKey db) + (_,k) <- filterMatches (fst s) (kkData db) mp <- flattenTop "" True k return $ packet mp -- putStrLn $ "show key " ++ show s @@ -416,8 +415,8 @@ bitcoinAddress network_id k = address ripemd160 x = convert (Crypto.Hash.hash x :: Digest RIPEMD160) :: S.ByteString address = base58_encode hsh -whoseKey :: RSAPublicKey -> Map.Map KeyKey KeyData -> [KeyData] -whoseKey rsakey db = filter matchkey (Map.elems db) +whoseKey :: RSAPublicKey -> KeyDB -> [KeyData] +whoseKey rsakey db = filter matchkey (keyData db) where matchkey (KeyData k _ _ subs) = any (ismatch k) $ Map.elems subs @@ -1656,7 +1655,7 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" where ipsecs = do (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt) - let kd = (byKeyKey (rtKeyDB rt) Map.! kk) + let kd = fromJust $ lookupKeyData kk (rtKeyDB rt) Hostnames addr onames ns _ = getHostnames kd oname <- onames return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs) @@ -1668,15 +1667,14 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of _ | spec == Just "-" || spec == Just "" -> maybeToList (rtWorkingKey rt) - >>= return . (Map.!) (byKeyKey $ rtKeyDB rt) . keykey + >>= return . fromJust . (`lookupKeyData` rtKeyDB rt) . keykey Just topspec - -> map snd $ filterMatches topspec $ Map.toList $ byKeyKey $ rtKeyDB rt + -> map snd $ filterMatches topspec $ kkData $ rtKeyDB rt w -> [] - lookupSecret tag kd = maybeToList $ selectSecretKey (KeyGrip "",Just tag) m - where - m = KeyDB { byKeyKey = Map.singleton (keykey $ keyPacket kd) kd - } + lookupSecret tag kd = take 1 $ snd $ (\(y:ys) -> seek_key (KeyTag y tag) ys) + $ snd $ seek_key (KeyGrip "") + $ map packet $ flattenTop "" False kd dir :: FilePath -> FilePath dir d = d -- TODO: prepend prefix path? @@ -1746,7 +1744,7 @@ tarC (sargs,margs) = do knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey) where ns = onames ++ others - Hostnames _ onames others _ = getHostnames $ byKeyKey (rtKeyDB rt) Map.! kk + Hostnames _ onames others _ = getHostnames $ fromJust $ lookupKeyData kk (rtKeyDB rt) build_secret :: Num t => KeyRingRuntime -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b) build_secret rt k = ( fromIntegral $ timestamp k diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs index f5a4357..1f0849c 100644 --- a/lib/KeyDB.hs +++ b/lib/KeyDB.hs @@ -1,5 +1,4 @@ module KeyDB - {- ( TrustMap , SigAndTrust , SubKey(..) @@ -7,15 +6,31 @@ module KeyDB , KeyDB , emptyKeyDB , keyData + , kkData + , lookupKeyData , transmute - ) -} where + , transmuteAt + , alterKeyDB + , mergeKeyDB + , mapKeyDB + -- These probably don't belong here + , selectKey0 + , flattenTop + , flattenAllUids + , flattenSub + , sortByHint + , flattenKeys + , flattenFiltered + ) where import Control.Monad import Data.Functor +import Data.List import qualified Data.Map.Strict as Map +import Data.Maybe import Data.OpenPGP +import Data.Ord -import FunctorToMaybe import KeyRing.Types type TrustMap = Map.Map FilePath Packet @@ -43,6 +58,11 @@ emptyKeyDB = KeyDB { byKeyKey = Map.empty } keyData :: KeyDB -> [KeyData] keyData db = Map.elems (byKeyKey db) +kkData :: KeyDB -> [(KeyKey, KeyData)] +kkData db = Map.toList (byKeyKey db) + +lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData +lookupKeyData kk db = Map.lookup kk (byKeyKey db) transmute :: (Monad m, Monad kiki, Traversable kiki) => ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter @@ -56,3 +76,87 @@ transmute perform update db = do r <- sequenceA <$> mapM performAll (byKeyKey db) return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk } , concatMap snd $ Map.elems bkk ) + +alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB +alterKeyDB update kk db = db { byKeyKey = Map.alter update kk (byKeyKey db) } + +transmuteAt :: ( Monad m + , Functor kiki + ) => (Maybe KeyData -> m (kiki (KeyData,[info]))) -> KeyKey -> KeyDB -> m (kiki (KeyDB,[info])) +transmuteAt go kk db = do + kdr <- go (Map.lookup kk $ byKeyKey db) + return $ kdr <&> \(kd',rrs) -> ( alterKeyDB (const $ Just kd') kk db + , rrs ) + +mergeKeyDB :: (KeyData -> KeyData -> KeyData) -> KeyDB -> KeyDB -> KeyDB +mergeKeyDB mergeKeyData db dbtrans = + KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) } + +mapKeyDB :: Monad m => (KeyData -> m KeyData) -> KeyDB -> m KeyDB +mapKeyDB f db = fmap (\m -> db { byKeyKey = m }) $ mapM f (byKeyKey db) + +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 + + +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 + +flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] +flattenUid fname ispub (str,(sigs,om)) = + (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs + +flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] +flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs + +flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] +flattenAllUids fname ispub uids = + concatSort fname head (flattenUid fname ispub) (Map.assocs uids) + +flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] +flattenTop fname ispub (KeyData key sigs uids subkeys) = + unk ispub key : + ( flattenAllUids fname ispub uids + ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) + +sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] +sortByHint fname f = sortBy (comparing gethint) + where + gethint = maybe defnum originalNum . Map.lookup fname . locations . f + defnum = -1 + +concatSort :: + FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] +concatSort fname getp f = concat . sortByHint fname getp . map f + +unk :: Bool -> MappedPacket -> MappedPacket +unk isPublic = if isPublic then toPacket secretToPublic else id + where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} + + +unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] +unsig fname isPublic (sig,trustmap) = + sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) + where + f n _ = n==fname -- && trace ("fname=n="++show n) True + asMapped n p = let m = mappedPacket fname p + in m { locations = fmap (\x->x {originalNum=n}) (locations m) } + +flattenFiltered :: Bool -> (KeyData -> Bool) -> KeyDB -> Message +flattenFiltered wantPublic pred db = flattenKeys wantPublic $ Map.filter pred (byKeyKey db) diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 1d52dd1..b946e54 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -73,7 +73,7 @@ import KeyRing.BuildKeyDB (Hostnames(..), buildKeyDB, combineTransforms, filterMatches, - fingerdress, flattenKeys, + fingerdress, generateInternals, getHostnames, getSubkeys, importSecretKey, @@ -84,8 +84,8 @@ import KeyRing.BuildKeyDB (Hostnames(..), parseSingleSpec, parseSpec, readInputFileL, readSecretPEMFile, - secp256k1_id, seek_key, - selectKey0, selectPublicKey, + secp256k1_id, + selectPublicKey, usageFromFilter) import KeyRing.Types @@ -412,10 +412,10 @@ selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Pa selectPublicKeyAndSigs (spec,mtag) db = case mtag of Nothing -> do - (kk,r) <- Map.toList $ fmap (findbyspec spec) (byKeyKey db) + (kk,r) <- fmap (second $ findbyspec spec) (kkData db) (sub,sigs) <- r return (kk,sub,sigs) - Just tag -> Map.toList (Map.filter (matchSpec spec) (byKeyKey db)) >>= findsubs tag + Just tag -> filterMatches spec (kkData db) >>= findsubs tag where topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) @@ -600,7 +600,7 @@ coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPack coinKeysOwnedBy db wk = do wk <- maybeToList wk let kk = keykey wk - KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk (byKeyKey db) + KeyData top topsigs uids subs <- maybeToList $ lookupKeyData kk db (subkk,SubKey mp sigs) <- Map.toList subs let sub = packet mp guard $ isCryptoCoinKey sub @@ -664,7 +664,7 @@ guardAuthentic rt keydata = guard (isauth rt keydata) isauth :: KeyRingRuntime -> KeyData -> Bool isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk - where wk = workingKey (rtGrip rt) (byKeyKey $ rtKeyDB rt) + where wk = workingKey (rtGrip rt) (rtKeyDB rt) dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) $ locations p has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids @@ -676,7 +676,7 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk workingKey grip use_db = listToMaybe $ do fp <- maybeToList grip - elm <- Map.elems use_db + elm <- keyData use_db guard $ matchSpec (KeyGrip fp) elm return $ keyPacket elm @@ -731,7 +731,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do (error $ f ++ ": write public or secret key to file?") importByExistingMaster kd@(KeyData p _ _ _) = fmap originallyPublic $ Map.lookup f $ locations p - d <- sortByHint f keyMappedPacket (Map.elems $ byKeyKey db') + d <- sortByHint f keyMappedPacket (keyData db') acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) only_public <- maybeToList $ wantedForFill acc (fill stream) d guard $ only_public || isSecretKey (keyPacket d) @@ -984,7 +984,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db -- ms = filterMatches topspec $ Map.toList db ns = do - (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db + (kk,kd) <- filterMatches topspec $ kkData db return (kk , subkeysForExport subspec kd) return (fname,subspec,ns,stream) (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) @@ -1032,7 +1032,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage guard $ null $ do - (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db + (kk,kd) <- filterMatches topspec $ kkData db subkeysForExport subspec kd return (f,stream) where 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 + diff --git a/lib/Kiki.hs b/lib/Kiki.hs index e5c4eb4..e919b88 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -496,7 +496,7 @@ installIpsecConf fw MyIdentity{myGpgAddress} cs = do getMyIdentity :: KeyRingRuntime -> Maybe MyIdentity getMyIdentity rt = do wk <- rtWorkingKey rt - Hostnames wkaddr _ _ _ <- Just $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk) + Hostnames wkaddr _ _ _ <- getHostnames <$> lookupKeyData (keykey wk) (rtKeyDB rt) return $ MyIdentity wkaddr (fingerprint wk) refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () @@ -543,7 +543,7 @@ newtype UidHostname = UidHostname Char8.ByteString newtype ResolvableHostname = ResolvableHostname Char8.ByteString listPeers :: KeyRingRuntime -> [Peer] -listPeers rt = map (uncurry Peer) . filter notme . mapMaybe namedContact . Map.elems . byKeyKey . rtKeyDB $ rt +listPeers rt = map (uncurry Peer) . filter notme . mapMaybe namedContact . keyData . rtKeyDB $ rt where kk = keykey (fromJust $ rtWorkingKey rt) notme (_,kd) = keykey (keyPacket kd) /= kk diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs index 730a221..16d1db5 100644 --- a/lib/PacketTranscoder.hs +++ b/lib/PacketTranscoder.hs @@ -332,6 +332,6 @@ keyQueries grip ringPackets = (mwk, fmap makeQuery keys) combineKeyKey (master1,mp,um) (master2,mp2,um2) = (master1 `mplus` master2,mp,Map.unionWith (++) um um2) uidmap ps = um2 where - ugs = dropWhile (not . isUserID . packet .head) $ groupBy (const $ not . isUserID . packet) ps + ugs = dropWhile (isNothing . isUserID . packet .head) $ groupBy (const $ isNothing . isUserID . packet) ps um2 = Map.fromList $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs diff --git a/lib/Transforms.hs b/lib/Transforms.hs index 0a3a9a6..edc18bb 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs @@ -22,7 +22,6 @@ import FunctorToMaybe import GnuPGAgent ( key_nbits ) import PacketTranscoder import TimeUtil -import qualified Data.Traversable as Traversable import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as Char8 @@ -120,25 +119,6 @@ data UserIDRecord = UserIDRecord { } deriving Show -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) - -- Functions @@ -235,18 +215,6 @@ mkUsage tag = NotationDataPacket } -unk :: Bool -> MappedPacket -> MappedPacket -unk isPublic = if isPublic then toPacket secretToPublic else id - where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} - - -unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] -unsig fname isPublic (sig,trustmap) = - sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) - where - f n _ = n==fname -- && trace ("fname=n="++show n) True - asMapped n p = let m = mappedPacket fname p - in m { locations = fmap (\x->x {originalNum=n}) (locations m) } smallpr :: Packet -> [Char] smallpr k = drop 24 $ fingerprint k @@ -360,34 +328,6 @@ accBindings bs = as (bc,_,bkind,bhashed,bclaimaints) = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) -sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] -sortByHint fname f = sortBy (comparing gethint) - where - gethint = maybe defnum originalNum . Map.lookup fname . locations . f - defnum = -1 - -concatSort :: - FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] -concatSort fname getp f = concat . sortByHint fname getp . map f - -flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] -flattenUid fname ispub (str,(sigs,om)) = - (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs - -flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] -flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs - -flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] -flattenAllUids fname ispub uids = - concatSort fname head (flattenUid fname ispub) (Map.assocs uids) - -flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] -flattenTop fname ispub (KeyData key sigs uids subkeys) = - unk ispub key : - ( flattenAllUids fname ispub uids - ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) - - sigpackets :: Monad m => Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet @@ -407,72 +347,11 @@ sigpackets typ hashed unhashed = return $ keyFlags :: t -> [Packet] -> [SignatureSubpacket] keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) --- 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 - - - -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 - - - -uidkey :: Packet -> String -uidkey (UserIDPacket str) = str - -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 + + + + + ifSecret :: Packet -> t -> t -> t @@ -487,7 +366,7 @@ showPacket p | isKey p = (if is_subkey p ++ " "++fingerprint p ++ " "++show (key_algorithm p) ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" } - | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) + | Just uid <- isUserID p = showPacket0 p ++ " " ++ show uid -- isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p) | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p | otherwise = showPacket0 p @@ -721,8 +600,10 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do (es,qs) = partition isExpiration ps stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs where unwrap (SignatureCreationTimePacket x) = x + unwrap _ = error "isCreation fail" exp = listToMaybe $ sort $ map unwrap es where unwrap (SignatureExpirationTimePacket x) = x + unwrap _ = error "isExpiration fail" expires = liftA2 (+) stamp exp timestamp <- now if fmap ( (< timestamp) . fromIntegral) expires == Just True then -- cgit v1.2.3