show --cert, certificate import bug fixes

3 files changed, 70 insertions, 14 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
diff --git a/PEM.hs b/PEM.hs
index e6c8259..7b27e04 100644
--- a/PEM.hs
+++ b/PEM.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module PEM where
 
-import Data.Maybe
 import Data.Monoid
 import qualified Data.ByteString.Lazy as LW
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -30,5 +29,5 @@ pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy
         (ys,rs) = span (/="-----END " <> typ <> "-----") xs
         mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta)
         dta = case ys of
-                _:dta_lines -> L.concat dta_lines
-                []          -> ""
+                []        -> ""
+                dta_lines -> L.concat dta_lines
diff --git a/kiki.hs b/kiki.hs
index 063c42c..f1568aa 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -39,7 +39,7 @@ import Data.Binary.Put (putWord32be,runPut,putByteString)
 import Data.X509 -- (Certificate,SignedCertificate, decodeSignedObject, decodeSignedCertificate )
 import Crypto.PubKey.RSA as RSA
 import qualified Codec.Compression.GZip as GZip
-import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds )
+import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds, posixSecondsToUTCTime )
 import Data.Time.Clock ( UTCTime )
 import Data.Monoid ( (<>) )
 
@@ -343,7 +343,26 @@ show_torhash pubkey _ = do
         keys = catMaybes $ scanAndParse (pkcs1 <> pkcs8 <> cert) $ Char8.lines bs
     mapM_ (putStrLn . addy . torhash) keys
 
+show_cert keyspec wkgrip db = do
+    let s = parseSpec wkgrip keyspec
+    putStrLn $ "parsed spec: "++show s
+    case selectPublicKeyAndSigs s db of
+        [] -> void $ warn (keyspec ++ ": not found")
+        [(k,sigs)] -> do
+            {-
+            let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
+                der = encodeASN1 DER (toASN1 rsa [])
+                qq  = Base64.encode (L.unpack der)
+            putStrLn $ writePEM "PUBLIC KEY (TODO: CERT)" qq -- ("TODO "++show keyspec)
+            -}
+            let cs = mapMaybe x509cert $ (sigs >>= hashed_subpackets)
+                ds = map decodeBlob $ map (ParsedCert k (posixSecondsToUTCTime $ fromIntegral $ timestamp k)) cs
+                qqs = map (Base64.encode . L.unpack) ds
+                pems = map (writePEM "CERTIFICATE") qqs
+            forM_ pems putStrLn
+        _ -> void $ warn (keyspec ++ ": ambiguous")
     
+{-
 show_cert certfile _ = do
     bs <- Char8.readFile certfile
     let dta = scanAndParse (fmap pemBlob $ pemParser $ Just "CERTIFICATE") $ Char8.lines bs
@@ -385,6 +404,7 @@ show_cert certfile _ = do
     putStrLn ""
     putStrLn $ "prefix = " ++ hexL v
     return ()
+-}
 
 cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8]
  where
@@ -935,7 +955,7 @@ kiki "show" args = do
                                       ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip)
                                       ,("--ssh",\[x] -> show_ssh x $ fromMaybe "" grip)
                                       ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip)
-                                      ,("--cert",\[x] -> show_cert x)
+                                      ,("--cert",\[x] -> show_cert x $ fromMaybe "" grip)
                                       ,("--torhash",\[x] -> show_torhash x)
                                       ]
                 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs