summaryrefslogtreecommitdiff
path: root/lib/KeyRing.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2016-08-28 03:16:07 -0400
committerjoe <joe@jerkface.net>2016-08-28 03:16:07 -0400
commit83e97b86973fc63eda92f5b38c112f0d374503c0 (patch)
treea36851ead54c2da03b3a9d9d112c117a9fee2f12 /lib/KeyRing.hs
parent7c024e8b1545666915d7eb313098e6015974c164 (diff)
Basic gpg-agent support.
Diffstat (limited to 'lib/KeyRing.hs')
-rw-r--r--lib/KeyRing.hs157
1 files changed, 120 insertions, 37 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index ae2d14d..a055dad 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -47,7 +47,8 @@ module KeyRing
47 , KeyFilter(..) 47 , KeyFilter(..)
48 -- * Results of a KeyRing Operation 48 -- * Results of a KeyRing Operation
49 , KeyRingRuntime(..) 49 , KeyRingRuntime(..)
50 , MappedPacket(..) 50 , OriginMapped(..)
51 , MappedPacket
51 , KeyDB 52 , KeyDB
52 , KeyData(..) 53 , KeyData(..)
53 , SubKey(..) 54 , SubKey(..)
@@ -209,6 +210,7 @@ import Base58
209import FunctorToMaybe 210import FunctorToMaybe
210import DotLock 211import DotLock
211import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) 212import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
213import GnuPGAgent as Agent
212 214
213-- DER-encoded elliptic curve ids 215-- DER-encoded elliptic curve ids
214-- nistp256_id = 0x2a8648ce3d030107 216-- nistp256_id = 0x2a8648ce3d030107
@@ -429,6 +431,7 @@ data PassphraseSpec = PassphraseSpec
429 } 431 }
430 -- | Use this to carry pasphrases from a previous run. 432 -- | Use this to carry pasphrases from a previous run.
431 | PassphraseMemoizer PacketTranscoder 433 | PassphraseMemoizer PacketTranscoder
434 | PassphraseAgent
432 435
433instance Show PassphraseSpec where 436instance Show PassphraseSpec where
434 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) 437 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
@@ -1433,6 +1436,9 @@ doesInputFileExist ctx f = do
1433-} 1436-}
1434 1437
1435 1438
1439-- | Reads contents of an 'InputFile' or returns the cached content from a prior call.
1440-- An optional prompt is provided and will be printed on stdout only in the case that
1441-- the provided 'InputFile' is 'FileDesc' 0 (i.e. stdin).
1436cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) 1442cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
1437cachedContents maybePrompt ctx fd = do 1443cachedContents maybePrompt ctx fd = do
1438 ref <- newIORef Nothing 1444 ref <- newIORef Nothing
@@ -1637,7 +1643,7 @@ buildKeyDB ctx grip0 keyring = do
1637 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) 1643 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
1638 1644
1639 -- KeyRings (todo: KikiCondition reporting?) 1645 -- KeyRings (todo: KikiCondition reporting?)
1640 (spilled,mwk,grip,accs,keys,unspilled) <- do 1646 (spilled,mwk,grip,accs,keyqs,unspilled) <- do
1641#if MIN_VERSION_containers(0,5,0) 1647#if MIN_VERSION_containers(0,5,0)
1642 ringPackets <- Map.traverseWithKey readp ringMap 1648 ringPackets <- Map.traverseWithKey readp ringMap
1643#else 1649#else
@@ -1660,32 +1666,69 @@ buildKeyDB ctx grip0 keyring = do
1660 -- | keys 1666 -- | keys
1661 -- process ringPackets, and get a map of fingerprint info to 1667 -- process ringPackets, and get a map of fingerprint info to
1662 -- to a packet, remembering it's original file, access. 1668 -- to a packet, remembering it's original file, access.
1663 keys :: Map.Map KeyKey MappedPacket 1669 keys :: Map.Map KeyKey (MappedPacket,Map.Map String [Packet])
1664 keys = Map.foldl slurpkeys Map.empty 1670 keys = Map.foldl slurpkeys Map.empty
1665 $ Map.mapWithKey filterSecrets ringPackets 1671 $ Map.mapWithKey filterSecrets ringPackets
1666 where 1672 where
1667 filterSecrets f (_,Message ps) = 1673 filterSecrets :: InputFile -> (a,Message) -> [[MappedPacket]]
1668 filter (isSecretKey . packet) 1674 filterSecrets f (_,Message ps) = keygroups
1669 $ zipWith (mappedPacketWithHint fname) ps [1..] 1675 -- filter (isSecretKey . packet) mps
1670 where fname = resolveForReport (Just ctx) f 1676 where
1671 slurpkeys m ps = m `Map.union` Map.fromList ps' 1677 mps = zipWith (mappedPacketWithHint fname) ps [1..]
1672 where ps' = zip (map (keykey . packet) ps) ps 1678 fname = resolveForReport (Just ctx) f
1679 keygroups = dropWhile (not . isSecretKey . packet . head)
1680 $ groupBy (const $ not . isSecretKey . packet) mps
1681 slurpkeys :: (Map.Map KeyKey (MappedPacket,Map.Map String [Packet]))
1682 -> [[MappedPacket]]
1683 -> (Map.Map KeyKey (MappedPacket,Map.Map String [Packet]))
1684 slurpkeys m pss = Map.unionWith combineKeyKey m m2
1685 where
1686 m2 :: Map.Map KeyKey (MappedPacket, (Map.Map String [Packet]))
1687 m2 = Map.fromList $ map build pss
1688 where
1689 build ps = (kk,(kp,uidmap ps'))
1690 where
1691 (kpkt,ps') = splitAt 1 ps
1692 kp = head kpkt
1693 kk = keykey . packet $ kp
1694 combineKeyKey (mp,um) (mp2,um2) = (mp,Map.unionWith (++) um um2)
1695 uidmap ps = um2
1696 where
1697 ugs = dropWhile (not . isUserID . packet .head) $ groupBy (const $ not . isUserID . packet) ps
1698 um2 = Map.fromList
1699 $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs
1673 -- | mwk 1700 -- | mwk
1674 -- first master key matching the provided grip 1701 -- first master key matching the provided grip
1675 -- (the m is for "MappedPacket", wk for working key) 1702 -- (the m is for "MappedPacket", wk for working key)
1676 mwk :: Maybe MappedPacket 1703 mwk = fst <$> mwkq
1677 mwk = listToMaybe $ do 1704
1705 main_query = fromMaybe (Query MarkerPacket "anonymous1" Nothing) $ snd <$> mwkq
1706
1707 keyqs :: Map.Map KeyKey (OriginMapped Query)
1708 keyqs = fmap (\(mp,us) -> mp { packet = main_query { queryPacket = packet mp} }) keys
1709
1710 mwkq :: Maybe (MappedPacket,Query)
1711 mwkq = listToMaybe $ do
1678 fp <- maybeToList grip 1712 fp <- maybeToList grip
1679 let matchfp mp = not (is_subkey p) && matchpr fp p == fp 1713 let matchfp (mp,us)
1714 | not (is_subkey p) && matchpr fp p == fp = Just (mp,query p us)
1715 | otherwise = Nothing
1680 where p = packet mp 1716 where p = packet mp
1681 Map.elems $ Map.filter matchfp keys 1717 -- TODO: check signature on UID packet?
1718 -- TODO: custom queries for subkeys?
1719 query p us = Query p
1720 (fromMaybe "" $ listToMaybe $ Map.keys us)
1721 Nothing -- No subkey queries for now.
1722 Map.elems $ Map.mapMaybe matchfp keys
1723
1682 -- | accs 1724 -- | accs
1683 -- file access(Sec | Pub) lookup table 1725 -- file access(Sec | Pub) lookup table
1684 accs :: Map.Map InputFile Access 1726 accs :: Map.Map InputFile Access
1685 accs = fmap (access . fst) ringPackets 1727 accs = fmap (access . fst) ringPackets
1686 return (spilled,mwk,grip,accs,keys,fmap snd unspilled) 1728 return (spilled,mwk,grip,accs,keyqs,fmap snd unspilled)
1687 1729
1688 transcode <- makeMemoizingDecrypter keyring ctx keys 1730 putStrLn $ ppShow keyqs
1731 transcode <- makeMemoizingDecrypter keyring ctx keyqs
1689 let doDecrypt = transcode (Unencrypted,S2K 100 "") 1732 let doDecrypt = transcode (Unencrypted,S2K 100 "")
1690 1733
1691 let wk = fmap packet mwk 1734 let wk = fmap packet mwk
@@ -1707,6 +1750,9 @@ buildKeyDB ctx grip0 keyring = do
1707 r <- performManipulations doDecrypt rt1 mwk manip 1750 r <- performManipulations doDecrypt rt1 mwk manip
1708 try r $ \(rt2,report) -> do 1751 try r $ \(rt2,report) -> do
1709 return $ KikiSuccess (report,rtKeyDB rt2) 1752 return $ KikiSuccess (report,rtKeyDB rt2)
1753 -- XXX: Unspilled keys are not obtainable from rtKeyDB.
1754 -- If the working key is marked non spillable, then how
1755 -- would we look up it's UID and such?
1710#if MIN_VERSION_containers(0,5,0) 1756#if MIN_VERSION_containers(0,5,0)
1711 in fmap sequenceA $ Map.traverseWithKey trans spilled 1757 in fmap sequenceA $ Map.traverseWithKey trans spilled
1712#else 1758#else
@@ -2544,7 +2590,7 @@ writePEMKeys doDecrypt db exports = do
2544 return $ KikiSuccess (fname,stream,pun) 2590 return $ KikiSuccess (fname,stream,pun)
2545 2591
2546makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext 2592makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
2547 -> Map.Map KeyKey MappedPacket 2593 -> Map.Map KeyKey (OriginMapped Query)
2548 -> IO PacketTranscoder 2594 -> IO PacketTranscoder
2549makeMemoizingDecrypter operation ctx keys = do 2595makeMemoizingDecrypter operation ctx keys = do
2550 if null chains then do 2596 if null chains then do
@@ -2555,12 +2601,14 @@ makeMemoizingDecrypter operation ctx keys = do
2555 -- FilePath? 2601 -- FilePath?
2556 -- pws :: Map.Map FilePath (IO S.ByteString) 2602 -- pws :: Map.Map FilePath (IO S.ByteString)
2557 {- 2603 {-
2604 -- This disabled code obtained password sources from StreamInfo records.
2558 pws <- 2605 pws <-
2559 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) 2606 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
2560 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above 2607 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
2561 $ Map.filter (isJust . pwfile . typ) $ opFiles operation) 2608 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
2562 -} 2609 -}
2563 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" 2610 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
2611 -- List of file-specific password sources.
2564 pws2 <- 2612 pws2 <-
2565 Traversable.mapM (cachedContents prompt ctx) 2613 Traversable.mapM (cachedContents prompt ctx)
2566 $ Map.fromList $ mapMaybe 2614 $ Map.fromList $ mapMaybe
@@ -2568,55 +2616,80 @@ makeMemoizingDecrypter operation ctx keys = do
2568 guard $ isNothing $ passSpecKeySpec spec 2616 guard $ isNothing $ passSpecKeySpec spec
2569 passSpecRingFile spec) 2617 passSpecRingFile spec)
2570 passspecs 2618 passspecs
2619 -- List of general password sources.
2571 defpw <- do 2620 defpw <- do
2572 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) 2621 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
2573 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) 2622 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
2574 && isNothing (passSpecKeySpec sp)) 2623 && isNothing (passSpecKeySpec sp))
2575 $ opPassphrases operation 2624 $ passspecs
2576 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) 2625 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
2577 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw 2626 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec)
2578 else let PassphraseMemoizer f = head chains 2627 else let PassphraseMemoizer f = head chains
2579 in return f 2628 in return f
2580 where 2629 where
2581 (chains,passspecs) = partition isChain $ opPassphrases operation 2630 (chains,passspecs0) = partition isChain $ opPassphrases operation
2582 where isChain (PassphraseMemoizer {}) = True 2631 where isChain (PassphraseMemoizer {}) = True
2583 isChain _ = False 2632 isChain _ = False
2633 (agentspec,passspecs) = partition isAgent $ opPassphrases operation
2634 where isAgent PassphraseAgent = True
2635 isAgent _ = False
2584 doDecrypt :: IORef (Map.Map KeyKey Packet) 2636 doDecrypt :: IORef (Map.Map KeyKey Packet)
2585 -> Map.Map FilePath (IO S.ByteString) 2637 -> Map.Map FilePath (IO S.ByteString)
2586 -> Maybe (IO S.ByteString) 2638 -> Maybe (IO S.ByteString)
2639 -> Bool
2587 -> (SymmetricAlgorithm,S2K) 2640 -> (SymmetricAlgorithm,S2K)
2588 -> MappedPacket 2641 -> MappedPacket
2589 -> IO (KikiCondition Packet) 2642 -> IO (KikiCondition Packet)
2590 doDecrypt unkeysRef pws defpw (dest_alg,dest_s2k) mp0 = do 2643 doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do
2591 unkeys <- readIORef unkeysRef 2644 unkeys <- readIORef unkeysRef
2592 let mp = fromMaybe mp0 $ do 2645 let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) $ do
2593 k <- Map.lookup kk keys 2646 k <- Map.lookup kk keys
2594 return $ mergeKeyPacket "decrypt" mp0 k 2647 return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k)
2595 wk = packet mp0 2648 wk = packet mp0
2596 kk = keykey wk 2649 kk = keykey wk
2597 fs = Map.keys $ locations mp 2650 fs = Map.keys $ locations mp
2598 2651
2599 decryptIt [] = return BadPassphrase 2652 decryptIt [] = return BadPassphrase
2600 decryptIt (getpw:getpws) = do 2653 decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws)
2601 -- TODO: This function should use mergeKeyPacket to 2654 where
2655 tries count getpw recurse = do
2656 -- TODO: This function should use mergeKeyPacket to
2602 -- combine the packet with it's unspilled version before 2657 -- combine the packet with it's unspilled version before
2603 -- attempting to decrypt it. 2658 -- attempting to decrypt it. Note: We are uninterested
2604 pw <- getpw 2659 -- in the 'locations' field, so this would effectively
2660 -- allow you to run 'decryptIt' on an unencrypted public key
2661 -- to obtain it's secret key.
2662 (pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry)
2605 let wkun = fromMaybe wk $ do 2663 let wkun = fromMaybe wk $ do
2606 guard $ symmetric_algorithm (packet mp) /= Unencrypted 2664 guard $ symmetric_algorithm (packet mp) /= Unencrypted
2607 decryptSecretKey pw (packet mp) 2665 decryptSecretKey pw (packet mp)
2666
2608 case symmetric_algorithm wkun of 2667 case symmetric_algorithm wkun of
2668
2609 Unencrypted -> do 2669 Unencrypted -> do
2610 writeIORef unkeysRef (Map.insert kk wkun unkeys) 2670 writeIORef unkeysRef (Map.insert kk wkun unkeys)
2611 ek <- if dest_alg==Unencrypted 2671 ek <- if dest_alg==Unencrypted
2612 then return $ Just wkun 2672 then return $ Just wkun
2613 else encryptSecretKey pw dest_s2k dest_alg wkun 2673 else encryptSecretKey pw dest_s2k dest_alg wkun
2614 case ek of 2674 case ek of
2615 Nothing -> return $ BadPassphrase 2675 Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse
2616 Just wken -> return $ KikiSuccess wken 2676 Nothing -> recurse
2617 _ -> decryptIt getpws 2677 Just wken -> return $ KikiSuccess wken
2678
2679 _ -> recurse
2618 2680
2619 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw 2681 getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
2682
2683 agentpw (ask,qry) = do
2684 s <- session
2685 fromMaybe (return ("",False)) $ do
2686 s <- s
2687 Just $ do
2688 case ask of AskAgain _ -> clearPassphrase s (queryPacket qry)
2689 _ -> return ()
2690 mbpw <- getPassphrase s ask qry
2691 quit s
2692 return ( maybe "" S8.pack mbpw, True)
2620 2693
2621 if symmetric_algorithm wk == dest_alg 2694 if symmetric_algorithm wk == dest_alg
2622 && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k ) 2695 && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k )
@@ -3434,10 +3507,13 @@ data OriginFlags = OriginFlags
3434 3507
3435type OriginMap = Map.Map FilePath OriginFlags 3508type OriginMap = Map.Map FilePath OriginFlags
3436 3509
3437data MappedPacket = MappedPacket 3510type MappedPacket = OriginMapped Packet
3438 { packet :: Packet 3511data OriginMapped a = MappedPacket
3512 { packet :: a
3439 , locations :: OriginMap 3513 , locations :: OriginMap
3440 } deriving Show 3514 } deriving Show
3515instance Functor OriginMapped where
3516 fmap f (MappedPacket x ls) = MappedPacket (f x) ls
3441 3517
3442type TrustMap = Map.Map FilePath Packet 3518type TrustMap = Map.Map FilePath Packet
3443type SigAndTrust = ( MappedPacket 3519type SigAndTrust = ( MappedPacket
@@ -3521,19 +3597,26 @@ onionName kd = (addr,name)
3521 where 3597 where
3522 (addr,(name:_,_)) = getHostnames kd 3598 (addr,(name:_,_)) = getHostnames kd
3523-} 3599-}
3600
3601-- | Compare different versions if the same key pair. Public versions
3602-- are considered greater. If the two packets do not represent the same
3603-- key or the packets are not keys at all, an error will result that
3604-- includes the context provided as the first argument.
3524keyCompare :: String -> Packet -> Packet -> Ordering 3605keyCompare :: String -> Packet -> Packet -> Ordering
3525keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT 3606keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
3526keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT 3607keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
3527keyCompare what a b | keykey a==keykey b = EQ 3608keyCompare what a b | keykey a==keykey b = EQ
3528keyCompare what a b = error $ unlines ["Unable to merge "++what++":" 3609keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
3529 , fingerprint a 3610 , if isKey a then fingerprint a else ""
3530 , PP.ppShow a 3611 , PP.ppShow a
3531 , fingerprint b 3612 , if isKey b then fingerprint b else ""
3532 , PP.ppShow b 3613 , PP.ppShow b
3533 ] 3614 ]
3534 3615
3616-- | Merge two representations of the same key, prefering secret version
3617-- because they have more information.
3535mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket 3618mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
3536mergeKeyPacket what key p = 3619mergeKeyPacket what key p =
3537 key { packet = minimumBy (keyCompare what) [packet key,packet p] 3620 key { packet = minimumBy (keyCompare what) [packet key,packet p]
3538 , locations = Map.union (locations key) (locations p) 3621 , locations = Map.union (locations key) (locations p)
3539 } 3622 }