show --cert, certificate import bug fixes

1 files changed, 46 insertions, 9 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 68ec843..8864df4 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -84,6 +84,8 @@ module KeyRing
     , parseCertBlob
     , packetFromPublicRSAKey
     , decodeBlob
+    , selectPublicKeyAndSigs
+    , x509cert
     ) where
 
 import System.Environment
@@ -643,6 +645,14 @@ usage (NotationDataPacket
         }) = Just u
 usage _    = Nothing
 
+x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
+x509cert (NotationDataPacket
+        { human_readable = False
+        , notation_name  = "x509cert@"
+        , notation_value = u
+        }) = Just (Char8.pack u)
+x509cert _    = Nothing
+
 makeInducerSig
   :: Packet
      -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
@@ -811,12 +821,12 @@ keyFlags0 wkun uidsigs = concat
     isfeatures _ = False
 
 
-matchSpec :: KeySpec -> (t, KeyData) -> Bool
-matchSpec (KeyGrip grip) (_,KeyData p _ _ _)
+matchSpec :: KeySpec -> KeyData -> Bool
+matchSpec (KeyGrip grip) (KeyData p _ _ _)
     | matchpr grip (packet p)==grip = True
     | otherwise                     = False
 
-matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps
+matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
  where
     ps = map (packet .fst) sigs
     match p = isSignaturePacket p
@@ -828,7 +838,7 @@ matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps
     has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
                     || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
 
-matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us
+matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
   where
     us = filter (isInfixOf pat) $ Map.keys uids
 
@@ -895,6 +905,7 @@ parseSpec grip spec = (topspec,subspec)
                 "fp" | top=="" -> Nothing
                 "" | top=="" && is40digitHex sub -> Nothing
                 "" -> listToMaybe sub >> Just sub
+                -- "fp" -> ???  TODO: non-ehaustive patterns in case: fp:7/fp:
 
      is40digitHex xs = ys == xs && length ys==40
       where
@@ -913,7 +924,7 @@ parseSpec grip spec = (topspec,subspec)
 
 
 filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
-filterMatches spec ks = filter (matchSpec spec) ks
+filterMatches spec ks = filter (matchSpec spec . snd) ks
 
 filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
 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
 selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
 selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
 
+selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(Packet,[Packet])]
+selectPublicKeyAndSigs (spec,mtag) db =
+    case mtag of
+        Nothing -> concat $ Map.elems $ fmap (findbyspec spec) db
+        Just tag -> Map.elems (Map.filter (matchSpec spec) db) >>= findsubs tag
+ where
+    topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
+
+    findbyspec (KeyGrip g) kd = do
+        filter ismatch $
+            topresult kd
+            : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
+                  (Map.elems $ keySubKeys kd)
+      where
+        ismatch (p,sigs) = matchpr g p ==g
+    findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
+
+    findsubs tag (KeyData topk _ _ subs) = Map.elems subs >>= gettag
+     where
+        gettag (SubKey sub sigs) = do
+            let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
+            (hastag,_) <- maybeToList mb
+            guard hastag
+            return $ (packet sub, map (packet . fst) sigs)
+
 selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
 selectKey0 wantPublic (spec,mtag) db = do
     let Message ps = flattenKeys wantPublic db
@@ -1395,6 +1431,7 @@ data ParsedCert = ParsedCert
     }
  deriving (Show,Eq)
 data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
+ deriving (Show,Eq)
 
 spemPacket (PEMPacket p) = Just p
 spemPacket _ = Nothing
@@ -1465,7 +1502,7 @@ readSecretPEMFile fname = do
     let dta = catMaybes $ scanAndParse (pkcs1 <> cert) $ Char8.lines input
         pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
                     $ pemParser $ Just "RSA PRIVATE KEY"
-        cert  = fmap (fmap (PEMPacket . pcertKey) . parseCertBlob False . pemBlob)
+        cert  = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
                     $ pemParser $ Just "CERTIFICATE"
         parseRSAPrivateKey dta = do
            let e = decodeASN1 DER dta
@@ -1729,9 +1766,9 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
 
                 workingKey grip use_db = listToMaybe $ do
                             fp <- maybeToList grip
-                            elm <- Map.toList use_db
+                            elm <- Map.elems use_db
                             guard $ matchSpec (KeyGrip fp) elm
-                            return $ keyPacket (snd elm)
+                            return $ keyPacket elm
 
 writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
                 {-
@@ -2583,7 +2620,7 @@ findTag tag topk subkey subsigs = (xs',minsig,ys')
                                         $ sig
                                 listToMaybe $
                                   map (signature_time . verify (Message [topk]))
-                                      (signatures $ Message [wk,subkey,sig])))
+                                      (signatures $ Message [topk,subkey,sig])))
                      subsigs
             (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
             xs' = map fst xs