this compiles

6 files changed, 54 insertions, 42 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index cd69042..8c92a81 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -425,7 +425,7 @@ selectPublicKeyAndSigs (spec,mtag) db =
             : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
                   (Map.elems $ keySubKeys kd)
       where
-        ismatch (p,sigs) = matchpr g p ==g
+        ismatch (p,sigs) = matchpr' g p
     findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
 
     findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag
@@ -673,7 +673,7 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
                 workingKey grip use_db = listToMaybe $ do
                             fp <- maybeToList grip
                             elm <- keyData use_db
-                            guard $ matchSpec (KeyGrip fp) elm
+                            guard $ matchSpec (KeyGrip $ show fp) elm
                             return $ keyPacket elm
 
 mkarmor :: Access -> L.ByteString -> [Armor]
@@ -734,7 +734,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
                 case fill stream of
                     KF_Match usage -> do grip <- maybeToList $ rtGrip rt
                                          flattenTop f only_public
-                                            $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3
+                                            $ filterNewSubs f (parseSpec (Just grip) usage) d -- TODO: parseSpec3
                     _              -> flattenTop f only_public d
             new_packets = filter isnew x
                 where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
@@ -945,7 +945,7 @@ writePEMKeys doDecrypt db exports = do
 initializeMissingPEMFiles ::
     KeyRingOperation
       -> InputFileContext
-      -> Maybe String
+      -> Maybe Fingerprint
       -> Maybe MappedPacket
       -> PacketTranscoder
       -> KeyDB
@@ -974,7 +974,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
                 usage <- maybeToList mutableTag
                 -- TODO: Use parseSpec3
                 -- TODO: Report error if generating without specifying usage tag.
-                let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
+                let (topspec,subspec) = parseSpec grip usage
                     -- ms will contain duplicates if a top key has multiple matching
                     -- subkeys.  This is intentional.
                     -- ms =  map (keykey . fst) $ selectAll True (topspec,subspec) db
@@ -1026,7 +1026,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
            let internals = mapMaybe getParams $ do
                     (f,stream) <- nonexistents
                     usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream]
-                    let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
+                    let (topspec,subspec) = parseSpec grip usage
                     guard $ null $ do
                         (kk,kd) <- filterMatches topspec $ kkData db
                         subkeysForExport subspec kd
@@ -1071,7 +1071,7 @@ runKeyRing operation =
 
 withLockedKeyring :: Maybe FilePath
                            -> Map.Map InputFile StreamInfo
-                           -> (InputFileContext -> Maybe String -> IO (KikiResult a))
+                           -> (InputFileContext -> Maybe Fingerprint -> IO (KikiResult a))
                            -> IO (KikiResult a)
 withLockedKeyring homespec opfiles go = do
     -- get homedir and keyring files + fingerprint for working key
@@ -1099,7 +1099,7 @@ withLockedKeyring homespec opfiles go = do
     return ret
 
 
-realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe String -> IO (KikiResult KeyRingRuntime)
+realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe Fingerprint -> IO (KikiResult KeyRingRuntime)
 realRunKeyRing operation ctx grip0 = do
         bresult <- buildKeyDB ctx grip0 operation
         try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do
@@ -1163,7 +1163,7 @@ parseOptionFile fname = do
 --           , path to public ring
 --           , fingerprint of working key
 --           )
-getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String))
+getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe Fingerprint))
 getHomeDir protohome = do
         homedir <- envhomedir protohome
         flip (maybe (return CantFindHome))
@@ -1183,6 +1183,7 @@ getHomeDir protohome = do
         return $ val
 
     -- TODO: rename this to getGrip
+    getWorkingKey :: String -> IO (Maybe Fingerprint)
     getWorkingKey homedir = do
         let o = Nothing
             h = Just homedir
@@ -1196,5 +1197,6 @@ getHomeDir protohome = do
             \(forgive,fname) -> parseOptionFile fname
         let config = map (topair . words) args
                         where topair (x:xs) = (x,xs)
-        return $ lookup "default-key" config >>= listToMaybe
+        -- return $ lookup "default-key" config >>= listToMaybe
+        return Nothing
 
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 461afa2..510c820 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -83,9 +83,9 @@ newtype IPsToWriteToHostsFile = IPsToWriteToHostsFile [SockAddr]
 --
 --   merge all keyrings, PEM files, and wallets into process memory.
 --
-buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
+buildKeyDB :: InputFileContext -> Maybe Fingerprint -> KeyRingOperation
               -> IO (KikiCondition (({- db        -} KeyDB
-                                    ,{- grip      -} Maybe String
+                                    ,{- grip      -} Maybe Fingerprint
                                     ,{- wk        -} Maybe MappedPacket
                                     ,{- hs        -} ({- hostdbs0 -}[Hosts.Hosts],
                                                       {- hostdbs  -}[Hosts.Hosts],
@@ -128,7 +128,8 @@ buildKeyDB ctx grip0 keyring = do
         ringPackets <- Map.traverseWithKey readp ringMap
         let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
 
-        let grip = grip0 `mplus` (show . fingerprint <$> fstkey)
+        let grip :: Maybe Fingerprint
+            grip = grip0 `mplus` (fingerprint <$> fstkey)
               where
                 fstkey = do
                     (_,Message ps) <- Map.lookup HomeSec ringPackets
@@ -223,7 +224,7 @@ buildKeyDB ctx grip0 keyring = do
             guard $ all (==usage) $ drop 1 us
             -- TODO: KikiCondition reporting for spill/fill usage mismatch?
             -- TODO: parseSpec3
-            let (topspec,subspec) = parseSpec grip usage
+            let (topspec,subspec) = parseSpec (Just grip) usage
                 ms = map fst $ filterMatches topspec (kkData db)
                 cmd = initializer stream
             return (n,subspec,ms,stream, cmd)
@@ -408,16 +409,16 @@ usageFromFilter _                = mzero
 
 -- | Parse a key specification.
 -- The first argument is a grip for the default working key.
-parseSpec :: Fingerprint -> String -> (KeySpec,Maybe String)
+parseSpec :: Maybe Fingerprint -> String -> (KeySpec,Maybe String)
 parseSpec wkgrip spec =
     if not slashed
         then
             case prespec of
                 AnyMatch                               -> (KeyGrip "", 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                        -> (KeyGrip $ show wkgrip, Nothing)
+                SubstringMatch (Just KeyTypeField) tag -> (KeyGrip $ show wkgrip, Just tag)
+                SubstringMatch Nothing str             -> (KeyGrip $ show wkgrip, Just str)
                 SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
                 FingerprintMatch fp                    -> (KeyGrip fp, Nothing)
         else
@@ -780,8 +781,8 @@ is40digitHex xs = ys == xs && length ys==40
 
 matchSpec :: KeySpec -> KeyData -> Bool
 matchSpec (KeyGrip grip) (KeyData p _ _ _)
-    | matchpr grip (packet p)==grip = True
-    | otherwise                     = False
+    | matchpr' grip (packet p) = True
+    | otherwise                = False
 
 matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
  where
@@ -791,7 +792,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' issuer key
     has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
                     || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
 
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
index 1177789..1a12a61 100644
--- a/lib/KeyRing/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE PatternSynonyms   #-}
@@ -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 Fingerprint
     -- ^ Non-Nothing value reserved for future use.
     -- (TODO: Use this to implement per-key passphrase associations).
     , passSpecPassFile :: InputFile
@@ -129,6 +130,9 @@ data PassphraseSpec = PassphraseSpec
     | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder }
     | PassphraseAgent
 
+deriving instance Ord Fingerprint
+deriving instance Eq Fingerprint
+
 instance Show PassphraseSpec where
     show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
     show (PassphraseMemoizer _) = "PassphraseMemoizer"
@@ -350,14 +354,19 @@ isTrust _                = False
 -- matchpr fp = Data.List.Extra.takeEnd (length fp)
 --
 matchpr :: Fingerprint -> Packet -> Bool
-matchpr fp k = p == show fp
-  where
-    p = reverse $ zipWith const (reverse (show $ fingerprint k)) (show fp)
+matchpr fp k = matchpr' (show fp) k
 
+matchpr' :: String -> Packet -> Bool
+matchpr' fp k = p == fp
+  where
+    p = reverse $ zipWith const (reverse (show $ fingerprint k)) fp
 
+matchpr'' :: String -> Packet -> String
+matchpr'' fp k | matchpr' fp k = fp
+matchpr'' fp k | otherwise = ""
 
 data KeySpec =
-      KeyGrip Fingerprint  -- fp:
+      KeyGrip String       -- fp:
     | KeyTag Packet String -- fp:????/t:
     | KeyUidMatch String   -- u:
  deriving Show
@@ -428,8 +437,8 @@ seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
 seek_key (KeyGrip grip) sec = (pre, subs)
   where
     (pre,subs) = break pred sec
-    pred p@(SecretKeyPacket {}) = matchpr grip p
-    pred p@(PublicKeyPacket {}) = matchpr grip p
+    pred p@(SecretKeyPacket {}) = matchpr' grip p
+    pred p@(PublicKeyPacket {}) = matchpr' grip p
     pred _                      = False
 
 seek_key (KeyTag key tag) ps
@@ -442,7 +451,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' (fromJust $ signature_issuer p) key)
                     ps
     (rs,qs) = break isKey (reverse as)
 
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 9934aaa..523c8c4 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -554,9 +554,9 @@ writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> MyIdentity -> IO ()
 writePublicKeyFiles rt fw myId@(MyIdentity _ grip) = do
 
     -- Finally, export public keys if they do not exist.
-    either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt)
-    either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt)
-    either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
+    either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" (Just grip) (rtKeyDB rt)
+    either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" (Just grip) (rtKeyDB rt)
+    either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" (Just grip) (rtKeyDB rt) pemFromPacket
 
     let cs          = listPeers rt
         known_hosts = L.concat $ map getSshKnownHosts $ cs
@@ -615,10 +615,10 @@ pemFromPacket k = do
     return $
         writePEM PemPublicKey qq -- ("TODO "++show keyspec)
 
-show_pem :: String -> String -> KeyDB -> IO ()
+show_pem :: String -> Maybe Fingerprint -> KeyDB -> IO ()
 show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket
 
-show_pem' :: String -> String -> KeyDB -> (Packet -> Either String b) -> Either String b
+show_pem' :: String -> Maybe Fingerprint -> KeyDB -> (Packet -> Either String b) -> Either String b
 show_pem' keyspec wkgrip db keyfmt = do
     let s = parseSpec wkgrip keyspec
     flip (maybe . Left $ keyspec ++ ": not found")
@@ -628,17 +628,17 @@ show_pem' keyspec wkgrip db keyfmt = do
 warn :: String -> IO ()
 warn str = hPutStrLn stderr str
 
-show_sshfp :: String -> String -> KeyDB -> IO ()
+show_sshfp :: String -> Maybe Fingerprint -> KeyDB -> IO ()
 show_sshfp keyspec wkgrip db = do
     let s = parseSpec wkgrip keyspec
     case selectPublicKey s db of
         Nothing -> hPutStrLn stderr $ keyspec ++ ": not found"
         Just k  -> Char8.putStrLn $ sshKeyToHostname k
 
-show_ssh :: String -> String -> KeyDB -> IO ()
+show_ssh :: String -> Maybe Fingerprint -> KeyDB -> IO ()
 show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db
 
-show_ssh' :: String -> Fingerprint -> KeyDB -> Either String String
+show_ssh' :: String -> Maybe Fingerprint -> KeyDB -> Either String String
 show_ssh' keyspec wkgrip db = do
     let s = parseSpec wkgrip keyspec
     flip (maybe . Left $ keyspec ++ ": not found")
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
index 759d83f..b24f3d2 100644
--- a/lib/PacketTranscoder.hs
+++ b/lib/PacketTranscoder.hs
@@ -113,7 +113,7 @@ interpretPassSpec ctx _ PassphraseSpec { passSpecPassFile = fd
         cachedContents (Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n")
                        ctx
                        fd
-    let matchkey fp mp = matchpr fp (packet mp) == fp
+    let matchkey fp mp = matchpr fp (packet mp)
         matchfile file mp = Map.member file (locations mp)
         specializers = [ fmap matchkey keyspec, fmap matchfile inputfile]
         specialize alg mp =
@@ -268,7 +268,7 @@ makeMemoizingDecrypter passwdspec ctx (workingkey,keys) = do
 
     trans unkeysRef = transcodeWithCache unkeysRef (foldr (makeTranscoder unkeysRef) (\_ _ -> return BadPassphrase) srcs)
 
-keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query))
+keyQueries :: Maybe Fingerprint -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query))
 keyQueries grip ringPackets = (mwk, fmap makeQuery keys)
  where
     makeQuery (maink,mp,us) = mp { packet = q }
@@ -291,8 +291,8 @@ keyQueries grip ringPackets = (mwk, fmap makeQuery keys)
     mwk = listToMaybe $ do
             fp <- maybeToList grip
             let matchfp mp
-                 | not (is_subkey p) && matchpr fp p == fp = Just mp
-                 | otherwise                               = Nothing
+                 | not (is_subkey p) && matchpr fp p = Just mp
+                 | otherwise                         = Nothing
                     where p = packet mp
             Map.elems $ Map.mapMaybe matchfp $ fmap (\(_,p,_) -> p) $ keys
 
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 8a1da73..f55bcc5 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -44,7 +44,7 @@ import Data.Bits              ((.|.), (.&.), Bits)
 data KeyRingRuntime = KeyRingRuntime
     { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub'
     , rtSecring :: FilePath -- ^ Path to the file represented by 'HomeSec'
-    , rtGrip    :: Maybe String
+    , rtGrip    :: Maybe Fingerprint
                             -- ^ Fingerprint or portion of a fingerprint used
                             -- to identify the working GnuPG identity used to
                             -- make signatures.