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
hGetInputEchoState :: Handle -> IO EchoState
hGetInputEchoState input = do
min_tty <- minTTY input
if min_tty
then fmap MinTTY (hGetInputEchoSTTY input)
else fmap DefaultTTY $ hGetEcho input
hGetInputEchoSTTY :: Handle -> IO STTYSettings
hGetInputEchoSTTY input = hSttyRaw input "-g"
hSetInputEchoState :: Handle -> EchoState -> IO ()
hSetInputEchoState input (MinTTY settings) = hSetInputEchoSTTY input settings
hSetInputEchoState input (DefaultTTY echo) = hSetEcho input echo
hSetInputEchoSTTY :: Handle -> STTYSettings -> IO ()
hSetInputEchoSTTY input = void . hSttyRaw input
hBracketInputEcho :: MonadException m => Handle -> m a -> m a
hBracketInputEcho input action =
bracket (liftIO $ hGetInputEchoState input)
(liftIO . hSetInputEchoState input)
(const action)
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)
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
data EchoState
= MinTTY STTYSettings
| DefaultTTY Bool
deriving (Eq, Ord, Show)
hEchoOff :: Handle -> IO EchoState
hEchoOff input = do
min_tty <- minTTY input
return $ if min_tty
then MinTTY "-echo"
else DefaultTTY False
type STTYSettings = String
minTTY :: Handle -> IO Bool
#if MIN_VERSION_Win32(2,5,0)
minTTY input = withHandleToHANDLE input isMinTTYHandle
#else
minTTY _ = return False
#endif
#if MIN_VERSION_Win32(2,5,0)
foreign import ccall unsafe "_get_osfhandle"
c_get_osfhandle :: CInt -> IO HANDLE
withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE haskell_handle action =
withStablePtr haskell_handle $ const $ do
let write_handle_mvar = case haskell_handle of
FileHandle _ handle_mvar -> handle_mvar
DuplexHandle _ _ handle_mvar -> handle_mvar
Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))
$ readMVar write_handle_mvar
windows_handle <- c_get_osfhandle fd
action windows_handle
withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
withStablePtr value = bracket (newStablePtr value) freeStablePtr
#endif