1 files changed, 33 insertions, 24 deletions

diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 44952de..57647b0 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -36,6 +36,7 @@ import qualified Data.Map                   as Map
 import           Data.Maybe
 import           Data.OpenPGP
 import           Data.OpenPGP.Util          (GenerateKeyParams (..), fingerprint, generateKey, pgpSign, verify)
+import           GHC.Stack
 
 
 import           Data.Time.Clock            (UTCTime)
@@ -171,7 +172,7 @@ buildKeyDB ctx grip0 keyring = do
             trans f (info,ps) = do
                 let manip = combineTransforms (transforms info)
                     rt1 = rt0 { rtKeyDB = merge emptyKeyDB f ps }
-                    acc = Just Sec /= Map.lookup f accs
+                    -- acc = Just Sec /= Map.lookup f accs
                 r <- performManipulations doDecrypt rt1 mwk manip
                 try r $ \(rt2,report) -> do
                 return $ KikiSuccess (report,rtKeyDB rt2)
@@ -390,6 +391,7 @@ doImportG transcode db m0 tags fname key = do
                                                  , rrs )
     -}
     let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key
+        go Nothing = pure NoWorkingKey
     transmuteAt go kk db
 
 
@@ -413,27 +415,27 @@ parseSpec wkgrip spec =
     if not slashed
         then
             case prespec of
-                AnyMatch                               -> (KeyGrip "", Nothing)
+                AnyMatch                               -> (KeyFP 0 "", Nothing)
                 EmptyMatch                             -> error "Bad key spec."
-                WorkingKeyMatch                        -> (KeyGrip wkgrip, Nothing)
-                SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
-                SubstringMatch Nothing str             -> (KeyGrip wkgrip, Just str)
+                WorkingKeyMatch                        -> (KeyFP 0 wkgrip, Nothing)
+                SubstringMatch (Just KeyTypeField) tag -> (KeyFP 0 wkgrip, Just tag)
+                SubstringMatch Nothing str             -> (KeyFP 0 wkgrip, Just str)
                 SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
-                FingerprintMatch fp                    -> (KeyGrip fp, Nothing)
+                FingerprintMatch ver fp                -> (KeyFP ver fp, Nothing)
         else
             case (prespec,postspec) of
-                (FingerprintMatch fp, SubstringMatch st t)
-                    | st /= Just UserIDField                -> (KeyGrip fp, Just t)
+                (FingerprintMatch ver fp, SubstringMatch st t)
+                    | st /= Just UserIDField                -> (KeyFP ver fp, Just t)
                 (SubstringMatch mt u, _)
                     | postspec `elem` [AnyMatch,EmptyMatch]
                       && mt /= Just KeyTypeField            -> (KeyUidMatch u, Nothing)
                 (SubstringMatch mt u, SubstringMatch st t)
                     | mt /= Just KeyTypeField
                       && st /= Just UserIDField             -> (KeyUidMatch u, Just t)
