1 files changed, 204 insertions, 0 deletions

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
+