moved doImport to KeyRing.hs

2 files changed, 123 insertions, 116 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index b738a25..e3d41d8 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -14,6 +14,7 @@ import Data.Ord
 import Data.List
 import Data.OpenPGP
 import Data.Functor
+import Data.Monoid
 import Data.Bits              ( (.|.) )
 import Control.Applicative    ( liftA2, (<$>) )
 import System.Directory       ( getHomeDirectory, doesFileExist )
@@ -27,15 +28,16 @@ import ControlMaybe ( handleIO_ )
 import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
        , ASN1(Start,End,IntVal,OID,BitString), ASN1ConstructionType(Sequence) )
 import Data.ASN1.BitArray ( BitArray(..), toBitArray )
-import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1' )
+import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
 import Data.ASN1.BinaryEncoding ( DER(..) )
 import Data.Time.Clock.POSIX ( getPOSIXTime )
 import qualified Data.Map as Map
-import qualified Data.ByteString.Lazy as L ( null, readFile, writeFile, ByteString, toChunks )
+import qualified Data.ByteString.Lazy as L ( pack, null, readFile, writeFile, ByteString, toChunks )
 import qualified Data.ByteString      as S ( unpack, splitAt, concat, cons )
-import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break ) 
+import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break, concat, lines )
 import qualified Crypto.Types.PubKey.ECC as ECC
 import qualified Codec.Binary.Base32 as Base32
+import qualified Codec.Binary.Base64 as Base64
 import qualified Crypto.Hash.SHA1 as SHA1
 import qualified Data.Text as T ( Text, unpack, pack,
         strip, reverse, drop, break, dropAround )
@@ -168,12 +170,59 @@ data RSAPrivateKey = RSAPrivateKey
     }
  deriving Show
 
+instance ASN1Object RSAPrivateKey where
+    toASN1 rsa@(RSAPrivateKey {})
+        = \xs -> Start Sequence
+               : IntVal 0
+               : mpiVal rsaN
+               : mpiVal rsaE
+               : mpiVal rsaD
+               : mpiVal rsaP
+               : mpiVal rsaQ
+               : mpiVal rsaDmodP1
+               : mpiVal rsaDmodQminus1
+               : mpiVal rsaCoefficient
+               : End Sequence
+               : xs
+                  where mpiVal f = IntVal x where MPI x = f rsa
+
+    fromASN1 ( Start Sequence
+             : IntVal _ -- version
+             : IntVal n
+             : IntVal e
+             : IntVal d
+             : IntVal p
+             : IntVal q
+             : IntVal dmodp1
+             : IntVal dmodqminus1
+             : IntVal coefficient
+             : ys) =
+        Right ( privkey, tail $ dropWhile notend ys)
+         where
+            notend (End Sequence) = False
+            notend _              = True
+            privkey = RSAPrivateKey
+                { rsaN = MPI n
+                , rsaE = MPI e
+                , rsaD = MPI d
+                , rsaP = MPI p
+                , rsaQ = MPI q
+                , rsaDmodP1 = MPI dmodp1
+                , rsaDmodQminus1 = MPI dmodqminus1
+                , rsaCoefficient = MPI coefficient
+                }
+    fromASN1 _ =
+        Left "fromASN1: RSAPrivateKey: unexpected format"
+
+
 
 data KikiCondition a = KikiSuccess a
     | FailedToLock [FilePath]
     | BadPassphrase
     | FailedToMakeSignature
     | CantFindHome
+    | AmbiguousKeySpec
+    | CannotImportMasterKey
  deriving ( Functor, Show )
 
 instance FunctorToMaybe KikiCondition where
@@ -479,6 +528,10 @@ buildKeyDB secring pubring grip0 keyring = do
 
     db <- foldM importWalletKey (KikiSuccess (db_rings,[])) wallet_keys
     try db $ \(db,report) -> do
+
+    -- todo: import PEMFiles
+    -- use_db <- foldM (doImport decrypt) use_db0 (map snd imports)
+
     return $ KikiSuccess ( (db, grip, wk), report )
 
 torhash key = maybe "" id $ derToBase32 <$> derRSA key
