diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 0.1 [2016-12-22] + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Ryan Scott + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Scott nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# `echo` +[![Hackage](https://img.shields.io/hackage/v/echo.svg)][Hackage: echo] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/echo.svg)](http://packdeps.haskellers.com/reverse/echo) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] +[![Build](https://img.shields.io/travis/RyanGlScott/echo.svg)](https://travis-ci.org/RyanGlScott/echo) +[![Windows build](https://ci.appveyor.com/api/projects/status/a0dh9v7j995tjj2u?svg=true)](https://ci.appveyor.com/project/RyanGlScott/echo) + +[Hackage: echo]: + http://hackage.haskell.org/package/echo + "text-show package on Hackage" +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" + +The `base` library exposes the `hGetEcho` and `hSetEcho` functions for querying and setting echo status, but unfortunately, neither function works with MinTTY consoles on Windows. This is a serious issue, since `hGetEcho` and `hSetEcho` are often used to disable input echoing when a program prompts for a password, so many programs will reveal your password as you type it on MinTTY! + +This library provides an alternative interface which works with both MinTTY and other consoles. An example is included which demonstrates how one might prompt for a password using this library. To build it, make sure to configure with the `-fexample` flag. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/echo.cabal b/echo.cabal new file mode 100644 --- /dev/null +++ b/echo.cabal @@ -0,0 +1,63 @@ +name: echo +version: 0.1 +synopsis: A cross-platform, cross-console way to handle echoing terminal input +description: The @base@ library exposes the @hGetEcho@ and @hSetEcho@ functions + for querying and setting echo status, but unfortunately, neither + function works with MinTTY consoles on Windows. This is a serious + issue, since @hGetEcho@ and @hSetEcho@ are often used to disable + input echoing when a program prompts for a password, so many + programs will reveal your password as you type it on MinTTY! + . + This library provides an alternative interface which works + with both MinTTY and other consoles. An example is included + which demonstrates how one might prompt for a password using + this library. To build it, make sure to configure with the + @-fexample@ flag. +homepage: https://github.com/RyanGlScott/echo +bug-reports: https://github.com/RyanGlScott/echo/issues +license: BSD3 +license-file: LICENSE +author: Ryan Scott +maintainer: Ryan Scott +stability: Provisional +copyright: (C) 2016 Ryan Scott +category: System +build-type: Simple +extra-source-files: CHANGELOG.md, README.md, include/*.h +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/RyanGlScott/echo + +flag example + description: Build the bundled example program. + default: False + +library + exposed-modules: System.IO.Echo + System.IO.Echo.Internal + + build-depends: base >= 4.3 && < 5, process + if os(windows) + build-depends: filepath, Win32 + build-tools: hsc2hs + include-dirs: include + includes: windows_cconv.h, winternl_compat.h + cpp-options: "-DWINDOWS" + other-modules: System.IO.Echo.MinTTY + extra-libraries: ntdll + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable password + if !flag(example) + buildable: False + + main-is: Password.hs + build-depends: base >= 4.3 && < 5, echo + hs-source-dirs: example + default-language: Haskell2010 + ghc-options: -Wall diff --git a/example/Password.hs b/example/Password.hs new file mode 100644 --- /dev/null +++ b/example/Password.hs @@ -0,0 +1,29 @@ +{-| +Module: Password +Copyright: (C) 2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: Portable + +A simple program which prompts you for your username and password (without +leaking your password onto the screen as you type it). +-} +module Main (main) where + +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) + +main :: IO () +main = do + putLabel "Username: " + username <- getLine + putLabel "Password: " + password <- withoutInputEcho getLine + + putStrLn "" + putStrLn "-----------------------------------" + putStrLn $ "Your username is: " ++ username + putStrLn $ "Your password is: " ++ password + where + putLabel label = putStr label >> hFlush stdout diff --git a/include/windows_cconv.h b/include/windows_cconv.h new file mode 100644 --- /dev/null +++ b/include/windows_cconv.h @@ -0,0 +1,12 @@ +#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 diff --git a/include/winternl_compat.h b/include/winternl_compat.h new file mode 100644 --- /dev/null +++ b/include/winternl_compat.h @@ -0,0 +1,39 @@ +#ifndef WINTERNL_COMPAT_H +#define WINTERNL_COMPAT_H + +/* + * winternl.h is not included in MinGW, which was shipped with the 32-bit + * Windows version of GHC prior to the 7.10.3 release. + */ +#if defined(x86_64_HOST_ARCH) || \ + __GLASGOW_HASKELL__ >= 711 || \ + (__GLASGOW_HASKELL__ == 710 && \ + defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ + __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) +# include +#else +// Some declarations from winternl.h that we need in Win32 +# include + +typedef enum _OBJECT_INFORMATION_CLASS { + ObjectBasicInformation, + ObjectNameInformation, + ObjectTypeInformation, + ObjectAllInformation, + ObjectDataInformation +} OBJECT_INFORMATION_CLASS, *POBJECT_INFORMATION_CLASS; + +typedef LONG NTSTATUS, *PNTSTATUS; + +typedef struct _UNICODE_STRING { + USHORT Length; + USHORT MaximumLength; + PWSTR Buffer; +} UNICODE_STRING, *PUNICODE_STRING; + +typedef struct _OBJECT_NAME_INFORMATION { + UNICODE_STRING Name; +} OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION; +#endif + +#endif /* WINTERNL_COMPAT_H */ diff --git a/src/System/IO/Echo.hs b/src/System/IO/Echo.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Echo.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif + +{-| +Module: System.IO.Echo +Copyright: (C) 2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: Portable + +Exports functions that handle whether or not terminal input is handled in a way +that should be portable across different platforms and consoles. +-} +module System.IO.Echo ( + -- * Public interface + withoutInputEcho, bracketInputEcho + , getInputEchoState, setInputEchoState + , EchoState, echoOff, echoOn + + -- * Alternative interface + , getInputEcho, setInputEcho + ) where + +import System.IO.Echo.Internal diff --git a/src/System/IO/Echo/Internal.hs b/src/System/IO/Echo/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Echo/Internal.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 702 +# if defined(WINDOWS) +{-# LANGUAGE Trustworthy #-} +# else +# if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Safe #-} +# else +{-# LANGUAGE Trustworthy #-} +# endif +# endif +#endif + +{-| +Module: System.IO.Echo.Internal +Copyright: (C) 2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: Portable + +Exports functions that handle whether or not terminal input is handled in a way +that should be portable across different platforms and consoles. + +Unlike "System.IO.Echo", this module exports internal functionality which, if +used improperly, can lead to runtime errors. Make sure to read the +documentation beforehand! +-} +module System.IO.Echo.Internal ( + -- * Safe public interface + withoutInputEcho, bracketInputEcho + , getInputEchoState, setInputEchoState + , echoOff, echoOn + + -- * Alternative (safe) interface + , getInputEcho, setInputEcho + + -- * Unsafe STTY internals + , EchoState(..), STTYSettings + , getInputEchoSTTY, setInputEchoSTTY, sttyRaw + + -- * MinTTY + , minTTY + ) where + +import Control.Exception (bracket, throw) +import Control.Monad (void) + +import Data.List (isInfixOf) + +import System.Exit (ExitCode(..)) +import System.IO (hGetContents, hGetEcho, hSetEcho, stdin) +import System.Process (StdStream(..), createProcess, shell, + std_in, std_out, waitForProcess) + +#if defined(WINDOWS) +import Graphics.Win32.Misc (getStdHandle, sTD_INPUT_HANDLE) + +import System.IO.Echo.MinTTY (isMinTTYHandle) +import System.IO.Unsafe (unsafePerformIO) +#endif + +-- | Return whether the terminal's echoing is on ('True') or off ('False'). +-- +-- Note that while this works on MinTTY, it is not as efficient as +-- 'getInputEchoState', as it involves a somewhat expensive substring +-- computation. +getInputEcho :: IO Bool +getInputEcho = if minTTY + then do settings <- sttyRaw "-a" + -- This assumes that other settings come after + -- [-]echo in the output of `stty -a`. Luckily, this + -- seems to be the case on every incarnation of + -- MinTTY that I've tried. + return $ not ("-echo " `isInfixOf` settings) + else hGetEcho stdin + +-- | Return the terminal's current input 'EchoState'. +getInputEchoState :: IO EchoState +getInputEchoState = if minTTY + then fmap MinTTY getInputEchoSTTY + else fmap DefaultTTY $ hGetEcho stdin + +-- | 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 +-- 'setInputEchoState'. +getInputEchoSTTY :: IO STTYSettings +getInputEchoSTTY = sttyRaw "-g" + +-- | Set the terminal's echoing on ('True') or off ('False'). +setInputEcho :: Bool -> IO () +setInputEcho echo = if minTTY + then setInputEchoSTTY $ ['-' | not echo] ++ "echo" + else hSetEcho stdin echo + +-- | Set the terminal's input 'EchoState'. +setInputEchoState :: EchoState -> IO () +setInputEchoState (MinTTY settings) = setInputEchoSTTY settings +setInputEchoState (DefaultTTY echo) = hSetEcho stdin 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. +-- +-- @ +-- setInputEchoSTTY = 'void' . 'sttyRaw' +-- @ +setInputEchoSTTY :: STTYSettings -> IO () +setInputEchoSTTY = void . sttyRaw + +-- | Save the terminal's current input 'EchoState', perform a computation, +-- restore the saved 'EchoState', and then return the result of the +-- computation. +-- +-- @ +-- bracketInputEcho action = 'bracket' 'getInputEcho' 'setInputEcho' (const action) +-- @ +bracketInputEcho :: IO a -> IO a +bracketInputEcho action = bracket getInputEcho setInputEcho (const action) + +-- | Perform a computation with the terminal's input echoing disabled. Before +-- running the computation, the terminal's input 'EchoState' is saved, and the +-- saved 'EchoState' is restored after the computation finishes. +-- +-- @ +-- withoutInputEcho action = 'bracketInputEcho' ('setInputEchoState' 'echoOff' >> action) +-- @ +withoutInputEcho :: IO a -> IO a +withoutInputEcho action = bracketInputEcho (setInputEchoState echoOff >> action) + +-- | Create an @stty@ process, wait for it to complete, and return its output. +sttyRaw :: String -> IO STTYSettings +sttyRaw arg = do + let stty = (shell $ "stty " ++ arg) { + std_in = UseHandle stdin + , 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 terminal input's current echoing state. Example +-- values include 'echoOff' and 'echoOn'. +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 terminal's input echoing is (or should be) off. +echoOff :: EchoState +echoOff = if minTTY then MinTTY "-echo" else DefaultTTY False + +-- | Indicates that the terminal's input echoing is (or should be) on. +echoOn :: EchoState +echoOn = if minTTY then MinTTY "echo" else DefaultTTY True + +-- | 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 :: Bool +#if defined(WINDOWS) +minTTY = unsafePerformIO $ do + h <- getStdHandle sTD_INPUT_HANDLE + isMinTTYHandle h +{-# NOINLINE minTTY #-} +#else +minTTY = False +#endif diff --git a/src/System/IO/Echo/MinTTY.hsc b/src/System/IO/Echo/MinTTY.hsc new file mode 100644 --- /dev/null +++ b/src/System/IO/Echo/MinTTY.hsc @@ -0,0 +1,240 @@ +{- +This is a direct copy of System.Win32.MinTTY from the Win32 library. We need +this for backwards compatibility with older versions of Win32 which do not ship +with this module. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.MinTTY +-- Copyright : (c) University of Glasgow 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A function to check if the current terminal uses MinTTY. +-- Much of this code was originally authored by Phil Ruffwind and the +-- git-for-windows project. +-- +----------------------------------------------------------------------------- + +module System.IO.Echo.MinTTY (isMinTTY, isMinTTYHandle) where + +import Graphics.Win32.Misc +import System.Win32.DLL +import System.Win32.File +import System.Win32.Types + +#if MIN_VERSION_base(4,6,0) +import Control.Exception (catch) +#endif +import Data.List (isPrefixOf, isInfixOf, isSuffixOf) +import Foreign +import Foreign.C.Types +import System.FilePath (takeFileName) + +#if __GLASGOW_HASKELL__ < 711 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +-- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP. +-- Since we need some structs that are only available with Vista or later, +-- we must manually set WINVER/_WIN32_WINNT accordingly. +#undef WINVER +#define WINVER 0x0600 +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 +##include "windows_cconv.h" +#include +#include "winternl_compat.h" + +-- | Returns 'True' if the current process's standard error is attached to a +-- MinTTY console (e.g., Cygwin or MSYS). Returns 'False' otherwise. +isMinTTY :: IO Bool +isMinTTY = do + h <- getStdHandle sTD_ERROR_HANDLE + `catch` \(_ :: IOError) -> + return nullHANDLE + if h == nullHANDLE + then return False + else isMinTTYHandle h + +-- | Returns 'True' is the given handle is attached to a MinTTY console +-- (e.g., Cygwin or MSYS). Returns 'False' otherwise. +isMinTTYHandle :: HANDLE -> IO Bool +isMinTTYHandle h = do + fileType <- getFileType h + if fileType /= fILE_TYPE_PIPE + then return False + else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h + -- GetFileNameByHandleEx is only available on Vista and later (hence + -- the name isMinTTYVista). If we're on an older version of Windows, + -- getProcAddress will throw an IOException when it fails to find + -- GetFileNameByHandleEx, and thus we will default to using + -- NtQueryObject (isMinTTYCompat). + +isMinTTYVista :: HANDLE -> IO Bool +isMinTTYVista h = do + fn <- getFileNameByHandle h + return $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> + return False + +isMinTTYCompat :: HANDLE -> IO Bool +isMinTTYCompat h = do + fn <- ntQueryObjectNameInformation h + return $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> + return False + +cygwinMSYSCheck :: String -> Bool +cygwinMSYSCheck fn = ("cygwin-" `isPrefixOf` fn' || "msys-" `isPrefixOf` fn') && + "-pty" `isInfixOf` fn' && + "-master" `isSuffixOf` fn' + where + fn' = takeFileName fn +-- Note that GetFileInformationByHandleEx might return a filepath like: +-- +-- \msys-dd50a72ab4668b33-pty1-to-master +-- +-- But NtQueryObject might return something like: +-- +-- \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master +-- +-- This means we can't rely on "\cygwin-" or "\msys-" being at the very start +-- of the filepath. Therefore, we must take care to first call takeFileName +-- before checking for "cygwin" or "msys" at the start using `isPrefixOf`. + +getFileNameByHandle :: HANDLE -> IO String +getFileNameByHandle h = do + let sizeOfDWORD = sizeOf (undefined :: DWORD) + -- note: implicitly assuming that DWORD has stronger alignment than wchar_t + bufSize = sizeOfDWORD + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> do + getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) + fni <- peek buf + return $ fniFileName fni + +getFileInformationByHandleEx + :: HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO () +getFileInformationByHandleEx h cls buf bufSize = do + lib <- getModuleHandle (Just "kernel32.dll") + ptr <- getProcAddress lib "GetFileInformationByHandleEx" + let c_GetFileInformationByHandleEx = + mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) + failIfFalse_ "getFileInformationByHandleEx" + (c_GetFileInformationByHandleEx h cls buf bufSize) + +ntQueryObjectNameInformation :: HANDLE -> IO String +ntQueryObjectNameInformation h = do + let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION) + bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> + alloca $ \p_len -> do + _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject + h objectNameInformation buf (fromIntegral bufSize) p_len + oni <- peek buf + return $ usBuffer $ oniName oni + +fileNameInfo :: CInt +fileNameInfo = #const FileNameInfo + +mAX_PATH :: Num a => a +mAX_PATH = #const MAX_PATH + +objectNameInformation :: CInt +objectNameInformation = #const ObjectNameInformation + +type F_GetFileInformationByHandleEx = + HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "dynamic" + mk_GetFileInformationByHandleEx + :: FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx + +data FILE_NAME_INFO = FILE_NAME_INFO + { fniFileNameLength :: DWORD + , fniFileName :: String + } deriving Show + +instance Storable FILE_NAME_INFO where + sizeOf _ = #size FILE_NAME_INFO + alignment _ = #alignment FILE_NAME_INFO + poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName) + end = advancePtr start len' + (#poke FILE_NAME_INFO, FileNameLength) buf len' + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf + let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR + vfniFileName <- peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len) + return $ FILE_NAME_INFO + { fniFileNameLength = vfniFileNameLength + , fniFileName = vfniFileName + } + +foreign import WINDOWS_CCONV "winternl.h NtQueryObject" + c_NtQueryObject :: HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION + -> ULONG -> Ptr ULONG -> IO NTSTATUS + +type NTSTATUS = #type NTSTATUS +type ULONG = #type ULONG + +failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a +failIfNeg = failIf (< 0) + +newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION + { oniName :: UNICODE_STRING + } deriving Show + +instance Storable OBJECT_NAME_INFORMATION where + sizeOf _ = #size OBJECT_NAME_INFORMATION + alignment _ = #alignment OBJECT_NAME_INFORMATION + poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni) + peek buf = fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf + +data UNICODE_STRING = UNICODE_STRING + { usLength :: USHORT + , usMaximumLength :: USHORT + , usBuffer :: String + } deriving Show + +instance Storable UNICODE_STRING where + sizeOf _ = #size UNICODE_STRING + alignment _ = #alignment UNICODE_STRING + poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#size UNICODE_STRING) + end = advancePtr start len' + (#poke UNICODE_STRING, Length) buf len' + (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR) + (#poke UNICODE_STRING, Buffer) buf start + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vusLength <- (#peek UNICODE_STRING, Length) buf + vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf + vusBufferPtr <- (#peek UNICODE_STRING, Buffer) buf + let len = fromIntegral vusLength `div` sizeOfTCHAR + vusBuffer <- peekTStringLen (vusBufferPtr, len) + return $ UNICODE_STRING + { usLength = vusLength + , usMaximumLength = vusMaximumLength + , usBuffer = vusBuffer + } + +sizeOfTCHAR :: Int +sizeOfTCHAR = sizeOf (undefined :: TCHAR)