Work in progress toward cross-merge interface.

1 files changed, 52 insertions, 151 deletions

diff --git a/kiki.hs b/kiki.hs
index c1e6aea..1ea014d 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -53,6 +53,11 @@ import System.Posix.Files
 import Data.Monoid ((<>))
 -- import Data.X509
 import qualified Data.Map as Map
+import DotLock
+import System.IO (hPutStrLn,stderr)
+
+
+warn str = hPutStrLn stderr str
 
 unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
  where p = break (==c) spec
@@ -556,7 +561,21 @@ readPacketsFromFile fname = do
         Right (_,_,msg ) -> msg
         Left  (_,_,_)    -> Message []
 
-readPacketsFromFile' n = fmap (n,) (readPacketsFromFile n)
+lockFiles fs = do
+    let dolock f = do
+            lk <- dotlock_create f 0
+            let fail = return Nothing
+                dotake lk = do
+                    e <- dotlock_take lk (-1)
+                    if e==0 then return (Just lk)
+                            else fail
+            v <- maybe fail dotake lk
+            return (v,f)
+    ls <- mapM dolock fs
+    let (lks, fails) = partition (isJust . fst) ls
+    return (map (\(lk,f)->(fromJust lk,f)) lks, map snd fails)
+    
+unlockFiles lks = forM_ lks $ \lk -> dotlock_release lk
 
 parseOptionFile fname = do
     xs <- fmap lines (readFile fname)
@@ -765,41 +784,6 @@ readKeyFromFile False "PEM" fname = do
             }
 readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
 
-data Arguments = 
-        List { homedir :: Maybe FilePath }
-        | WorkingKey { homedir :: Maybe FilePath }
-        | AutoSign { homedir :: Maybe FilePath
-                   , passphrase_fd :: Maybe Int
-                   , input :: FilePath
-                   , output :: FilePath}
-        | Public { homedir :: Maybe FilePath
-                 , output :: FilePath}
-        | Add { homedir :: Maybe FilePath
-              , passphrase_fd :: Maybe Int
-              , key_usage :: String
-              , seckey :: String 
-              , output :: FilePath }
-        | PemFP { homedir :: Maybe FilePath
-                , seckey :: String }
-        | CatPub { homedir :: Maybe FilePath
-                 , catpub_args :: [String] }
-        | MergeSecrets 
-                 { homedir :: Maybe FilePath
-                 , files :: [FilePath]
-                 }
-        | Merge { homedir :: Maybe FilePath
-                 , files :: [FilePath]
-                 }
-        | DumpPackets { homedir :: Maybe FilePath
-                      , marshal_test :: String
-                      , files :: [FilePath] }
-        {-
-        | Decrypt { homedir :: Maybe FilePath
-                  , passphrase_fd :: Maybe Int
-                  , output :: FilePath }
-        -}
-  deriving (Show, Data, Typeable)
-
 getPassphrase cmd = 
          case passphrase_fd cmd of
                 Just fd -> do pwh <- fdToHandle (toEnum fd)
