From f4ae7656efe48845bd49cc62bfa050df0abfa148 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 5 Dec 2013 05:19:57 -0500 Subject: WIP: import/export secret keys --- kiki.hs | 382 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file 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 -- cgit v1.2.3