From 7cfd556b8681d0675b1a7df127bbdbe4b7c7e9ff Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Tue, 15 Apr 2014 20:09:34 -0400
Subject: importing of PEM files

---
 KeyRing.hs | 113 +++++++++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 84 insertions(+), 29 deletions(-)

(limited to 'KeyRing.hs')

diff --git a/KeyRing.hs b/KeyRing.hs
index ced1994..52e8f67 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -15,6 +15,7 @@ import Data.List
 import Data.OpenPGP
 import Data.Functor
 import Data.Monoid
+import Data.Tuple             ( swap )
 import Data.Bits              ( (.|.) )
 import Control.Applicative    ( liftA2, (<$>) )
 import System.Directory       ( getHomeDirectory, doesFileExist )
@@ -77,6 +78,9 @@ data FileType = KeyRingFile PassWordFile | PEMFile UsageTag | WalletFile
 
 data RefType = ConstRef | MutableRef (Maybe Initializer)
 
+initializer (MutableRef x) = x
+initializer _              = Nothing
+
 
 data KeyRingRuntime = KeyRingRuntime
                         { rtPubring :: FilePath
@@ -96,6 +100,7 @@ data KeyRingData = KeyRingData
     , homeSpec :: Maybe String
     }
 
+resolveInputFile :: FilePath -> FilePath -> InputFile -> [FilePath]
 resolveInputFile secring pubring = resolve
  where
     resolve HomeSec = return secring
@@ -472,6 +477,44 @@ data KeySpec =
     | KeyUidMatch String
  deriving Show
 
+parseSpec :: String -> String -> (KeySpec,Maybe String)
+parseSpec grip spec = (topspec,subspec)
+ where
+     (topspec0,subspec0) = unprefix '/' spec
+     (toptyp,top) = unprefix ':' topspec0
+     (subtyp,sub) = unprefix ':' subspec0
+     topspec = case () of
+                    _ | null top && or [ subtyp=="fp"
+                                       , null subtyp && is40digitHex sub
+                                       ]
+                                 -> KeyGrip sub
+                    _ | null top && null grip -> KeyUidMatch sub
+                    _ | null top -> KeyGrip grip
+                    _ | toptyp=="fp" || (null toptyp && is40digitHex top)
+                                 -> {- trace "using top" $ -} KeyGrip top
+                    _ | toptyp=="u" -> KeyUidMatch top
+                    _ | otherwise -> KeyUidMatch top
+     subspec = case subtyp of
+                "t" -> Just sub
+                "fp" | top=="" -> Nothing
+                "" | top=="" && is40digitHex sub -> Nothing
+                "" -> listToMaybe sub >> Just sub
+
+     is40digitHex xs = ys == xs && length ys==40
+      where
+        ys = filter ishex xs
+        ishex c | '0' <= c && c <= '9' = True
+                | 'A' <= c && c <= 'F' = True
+                | 'a' <= c && c <= 'f' = True
+        ishex c = False
+
+     unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
+      where p = break (==c) spec
+
+
+filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
+filterMatches spec ks = filter (matchSpec spec) ks
+
 
 buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData
               -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)]))
@@ -494,31 +537,7 @@ buildKeyDB secring pubring grip0 keyring = do
 
         readw wk n = fmap (n,) (readPacketsFromWallet wk n)
 
-    ms <- mapM readp (files isring)
-    let grip = grip0 `mplus` (fingerprint <$> fstkey)
-          where
-            fstkey = listToMaybe $ mapMaybe isSecringKey ms 
-                      where isSecringKey (fn,Message ps)
-                                | fn==secring = listToMaybe ps
-                            isSecringKey _  = Nothing
-        db_rings = foldl' (uncurry . merge) Map.empty ms
-        wk = listToMaybe $ do
-                fp <- maybeToList grip
-                elm <- Map.toList db_rings
-                guard $ matchSpec (KeyGrip fp) elm
-                return $ keyPacket (snd elm)
-
-    wms <- mapM (readw wk) (files iswallet)
-    let wallet_keys = do
-            maybeToList wk
-            (fname,xs) <- wms
-            (_,sub,(_,m)) <- xs
-            (tag,top) <- Map.toList m
-            return (top,fname,sub,tag)
-
-        doDecrypt = todo
-
-        importWalletKey db' (top,fname,sub,tag) = do
+        importWalletKey wk db' (top,fname,sub,tag) = do
             try db' $ \(db',report0) -> do
             r <- doImportG doDecrypt 
                       db'
@@ -537,12 +556,48 @@ buildKeyDB secring pubring grip0 keyring = do
             try r $ \(db'',report) -> do
             return $ KikiSuccess (db'', report0 ++ report)
 
-    db <- foldM importWalletKey (KikiSuccess (db_rings,[])) wallet_keys
+        doDecrypt = todo
+
+    -- KeyRings (todo: KikiCondition reporting?)
+    (db_rings,wk,grip) <- do
+        ms <- mapM readp (files isring)
+        let grip = grip0 `mplus` (fingerprint <$> fstkey)
+              where
+                fstkey = listToMaybe $ mapMaybe isSecringKey ms 
+                          where isSecringKey (fn,Message ps)
+                                    | fn==secring = listToMaybe ps
+                                isSecringKey _  = Nothing
+            db_rings = foldl' (uncurry . merge) Map.empty ms
+
+            wk = listToMaybe $ do
+                    fp <- maybeToList grip
+                    elm <- Map.toList db_rings
+                    guard $ matchSpec (KeyGrip fp) elm
+                    return $ keyPacket (snd elm)
+        return (db_rings,wk,grip)
+
+    -- Wallets
+    wms <- mapM (readw wk) (files iswallet)
+    let wallet_keys = do
+            maybeToList wk
+            (fname,xs) <- wms
+            (_,sub,(_,m)) <- xs
+            (tag,top) <- Map.toList m
+            return (top,fname,sub,tag)
+    db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
     try db $ \(db,reportWallets) -> do
 
-    -- todo: import PEMFiles
-    let imports = todo
-    db <- foldM importPEMKey (KikiSuccess (db,[])) (map snd imports)
+    -- PEM files
+    let pems = do
+            (n,(rtyp,ftyp)) <- Map.toList $ kFiles keyring
+            grip <- maybeToList grip
+            (topspec,subspec) <- fmap (parseSpec grip) $ getUsage ftyp
+            n <- resolveInputFile secring pubring n
+            let ms = map fst $ filterMatches topspec (Map.toList db)
+                cmd = initializer rtyp
+            return (n,subspec,ms,cmd)
+    imports <- filterM (\(n,_,_,_) -> doesFileExist n) pems
+    db <- foldM importPEMKey (KikiSuccess (db,[])) imports
     try db $ \(db,reportPEMs) -> do
 
     return $ KikiSuccess ( (db, grip, wk), reportWallets ++ reportPEMs )
-- 
cgit v1.2.3