1 files changed, 34 insertions, 7 deletions

diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs
index 8bffd1b..165fdf2 100644
--- a/lib/GnuPGAgent.hs
+++ b/lib/GnuPGAgent.hs
@@ -3,6 +3,8 @@
 {-# LANGUAGE PatternGuards #-}
 module GnuPGAgent
     ( session
+    , Query(..)
+    , QueryMode(..)
     , getPassphrase
     , clearPassphrase
     , quit ) where
@@ -44,6 +46,12 @@ session = do
             connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
             agent <- socketToHandle sock ReadWriteMode
             hSetBuffering agent LineBuffering
+            lookupEnv "DISPLAY" >>= \case
+                Just display -> do hPutStrLn agent ("option putenv DISPLAY="++display)
+                                   _ <- hGetLine agent
+                                   return ()
+                Nothing      -> return ()
+            -- TODO: GPG_TTY
             return $ Just $ GnuPGAgent agent
         Nothing -> do
             hPutStrLn stderr "Unable to find home directory."
@@ -64,23 +72,42 @@ clearPassphrase agent key = do
     let cmd = "clear_passphrase "++fingerprint key
     hPutStrLn (agentHandle agent) cmd
 
-getPassphrase :: GnuPGAgent -> Bool -> Packet -> String -> Maybe Packet -> IO (Maybe String)
-getPassphrase agent ask key uid masterkey = do
-    let askopt = if ask then "" else "--no-ask "
-        (er,pr,desc) = prompts key uid masterkey
+data Query = Query
+    { queryPacket  :: Packet
+    , queryUID     :: String
+    , queryMainKey :: Maybe Packet
+    }
+ deriving Show
+
+data QueryMode = AskNot | AskAgain String | Ask
+ deriving (Show,Eq,Ord)
+
+getPassphrase :: GnuPGAgent -> QueryMode -> Query -> IO (Maybe String)
+getPassphrase agent ask (Query key uid masterkey) = do
+    let (er0,pr,desc) = prompts key uid masterkey
+        (er,askopt) = case ask of
+                        AskNot         -> (er0,"--no-ask")
+                        AskAgain ermsg -> (ermsg,"")
+                        Ask            -> (er0,"")
         cmd = "get_passphrase "++askopt++fingerprint key++" "++unwords (map percentPlusEscape [er,pr,desc])
-    putStrLn cmd
+    -- putStrLn cmd
     hPutStrLn (agentHandle agent) cmd
     r0 <- hGetLine (agentHandle agent)
+    -- putStrLn $ "agent says: " ++ r0
     case takeWhile (/=' ') r0 of
         "OK" -> hGetLine (agentHandle agent) >>= unhex . drop 3
             where
 #if defined(VERSION_memory)
                 unhex hx = case convertFromBase Base16 (S8.pack hx) of
-                            Left e -> return Nothing
+                            Left e -> do
+                                -- Useful for debugging but insecure generally ;)
+                                -- putStrLn $ "convertFromBase error for input "++show hx++": "++show e
+                                return Nothing
                             Right bs -> return $ Just $ S8.unpack bs
 #elif defined(VERSION_dataenc)
-                unhex hx = return $ fmap (map $ chr . fromIntegral) $ Base16.decode hx
+                unhex hx = maybe (return () {- putStrLn $ "dataenc error for input "++show hx -})
+                                 return
+                                 $ fmap (map $ chr . fromIntegral) $ Base16.decode hx
 #endif
         "ERR" -> return Nothing