From 7a579e7b82a2f5707af77f4a7101ce72e57635ac Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 28 Aug 2016 16:10:41 -0400 Subject: Refactored for smaller modules (faster rebuild). --- lib/PacketTranscoder.hs | 204 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 204 insertions(+) create mode 100644 lib/PacketTranscoder.hs (limited to 'lib/PacketTranscoder.hs') diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs new file mode 100644 index 0000000..651b00c --- /dev/null +++ b/lib/PacketTranscoder.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +module PacketTranscoder where + +import Control.Monad +import Data.IORef +import Data.List +import Data.Maybe +import Data.OpenPGP +import Data.OpenPGP.Util +import GnuPGAgent +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Map as Map +import qualified Data.Traversable as Traversable +import System.IO ( stderr) +import System.Posix.IO ( fdToHandle ) +import Text.Show.Pretty as PP ( ppShow ) +import Types + +-- | Merge two representations of the same key, prefering secret version +-- because they have more information. +mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket +mergeKeyPacket what key p = + key { packet = minimumBy (keyCompare what) [packet key,packet p] + , locations = Map.union (locations key) (locations p) + } + +-- | Compare different versions if the same key pair. Public versions +-- are considered greater. If the two packets do not represent the same +-- key or the packets are not keys at all, an error will result that +-- includes the context provided as the first argument. +keyCompare :: String -> Packet -> Packet -> Ordering +keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT +keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT +keyCompare what a b | keykey a==keykey b = EQ +keyCompare what a b = error $ unlines ["Unable to merge "++what++":" + , if isKey a then fingerprint a else "" + , PP.ppShow a + , if isKey b then fingerprint b else "" + , PP.ppShow b + ] + +resolveInputFile :: InputFileContext -> InputFile -> [FilePath] +resolveInputFile ctx = resolve + where + resolve HomeSec = return (homesecPath ctx) + resolve HomePub = return (homepubPath ctx) + resolve (ArgFile f) = return f + resolve _ = [] + +resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath +resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) + where str = case (fdr,fdw) of + (0,1) -> "-" + _ -> "&pipe" ++ show (fdr,fdw) +resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) + where str = "&" ++ show fd +resolveForReport mctx f = concat $ resolveInputFile ctx f + where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx + +readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString +readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents +readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents +readInputFileS ctx inp = do + let fname = resolveInputFile ctx inp + fmap S.concat $ mapM S.readFile fname + + + +-- | Reads contents of an 'InputFile' or returns the cached content from a prior call. +-- An optional prompt is provided and will be printed on stdout only in the case that +-- the provided 'InputFile' is 'FileDesc' 0 (i.e. stdin). +cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) +cachedContents maybePrompt ctx fd = do + ref <- newIORef Nothing + return $ get maybePrompt ref fd + where + trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs + + get maybePrompt ref fd = do + pw <- readIORef ref + flip (flip maybe return) pw $ do + if fd == FileDesc 0 then case maybePrompt of + Just prompt -> S.hPutStr stderr prompt + Nothing -> return () + else return () + pw <- fmap trimCR $ readInputFileS ctx fd + writeIORef ref (Just pw) + return pw + + + +makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext + -> Map.Map KeyKey (OriginMapped Query) + -> IO PacketTranscoder +makeMemoizingDecrypter operation ctx keys = do + if null chains then do + -- (*) Notice we do not pass ctx to resolveForReport. + -- This is because the merge function does not currently use a context + -- and the pws map keys must match the MappedPacket locations. + -- TODO: Perhaps these should both be of type InputFile rather than + -- FilePath? + -- pws :: Map.Map FilePath (IO S.ByteString) + {- + -- This disabled code obtained password sources from StreamInfo records. + pws <- + Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) + (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above + $ Map.filter (isJust . pwfile . typ) $ opFiles operation) + -} + let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" + -- List of file-specific password sources. + pws2 <- + Traversable.mapM (cachedContents prompt ctx) + $ Map.fromList $ mapMaybe + (\spec -> (,passSpecPassFile spec) `fmap` do + guard $ isNothing $ passSpecKeySpec spec + passSpecRingFile spec) + passspecs + -- List of general password sources. + defpw <- do + Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) + $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) + && isNothing (passSpecKeySpec sp)) + $ passspecs + unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) + return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec) + else let PassphraseMemoizer f = head chains + in return f + where + (chains,passspecs0) = partition isChain $ opPassphrases operation + where isChain (PassphraseMemoizer {}) = True + isChain _ = False + (agentspec,passspecs) = partition isAgent passspecs0 + where isAgent PassphraseAgent = True + isAgent _ = False + doDecrypt :: IORef (Map.Map KeyKey Packet) + -> Map.Map FilePath (IO S.ByteString) + -> Maybe (IO S.ByteString) + -> Bool + -> (SymmetricAlgorithm,S2K) + -> MappedPacket + -> IO (KikiCondition Packet) + doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do + unkeys <- readIORef unkeysRef + let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) $ do + k <- Map.lookup kk keys + return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k) + wk = packet mp0 + kk = keykey wk + fs = Map.keys $ locations mp + + decryptIt [] = return BadPassphrase + decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws) + where + tries count getpw recurse = do + -- TODO: This function should use mergeKeyPacket to + -- combine the packet with it's unspilled version before + -- attempting to decrypt it. Note: We are uninterested + -- in the 'locations' field, so this would effectively + -- allow you to run 'decryptIt' on an unencrypted public key + -- to obtain it's secret key. + (pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry) + let wkun = fromMaybe wk $ do + guard $ symmetric_algorithm (packet mp) /= Unencrypted + decryptSecretKey pw (packet mp) + + case symmetric_algorithm wkun of + + Unencrypted -> do + writeIORef unkeysRef (Map.insert kk wkun unkeys) + ek <- if dest_alg==Unencrypted + then return $ Just wkun + else encryptSecretKey pw dest_s2k dest_alg wkun + case ek of + Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse + Nothing -> recurse + Just wken -> return $ KikiSuccess wken + + _ -> recurse + + getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] + + -- TODO: First we should try the master key with AskNot. + -- If that fails, we should try the subkey. + agentpw (ask,qry) = do + s <- session + fromMaybe (return ("",False)) $ do + s <- s + Just $ do + case ask of AskAgain _ -> clearPassphrase s (queryPacket qry) + _ -> return () + mbpw <- getPassphrase s ask qry + quit s + return ( maybe "" S8.pack mbpw, True) + + if symmetric_algorithm wk == dest_alg + && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k ) + then return (KikiSuccess wk) + else maybe (decryptIt getpws) + (return . KikiSuccess) + $ Map.lookup kk unkeys + -- cgit v1.2.3