2 files changed, 76 insertions, 39 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
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
index af213ce..dbcc22c 100644
--- a/lib/KeyRing/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -13,6 +13,7 @@ import           Data.Maybe (maybeToList,isJust,fromJust,mapMaybe)
 import           Data.OpenPGP
 import           Data.OpenPGP.Util
 import           Data.Time.Clock
+import           Data.Word
 import           FunctorToMaybe
 import qualified Data.ByteString.Lazy as L
 import qualified System.Posix.Types as Posix
@@ -119,7 +120,7 @@ data PassphraseSpec = PassphraseSpec
     { passSpecRingFile :: Maybe FilePath
     -- ^ If not Nothing, the passphrase is to be used for packets
     -- from this file.
-    , passSpecKeySpec :: Maybe String
+    , passSpecKeySpec :: Maybe KeySpec
     -- ^ Non-Nothing value reserved for future use.
     -- (TODO: Use this to implement per-key passphrase associations).
     , passSpecPassFile :: InputFile
@@ -132,9 +133,12 @@ data PassphraseSpec = PassphraseSpec
 instance Show PassphraseSpec where
     show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
     show (PassphraseMemoizer _) = "PassphraseMemoizer"
+    show PassphraseAgent        = "PassphraseAgent"
 instance Eq PassphraseSpec where
     PassphraseSpec a b c == PassphraseSpec d e f
         = and [a==d,b==e,c==f]
+    PassphraseAgent == PassphraseAgent
+        = True
     _ == _
         = False
 
@@ -152,10 +156,13 @@ instance Ord PassphraseSpec where
     compare (PassphraseSpec a b c) (PassphraseSpec d e f)
         | fmap (const ()) a == fmap (const ()) d
           && fmap (const ()) b == fmap (const ()) e       = compare (a,b,c) (d,e,f)
-    compare (PassphraseSpec (Just _) (Just _) _)  _       = LT
-    compare (PassphraseSpec Nothing (Just _) _) _         = LT
-    compare (PassphraseSpec (Just _) _  _) _              = LT
-    compare PassphraseAgent _                             = GT
+    compare (PassphraseSpec (Just _) (Just _) _) _        = LT
+    compare (PassphraseSpec Nothing  (Just _) _) _        = LT
+    compare (PassphraseSpec (Just _) _        _) _        = LT
+    compare PassphraseAgent                      _        = GT
+    compare (PassphraseSpec Nothing Nothing _) (PassphraseSpec _ _ _) = GT
+    compare (PassphraseSpec Nothing Nothing _) (PassphraseMemoizer _) = GT
+    compare (PassphraseSpec Nothing Nothing _) PassphraseAgent        = LT
 
 data Transform =
         Autosign
@@ -349,17 +356,35 @@ isTrust _                = False
 --
 -- matchpr fp = Data.List.Extra.takeEnd (length fp)
 --
-matchpr :: String -> Packet -> String
-matchpr fp k = reverse $ zipWith const (reverse (show $ fingerprint k)) fp
+matchpr :: Word8 -> String -> Packet -> String
+matchpr ver fp k =
+    let (rev,v) = case ver of
+                    4 -> (reverse, 4)
+                    5 -> (id, 5)
+                    _ -> case auto_fp_version k of
+                            5 -> (id, 5)
+                            v -> (reverse, v)
+    in rev $ zipWith const (rev (show $ fingerprintv v k)) fp
 
 
 
 
 data KeySpec =
-      KeyGrip String       -- fp:
+      KeyFP { fpVer     :: Word8  -- 5 or 4 to select fingerprint style, 0 to match either.
+            , fpPartial :: String -- partial fingerprint, matches trailing for 4, or leading for 5
+            }              -- fp:
     | KeyTag Packet String -- fp:????/t:
     | KeyUidMatch String   -- u:
- deriving Show
+ deriving (Show,Eq)
+
+instance Ord KeySpec where
+    compare (KeyFP av af) (KeyFP bv bf) = compare (av,af) (bv,bf)
+    compare (KeyTag ap a) (KeyTag bp b) = compare (fingerprint ap,a) (fingerprint bp,b)
+    compare (KeyUidMatch a) (KeyUidMatch b) = compare a b
+    compare (KeyFP {})  _ = LT
+    compare (KeyTag {}) _ = LT
+    compare _           _ = GT
+
 
 {-
 RSAPrivateKey ::= SEQUENCE {
@@ -400,9 +425,9 @@ data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
 data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
  deriving (Show,Eq)
 
-data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
+data MatchingField = KeyTypeField | UserIDField deriving (Show,Eq,Ord,Enum)
 
-data SingleKeySpec = FingerprintMatch String
+data SingleKeySpec = FingerprintMatch Word8 String
                    | SubstringMatch (Maybe MatchingField) String
                    | EmptyMatch
                    | AnyMatch
@@ -423,12 +448,15 @@ secretToPublic pkt@(SecretKeyPacket {}) =
                     }
 secretToPublic pkt = pkt
 
+matchKeySpec :: KeySpec -> Packet -> Bool
+matchKeySpec spec pkt = not $ null $ snd $ seek_key spec [pkt]
+
 seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
-seek_key (KeyGrip grip) sec = (pre, subs)
+seek_key (KeyFP ver grip) sec = (pre, subs)
   where
     (pre,subs) = break pred sec
-    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
-    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
+    pred p@(SecretKeyPacket {}) = matchpr ver grip p == grip
+    pred p@(PublicKeyPacket {}) = matchpr ver grip p == grip
     pred _                      = False
 
 seek_key (KeyTag key tag) ps
@@ -441,7 +469,7 @@ seek_key (KeyTag key tag) ps
     (as,bs) = break (\p -> isSignaturePacket p
                         && has_tag tag p
                         && isJust (signature_issuer p)
-                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
+                        && matchpr (version p) (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
                     ps
     (rs,qs) = break isKey (reverse as)