-                (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
-                (_,FingerprintMatch fp)                 -> error "todo: support /fp: spec"
-                (FingerprintMatch fp,_)                 -> error "todo: support fp:/ spec"
-                _                                       -> error "Bad key spec."
+                (FingerprintMatch _ _,FingerprintMatch _ _) -> error "todo: support fp:/fp: spec"
+                (_,FingerprintMatch _ fp)                   -> error "todo: support /fp: spec"
+                (FingerprintMatch _ fp,_)                   -> error "todo: support fp:/ spec"
+                _                                           -> error "Bad key spec."
  where
     (preslash,slashon) = break (=='/') spec
     slashed = not $ null $ take 1 slashon
@@ -522,6 +524,7 @@ generateInternals transcode mwk db gens = do
             transmuteAt (go kk) kk db
         where
          go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
+         go kk Nothing    = error "generateInternals: Key not found."
 
 mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
      -> IO
@@ -588,7 +591,7 @@ readInputFileL ctx inp = do
     hs <- mapM (`openFile` ReadMode) fname
     fmap L.concat $ mapM (hGetContentsN oneMeg) hs
 
-getInputFileTime :: InputFileContext -> InputFile -> IO CTime
+getInputFileTime :: HasCallStack => InputFileContext -> InputFile -> IO CTime
 getInputFileTime ctx (Pipe fdr fdw) = do
     mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr
     maybe tryw return mt
@@ -602,6 +605,8 @@ getInputFileTime ctx (FileDesc fd) = do
 getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
     handleIO_ (error $ fname++": modificaiton time?") $
                     modificationTime <$> getFileStatus fname
+getInputFileTime ctx arg = error $ "getInputFileTime: Invalid argument: " ++ show arg
+
 
 slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
 slurpWIPKeys stamp "" = ([],[])
@@ -763,14 +768,15 @@ parseSingleSpec "-"              = WorkingKeyMatch
 parseSingleSpec ""               = EmptyMatch
 parseSingleSpec ('t':':':tag)    = SubstringMatch (Just KeyTypeField) tag
 parseSingleSpec ('u':':':tag)    = SubstringMatch (Just UserIDField) tag
-parseSingleSpec ('c':':':tag)    = SubstringMatch (Just GroupIDField) tag
-parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
+-- parseSingleSpec ('c':':':tag)    = SubstringMatch (Just GroupIDField) tag
+parseSingleSpec ('f':'p':':':fp) = FingerprintMatch 0 fp
 parseSingleSpec str
-    | is40digitHex str = FingerprintMatch str
-    | otherwise        = SubstringMatch Nothing str
+    | Just 40 <- isHexDigits str = FingerprintMatch 4 str
+    | Just 64 <- isHexDigits str = FingerprintMatch 5 str
+    | otherwise                  = SubstringMatch Nothing str
 
-is40digitHex :: [Char] -> Bool
-is40digitHex xs = ys == xs && length ys==40
+isHexDigits :: [Char] -> Maybe Int
+isHexDigits xs = guard (ys == xs) >> Just (length ys)
       where
         ys = filter ishex xs
         ishex c | '0' <= c && c <= '9' = True
@@ -779,9 +785,9 @@ is40digitHex xs = ys == xs && length ys==40
         ishex c = False
 
 matchSpec :: KeySpec -> KeyData -> Bool
-matchSpec (KeyGrip grip) (KeyData p _ _ _)
-    | matchpr grip (packet p)==grip = True
-    | otherwise                     = False
+matchSpec (KeyFP ver grip) (KeyData p _ _ _)
+    = let mg = matchpr ver grip (packet p)
+        in mg == grip
 
 matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
  where
@@ -791,7 +797,7 @@ matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
                 && has_issuer key p
     has_issuer key p = isJust $ do
         issuer <- signature_issuer p
-        guard $ matchpr issuer key == issuer
+        guard $ matchpr 0 issuer key == issuer
     has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
                     || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
 
@@ -907,7 +913,7 @@ getHostnames (KeyData topmp _ uids subs) = Hostnames addr onames othernames Noth
 
 hasFingerDress :: KeyDB -> SockAddr -> Bool
 hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
-hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
+hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyFP 0 g',Nothing) db)
  where
     (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
     g' = map toUpper g
@@ -1012,6 +1018,7 @@ decode_btc_key timestamp str = do
                     ]
             , s2k_useage = 0
             , s2k = S2K 100 ""
+            , aead_algorithm = Nothing
             , symmetric_algorithm = Unencrypted
             , encrypted_data = ""
             , is_subkey = True
@@ -1205,6 +1212,7 @@ readSecretDNSFile fname = do
                             _ -> RSA
     case alg of
         RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
+        _ -> return $ error $ "readSecretDNSFile: " ++ show alg ++ " unimplemented."
 
 spemPacket :: SecretPEMData -> Maybe Packet
 spemPacket (PEMPacket p) = Just p
@@ -1310,6 +1318,7 @@ rsaToPGP stamp rsa = SecretKeyPacket
                 -- , ecc_curve = def
                 , s2k_useage = 0
                 , s2k = S2K 100 ""
+                , aead_algorithm = Nothing
                 , symmetric_algorithm = Unencrypted
                 , encrypted_data = ""
                 , is_subkey = True