Commit 9027b63a authored by Ryan Scott's avatar Ryan Scott Committed by judah
Browse files

Properly disable echoing in getPassword when running in MinTTY (#52)

Fixes #50.
parent 2002f85b
......@@ -235,6 +235,10 @@ When using terminal-style interaction, the masking character (if given) will rep
When using file-style interaction, this function turns off echoing while reading
the line of input.
Note that if Haskeline is built against a version of the @Win32@ library
earlier than 2.5, 'getPassword' will incorrectly echo back input on MinTTY
consoles (such as Cygwin or MSYS).
-}
getPassword :: MonadException m => Maybe Char -- ^ A masking character; e.g., @Just \'*\'@
......@@ -243,9 +247,7 @@ getPassword x = promptedInput
(\tops prefix -> runInputCmdT tops
$ runCommandLoop tops prefix loop
$ Password [] x)
(\fops -> let h_in = inputHandle fops
in bracketSet (hGetEcho h_in) (hSetEcho h_in) False
$ runMaybeT $ getLocaleLine fops)
(\fops -> withoutInputEcho fops $ runMaybeT $ getLocaleLine fops)
where
loop = choiceCmd [ simpleChar '\n' +> finish
, simpleKey Backspace +> change deletePasswordChar
......
......@@ -320,12 +320,15 @@ posixFileRunTerm hs = do
hFlush (ehOut hs)
, closeTerm = closeHandles hs
, wrapInterrupt = withSigIntHandler
, termOps = Right FileOps
{ inputHandle = ehIn hs
, termOps = let h_in = ehIn hs
in Right FileOps
{ withoutInputEcho = bracketSet (hGetEcho h_in)
(hSetEcho h_in)
False
, wrapFileInput = withCodingMode (hIn hs)
, getLocaleChar = guardedEOF hGetChar (ehIn hs)
, maybeReadNewline = hMaybeReadNewline (ehIn hs)
, getLocaleLine = guardedEOF hGetLine (ehIn hs)
, getLocaleChar = guardedEOF hGetChar h_in
, maybeReadNewline = hMaybeReadNewline h_in
, getLocaleLine = guardedEOF hGetLine h_in
}
}
......
......@@ -22,19 +22,13 @@ import System.Console.Haskeline.Monads hiding (Handler)
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Term
import System.Console.Haskeline.Backend.WCWidth
import System.Console.Haskeline.Backend.Win32.Echo (hWithoutInputEcho)
import Data.ByteString.Internal (createAndTrim)
import qualified Data.ByteString as B
##if defined(i386_HOST_ARCH)
## define WINDOWS_CCONV stdcall
##elif defined(x86_64_HOST_ARCH)
## define WINDOWS_CCONV ccall
##else
## error Unknown mingw32 arch
##endif
#include "win_console.h"
##include "windows_cconv.h"
foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput
:: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool
......@@ -409,7 +403,7 @@ fileRunTerm h_in = do
putStrOut = putter,
wrapInterrupt = withCtrlCHandler,
termOps = Right FileOps
{ inputHandle = h_in
{ withoutInputEcho = hWithoutInputEcho h_in
, wrapFileInput = hWithBinaryMode h_in
, getLocaleChar = getMultiByteChar cp h_in
, maybeReadNewline = hMaybeReadNewline h_in
......
{-# LANGUAGE CPP #-}
module System.Console.Haskeline.Backend.Win32.Echo (hWithoutInputEcho) where
import Control.Exception (throw)
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import System.Console.Haskeline.MonadException (MonadException, bracket)
import System.Exit (ExitCode(..))
import System.IO (Handle, hGetContents, hGetEcho, hSetEcho)
import System.Process (StdStream(..), createProcess, shell,
std_in, std_out, waitForProcess)
#if MIN_VERSION_Win32(2,5,0)
import Control.Concurrent.MVar (readMVar)
import Data.Typeable (cast)
import Foreign.C.Types
import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr)
import GHC.IO.FD (FD(..))
import GHC.IO.Handle.Types (Handle(..), Handle__(..))
import System.Win32.Types (HANDLE)
import System.Win32.MinTTY (isMinTTYHandle)
#endif
-- | Return the handle's current input 'EchoState'.
hGetInputEchoState :: Handle -> IO EchoState
hGetInputEchoState input = do
min_tty <- minTTY input
if min_tty
then fmap MinTTY (hGetInputEchoSTTY input)
else fmap DefaultTTY $ hGetEcho input
-- | Return all of @stty@'s current settings in a non-human-readable format.
--
-- This function is not very useful on its own. Its greater purpose is to
-- provide a compact 'STTYSettings' that can be fed back into
-- 'hSetInputEchoState'.
hGetInputEchoSTTY :: Handle -> IO STTYSettings
hGetInputEchoSTTY input = hSttyRaw input "-g"
-- | Set the handle's input 'EchoState'.
hSetInputEchoState :: Handle -> EchoState -> IO ()
hSetInputEchoState input (MinTTY settings) = hSetInputEchoSTTY input settings
hSetInputEchoState input (DefaultTTY echo) = hSetEcho input echo
-- | Create an @stty@ process and wait for it to complete. This is useful for
-- changing @stty@'s settings, after which @stty@ does not output anything.
--
-- @
-- hSetInputEchoSTTY input = 'void' . 'hSttyRaw' input
-- @
hSetInputEchoSTTY :: Handle -> STTYSettings -> IO ()
hSetInputEchoSTTY input = void . hSttyRaw input
-- | Save the handle's current input 'EchoState', perform a computation,
-- restore the saved 'EchoState', and then return the result of the
-- computation.
--
-- @
-- bracketInputEcho input action =
-- 'bracket' ('liftIO' $ 'hGetInputEchoState' input)
-- ('liftIO' . 'hSetInputEchoState' input)
-- (const action)
-- @
hBracketInputEcho :: MonadException m => Handle -> m a -> m a
hBracketInputEcho input action =
bracket (liftIO $ hGetInputEchoState input)
(liftIO . hSetInputEchoState input)
(const action)
-- | Perform a computation with the handle's input echoing disabled. Before
-- running the computation, the handle's input 'EchoState' is saved, and the
-- saved 'EchoState' is restored after the computation finishes.
hWithoutInputEcho :: MonadException m => Handle -> m a -> m a
hWithoutInputEcho input action = do
echo_off <- liftIO $ hEchoOff input
hBracketInputEcho input
(liftIO (hSetInputEchoState input echo_off) >> action)
-- | Create an @stty@ process, wait for it to complete, and return its output.
hSttyRaw :: Handle -> String -> IO STTYSettings
hSttyRaw input arg = do
let stty = (shell $ "stty " ++ arg) {
std_in = UseHandle input
, std_out = CreatePipe
}
(_, mbStdout, _, rStty) <- createProcess stty
exStty <- waitForProcess rStty
case exStty of
e@ExitFailure{} -> throw e
ExitSuccess -> maybe (return "") hGetContents mbStdout
-- | A representation of the handle input's current echoing state.
-- See, for instance, 'hEchoOff'.
data EchoState
= MinTTY STTYSettings
-- ^ The argument to (or value returned from) an invocation of the @stty@
-- command-line utility. Most POSIX-like shells have @stty@, including
-- MinTTY on Windows. Since neither 'hGetEcho' nor 'hSetEcho' work on
-- MinTTY, when 'getInputEchoState' runs on MinTTY, it returns a value
-- built with this constructor.
--
-- However, native Windows consoles like @cmd.exe@ or PowerShell do not
-- have @stty@, so if you construct an 'EchoState' with this constructor
-- manually, take care not to use it with a native Windows console.
| DefaultTTY Bool
-- ^ A simple on ('True') or off ('False') toggle. This is returned by
-- 'hGetEcho' and given as an argument to 'hSetEcho', which work on most
-- consoles, with the notable exception of MinTTY on Windows. If you
-- construct an 'EchoState' with this constructor manually, take care not
-- to use it with MinTTY.
deriving (Eq, Ord, Show)
-- | Indicates that the handle's input echoing is (or should be) off.
hEchoOff :: Handle -> IO EchoState
hEchoOff input = do
min_tty <- minTTY input
return $ if min_tty
then MinTTY "-echo"
else DefaultTTY False
-- | Settings used to configure the @stty@ command-line utility.
type STTYSettings = String
-- | Is the current process attached to a MinTTY console (e.g., Cygwin or MSYS)?
minTTY :: Handle -> IO Bool
#if MIN_VERSION_Win32(2,5,0)
minTTY input = withHandleToHANDLE input isMinTTYHandle
#else
-- On older versions of Win32, we simply punt.
minTTY _ = return False
#endif
#if MIN_VERSION_Win32(2,5,0)
foreign import ccall unsafe "_get_osfhandle"
c_get_osfhandle :: CInt -> IO HANDLE
-- | Extract a Windows 'HANDLE' from a Haskell 'Handle' and perform
-- an action on it.
-- Originally authored by Max Bolingbroke in the ansi-terminal library
withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE haskell_handle action =
-- Create a stable pointer to the Handle. This prevents the garbage collector
-- getting to it while we are doing horrible manipulations with it, and hence
-- stops it being finalized (and closed).
withStablePtr haskell_handle $ const $ do
-- Grab the write handle variable from the Handle
let write_handle_mvar = case haskell_handle of
FileHandle _ handle_mvar -> handle_mvar
DuplexHandle _ _ handle_mvar -> handle_mvar
-- This is "write" MVar, we could also take the "read" one
-- Get the FD from the algebraic data type
Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))
$ readMVar write_handle_mvar
-- Finally, turn that (C-land) FD into a HANDLE using msvcrt
windows_handle <- c_get_osfhandle fd
-- Do what the user originally wanted
action windows_handle
withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
withStablePtr value = bracket (newStablePtr value) freeStablePtr
#endif
......@@ -18,14 +18,7 @@ import qualified System.Directory
#include <windows.h>
#include <shlobj.h>
##if defined(i386_HOST_ARCH)
## define WINDOWS_CCONV stdcall
##elif defined(x86_64_HOST_ARCH)
## define WINDOWS_CCONV ccall
##else
## error Unknown mingw32 arch
##endif
##include "windows_cconv.h"
foreign import WINDOWS_CCONV "FindFirstFileW" c_FindFirstFile
:: LPCTSTR -> Ptr () -> IO HANDLE
......@@ -63,7 +56,7 @@ doesDirectoryExist file = do
getHomeDirectory :: IO FilePath
getHomeDirectory = System.Directory.getHomeDirectory
#else
#else
import System.Directory
......
......@@ -67,7 +67,8 @@ flushEventQueue print' eventChan = yield >> loopUntilFlushed
-- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline
-- are "wrapped" by wrapFileInput.
data FileOps = FileOps {
inputHandle :: Handle, -- ^ e.g. for turning off echoing.
withoutInputEcho :: forall m a . MonadException m => m a -> m a,
-- ^ Perform an action without echoing input.
wrapFileInput :: forall a . IO a -> IO a,
getLocaleLine :: MaybeT IO String,
getLocaleChar :: MaybeT IO Char,
......
......@@ -20,7 +20,7 @@ Homepage: http://trac.haskell.org/haskeline
Bug-Reports: https://github.com/judah/haskeline/issues
Stability: Stable
Build-Type: Custom
extra-source-files: examples/Test.hs Changelog
extra-source-files: examples/Test.hs Changelog includes/*.h
source-repository head
type: git
......@@ -44,7 +44,8 @@ Library
-- wasn't fixed until 7.4.1
Build-depends: base >=4.5 && < 4.11, containers>=0.4 && < 0.6,
directory>=1.1 && < 1.4, bytestring>=0.9 && < 0.11,
filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6
filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6,
process >= 1.0 && < 1.5
Default-Language: Haskell98
Default-Extensions:
ForeignFunctionInterface, Rank2Types, FlexibleInstances,
......@@ -86,13 +87,14 @@ Library
if os(windows) {
Build-depends: Win32>=2.0
Other-modules: System.Console.Haskeline.Backend.Win32
System.Console.Haskeline.Backend.Win32.Echo
c-sources: cbits/win_console.c
includes: win_console.h
includes: win_console.h, windows_cconv.h
install-includes: win_console.h
cpp-options: -DMINGW
} else {
Build-depends: unix>=2.0 && < 2.8
Other-modules:
Other-modules:
System.Console.Haskeline.Backend.Posix
System.Console.Haskeline.Backend.Posix.Encoder
System.Console.Haskeline.Backend.DumbTerm
......
#ifndef WINDOWS_CCONV_H
#define WINDOWS_CCONV_H
#if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
#else
# error Unknown mingw32 arch
#endif
#endif
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment