{-# LANGUAGE CPP #-}

module System.Console.Haskeline.Backend.Win32.Echo (hWithoutInputEcho) where

import Control.Exception (throw)
import Control.Monad (void)
import Control.Monad.Catch (MonadMask, bracket)
import Control.Monad.IO.Class (MonadIO(..))

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(..))
#if defined(__IO_MANAGER_WINIO__)
import GHC.IO.Handle.Windows (handleToHANDLE)
import GHC.IO.SubSystem ((<!>))
#endif
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 :: Handle -> IO EchoState
hGetInputEchoState Handle
input = do
  min_tty <- Handle -> IO Bool
minTTY Handle
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 :: Handle -> IO [Char]
hGetInputEchoSTTY Handle
input = Handle -> [Char] -> IO [Char]
hSttyRaw Handle
input [Char]
"-g"

-- | Set the handle's input 'EchoState'.
hSetInputEchoState :: Handle -> EchoState -> IO ()
hSetInputEchoState :: Handle -> EchoState -> IO ()
hSetInputEchoState Handle
input (MinTTY [Char]
settings) = Handle -> [Char] -> IO ()
hSetInputEchoSTTY Handle
input [Char]
settings
hSetInputEchoState Handle
input (DefaultTTY Bool
echo) = Handle -> Bool -> IO ()
hSetEcho Handle
input Bool
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 :: Handle -> [Char] -> IO ()
hSetInputEchoSTTY Handle
input = IO [Char] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Char] -> IO ()) -> ([Char] -> IO [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO [Char]
hSttyRaw Handle
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 :: (MonadIO m, MonadMask m) => Handle -> m a -> m a
hBracketInputEcho :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handle -> m a -> m a
hBracketInputEcho Handle
input m a
action =
  m EchoState -> (EchoState -> m ()) -> (EchoState -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO EchoState -> m EchoState
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EchoState -> m EchoState) -> IO EchoState -> m EchoState
forall a b. (a -> b) -> a -> b
$ Handle -> IO EchoState
hGetInputEchoState Handle
input)
          (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (EchoState -> IO ()) -> EchoState -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> EchoState -> IO ()
hSetInputEchoState Handle
input)
          (m a -> EchoState -> m a
forall a b. a -> b -> a
const m a
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 :: (MonadIO m, MonadMask m) => Handle -> m a -> m a
hWithoutInputEcho :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handle -> m a -> m a
hWithoutInputEcho Handle
input m a
action = do
  echo_off <- IO EchoState -> m EchoState
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EchoState -> m EchoState) -> IO EchoState -> m EchoState
forall a b. (a -> b) -> a -> b
$ Handle -> IO EchoState
hEchoOff Handle
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 :: Handle -> [Char] -> IO [Char]
hSttyRaw Handle
input [Char]
arg = do
  let stty :: CreateProcess
stty = ([Char] -> CreateProcess
shell ([Char] -> CreateProcess) -> [Char] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ [Char]
"stty " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
arg) {
        std_in  = UseHandle input
      , std_out = CreatePipe
      }
  (_, mbStdout, _, rStty) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
stty
  exStty <- waitForProcess rStty
  case exStty of
    e :: ExitCode
e@ExitFailure{} -> ExitCode -> IO [Char]
forall a e. (HasCallStack, Exception e) => e -> a
throw ExitCode
e
    ExitCode
ExitSuccess     -> IO [Char] -> (Handle -> IO [Char]) -> Maybe Handle -> IO [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"") Handle -> IO [Char]
hGetContents Maybe Handle
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 (EchoState -> EchoState -> Bool
(EchoState -> EchoState -> Bool)
-> (EchoState -> EchoState -> Bool) -> Eq EchoState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EchoState -> EchoState -> Bool
== :: EchoState -> EchoState -> Bool
$c/= :: EchoState -> EchoState -> Bool
/= :: EchoState -> EchoState -> Bool
Eq, Eq EchoState
Eq EchoState =>
(EchoState -> EchoState -> Ordering)
-> (EchoState -> EchoState -> Bool)
-> (EchoState -> EchoState -> Bool)
-> (EchoState -> EchoState -> Bool)
-> (EchoState -> EchoState -> Bool)
-> (EchoState -> EchoState -> EchoState)
-> (EchoState -> EchoState -> EchoState)
-> Ord EchoState
EchoState -> EchoState -> Bool
EchoState -> EchoState -> Ordering
EchoState -> EchoState -> EchoState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EchoState -> EchoState -> Ordering
compare :: EchoState -> EchoState -> Ordering
$c< :: EchoState -> EchoState -> Bool
< :: EchoState -> EchoState -> Bool
$c<= :: EchoState -> EchoState -> Bool
<= :: EchoState -> EchoState -> Bool
$c> :: EchoState -> EchoState -> Bool
> :: EchoState -> EchoState -> Bool
$c>= :: EchoState -> EchoState -> Bool
>= :: EchoState -> EchoState -> Bool
$cmax :: EchoState -> EchoState -> EchoState
max :: EchoState -> EchoState -> EchoState
$cmin :: EchoState -> EchoState -> EchoState
min :: EchoState -> EchoState -> EchoState
Ord, Int -> EchoState -> [Char] -> [Char]
[EchoState] -> [Char] -> [Char]
EchoState -> [Char]
(Int -> EchoState -> [Char] -> [Char])
-> (EchoState -> [Char])
-> ([EchoState] -> [Char] -> [Char])
-> Show EchoState
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> EchoState -> [Char] -> [Char]
showsPrec :: Int -> EchoState -> [Char] -> [Char]
$cshow :: EchoState -> [Char]
show :: EchoState -> [Char]
$cshowList :: [EchoState] -> [Char] -> [Char]
showList :: [EchoState] -> [Char] -> [Char]
Show)

-- | Indicates that the handle's input echoing is (or should be) off.
hEchoOff :: Handle -> IO EchoState
hEchoOff :: Handle -> IO EchoState
hEchoOff Handle
input = do
  min_tty <- Handle -> IO Bool
minTTY Handle
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 :: Handle -> IO Bool
minTTY Handle
input = Handle -> (HANDLE -> IO Bool) -> IO Bool
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE Handle
input HANDLE -> IO Bool
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
#if defined(__IO_MANAGER_WINIO__)
withHandleToHANDLE :: forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE = Handle -> (HANDLE -> IO a) -> IO a
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLEPosix (Handle -> (HANDLE -> IO a) -> IO a)
-> (Handle -> (HANDLE -> IO a) -> IO a)
-> Handle
-> (HANDLE -> IO a)
-> IO a
forall a. a -> a -> a
<!> Handle -> (HANDLE -> IO a) -> IO a
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLENative
#else
withHandleToHANDLE = withHandleToHANDLEPosix
#endif

#if defined(__IO_MANAGER_WINIO__)
withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLENative :: forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLENative Handle
haskell_handle HANDLE -> IO a
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).
    Handle -> (StablePtr Handle -> IO a) -> IO a
