Better gpg-agent support.

1 files changed, 33 insertions, 110 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 313258d..e084fcd 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -23,6 +23,7 @@
 {-# LANGUAGE DoAndIfThenElse #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE LambdaCase #-}
 module KeyRing
     (
     -- * Error Handling
@@ -84,6 +85,7 @@ module KeyRing
     , accBindings
     , isSubkeySignature
     , torhash
+    , torUIDFromKey
     , ParsedCert(..)
     , parseCertBlob
     , packetFromPublicRSAKey
@@ -186,7 +188,7 @@ import Foreign.C.Error ( throwErrnoIfMinus1_ )
 import Foreign.Storable
 #endif
 import System.FilePath ( takeDirectory )
-import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr)
+import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr, hClose)
 import Data.IORef
 import System.Posix.IO ( fdToHandle )
 import qualified Data.Traversable as Traversable
@@ -624,14 +626,6 @@ usageString flgs =
 
 
 
--- matchpr computes the fingerprint of the given key truncated to
--- be the same lenght as the given fingerprint for comparison.
---
--- matchpr fp = Data.List.Extra.takeEnd (length fp)
---
-matchpr :: String -> Packet -> String
-matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
-
 keyFlags :: t -> [Packet] -> [SignatureSubpacket]
 keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
 
@@ -1181,7 +1175,7 @@ writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeF
 -}
 
 writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
-writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str
+writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h)  writeFile) str
 
 getInputFileTime :: InputFileContext -> InputFile -> IO CTime
 getInputFileTime ctx (Pipe fdr fdw) = do
@@ -1222,7 +1216,7 @@ generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
     if null subs
       then do
         newkey <- generateKey genparam
-        kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
+        kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
         try kdr $ \(newkd,report) -> do
         return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
       else do
@@ -1233,7 +1227,7 @@ importSecretKey ::
   (PacketTranscoder)
   -> KikiCondition
        (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
-  -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
+  -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
   -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
 importSecretKey transcode db' tup = do
             try db' $ \(db',report0) -> do
@@ -1345,10 +1339,6 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
         return $ map (first $ resolveForReport $ Just ctx) rs
     return $ concat rss
 
-isSecretKey :: Packet -> Bool
-isSecretKey (SecretKeyPacket {}) = True
-isSecretKey _                    = False
-
 -- | buildKeyDB
 --
 --   merge all keyrings, PEM files, and wallets into process memory.
@@ -1368,11 +1358,10 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
                                     )
                                    ,{- report_imports -} [(FilePath,KikiReportAction)]))
 buildKeyDB ctx grip0 keyring = do
-    let 
-        files istyp = do
+    let files istyp = do
             (f,stream) <- Map.toList (opFiles keyring)
             guard (istyp $ typ stream)