@@ -972,96 +956,27 @@ flattenKeys isPublic db = Message $ concatMap flattenTop (prefilter . Map.assocs
                  where isSecret (_,(KeyData (SecretKeyPacket {}) _ _ _)) = True
                        isSecret _                                        = False
 
-{-
-merge db (Message ps) = scanl mergeit db qs
- where
-    qs = scanPackets ps
-    mergeit db (top,sub,p) = todo
-      where
-        k = keykey top
-        v = maybe (merge1 (newrec top)) (merge2 sub p) $ Map.lookup k db
-
-        keykey key = fingerprint_material key -- TODO: smaller key?
+writeOutKeyrings db = return () -- TODO
 
-        newrec key | isKey key && not (is_subkey key) = 
-            KeyData key [] Map.empty Map.empty
-        newrec _ = error "Unexpected packet."
+data Arguments = 
+        Cross_Merge { homedir :: Maybe FilePath
+                    , passphrase_fd :: Maybe Int
+                    , files :: [FilePath]
+                    }
+  deriving (Show, Data, Typeable)
 
-        merge1 rec db = Map.insert k rec db
 
-        merge2 sub p (KeyData mk sigs uids subkeys)
-            | isKey sub = 
-                maybe todo todo $ Map.lookup skey subkeys
-          where
-            skey = keykey sub
--}
 
 main = do
+    dotlock_init
     args <- cmdArgs $ modes 
-        [ List HOMEOPTION
-            &= help "List key pairs in the secret keyring."
-            &= auto
-        , WorkingKey HOMEOPTION
-            &= help "Shows the current working key set that will be used to make signatures."
-        , Public HOMEOPTION
-                 (def &= argPos 1 &= typFile )
-            &= help "Extract public keys into the given file."
-        , AutoSign HOMEOPTION 
-                   (def &= opt ("passphrase"::String) 
-                        &= typ "FD"
-                        &= (help . concat) ["file descriptor from "
-                                           ,"which to read passphrase"])
-                   (def &= argPos 1 &= typFile ) 
-                   (def &=argPos 2 &= typFile) 
-            &= (help . concat)
-                    [ "Copies the first file to the second while adding"
-                    , " signatures for tor-style uids that match"
-                    , " cross-certified keys." ]
-        {-
-        , Decrypt HOMEOPTION
+        [ Cross_Merge HOMEOPTION
               (def &= opt ("passphrase"::String) 
-                   &= typ "FD"
-                   &= (help . concat) ["file descriptor from "
-                                      ,"which to read passphrase"])
-              (def &= argPos 1 &= typFile ) 
-              -- (def &= argPos 3 &= typ "PUBLIC-KEY")
-            &= (help . concat)
-                    [ "Remove password protection from the working keyring" 
-                    , " and save the result into the given file."]
-        -}
-        , CatPub HOMEOPTION
-              (def &= args &= typ "KEYSPEC FILES")
-            &= help "Extract a public subkey to stdout."
-        , MergeSecrets HOMEOPTION
+                &= typ "FD"
+                &= (help . concat)  ["file descriptor from "
+                                    ,"which to read passphrase"])
               (def &= args &= typFile)
             &= help "Merge multiple secret keyrings to stdout."
-        , Merge HOMEOPTION
-              (def &= args &= typFile)
-            &= help "Merge multiple keyrings to stdout.  Secrets are filtered."
-        , DumpPackets HOMEOPTION
-              (def &= opt ("n" ::String))
-              (def &= args &= typFile)
-            &= help "Output secret ring packets in ascii format for debugging."
-        , Add HOMEOPTION
-              (def &= opt ("passphrase"::String) 
-                   &= typ "FD"
-                   &= (help . concat) ["file descriptor from "
-                                      ,"which to read passphrase"])
-              (def &= argPos 1 &= typ "USAGE") 
-              (def &= argPos 2 &= typ "PRIVATE-KEY")
-              (def &= argPos 3 &= typFile)
-              -- (def &= argPos 3 &= typ "PUBLIC-KEY")
-            &= (help . concat)
-                    [ "Add a subkey."
-                    , "  USAGE is the usage@ annotation of the subkey."
-                    , "  Keys are specified as FMT:FILE where"
-                    , " FMT may be one of following: PEM." 
-                    , "  Results are written to the given file." ]
-
-        , PemFP HOMEOPTION
-                (def &= argPos 1 &= typFile )
-            &= (help . concat)
-                    [ "Display the fingerprint of a PEM key pair."]
         ]
         &= program "kiki"
         &= summary "kiki - a pgp key editing utility"
@@ -1086,9 +1001,10 @@ main = do
              homedir $ \homedir -> do
         -- putStrLn $ "homedir = " ++show homedir
         let secring = homedir ++ "/" ++ "secring.gpg"
+            pubring = homedir ++ "/" ++ "pubring.gpg"
         -- putStrLn $ "secring = " ++ show secring
         workingkey <- getWorkingKey homedir
-        return (homedir,secring,workingkey)
+        return (homedir,secring,pubring,workingkey)
 
     getWorkingKey homedir = do
         let o = Nothing
@@ -1107,7 +1023,7 @@ main = do
         return $ lookup "default-key" config >>= listToMaybe
 
     getPGPEnviron cmd = do
-        (homedir,secring,grip) <- getHomeDir cmd
+        (homedir,secring,pubring,grip) <- getHomeDir cmd
         (Message sec) <- readPacketsFromFile secring
         let (keys,_) = partition (\k -> case k of 
                                    { SecretKeyPacket {} -> True 
@@ -1192,6 +1108,7 @@ main = do
 
         ys = uid:sigs'++xs''
 
+    {-
     doCmd cmd@(List {}) = do
         (homedir,secring,grip) <- getHomeDir cmd
         (Message sec) <- readPacketsFromFile secring
@@ -1268,28 +1185,6 @@ main = do
             bs = encode (Message pub)
         L.writeFile (output cmd) bs
 
-    {-
-    doCmd cmd@(Decrypt {}) = do
-        ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
-          , sec   -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
-          , grip  -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
-          ) <- getPGPEnviron cmd
-        pw <- getPassphrase cmd
-
-        let sec' = map decrypt sec
-            decrypt k@(SecretKeyPacket {}) = k -- TODO
-
-        L.writeFile (output cmd) (encode $ Message sec')
-
-        {-
-        let wk = grip >>= find_key fingerprint (Message sec)
-        case wk of
-          Nothing -> error "No working key?"
-          Just wk -> do
-            putStrLn $ "wk = " ++ fingerprint wk
-        -}
-    -}
-
     doCmd cmd@(DumpPackets {}) = do
         ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
           , sec   -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
@@ -1317,18 +1212,23 @@ main = do
         L.putStr (encode m)
         return ()
 
-    doCmd cmd@(Merge {}) = do
-        ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
-          , sec   -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
-          , grip  -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
-          ) <- getPGPEnviron cmd
-        let db = merge Map.empty "%secring" (Message sec)
-        ms <- mapM readPacketsFromFile' (files cmd)
-        let db' = foldl' (uncurry . merge) db ms
-            m = flattenKeys True db'
-        L.putStr (encode m)
+    -}
+
+    doCmd cmd@(Cross_Merge {}) = do
+        (homedir,secring,pubring,grip0) <- getHomeDir cmd
+        -- grip0 may be empty, in which case we should use the first key
+        (fsns,failed_locks) <- lockFiles (secring:pubring:files cmd)
+        forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f
+        let (lks,fs) = unzip fsns
+        forM_ fs $ \f -> warn $ "locked: " ++ f
+        let readp n = fmap (n,) (readPacketsFromFile n)
+        ms <- mapM readp fs
+        let db = foldl' (uncurry . merge) Map.empty ms
+        writeOutKeyrings db
+        unlockFiles lks
         return ()
 
+    {-
     doCmd cmd@(CatPub {}) = do
         let spec:files = catpub_args cmd
         let (topspec,subspec) = unprefix '/' spec
@@ -1458,6 +1358,7 @@ main = do
         -- let torhash sub = maybe "" id $ derToBase32 <$> derRSA sub
         putStrLn $ fingerprint (head seckey) -- ++ " " ++ torhash (head seckey)
 
+    -}
 
 isSameKey a b = sort (key apub) == sort (key bpub)
  where