WIP: import/export secret keys

1 files changed, 369 insertions, 13 deletions

diff --git a/kiki.hs b/kiki.hs
index 26618c1..997ba3f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -126,7 +126,7 @@ RSAPrivateKey ::= SEQUENCE {
   privateExponent   INTEGER,  -- d
   prime1            INTEGER,  -- p
   prime2            INTEGER,  -- q
-  exponent1         INTEGER,  -- d mod (p1)
+  exponent1         INTEGER,  -- d mod (p1) -- ?? d mod (p-1)
   exponent2         INTEGER,  -- d mod (q-1)
   coefficient       INTEGER,  -- (inverse of q) mod p
   otherPrimeInfos   OtherPrimeInfos OPTIONAL
@@ -177,6 +177,7 @@ instance ASN1Object RSAPrivateKey where
     fromASN1 _ =
         Left "fromASN1: RSAPrivateKey: unexpected format"
 
+rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
 rsaKeyFromPacket p@(PublicKeyPacket {}) = do
     n <- lookup 'n' $ key p
     e <- lookup 'e' $ key p
@@ -186,10 +187,34 @@ rsaKeyFromPacket p@(SecretKeyPacket {}) = do
     e <- lookup 'e' $ key p
     return $ RSAKey n e
 rsaKeyFromPacket _ = Nothing
+
 derRSA rsa = do
     k <- rsaKeyFromPacket rsa
     return $ encodeASN1 DER (toASN1 k [])
 
+rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
+    -- public fields...
+    n <- lookup 'n' $ key pkt
+    e <- lookup 'e' $ key pkt
+    -- secret fields
+    MPI d <- lookup 'd' $ key pkt
+    MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped
+    MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped
+    coefficient <- lookup 'u' $ key pkt -- TODO: compute (inverse q) mod p
+    let dmodp1 = MPI $ d `mod` (p - 1)
+        dmodqminus1 = MPI $ d `mod` (q - 1)
+    return $ RSAPrivateKey 
+        { rsaN = n
+        , rsaE = e
+        , rsaD = MPI d
+        , rsaP = MPI p
+        , rsaQ = MPI q
+        , rsaDmodP1 = dmodp1
+        , rsaDmodQminus1 = dmodqminus1
+        , rsaCoefficient = coefficient }
+rsaPrivateKeyFromPacket _ = Nothing
+
+
 getPackets :: IO [Packet]
 getPackets = do
     input <- L.getContents
@@ -219,6 +244,17 @@ extractPEM typ pem = dta
     xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem)
     ys = takeWhile (/="-----END " <> typ <> "-----") xs
 
+writePEM typ dta = pem
+ where
+    pem = unlines . concat $
+            [ ["-----BEGIN " <> typ <> "-----"]
+            , split64s dta
+            , ["-----END " <> typ <> "-----"] ]
+    split64s "" = []
+    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
+
+    -- 64 byte lines
+
 isKey (PublicKeyPacket {}) = True
 isKey (SecretKeyPacket {}) = True
 isKey _                    = False
@@ -751,6 +787,20 @@ guessKeyFormat 'S' "ssh-client" = "PEM"
 guessKeyFormat 'S' "ssh-host"   = "PEM"
 guessKeyFormat _   _            = "PEM" -- "PGP"
 
