writePEMKeys

1 files changed, 102 insertions, 16 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index c595d77..3268070 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -9,6 +9,7 @@ module KeyRing where
 import System.Environment
 import Control.Monad
 import Data.Maybe
+import Data.Either
 import Data.Char
 import Data.Ord
 import Data.List
@@ -84,6 +85,9 @@ data FileType = KeyRingFile PassWordFile
 
 data RefType = ConstRef | MutableRef (Maybe Initializer)
 
+isMutable (MutableRef {}) = True
+isMutable _               = False
+
 initializer (MutableRef x) = x
 initializer _              = Nothing
 
@@ -236,7 +240,7 @@ data KikiCondition a = KikiSuccess a
     | BadPassphrase
     | FailedToMakeSignature
     | CantFindHome
-    | AmbiguousKeySpec
+    | AmbiguousKeySpec FilePath
     | CannotImportMasterKey
  deriving ( Functor, Show )
 
@@ -266,6 +270,9 @@ keyPacket (KeyData k _ _ _) = packet k
 
 keyMappedPacket (KeyData k _ _ _) = k
 
+subkeyPacket (SubKey k _ ) = packet k
+subkeyMappedPacket (SubKey k _ ) = k
+
 
 usage (NotationDataPacket
         { human_readable = True
@@ -544,6 +551,20 @@ selectKey0 wantPublic (spec,mtag) db = do
         zs = snd $ seek_key subspec ys1
     listToMaybe zs
 
+selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
+selectAll wantPublic (spec,mtag) db = do
+    let Message ps = flattenKeys wantPublic db
+        ys = snd $ seek_key spec ps
+    y <- take 1 ys
+    case mtag of
+        Nothing -> return (y,Nothing)
+        Just tag -> 
+            let search ys1 = do
+                    let zs = snd $ seek_key (KeyTag y tag) ys1
+                    z <- take 1 zs
+                    (y,Just z):search (drop 1 zs)
+            in search (drop 1 ys)
+
 seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
 seek_key (KeyGrip grip) sec = (pre, subs)
   where
@@ -747,7 +768,7 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
          (listToMaybe parsedkey) $ \key -> do
     let (m0,tailms) = splitAt 1 ms
     if (not (null tailms) || null m0)
-        then return AmbiguousKeySpec
+        then return $ AmbiguousKeySpec fname
         else doImportG doDecrypt db m0 tag fname key
 
 doImportG
@@ -919,8 +940,6 @@ writeRingKeys krd db wk secring pubring = do
     let ks = Map.elems db
         isring (KeyRingFile {}) = True
         isring _                = False
-        isMutable (MutableRef {}) = True
-        isMutable _               = False
         fs = do
             (f,(rtyp,ftyp)) <- Map.toList (kFiles krd)
             guard (isring ftyp)
@@ -960,6 +979,49 @@ writeRingKeys krd db wk secring pubring = do
     return $ KikiSuccess report
 
 
+{-
+getSubkeysForExport kk subspec db = do
+    kd <- maybeToList $ Map.lookup kk db
+    subkeysForExport subspec kd
+-}
+
+subkeysForExport subspec (KeyData key _ _ subkeys) = do
+    let subs tag = do
+            e <- Map.elems subkeys
+            guard $ doSearch key tag e
+            return $ subkeyPacket e
+    maybe [packet key] subs subspec
+ where
+    doSearch key tag (SubKey sub_mp sigtrusts) =
+        let (_,v,_) = findTag tag
+                          (packet key)
+                          (packet sub_mp) 
+                          sigtrusts
+        in fmap fst v==Just True
+
+writePEMKeys :: KeyDB
+                -> [(FilePath,Maybe String,[Packet],Maybe Initializer)]
+                -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writePEMKeys db exports = do
+    ds <- mapM decryptKeys exports
+    let ds' = map functorToEither ds
+    if null (lefts ds')
+        then do
+            rs <- mapM (uncurry $ writeKeyToFile False "PEM")
+                       (rights ds')
+            return $ KikiSuccess (concat rs)
+        else do
+            return (head $ lefts ds')
+ where
+    doDecrypt = todo
+    writeKeyToFile = todo -- writeKeyToFile False "PEM" fname pun
+
+    decryptKeys (fname,subspec,[p],_) = do
+        pun <- doDecrypt p
+        flip (maybe $ return BadPassphrase) pun $ \pun -> do
+        return $ KikiSuccess (fname,pun)
+
+
 runKeyRing :: KeyRingData -> IO (KikiResult KeyRingRuntime)
 runKeyRing keyring = do
     homedir <- getHomeDir (homeSpec keyring)
@@ -999,17 +1061,39 @@ runKeyRing keyring = do
                      f <- resolveInputFile secring pubring f
                      return (f,t)
 
-
-         -- create nonexistent files via external commands
-         externals_ret <- do
-            let cmds = do
+         let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
                  (fname,(rtyp,ftyp)) <- nonexistents
-                 cmd <- maybeToList (initializer rtyp)
+                 guard $ isMutable rtyp
                  (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip)
                                         $ getUsage ftyp
-                 let ms = map fst $ filterMatches topspec (Map.toList db)
-                 guard $ isNothing $ selectPublicKey (topspec,subspec) db
-                 return (fname,subspec,ms,cmd)
+                 -- ms will contain duplicates if a top key has multiple matching
+                 -- subkeys.  This is intentional.
+                 let -- ms =  map (keykey . fst) $ selectAll True (topspec,subspec) db
+                     -- ms = filterMatches topspec $ Map.toList db
+                     ns = do
+                        (kk,kd) <- filterMatches topspec $ Map.toList db
+                        return (kk , subkeysForExport subspec kd)
+                 return (fname,subspec,ns,initializer rtyp)
+             (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
+                                              notmissing
+             exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0
+
+
+             ambiguity (f,topspec,subspec,_) = do
+                return $ KikiResult (AmbiguousKeySpec f) []
+
+             ifnotnull (x:xs) f g = f x
+             ifnotnull _      f g = g
+
+         ifnotnull ambiguous ambiguity $ do
+
+         -- create nonexistent files via external commands
+         externals_ret <- do
+            let cmds = mapMaybe getcmd missing
+                  where
+                    getcmd (fname,subspec,ms,mcmd) = do
+                        cmd <- mcmd
+                        return (fname,subspec,ms,cmd)
             rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do
                 e <- systemEnv [ ("file",fname)
                                , ("usage",maybe "" id subspec) ]
@@ -1019,11 +1103,11 @@ runKeyRing keyring = do
                   ExitSuccess     -> return (tup,ExternallyGeneratedFile)
 
             v <- foldM importPEMKey (KikiSuccess (db,[])) $ do
-                     (tup,r) <- rs
+                     ((f,subspec,ms,cmd),r) <- rs
                      guard $ case r of
                         ExternallyGeneratedFile -> True
                         _ -> False
-                     return tup
+                     return (f,subspec,map fst ms,cmd)
 
             try v $ \(db,import_rs) -> do
             return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs
@@ -1037,7 +1121,8 @@ runKeyRing keyring = do
          r <- writeRingKeys keyring db wk secring pubring
          try' r $ \report_rings -> do
 
-         -- todo writePEMKeys
+         r <- writePEMKeys db exports
+         try' r $ \report_pems -> do
 
          let rt = KeyRingRuntime
                         { rtPubring = pubring
@@ -1049,7 +1134,8 @@ runKeyRing keyring = do
                     $ concat [ report_imports
                              , report_externals
                              , report_wallets
-                             , report_rings ]
+                             , report_rings
+                             , report_pems ]
 
     forM_ lked $ \(Just lk, fname) -> dotlock_release lk