-            resolveInputFile ctx f
+            return f -- resolveInputFile ctx f
 
         ringMap0 = Map.filter (isring . typ) $ opFiles keyring
         (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
@@ -1392,7 +1381,7 @@ buildKeyDB ctx grip0 keyring = do
                                     _                                -> AutoAccess
                             acc -> acc
 
-        readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
+        readw wk n = fmap (n,) (readPacketsFromWallet wk n)
 
     -- KeyRings (todo: KikiCondition reporting?)
     (spilled,mwk,grip,accs,keyqs,unspilled) <- do
@@ -1418,69 +1407,17 @@ buildKeyDB ctx grip0 keyring = do
             -- | keys
             -- process ringPackets, and get a map of fingerprint info to 
             -- to a packet, remembering it's original file, access.
-            keys :: Map.Map KeyKey (MappedPacket,Map.Map String [Packet])
-            keys = Map.foldl slurpkeys Map.empty
-                        $ Map.mapWithKey filterSecrets ringPackets
-                    where
-                          filterSecrets :: InputFile -> (a,Message) -> [[MappedPacket]]
-                          filterSecrets f (_,Message ps)  = keygroups
-                            -- filter (isSecretKey . packet) mps
-                            where
-                              mps = zipWith (mappedPacketWithHint fname) ps [1..]
-                              fname = resolveForReport (Just ctx) f
-                              keygroups = dropWhile (not . isSecretKey . packet . head)
-                                          $ groupBy (const $ not . isSecretKey . packet) mps
-                          slurpkeys :: (Map.Map KeyKey (MappedPacket,Map.Map String [Packet]))
-                                        -> [[MappedPacket]]
-                                        -> (Map.Map KeyKey (MappedPacket,Map.Map String [Packet]))
-                          slurpkeys m pss = Map.unionWith combineKeyKey m m2
-                            where
-                                m2 :: Map.Map KeyKey (MappedPacket, (Map.Map String [Packet]))
-                                m2 = Map.fromList $ map build pss
-                                    where
-                                        build ps = (kk,(kp,uidmap ps'))
-                                         where
-                                            (kpkt,ps') = splitAt 1 ps
-                                            kp = head kpkt
-                                            kk = keykey . packet $ kp
-                                combineKeyKey (mp,um) (mp2,um2) = (mp,Map.unionWith (++) um um2)
-                                uidmap ps = um2
-                                 where
-                                    ugs = dropWhile (not . isUserID . packet .head) $ groupBy (const $ not . isUserID . packet) ps
-                                    um2 = Map.fromList
-                                            $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs
-            -- | mwk 
-            -- first master key matching the provided grip
-            -- (the m is for "MappedPacket", wk for working key)
-            mwk = fst <$> mwkq
-
-            main_query = fromMaybe (Query MarkerPacket "anonymous1" Nothing) $ snd <$> mwkq
-
-            keyqs :: Map.Map KeyKey (OriginMapped Query)
-            keyqs = fmap (\(mp,us) -> mp { packet = main_query { queryPacket = packet mp} }) keys
-
-            mwkq :: Maybe (MappedPacket,Query)
-            mwkq = listToMaybe $ do
-                    fp <- maybeToList grip
-                    let matchfp (mp,us)
-                         | not (is_subkey p) && matchpr fp p == fp = Just (mp,query p us)
-                         | otherwise                               = Nothing
-                            where p = packet mp
-                                  -- TODO: check signature on UID packet?
-                                  -- TODO: custom queries for subkeys?
-                                  query p us = Query p
-                                                     (fromMaybe "" $ listToMaybe $ Map.keys us)
-                                                     Nothing -- No subkey queries for now.
-                    Map.elems $ Map.mapMaybe matchfp keys
+            keys :: Map.Map KeyKey (OriginMapped Query)
+            mwk :: Maybe MappedPacket
+            (mwk, keys) = keyQueries grip ringPackets
 
             -- | accs
             -- file access(Sec | Pub) lookup table
             accs :: Map.Map InputFile Access
             accs = fmap (access . fst) ringPackets
-        return (spilled,mwk,grip,accs,keyqs,fmap snd unspilled)
+        return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
 
-    putStrLn $ ppShow keyqs
-    transcode <- makeMemoizingDecrypter keyring ctx keyqs
+    transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
     let doDecrypt = transcode (Unencrypted,S2K 100 "")
 
     let wk = fmap packet mwk
@@ -1548,7 +1485,6 @@ buildKeyDB ctx grip0 keyring = do
     let pems = do
             (n,stream) <- Map.toList $ opFiles keyring
             grip <- maybeToList grip
-            n <- resolveInputFile ctx n
             guard $ spillable stream && isSecretKeyFile (typ stream)
             let us = mapMaybe usageFromFilter [fill stream,spill stream]
             usage <- take 1 us
@@ -1559,7 +1495,10 @@ buildKeyDB ctx grip0 keyring = do
                 ms = map fst $ filterMatches topspec (Map.toList db)
                 cmd = initializer stream
             return (n,subspec,ms,stream, cmd)
-    imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
+
+    imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
+                              _                   -> return True)
+                       pems
     db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
     try db $ \(db,reportPEMs) -> do
 
@@ -1595,6 +1534,9 @@ generateInternals transcode mwk db gens = do
 torhash :: Packet -> String
 torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
 
+torUIDFromKey :: Packet -> String
+torUIDFromKey key = "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
+
 derToBase32 :: ByteString -> String
 derToBase32 = map toLower . base32 . sha1
  where
@@ -1827,19 +1769,19 @@ readSecretPEMFile fname = do
 doImport
   :: PacketTranscoder
      -> Map.Map KeyKey KeyData
-     -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
+     -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
      -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
 doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
     flip (maybe $ return CannotImportMasterKey)
          subspec $ \tag -> do
     (certs,keys) <- case typ of
         PEMFile -> do
-            ps <- readSecretPEMFile (ArgFile fname)
+            ps <- readSecretPEMFile fname
             let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
                     = partition (isJust . spemCert) ps
             return (certs,keys)
         DNSPresentation -> do
-            p <- readSecretDNSFile (ArgFile fname)
+            p <- readSecretDNSFile fname
             return ([],[p])
     -- TODO Probably we need to move to a new design where signature
     -- packets are merged into the database in one phase with null
@@ -1852,7 +1794,7 @@ doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
         try prior $ \(db,report) -> do
         let (m0,tailms) = splitAt 1 ms
         if (not (null tailms) || null m0)
-            then return $ AmbiguousKeySpec fname
+            then return $ AmbiguousKeySpec (resolveForReport Nothing fname)
             else do
                 let kk = keykey key
                     cs = filter (\c -> kk==keykey (pcertKey c)) certs
@@ -1872,7 +1814,7 @@ doImportG
      -> Map.Map KeyKey KeyData
      -> [KeyKey] -- m0,  only head is used
      -> [SignatureSubpacket] -- tags
-     -> FilePath
+     -> InputFile
      -> Packet
      -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
 doImportG transcode db m0 tags fname key = do
@@ -1881,13 +1823,16 @@ doImportG transcode db m0 tags fname key = do
     kdr <- insertSubkey transcode kk kd tags fname key
     try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
 
-insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do
+insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do
     let topcipher = symmetric_algorithm $ packet top
         tops2k    = s2k $ packet top
+        doDecrypt = transcode (Unencrypted,S2K 100 "")
+        fname = resolveForReport Nothing inputfile
+    wkun <- doDecrypt top
+    try wkun $ \wkun -> do
     key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0
     try key' $ \key -> do
     let subkk = keykey key
-        doDecrypt = transcode (Unencrypted,S2K 100 "")
         (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
                                                [])
                                  ( (False,) . addOrigin )
@@ -1903,7 +1848,7 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do
 
         istor = do
             guard ("tor" `elem` mapMaybe usage tags)
-            return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
+            return $ torUIDFromKey key
 
     uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
                 let has_torid = do
@@ -1913,9 +1858,6 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do
                          s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
                          signatures_over $ verify (Message [packet top]) s
                 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
-                wkun <- doDecrypt top
-
-                try wkun $ \wkun -> do
 
                 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
                     uid = UserIDPacket idstr
@@ -2482,7 +2424,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
                     guard $ case r of
                        ExternallyGeneratedFile -> True
                        _ -> False
-                    return (f,subspec,map fst ms,stream,cmd)
+                    return (ArgFile f,subspec,map fst ms,stream,cmd)
 
            try v $ \(db,import_rs) -> do
 
@@ -3143,25 +3085,6 @@ data KeyData = KeyData { keyMappedPacket :: MappedPacket    -- main key
 
 type KeyDB = Map.Map KeyKey KeyData
 
-origin :: Packet -> Int -> OriginFlags
-origin p n = OriginFlags ispub n
- where
-    ispub = case p of
-                    SecretKeyPacket {} -> False
-                    _                  -> True
-
-mappedPacket :: FilePath -> Packet -> MappedPacket
-mappedPacket filename p = MappedPacket
-    { packet = p
-    , locations = Map.singleton filename (origin p (-1))
-    }
-
-mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
-mappedPacketWithHint filename p hint = MappedPacket
-    { packet = p
-    , locations = Map.singleton filename (origin p hint)
-    }
-
 uidkey :: Packet -> String
 uidkey (UserIDPacket str) = str