@@ -495,6 +548,73 @@ try x body =
            Left e -> return e
            Right x -> body x
 
+readKeyFromFile False "PEM" fname = do
+    -- warn $ fname ++ ": reading ..."
+    -- Note: The key's timestamp is included in it's fingerprint.
+    --       Therefore, we should attempt to preserve it.
+    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
+                    modificationTime <$> getFileStatus fname
+    input <- L.readFile fname
+    let dta = extractPEM "RSA PRIVATE KEY" input
+    -- Char8.putStrLn $ "dta = " <> dta
+    let rsa = do
+           e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta)
+           asn1 <- either (const Nothing) Just e
+           k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
+           let _ = k :: RSAPrivateKey
+           return k
+    -- putStrLn $ "rsa = "++ show rsa
+    return . Message $ do
+        rsa <- maybeToList rsa
+        return $ SecretKeyPacket
+            { version = 4
+            , timestamp = toEnum (fromEnum timestamp)
+            , key_algorithm = RSA
+            , key = [ -- public fields...
+                     ('n',rsaN rsa)
+                    ,('e',rsaE rsa)
+                    -- secret fields
+                    ,('d',rsaD rsa)
+                    ,('p',rsaQ rsa) -- Note: p & q swapped
+                    ,('q',rsaP rsa) -- Note: p & q swapped
+                    ,('u',rsaCoefficient rsa)
+                    ]
+            -- , ecc_curve = def
+            , s2k_useage = 0
+            , s2k = S2K 100 ""
+            , symmetric_algorithm = Unencrypted
+            , encrypted_data = ""
+            , is_subkey = True
+            }
+readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
+
+extractPEM typ pem = dta
+ where
+    dta = case ys of
+            _:dta_lines -> Char8.concat dta_lines
+            []          -> ""
+    xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem)
+    ys = takeWhile (/="-----END " <> typ <> "-----") xs
+
+
+doImport
+  :: Ord k =>
+     (Packet -> IO (KikiCondition Packet))
+     -> Map.Map k KeyData
+     -> ([Char], Maybe [Char], [k], t)
+     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
+doImport doDecrypt db (fname,subspec,ms,_) = do
+    let fetchkey = readKeyFromFile False "PEM" fname
+    flip (maybe $ return CannotImportMasterKey)
+         subspec $ \tag -> do
+    Message parsedkey <- fetchkey
+    flip (maybe $ return $ KikiSuccess (db,[]))
+         (listToMaybe parsedkey) $ \key -> do
+    let (m0,tailms) = splitAt 1 ms
+    if (not (null tailms) || null m0)
+        then return AmbiguousKeySpec
+        else doImportG doDecrypt db m0 tag fname key
+
 doImportG
   :: Ord k =>
      (Packet -> IO (KikiCondition Packet))
diff --git a/kiki.hs b/kiki.hs
index 66e3e4f..b23e304 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -110,50 +110,6 @@ RSAPrivateKey ::= SEQUENCE {
 }
 -}
 
-instance ASN1Object RSAPrivateKey where
-    toASN1 rsa@(RSAPrivateKey {})
-        = \xs -> Start Sequence
-               : IntVal 0
-               : mpiVal rsaN
-               : mpiVal rsaE
-               : mpiVal rsaD
-               : mpiVal rsaP
-               : mpiVal rsaQ
-               : mpiVal rsaDmodP1
-               : mpiVal rsaDmodQminus1
-               : mpiVal rsaCoefficient
-               : End Sequence
-               : xs
-                  where mpiVal f = IntVal x where MPI x = f rsa
-
-    fromASN1 ( Start Sequence
-             : IntVal _ -- version
-             : IntVal n
-             : IntVal e
-             : IntVal d
-             : IntVal p
-             : IntVal q
-             : IntVal dmodp1
-             : IntVal dmodqminus1
-             : IntVal coefficient
-             : ys) =
-        Right ( privkey, tail $ dropWhile notend ys)
-         where
-            notend (End Sequence) = False
-            notend _              = True
-            privkey = RSAPrivateKey
-                { rsaN = MPI n
-                , rsaE = MPI e
-                , rsaD = MPI d
-                , rsaP = MPI p
-                , rsaQ = MPI q
-                , rsaDmodP1 = MPI dmodp1
-                , rsaDmodQminus1 = MPI dmodqminus1
-                , rsaCoefficient = MPI coefficient
-                }
-    fromASN1 _ =
-        Left "fromASN1: RSAPrivateKey: unexpected format"
-
 sshrsa :: Integer -> Integer -> Char8.ByteString
 sshrsa e n = runPut $ do
     putWord32be 7