+writeKeyToFile False "PEM" fname packet = do
+    flip (maybe (return ()))
+         (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
+        $ \rsa -> do
+    let asn1 = toASN1 rsa []
+        bs = encodeASN1 DER asn1
+        dta = Base64.encode (L.unpack bs)
+        output = writePEM "RSA PRIVATE KEY" dta
+        stamp = timestamp packet
+    writeFile fname output
+    -- TODO: set modificaiton time 
+    --       see UTIMENSAT(2)
+    --          utimensat or futimens
+
 readKeyFromFile False "PEM" fname = do
     timestamp <- modificationTime <$> getFileStatus fname
     input <- L.readFile fname
@@ -1140,6 +1190,245 @@ show_all db = do
     let Message packets = flattenKeys True db
     putStrLn $ listKeys packets
 
+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 && (subtyp=="fp" || (null subtyp && is40digitHex sub))
+                                 -> KeyGrip 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
+                "" -> Just sub
+
+insertSubKey tag key (Just (KeyData p sigs uids subs)) =
+    Just $ KeyData p sigs uids subs'
+ where
+    subs' = todo
+
+splitAtMinBy comp xs = minimumBy comp' xxs
+ where
+    xxs = zip (inits xs) (tails xs)
+    comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
+    compM (Just a) (Just b) = comp a b
+    compM Nothing  mb       = GT
+    compM _        _        = LT
+
+doExport doDecrypt db (fname,subspec,ms,cmd) =
+        case ms of
+            [_]   -> export
+            (_:_) -> ambiguous
+            []    -> shcmd
+ where
+    ambiguous = error "Key specification is ambiguous."
+    shcmd = do
+                --
+                --   does ms contain exactly one key?
+                --      yes -> export key
+                --      no  -> no keys?
+                --              no -> ambiguous error
+                --              yes -> cmd
+                --                     if error warn
+                --                     else need another pass
+        todo
+        return Nothing
+    export = do
+        let [(kk,KeyData key sigs uids subkeys)] = ms
+            p = flip (maybe (Just $ packet key)) subspec $ \tag -> do
+                  let subs = Map.elems subkeys
+                      doSearch (SubKey sub_mp sigtrusts) =
+                        let (_,v,_) = searchSubkeys tag
+                                          (packet key)
+                                          (packet sub_mp) 
+                                          sigtrusts
+                        in fmap fst v==Just True
+                  case filter doSearch subs of
+                    [SubKey mp _] -> Just $ packet mp
+                    [] -> Nothing
+                    _  -> ambiguous
+        flip (maybe shcmd) p $ \p -> do
+        pun <- doDecrypt p
+        flip (maybe shcmd) pun $ \pun -> do
+        warn $ "writing "++fname
+        writeKeyToFile False "PEM" fname pun
+        return db
+
+searchSubkeys tag wk subkey subsigs = (xs',minsig,ys')
+         where
+            vs = map (\sig ->
+                          (sig, do
+                                sig <- Just (packet . fst $ sig)
+                                guard (isSignaturePacket sig)
+                                guard $ flip isSuffixOf
+                                             (fingerprint wk)
+                                        . maybe "%bad%" id
+                                        . signature_issuer
+                                        $ sig
+                                listToMaybe $
+                                  map (signature_time . verify (Message [wk]))
+                                      (signatures $ Message [wk,subkey,sig])))
+                     subsigs
+            (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
+            xs' = map fst xs
+            ys' = map fst (drop 1 ys)
+            minsig = do
+                (sig,ov) <- listToMaybe ys
+                ov
+                let hs = filter (\p->isNotation p && notation_name p=="usage@")
+                                (hashed_subpackets . packet . fst $ sig)
+                    ks = map notation_value hs
+                    isNotation (NotationDataPacket {}) = True
+                    isNotation _ = False
+                return (tag `elem` ks, sig)
+
+doImport doDecrypt db (fname,subspec,ms,_) = do
+    let error s = do
+                        warn s
+                        exitFailure
+    flip (maybe $ error "Cannot import master key.")
+         subspec $ \tag -> do
+    Message parsedkey <- readKeyFromFile False "PEM" fname
+    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."
+    let (kk,KeyData top topsigs uids subs) = head m0
+    let subkk = keykey key
+        (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1))))
+                                               [])
+                                 (False,)
+                                 (Map.lookup subkk subs)
+    let SubKey subkey_p subsigs = subkey
+        wk = packet top
+        (xs',minsig,ys') = searchSubkeys tag wk key subsigs
+        doInsert mbsig db = do
+            sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
+            warn $ fname ++ ": new SignaturePacket"
+            let subs' = Map.insert subkk 
+                                   (SubKey subkey_p $ xs'++[sig']++ys')
+                                   subs
+            return $ Map.insert kk (KeyData top topsigs uids subs') db
+    when is_new (warn $ fname ++ ": new SecretKeyPacket")
+    case minsig of
+        Nothing          -> doInsert Nothing db    -- we need to create a new sig
+        Just (True,sig)  -> return db              -- we can deduce is_new == False
+        Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
+
+
+makeSig doDecrypt top fname subkey_p tag mbsig = do
+    let wk = packet top
+    wkun <- doDecrypt wk
+    flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do
+    g <- newGenIO :: IO SystemRandom
+    timestamp <- now
+    let grip = fingerprint wk
+        addOrigin new_sig = do
+            flip (maybe $ error "Failed to make signature.") 
+                 (listToMaybe $ signatures_over new_sig) 
+                 $ \new_sig -> do
+            let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1)))
+            return (mp', Map.empty)
+        newSig = do
+        let parsedkey = [packet $ subkey_p]
+            new_sig = fst $ sign (Message [wkun])
+                             (SubkeySignature wk
+                                              (head parsedkey)
+                                              (sigpackets 0x18
+                                                          hashed0
+                                                          ( IssuerPacket (fingerprint wk)
+                                                            : map EmbeddedSignaturePacket (signatures_over back_sig))))
+                             SHA1
+                             grip
+                             timestamp
+                             (g::SystemRandom)
+
+            hashed0 =
+                    [ KeyFlagsPacket
+                        { certify_keys = False
+                        , sign_data = False
+                        , encrypt_communication = False
+                        , encrypt_storage = False
+                        , split_key = False
+                        , authentication = True
+                        , group_key = False }
+                    , NotationDataPacket
+                        { human_readable = True
+                        , notation_name = "usage@"
+                        , notation_value = tag
+                        }
+                    , SignatureCreationTimePacket (fromIntegral timestamp)
+                    ]
+
+            subgrip = fingerprint (head parsedkey)
+
+            back_sig = fst $ sign (Message parsedkey)
+                             (SubkeySignature wk
+                                              (head parsedkey)
+                                              (sigpackets 0x19
+                                                          hashed0
+                                                          [IssuerPacket subgrip]))
+                             SHA1
+                             subgrip
+                             timestamp
+                             (g::SystemRandom)
+        addOrigin new_sig
+    flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
+    let sig = packet mp
+        isCreation (SignatureCreationTimePacket {}) = True
+        isCreation _ = False
+        isExpiration (SignatureExpirationTimePacket {}) = True
+        isExpiration _ = False
+        (cs,ps) = partition isCreation (hashed_subpackets sig)
+        (es,qs) = partition isExpiration ps
+        stamp = listToMaybe . sortBy (comparing Down) $
+                 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
+        exp = listToMaybe $ sort $
+                 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
+        expires = liftA2 (+) stamp exp
+    if fmap ( (< timestamp) . fromIntegral) expires == Just True then do
+        warn $ "Unable to update expired signature"
+        return (mp,trustmap)
+    else do
+        let new_sig = fst $ sign (Message [wkun])
+                                 (SubkeySignature wk
+                                    (packet subkey_p)
+                                     [sig'] )
+                             SHA1
+                             (fingerprint wk)
+                             timestamp
+                             (g::SystemRandom)
+            times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
+                        $ maybeToList $ do
+                            e <- expires
+                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
+            notation = NotationDataPacket
+                        { notation_name = "usage@"
+                        , notation_value = tag
+                        , human_readable = True }
+            sig' = sig { hashed_subpackets = times ++ [notation] ++ qs }
+        addOrigin new_sig
+
+signature_time ov = case if null cs then ds else cs of
+                                [] -> minBound
+                                xs -> last (sort xs)
+          where
+            ps = signatures_over ov
+            ss = filter isSignaturePacket ps
+            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
+            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
+            creationTime (SignatureCreationTimePacket t) = [t]
+            creationTime _                               = []
+
 main = do
     dotlock_init
     {-
@@ -1181,7 +1470,7 @@ main = do
                                   $ args'
                           appendArgs xs = Just . maybe xs (++xs)
     -- putStrLn $ "margs = " ++ show (Map.assocs margs)
-    let keypairs =
+    let keypairs0 =
             flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do
                 let (spec,efilecmd) = break (=='=') specfile
                 guard $ take 1 efilecmd=="="
@@ -1201,6 +1490,26 @@ main = do
                 Just (spec,file)
         keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs
         passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
+        decrypt wk = do
+            -- TODO: memoize?
+            pw <- case passphrase_fd of
+                    Just fd -> do pwh <- fdToHandle (read fd)
+                                  fmap trimCR $ S.hGetContents pwh
+                    Nothing -> return ""
+            let wkun = 
+                 if symmetric_algorithm wk == Unencrypted
+                    then Just wk
+                    else do
+                        k <- decryptSecretKey pw wk
+                        guard (symmetric_algorithm k == Unencrypted)
+                        return k
+            return wkun
+
+    when (not . null $ filter isNothing keypairs0) $ do
+        warn "syntax error"
+        exitFailure
+
+    let keypairs = catMaybes keypairs0
 
     (homedir,secring,pubring,grip0) <- getHomeDir ( concat <$> Map.lookup "--homedir" margs)
 
@@ -1235,6 +1544,41 @@ main = do
                                                    $ locations p
         use_db <- get_use_db
 
+        let pkeypairs = maybe [] id $ do
+                            g <- grip
+                            return $ map (\(spec,f,cmd)-> (parseSpec g spec,f,cmd)) keypairs
+        fs <- forM pkeypairs $ \((topspec,subspec),f,cmd) -> do
+            let ms = filterMatches topspec (Map.toList db)
+            f_found <- doesFileExist f
+            return (f_found,(f,subspec,ms,cmd))
+
+        let (imports,exports) = partition fst fs
+        use_db <- foldM (doImport decrypt) use_db (map snd imports)
+        ret_db <- foldM (doExport decrypt) (Just use_db) (map snd exports)
+        {-
+        forM_ pkeypairs $ \(spec,f,cmd) -> do
+            let ms = filterMatches spec (Map.toList db)
+                import_if_neccessary = todo
+                --   read file
+                --   is the key in ms?
+                --      yes -> continue
+                --      no  -> import key
+                --             need to write keyring files or remember imports
+                export_or_create = todo
+                --   does ms contain exactly one key?
+                --      yes -> export key
+                --      no  -> no keys?
+                --              no -> ambiguous error
+                --              yes -> cmd
+                --                     if error warn
+                --                     else need another pass
+            f_found <- doesFileExist f
+            if f_found
+                then import_if_neccessary
+                else export_or_create
+            return ()
+            -}
+
         let ret_db = Just use_db
 
         let shspec = Map.fromList [("--show-wk", show_wk secfile grip)
@@ -1703,17 +2047,6 @@ existingKey (prepk,pks) remainder wkun wk parsedkey tag pre uids subkeys output_
                                         ++ remainder
                             putStrLn $ "Adding usage@="++tag
                             L.writeFile output_file (encode (Message sec'))
-    where
-        signature_time ov = case if null cs then ds else cs of
-                                [] -> minBound
-                                xs -> last (sort xs)
-          where
-            ps = signatures_over ov
-            ss = filter isSignaturePacket ps
-            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
-            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
-            creationTime (SignatureCreationTimePacket t) = [t]
-            creationTime _                               = []
 
 newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do
         g <- newGenIO
@@ -1799,6 +2132,29 @@ isTopKey p@(SecretKeyPacket {}) | not (is_subkey p) = True
 isTopKey p@(PublicKeyPacket {}) | not (is_subkey p) = True
 isTopKey _ = False
 
+filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
+filterMatches spec ks = filter (matchSpec spec) ks
+
+matchSpec (KeyGrip grip) (_,KeyData p _ _ _) 
+    | matchpr grip (packet p)==grip = True
+    | otherwise                     = False
+
+matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps
+ where
+    ps = map (packet .fst) sigs
+    match p = isSignaturePacket p
+                && has_tag tag p
+                && has_issuer key p
+    has_issuer key p = isJust $ do
+        issuer <- signature_issuer p
+        guard $ matchpr issuer key == issuer
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us
+  where
+    us = filter (isInfixOf pat) $ Map.keys uids
+
 seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
 seek_key (KeyGrip grip) sec = (pre, subs)
   where