diff options
Diffstat (limited to 'KeyRing.hs')
-rw-r--r-- | KeyRing.hs | 55 |
1 files changed, 46 insertions, 9 deletions
@@ -84,6 +84,8 @@ module KeyRing | |||
84 | , parseCertBlob | 84 | , parseCertBlob |
85 | , packetFromPublicRSAKey | 85 | , packetFromPublicRSAKey |
86 | , decodeBlob | 86 | , decodeBlob |
87 | , selectPublicKeyAndSigs | ||
88 | , x509cert | ||
87 | ) where | 89 | ) where |
88 | 90 | ||
89 | import System.Environment | 91 | import System.Environment |
@@ -643,6 +645,14 @@ usage (NotationDataPacket | |||
643 | }) = Just u | 645 | }) = Just u |
644 | usage _ = Nothing | 646 | usage _ = Nothing |
645 | 647 | ||
648 | x509cert :: SignatureSubpacket -> Maybe Char8.ByteString | ||
649 | x509cert (NotationDataPacket | ||
650 | { human_readable = False | ||
651 | , notation_name = "x509cert@" | ||
652 | , notation_value = u | ||
653 | }) = Just (Char8.pack u) | ||
654 | x509cert _ = Nothing | ||
655 | |||
646 | makeInducerSig | 656 | makeInducerSig |
647 | :: Packet | 657 | :: Packet |
648 | -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver | 658 | -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver |
@@ -811,12 +821,12 @@ keyFlags0 wkun uidsigs = concat | |||
811 | isfeatures _ = False | 821 | isfeatures _ = False |
812 | 822 | ||
813 | 823 | ||
814 | matchSpec :: KeySpec -> (t, KeyData) -> Bool | 824 | matchSpec :: KeySpec -> KeyData -> Bool |
815 | matchSpec (KeyGrip grip) (_,KeyData p _ _ _) | 825 | matchSpec (KeyGrip grip) (KeyData p _ _ _) |
816 | | matchpr grip (packet p)==grip = True | 826 | | matchpr grip (packet p)==grip = True |
817 | | otherwise = False | 827 | | otherwise = False |
818 | 828 | ||
819 | matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps | 829 | matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps |
820 | where | 830 | where |
821 | ps = map (packet .fst) sigs | 831 | ps = map (packet .fst) sigs |
822 | match p = isSignaturePacket p | 832 | match p = isSignaturePacket p |
@@ -828,7 +838,7 @@ matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps | |||
828 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) | 838 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) |
829 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) | 839 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) |
830 | 840 | ||
831 | matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us | 841 | matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us |
832 | where | 842 | where |
833 | us = filter (isInfixOf pat) $ Map.keys uids | 843 | us = filter (isInfixOf pat) $ Map.keys uids |
834 | 844 | ||
@@ -895,6 +905,7 @@ parseSpec grip spec = (topspec,subspec) | |||
895 | "fp" | top=="" -> Nothing | 905 | "fp" | top=="" -> Nothing |
896 | "" | top=="" && is40digitHex sub -> Nothing | 906 | "" | top=="" && is40digitHex sub -> Nothing |
897 | "" -> listToMaybe sub >> Just sub | 907 | "" -> listToMaybe sub >> Just sub |
908 | -- "fp" -> ??? TODO: non-ehaustive patterns in case: fp:7/fp: | ||
898 | 909 | ||
899 | is40digitHex xs = ys == xs && length ys==40 | 910 | is40digitHex xs = ys == xs && length ys==40 |
900 | where | 911 | where |
@@ -913,7 +924,7 @@ parseSpec grip spec = (topspec,subspec) | |||
913 | 924 | ||
914 | 925 | ||
915 | filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] | 926 | filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] |
916 | filterMatches spec ks = filter (matchSpec spec) ks | 927 | filterMatches spec ks = filter (matchSpec spec . snd) ks |
917 | 928 | ||
918 | filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData | 929 | filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData |
919 | filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' | 930 | filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' |
@@ -948,6 +959,31 @@ selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db | |||
948 | selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet | 959 | selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet |
949 | selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db | 960 | selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db |
950 | 961 | ||
962 | selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(Packet,[Packet])] | ||
963 | selectPublicKeyAndSigs (spec,mtag) db = | ||
964 | case mtag of | ||
965 | Nothing -> concat $ Map.elems $ fmap (findbyspec spec) db | ||
966 | Just tag -> Map.elems (Map.filter (matchSpec spec) db) >>= findsubs tag | ||
967 | where | ||
968 | topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) | ||
969 | |||
970 | findbyspec (KeyGrip g) kd = do | ||
971 | filter ismatch $ | ||
972 | topresult kd | ||
973 | : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) | ||
974 | (Map.elems $ keySubKeys kd) | ||
975 | where | ||
976 | ismatch (p,sigs) = matchpr g p ==g | ||
977 | findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] | ||
978 | |||
979 | findsubs tag (KeyData topk _ _ subs) = Map.elems subs >>= gettag | ||
980 | where | ||
981 | gettag (SubKey sub sigs) = do | ||
982 | let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs | ||
983 | (hastag,_) <- maybeToList mb | ||
984 | guard hastag | ||
985 | return $ (packet sub, map (packet . fst) sigs) | ||
986 | |||
951 | selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet | 987 | selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet |
952 | selectKey0 wantPublic (spec,mtag) db = do | 988 | selectKey0 wantPublic (spec,mtag) db = do |
953 | let Message ps = flattenKeys wantPublic db | 989 | let Message ps = flattenKeys wantPublic db |
@@ -1395,6 +1431,7 @@ data ParsedCert = ParsedCert | |||
1395 | } | 1431 | } |
1396 | deriving (Show,Eq) | 1432 | deriving (Show,Eq) |
1397 | data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert | 1433 | data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert |
1434 | deriving (Show,Eq) | ||
1398 | 1435 | ||
1399 | spemPacket (PEMPacket p) = Just p | 1436 | spemPacket (PEMPacket p) = Just p |
1400 | spemPacket _ = Nothing | 1437 | spemPacket _ = Nothing |
@@ -1465,7 +1502,7 @@ readSecretPEMFile fname = do | |||
1465 | let dta = catMaybes $ scanAndParse (pkcs1 <> cert) $ Char8.lines input | 1502 | let dta = catMaybes $ scanAndParse (pkcs1 <> cert) $ Char8.lines input |
1466 | pkcs1 = fmap (parseRSAPrivateKey . pemBlob) | 1503 | pkcs1 = fmap (parseRSAPrivateKey . pemBlob) |
1467 | $ pemParser $ Just "RSA PRIVATE KEY" | 1504 | $ pemParser $ Just "RSA PRIVATE KEY" |
1468 | cert = fmap (fmap (PEMPacket . pcertKey) . parseCertBlob False . pemBlob) | 1505 | cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) |
1469 | $ pemParser $ Just "CERTIFICATE" | 1506 | $ pemParser $ Just "CERTIFICATE" |
1470 | parseRSAPrivateKey dta = do | 1507 | parseRSAPrivateKey dta = do |
1471 | let e = decodeASN1 DER dta | 1508 | let e = decodeASN1 DER dta |
@@ -1729,9 +1766,9 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk | |||
1729 | 1766 | ||
1730 | workingKey grip use_db = listToMaybe $ do | 1767 | workingKey grip use_db = listToMaybe $ do |
1731 | fp <- maybeToList grip | 1768 | fp <- maybeToList grip |
1732 | elm <- Map.toList use_db | 1769 | elm <- Map.elems use_db |
1733 | guard $ matchSpec (KeyGrip fp) elm | 1770 | guard $ matchSpec (KeyGrip fp) elm |
1734 | return $ keyPacket (snd elm) | 1771 | return $ keyPacket elm |
1735 | 1772 | ||
1736 | writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message | 1773 | writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message |
1737 | {- | 1774 | {- |
@@ -2583,7 +2620,7 @@ findTag tag topk subkey subsigs = (xs',minsig,ys') | |||
2583 | $ sig | 2620 | $ sig |
2584 | listToMaybe $ | 2621 | listToMaybe $ |
2585 | map (signature_time . verify (Message [topk])) | 2622 | map (signature_time . verify (Message [topk])) |
2586 | (signatures $ Message [wk,subkey,sig]))) | 2623 | (signatures $ Message [topk,subkey,sig]))) |
2587 | subsigs | 2624 | subsigs |
2588 | (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs | 2625 | (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs |
2589 | xs' = map fst xs | 2626 | xs' = map fst xs |