@@ -212,14 +168,6 @@ getPackets = do
 -}
 
 
-extractPEM typ pem = dta
- where
-    dta = case ys of
-            _:dta_lines -> Char8.concat dta_lines
-            []          -> ""
-    xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem)
-    ys = takeWhile (/="-----END " <> typ <> "-----") xs
-
 writePEM typ dta = pem
  where
     pem = unlines . concat $
@@ -682,46 +630,6 @@ writeKeyToFile False "PEM" fname packet =
         return ()
     algo -> warn $ fname ++ ": unable to export "++show algo++" key "++fingerprint packet
 
-readKeyFromFile False "PEM" fname = do
-    -- warn $ fname ++ ": reading ..."
-    -- Note: The key's timestamp is included in it's fingerprint.
-    --       Therefore, we should attempt to preserve it.
-    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
-                    modificationTime <$> getFileStatus fname
-    input <- L.readFile fname
-    let dta = extractPEM "RSA PRIVATE KEY" input
-    -- Char8.putStrLn $ "dta = " <> dta
-    let rsa = do
-           e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta)
-           asn1 <- either (const Nothing) Just e
-           k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
-           let _ = k :: RSAPrivateKey
-           return k
-    -- putStrLn $ "rsa = "++ show rsa
-    return . Message $ do
-        rsa <- maybeToList rsa
-        return $ SecretKeyPacket
-            { version = 4
-            , timestamp = toEnum (fromEnum timestamp)
-            , key_algorithm = RSA
-            , key = [ -- public fields...
-                     ('n',rsaN rsa)
-                    ,('e',rsaE rsa)
-                    -- secret fields
-                    ,('d',rsaD rsa)
-                    ,('p',rsaQ rsa) -- Note: p & q swapped
-                    ,('q',rsaP rsa) -- Note: p & q swapped
-                    ,('u',rsaCoefficient rsa)
-                    ]
-            -- , ecc_curve = def
-            , s2k_useage = 0
-            , s2k = S2K 100 ""
-            , symmetric_algorithm = Unencrypted
-            , encrypted_data = ""
-            , is_subkey = True
-            }
-readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
-
 readPublicKey :: Char8.ByteString -> RSAPublicKey
 readPublicKey bs = maybe er id $ do
     let (pre,bs1) = Char8.splitAt 7 bs
@@ -1164,27 +1072,6 @@ doBTCImport doDecrypt db (ms,subspec,content) = do
         $ error "Key specification is ambiguous."
     doImportG doDecrypt db m0 tag "" key
 
-doImport
-  :: Ord k =>
-     (Packet -> IO (Maybe Packet))
-     -> Map.Map k KeyData
-     -> ([Char], Maybe [Char], [k], t)
-     -> IO (Map.Map k KeyData)
-doImport doDecrypt db (fname,subspec,ms,_) = do
-    let fetchkey = readKeyFromFile False "PEM" fname
-    let error s = do
-                        warn s
-                        exitFailure
-    flip (maybe $ error "Cannot import master key.")
-         subspec $ \tag -> do
-    Message parsedkey <- fetchkey
-    flip (maybe $ return db)
-         (listToMaybe parsedkey) $ \key -> do
-    let (m0,tailms) = splitAt 1 ms
-    when (not (null tailms) || null m0)
-        $ error "Key specification is ambiguous."
-    doImportG doDecrypt db m0 tag fname key
-
 -- We return into IO in case we want to make a signature here.
 setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
 setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =