diff options
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 382 |
1 files changed, 369 insertions, 13 deletions
@@ -126,7 +126,7 @@ RSAPrivateKey ::= SEQUENCE { | |||
126 | privateExponent INTEGER, -- d | 126 | privateExponent INTEGER, -- d |
127 | prime1 INTEGER, -- p | 127 | prime1 INTEGER, -- p |
128 | prime2 INTEGER, -- q | 128 | prime2 INTEGER, -- q |
129 | exponent1 INTEGER, -- d mod (p1) | 129 | exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1) |
130 | exponent2 INTEGER, -- d mod (q-1) | 130 | exponent2 INTEGER, -- d mod (q-1) |
131 | coefficient INTEGER, -- (inverse of q) mod p | 131 | coefficient INTEGER, -- (inverse of q) mod p |
132 | otherPrimeInfos OtherPrimeInfos OPTIONAL | 132 | otherPrimeInfos OtherPrimeInfos OPTIONAL |
@@ -177,6 +177,7 @@ instance ASN1Object RSAPrivateKey where | |||
177 | fromASN1 _ = | 177 | fromASN1 _ = |
178 | Left "fromASN1: RSAPrivateKey: unexpected format" | 178 | Left "fromASN1: RSAPrivateKey: unexpected format" |
179 | 179 | ||
180 | rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey | ||
180 | rsaKeyFromPacket p@(PublicKeyPacket {}) = do | 181 | rsaKeyFromPacket p@(PublicKeyPacket {}) = do |
181 | n <- lookup 'n' $ key p | 182 | n <- lookup 'n' $ key p |
182 | e <- lookup 'e' $ key p | 183 | e <- lookup 'e' $ key p |
@@ -186,10 +187,34 @@ rsaKeyFromPacket p@(SecretKeyPacket {}) = do | |||
186 | e <- lookup 'e' $ key p | 187 | e <- lookup 'e' $ key p |
187 | return $ RSAKey n e | 188 | return $ RSAKey n e |
188 | rsaKeyFromPacket _ = Nothing | 189 | rsaKeyFromPacket _ = Nothing |
190 | |||
189 | derRSA rsa = do | 191 | derRSA rsa = do |
190 | k <- rsaKeyFromPacket rsa | 192 | k <- rsaKeyFromPacket rsa |
191 | return $ encodeASN1 DER (toASN1 k []) | 193 | return $ encodeASN1 DER (toASN1 k []) |
192 | 194 | ||
195 | rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do | ||
196 | -- public fields... | ||
197 | n <- lookup 'n' $ key pkt | ||
198 | e <- lookup 'e' $ key pkt | ||
199 | -- secret fields | ||
200 | MPI d <- lookup 'd' $ key pkt | ||
201 | MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped | ||
202 | MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped | ||
203 | coefficient <- lookup 'u' $ key pkt -- TODO: compute (inverse q) mod p | ||
204 | let dmodp1 = MPI $ d `mod` (p - 1) | ||
205 | dmodqminus1 = MPI $ d `mod` (q - 1) | ||
206 | return $ RSAPrivateKey | ||
207 | { rsaN = n | ||
208 | , rsaE = e | ||
209 | , rsaD = MPI d | ||
210 | , rsaP = MPI p | ||
211 | , rsaQ = MPI q | ||
212 | , rsaDmodP1 = dmodp1 | ||
213 | , rsaDmodQminus1 = dmodqminus1 | ||
214 | , rsaCoefficient = coefficient } | ||
215 | rsaPrivateKeyFromPacket _ = Nothing | ||
216 | |||
217 | |||
193 | getPackets :: IO [Packet] | 218 | getPackets :: IO [Packet] |
194 | getPackets = do | 219 | getPackets = do |
195 | input <- L.getContents | 220 | input <- L.getContents |
@@ -219,6 +244,17 @@ extractPEM typ pem = dta | |||
219 | xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) | 244 | xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) |
220 | ys = takeWhile (/="-----END " <> typ <> "-----") xs | 245 | ys = takeWhile (/="-----END " <> typ <> "-----") xs |
221 | 246 | ||
247 | writePEM typ dta = pem | ||
248 | where | ||
249 | pem = unlines . concat $ | ||
250 | [ ["-----BEGIN " <> typ <> "-----"] | ||
251 | , split64s dta | ||
252 | , ["-----END " <> typ <> "-----"] ] | ||
253 | split64s "" = [] | ||
254 | split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta | ||
255 | |||
256 | -- 64 byte lines | ||
257 | |||
222 | isKey (PublicKeyPacket {}) = True | 258 | isKey (PublicKeyPacket {}) = True |
223 | isKey (SecretKeyPacket {}) = True | 259 | isKey (SecretKeyPacket {}) = True |
224 | isKey _ = False | 260 | isKey _ = False |
@@ -751,6 +787,20 @@ guessKeyFormat 'S' "ssh-client" = "PEM" | |||
751 | guessKeyFormat 'S' "ssh-host" = "PEM" | 787 | guessKeyFormat 'S' "ssh-host" = "PEM" |
752 | guessKeyFormat _ _ = "PEM" -- "PGP" | 788 | guessKeyFormat _ _ = "PEM" -- "PGP" |
753 | 789 | ||
790 | writeKeyToFile False "PEM" fname packet = do | ||
791 | flip (maybe (return ())) | ||
792 | (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey | ||
793 | $ \rsa -> do | ||
794 | let asn1 = toASN1 rsa [] | ||
795 | bs = encodeASN1 DER asn1 | ||
796 | dta = Base64.encode (L.unpack bs) | ||
797 | output = writePEM "RSA PRIVATE KEY" dta | ||
798 | stamp = timestamp packet | ||
799 | writeFile fname output | ||
800 | -- TODO: set modificaiton time | ||
801 | -- see UTIMENSAT(2) | ||
802 | -- utimensat or futimens | ||
803 | |||
754 | readKeyFromFile False "PEM" fname = do | 804 | readKeyFromFile False "PEM" fname = do |
755 | timestamp <- modificationTime <$> getFileStatus fname | 805 | timestamp <- modificationTime <$> getFileStatus fname |
756 | input <- L.readFile fname | 806 | input <- L.readFile fname |
@@ -1140,6 +1190,245 @@ show_all db = do | |||
1140 | let Message packets = flattenKeys True db | 1190 | let Message packets = flattenKeys True db |
1141 | putStrLn $ listKeys packets | 1191 | putStrLn $ listKeys packets |
1142 | 1192 | ||
1193 | parseSpec :: String -> String -> (KeySpec,Maybe String) | ||
1194 | parseSpec grip spec = (topspec,subspec) | ||
1195 | where | ||
1196 | (topspec0,subspec0) = unprefix '/' spec | ||
1197 | (toptyp,top) = unprefix ':' topspec0 | ||
1198 | (subtyp,sub) = unprefix ':' subspec0 | ||
1199 | topspec = case () of | ||
1200 | _ | null top && (subtyp=="fp" || (null subtyp && is40digitHex sub)) | ||
1201 | -> KeyGrip sub | ||
1202 | _ | null top -> KeyGrip grip | ||
1203 | _ | toptyp=="fp" || (null toptyp && is40digitHex top) | ||
1204 | -> {- trace "using top" $ -} KeyGrip top | ||
1205 | _ | toptyp=="u" -> KeyUidMatch top | ||
1206 | _ | otherwise -> KeyUidMatch top | ||
1207 | subspec = case subtyp of | ||
1208 | "t" -> Just sub | ||
1209 | "fp" | top=="" -> Nothing | ||
1210 | "" | top=="" && is40digitHex sub -> Nothing | ||
1211 | "" -> Just sub | ||
1212 | |||
1213 | insertSubKey tag key (Just (KeyData p sigs uids subs)) = | ||
1214 | Just $ KeyData p sigs uids subs' | ||
1215 | where | ||
1216 | subs' = todo | ||
1217 | |||
1218 | splitAtMinBy comp xs = minimumBy comp' xxs | ||
1219 | where | ||
1220 | xxs = zip (inits xs) (tails xs) | ||
1221 | comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) | ||
1222 | compM (Just a) (Just b) = comp a b | ||
1223 | compM Nothing mb = GT | ||
1224 | compM _ _ = LT | ||
1225 | |||
1226 | doExport doDecrypt db (fname,subspec,ms,cmd) = | ||
1227 | case ms of | ||
1228 | [_] -> export | ||
1229 | (_:_) -> ambiguous | ||
1230 | [] -> shcmd | ||
1231 | where | ||
1232 | ambiguous = error "Key specification is ambiguous." | ||
1233 | shcmd = do | ||
1234 | -- | ||
1235 | -- does ms contain exactly one key? | ||
1236 | -- yes -> export key | ||
1237 | -- no -> no keys? | ||
1238 | -- no -> ambiguous error | ||
1239 | -- yes -> cmd | ||
1240 | -- if error warn | ||
1241 | -- else need another pass | ||
1242 | todo | ||
1243 | return Nothing | ||
1244 | export = do | ||
1245 | let [(kk,KeyData key sigs uids subkeys)] = ms | ||
1246 | p = flip (maybe (Just $ packet key)) subspec $ \tag -> do | ||
1247 | let subs = Map.elems subkeys | ||
1248 | doSearch (SubKey sub_mp sigtrusts) = | ||
1249 | let (_,v,_) = searchSubkeys tag | ||
1250 | (packet key) | ||
1251 | (packet sub_mp) | ||
1252 | sigtrusts | ||
1253 | in fmap fst v==Just True | ||
1254 | case filter doSearch subs of | ||
1255 | [SubKey mp _] -> Just $ packet mp | ||
1256 | [] -> Nothing | ||
1257 | _ -> ambiguous | ||
1258 | flip (maybe shcmd) p $ \p -> do | ||
1259 | pun <- doDecrypt p | ||
1260 | flip (maybe shcmd) pun $ \pun -> do | ||
1261 | warn $ "writing "++fname | ||
1262 | writeKeyToFile False "PEM" fname pun | ||
1263 | return db | ||
1264 | |||
1265 | searchSubkeys tag wk subkey subsigs = (xs',minsig,ys') | ||
1266 | where | ||
1267 | vs = map (\sig -> | ||
1268 | (sig, do | ||
1269 | sig <- Just (packet . fst $ sig) | ||
1270 | guard (isSignaturePacket sig) | ||
1271 | guard $ flip isSuffixOf | ||
1272 | (fingerprint wk) | ||
1273 | . maybe "%bad%" id | ||
1274 | . signature_issuer | ||
1275 | $ sig | ||
1276 | listToMaybe $ | ||
1277 | map (signature_time . verify (Message [wk])) | ||
1278 | (signatures $ Message [wk,subkey,sig]))) | ||
1279 | subsigs | ||
1280 | (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs | ||
1281 | xs' = map fst xs | ||
1282 | ys' = map fst (drop 1 ys) | ||
1283 | minsig = do | ||
1284 | (sig,ov) <- listToMaybe ys | ||
1285 | ov | ||
1286 | let hs = filter (\p->isNotation p && notation_name p=="usage@") | ||
1287 | (hashed_subpackets . packet . fst $ sig) | ||
1288 | ks = map notation_value hs | ||
1289 | isNotation (NotationDataPacket {}) = True | ||
1290 | isNotation _ = False | ||
1291 | return (tag `elem` ks, sig) | ||
1292 | |||
1293 | doImport doDecrypt db (fname,subspec,ms,_) = do | ||
1294 | let error s = do | ||
1295 | warn s | ||
1296 | exitFailure | ||
1297 | flip (maybe $ error "Cannot import master key.") | ||
1298 | subspec $ \tag -> do | ||
1299 | Message parsedkey <- readKeyFromFile False "PEM" fname | ||
1300 | flip (maybe $ return db) | ||
1301 | (listToMaybe parsedkey) $ \key -> do | ||
1302 | let (m0,tailms) = splitAt 1 ms | ||
1303 | when (not (null tailms) || null m0) | ||
1304 | $ error "Key specification is ambiguous." | ||
1305 | let (kk,KeyData top topsigs uids subs) = head m0 | ||
1306 | let subkk = keykey key | ||
1307 | (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1)))) | ||
1308 | []) | ||
1309 | (False,) | ||
1310 | (Map.lookup subkk subs) | ||
1311 | let SubKey subkey_p subsigs = subkey | ||
1312 | wk = packet top | ||
1313 | (xs',minsig,ys') = searchSubkeys tag wk key subsigs | ||
1314 | doInsert mbsig db = do | ||
1315 | sig' <- makeSig doDecrypt top fname subkey_p tag mbsig | ||
1316 | warn $ fname ++ ": new SignaturePacket" | ||
1317 | let subs' = Map.insert subkk | ||
1318 | (SubKey subkey_p $ xs'++[sig']++ys') | ||
1319 | subs | ||
1320 | return $ Map.insert kk (KeyData top topsigs uids subs') db | ||
1321 | when is_new (warn $ fname ++ ": new SecretKeyPacket") | ||
1322 | case minsig of | ||
1323 | Nothing -> doInsert Nothing db -- we need to create a new sig | ||
1324 | Just (True,sig) -> return db -- we can deduce is_new == False | ||
1325 | Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag | ||
1326 | |||
1327 | |||
1328 | makeSig doDecrypt top fname subkey_p tag mbsig = do | ||
1329 | let wk = packet top | ||
1330 | wkun <- doDecrypt wk | ||
1331 | flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do | ||
1332 | g <- newGenIO :: IO SystemRandom | ||
1333 | timestamp <- now | ||
1334 | let grip = fingerprint wk | ||
1335 | addOrigin new_sig = do | ||
1336 | flip (maybe $ error "Failed to make signature.") | ||
1337 | (listToMaybe $ signatures_over new_sig) | ||
1338 | $ \new_sig -> do | ||
1339 | let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1))) | ||
1340 | return (mp', Map.empty) | ||
1341 | newSig = do | ||
1342 | let parsedkey = [packet $ subkey_p] | ||
1343 | new_sig = fst $ sign (Message [wkun]) | ||
1344 | (SubkeySignature wk | ||
1345 | (head parsedkey) | ||
1346 | (sigpackets 0x18 | ||
1347 | hashed0 | ||
1348 | ( IssuerPacket (fingerprint wk) | ||
1349 | : map EmbeddedSignaturePacket (signatures_over back_sig)))) | ||
1350 | SHA1 | ||
1351 | grip | ||
1352 | timestamp | ||
1353 | (g::SystemRandom) | ||
1354 | |||
1355 | hashed0 = | ||
1356 | [ KeyFlagsPacket | ||
1357 | { certify_keys = False | ||
1358 | , sign_data = False | ||
1359 | , encrypt_communication = False | ||
1360 | , encrypt_storage = False | ||
1361 | , split_key = False | ||
1362 | , authentication = True | ||
1363 | , group_key = False } | ||
1364 | , NotationDataPacket | ||
1365 | { human_readable = True | ||
1366 | , notation_name = "usage@" | ||
1367 | , notation_value = tag | ||
1368 | } | ||
1369 | , SignatureCreationTimePacket (fromIntegral timestamp) | ||
1370 | ] | ||
1371 | |||
1372 | subgrip = fingerprint (head parsedkey) | ||
1373 | |||
1374 | back_sig = fst $ sign (Message parsedkey) | ||
1375 | (SubkeySignature wk | ||
1376 | (head parsedkey) | ||
1377 | (sigpackets 0x19 | ||
1378 | hashed0 | ||
1379 | [IssuerPacket subgrip])) | ||
1380 | SHA1 | ||
1381 | subgrip | ||
1382 | timestamp | ||
1383 | (g::SystemRandom) | ||
1384 | addOrigin new_sig | ||
1385 | flip (maybe newSig) mbsig $ \(mp,trustmap) -> do | ||
1386 | let sig = packet mp | ||
1387 | isCreation (SignatureCreationTimePacket {}) = True | ||
1388 | isCreation _ = False | ||
1389 | isExpiration (SignatureExpirationTimePacket {}) = True | ||
1390 | isExpiration _ = False | ||
1391 | (cs,ps) = partition isCreation (hashed_subpackets sig) | ||
1392 | (es,qs) = partition isExpiration ps | ||
1393 | stamp = listToMaybe . sortBy (comparing Down) $ | ||
1394 | map unwrap cs where unwrap (SignatureCreationTimePacket x) = x | ||
1395 | exp = listToMaybe $ sort $ | ||
1396 | map unwrap es where unwrap (SignatureExpirationTimePacket x) = x | ||
1397 | expires = liftA2 (+) stamp exp | ||
1398 | if fmap ( (< timestamp) . fromIntegral) expires == Just True then do | ||
1399 | warn $ "Unable to update expired signature" | ||
1400 | return (mp,trustmap) | ||
1401 | else do | ||
1402 | let new_sig = fst $ sign (Message [wkun]) | ||
1403 | (SubkeySignature wk | ||
1404 | (packet subkey_p) | ||
1405 | [sig'] ) | ||
1406 | SHA1 | ||
1407 | (fingerprint wk) | ||
1408 | timestamp | ||
1409 | (g::SystemRandom) | ||
1410 | times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) | ||
1411 | $ maybeToList $ do | ||
1412 | e <- expires | ||
1413 | return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) | ||
1414 | notation = NotationDataPacket | ||
1415 | { notation_name = "usage@" | ||
1416 | , notation_value = tag | ||
1417 | , human_readable = True } | ||
1418 | sig' = sig { hashed_subpackets = times ++ [notation] ++ qs } | ||
1419 | addOrigin new_sig | ||
1420 | |||
1421 | signature_time ov = case if null cs then ds else cs of | ||
1422 | [] -> minBound | ||
1423 | xs -> last (sort xs) | ||
1424 | where | ||
1425 | ps = signatures_over ov | ||
1426 | ss = filter isSignaturePacket ps | ||
1427 | cs = concatMap (concatMap creationTime . hashed_subpackets) ss | ||
1428 | ds = concatMap (concatMap creationTime . unhashed_subpackets) ss | ||
1429 | creationTime (SignatureCreationTimePacket t) = [t] | ||
1430 | creationTime _ = [] | ||
1431 | |||
1143 | main = do | 1432 | main = do |
1144 | dotlock_init | 1433 | dotlock_init |
1145 | {- | 1434 | {- |
@@ -1181,7 +1470,7 @@ main = do | |||
1181 | $ args' | 1470 | $ args' |
1182 | appendArgs xs = Just . maybe xs (++xs) | 1471 | appendArgs xs = Just . maybe xs (++xs) |
1183 | -- putStrLn $ "margs = " ++ show (Map.assocs margs) | 1472 | -- putStrLn $ "margs = " ++ show (Map.assocs margs) |
1184 | let keypairs = | 1473 | let keypairs0 = |
1185 | flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do | 1474 | flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do |
1186 | let (spec,efilecmd) = break (=='=') specfile | 1475 | let (spec,efilecmd) = break (=='=') specfile |
1187 | guard $ take 1 efilecmd=="=" | 1476 | guard $ take 1 efilecmd=="=" |
@@ -1201,6 +1490,26 @@ main = do | |||
1201 | Just (spec,file) | 1490 | Just (spec,file) |
1202 | keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs | 1491 | keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs |
1203 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs | 1492 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs |
1493 | decrypt wk = do | ||
1494 | -- TODO: memoize? | ||
1495 | pw <- case passphrase_fd of | ||
1496 | Just fd -> do pwh <- fdToHandle (read fd) | ||
1497 | fmap trimCR $ S.hGetContents pwh | ||
1498 | Nothing -> return "" | ||
1499 | let wkun = | ||
1500 | if symmetric_algorithm wk == Unencrypted | ||
1501 | then Just wk | ||
1502 | else do | ||
1503 | k <- decryptSecretKey pw wk | ||
1504 | guard (symmetric_algorithm k == Unencrypted) | ||
1505 | return k | ||
1506 | return wkun | ||
1507 | |||
1508 | when (not . null $ filter isNothing keypairs0) $ do | ||
1509 | warn "syntax error" | ||
1510 | exitFailure | ||
1511 | |||
1512 | let keypairs = catMaybes keypairs0 | ||
1204 | 1513 | ||
1205 | (homedir,secring,pubring,grip0) <- getHomeDir ( concat <$> Map.lookup "--homedir" margs) | 1514 | (homedir,secring,pubring,grip0) <- getHomeDir ( concat <$> Map.lookup "--homedir" margs) |
1206 | 1515 | ||
@@ -1235,6 +1544,41 @@ main = do | |||
1235 | $ locations p | 1544 | $ locations p |
1236 | use_db <- get_use_db | 1545 | use_db <- get_use_db |
1237 | 1546 | ||
1547 | let pkeypairs = maybe [] id $ do | ||
1548 | g <- grip | ||
1549 | return $ map (\(spec,f,cmd)-> (parseSpec g spec,f,cmd)) keypairs | ||
1550 | fs <- forM pkeypairs $ \((topspec,subspec),f,cmd) -> do | ||
1551 | let ms = filterMatches topspec (Map.toList db) | ||
1552 | f_found <- doesFileExist f | ||
1553 | return (f_found,(f,subspec,ms,cmd)) | ||
1554 | |||
1555 | let (imports,exports) = partition fst fs | ||
1556 | use_db <- foldM (doImport decrypt) use_db (map snd imports) | ||
1557 | ret_db <- foldM (doExport decrypt) (Just use_db) (map snd exports) | ||
1558 | {- | ||
1559 | forM_ pkeypairs $ \(spec,f,cmd) -> do | ||
1560 | let ms = filterMatches spec (Map.toList db) | ||
1561 | import_if_neccessary = todo | ||
1562 | -- read file | ||
1563 | -- is the key in ms? | ||
1564 | -- yes -> continue | ||
1565 | -- no -> import key | ||
1566 | -- need to write keyring files or remember imports | ||
1567 | export_or_create = todo | ||
1568 | -- does ms contain exactly one key? | ||
1569 | -- yes -> export key | ||
1570 | -- no -> no keys? | ||
1571 | -- no -> ambiguous error | ||
1572 | -- yes -> cmd | ||
1573 | -- if error warn | ||
1574 | -- else need another pass | ||
1575 | f_found <- doesFileExist f | ||
1576 | if f_found | ||
1577 | then import_if_neccessary | ||
1578 | else export_or_create | ||
1579 | return () | ||
1580 | -} | ||
1581 | |||
1238 | let ret_db = Just use_db | 1582 | let ret_db = Just use_db |
1239 | 1583 | ||
1240 | let shspec = Map.fromList [("--show-wk", show_wk secfile grip) | 1584 | let shspec = Map.fromList [("--show-wk", show_wk secfile grip) |
@@ -1703,17 +2047,6 @@ existingKey (prepk,pks) remainder wkun wk parsedkey tag pre uids subkeys output_ | |||
1703 | ++ remainder | 2047 | ++ remainder |
1704 | putStrLn $ "Adding usage@="++tag | 2048 | putStrLn $ "Adding usage@="++tag |
1705 | L.writeFile output_file (encode (Message sec')) | 2049 | L.writeFile output_file (encode (Message sec')) |
1706 | where | ||
1707 | signature_time ov = case if null cs then ds else cs of | ||
1708 | [] -> minBound | ||
1709 | xs -> last (sort xs) | ||
1710 | where | ||
1711 | ps = signatures_over ov | ||
1712 | ss = filter isSignaturePacket ps | ||
1713 | cs = concatMap (concatMap creationTime . hashed_subpackets) ss | ||
1714 | ds = concatMap (concatMap creationTime . unhashed_subpackets) ss | ||
1715 | creationTime (SignatureCreationTimePacket t) = [t] | ||
1716 | creationTime _ = [] | ||
1717 | 2050 | ||
1718 | newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do | 2051 | newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do |
1719 | g <- newGenIO | 2052 | g <- newGenIO |
@@ -1799,6 +2132,29 @@ isTopKey p@(SecretKeyPacket {}) | not (is_subkey p) = True | |||
1799 | isTopKey p@(PublicKeyPacket {}) | not (is_subkey p) = True | 2132 | isTopKey p@(PublicKeyPacket {}) | not (is_subkey p) = True |
1800 | isTopKey _ = False | 2133 | isTopKey _ = False |
1801 | 2134 | ||
2135 | filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] | ||
2136 | filterMatches spec ks = filter (matchSpec spec) ks | ||
2137 | |||
2138 | matchSpec (KeyGrip grip) (_,KeyData p _ _ _) | ||
2139 | | matchpr grip (packet p)==grip = True | ||
2140 | | otherwise = False | ||
2141 | |||
2142 | matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps | ||
2143 | where | ||
2144 | ps = map (packet .fst) sigs | ||
2145 | match p = isSignaturePacket p | ||
2146 | && has_tag tag p | ||
2147 | && has_issuer key p | ||
2148 | has_issuer key p = isJust $ do | ||
2149 | issuer <- signature_issuer p | ||
2150 | guard $ matchpr issuer key == issuer | ||
2151 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) | ||
2152 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) | ||
2153 | |||
2154 | matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us | ||
2155 | where | ||
2156 | us = filter (isInfixOf pat) $ Map.keys uids | ||
2157 | |||
1802 | seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) | 2158 | seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) |
1803 | seek_key (KeyGrip grip) sec = (pre, subs) | 2159 | seek_key (KeyGrip grip) sec = (pre, subs) |
1804 | where | 2160 | where |