forall a b. a -> (StablePtr a -> IO b) -> IO b
withStablePtr Handle
haskell_handle ((StablePtr Handle -> IO a) -> IO a)
-> (StablePtr Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> StablePtr Handle -> IO a
forall a b. a -> b -> a
const (IO a -> StablePtr Handle -> IO a)
-> IO a -> StablePtr Handle -> IO a
forall a b. (a -> b) -> a -> b
$ do
        windows_handle <- Handle -> IO HANDLE
handleToHANDLE Handle
haskell_handle
        -- Do what the user originally wanted
        action windows_handle
#endif

withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLEPosix :: forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLEPosix Handle
haskell_handle HANDLE -> IO a
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).
    Handle -> (StablePtr Handle -> IO a) -> IO a
forall a b. a -> (StablePtr a -> IO b) -> IO b
withStablePtr Handle
haskell_handle ((StablePtr Handle -> IO a) -> IO a)
-> (StablePtr Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> StablePtr Handle -> IO a
forall a b. a -> b -> a
const (IO a -> StablePtr Handle -> IO a)
-> IO a -> StablePtr Handle -> IO a
forall a b. (a -> b) -> a -> b
$ do
        -- Grab the write handle variable from the Handle
        let write_handle_mvar :: MVar Handle__
write_handle_mvar = case Handle
haskell_handle of
                FileHandle [Char]
_ MVar Handle__
handle_mvar     -> MVar Handle__
handle_mvar
                DuplexHandle [Char]
_ MVar Handle__
_ MVar Handle__
handle_mvar -> MVar Handle__
handle_mvar
                  -- This is "write" MVar, we could also take the "read" one

        -- Get the FD from the algebraic data type
        Just fd <- (Handle__ -> Maybe CInt) -> IO Handle__ -> IO (Maybe CInt)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Handle__ { haDevice :: ()
haDevice = dev
dev }) -> (FD -> CInt) -> Maybe FD -> Maybe CInt
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FD -> CInt
fdFD (dev -> Maybe FD
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev))
                 (IO Handle__ -> IO (Maybe CInt)) -> IO Handle__ -> IO (Maybe CInt)
forall a b. (a -> b) -> a -> b
$ MVar Handle__ -> IO Handle__
forall a. MVar a -> IO a
readMVar MVar Handle__
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 :: forall a b. a -> (StablePtr a -> IO b) -> IO b
withStablePtr a
value = IO (StablePtr a)
-> (StablePtr a -> IO ()) -> (StablePtr a -> IO b) -> IO b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
value) StablePtr a -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr
#endif