app/Rehi/Win32bits.hsc

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 {-# LANGUAGE TypeFamilies #-}
   3 module Rehi.Win32bits where
   4
   5 import Data.Bits (Bits, toIntegralSized)
   6 import Data.Int (Int32)
   7 import Data.Proxy (Proxy)
   8 import Data.Typeable (Typeable, typeRep)
   9 import Data.Word (Word32)
  10 import Foreign.Ptr (Ptr(), nullPtr)
  11 import Foreign.Marshal.Alloc (allocaBytesAligned, alloca)
  12 import Foreign.Storable (Storable(alignment, peek, peekByteOff, poke, pokeByteOff, sizeOf))
  13 import Numeric (showHex)
  14
  15 import qualified System.Win32.Types as WT
  16
  17 #include <windef.h>
  18 #include <winnt.h>
  19 #include <ntdef.h>
  20
  21 #if defined(i386_HOST_ARCH)
  22 #let WINDOWS_CCONV = "stdcall"
  23 #elif defined(x86_64_HOST_ARCH)
  24 #let WINDOWS_CCONV = "ccall"
  25 #else
  26 # error Unknown mingw32 arch
  27 #endif
  28
  29 #def typedef struct __PUBLIC_OBJECT_TYPE_INFORMATION {
  30       UNICODE_STRING TypeName;
  31       ULONG Reserved [22];
  32   } PUBLIC_OBJECT_TYPE_INFORMATION;
  33
  34 #def typedef enum {
  35     ObjectNameInformation = 1,
  36   } OBJECT_INFORMATION_CLASS;
  37
  38 #def NTSTATUS NtQueryObject(
  39   HANDLE                   Handle,
  40   OBJECT_INFORMATION_CLASS ObjectInformationClass,
  41   *PUBLIC_OBJECT_TYPE_INFORMATION  ObjectInformation,
  42   ULONG                    ObjectInformationLength,
  43   PULONG                   ReturnLength
  44  );
  45
  46 -- https://stackoverflow.com/a/8354582/2303202
  47 -- https://wiki.haskell.org/FFICookBook#Working_with_structs
  48 #if __GLASGOW_HASKELL__ < 800
  49 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
  50 #endif
  51
  52 data NT_OBJECT_NAME_INFORMATION = NT_OBJECT_NAME_INFORMATION
  53     { noniLength :: WT.USHORT
  54     , noniMaximumLength :: WT.USHORT
  55     , noniBuffer :: WT.LPWSTR }
  56
  57 instance Storable NT_OBJECT_NAME_INFORMATION where
  58   sizeOf = const #{size PUBLIC_OBJECT_TYPE_INFORMATION}
  59   alignment = const #{alignment PUBLIC_OBJECT_TYPE_INFORMATION}
  60   peek p = NT_OBJECT_NAME_INFORMATION
  61             <$> #{peek UNICODE_STRING, Length} p
  62             <*> #{peek UNICODE_STRING, MaximumLength} p
  63             <*> #{peek UNICODE_STRING, Buffer} p
  64   poke p o = do
  65     #{poke UNICODE_STRING, Length} p (noniLength o)
  66     #{poke UNICODE_STRING, MaximumLength} p (noniMaximumLength o)
  67     #{poke UNICODE_STRING, Buffer} p (noniBuffer o)
  68
  69 type ObjectInformationClass = #{type OBJECT_INFORMATION_CLASS}
  70
  71 #enum ObjectInformationClass, , hs_ObjectNameInformation = ObjectNameInformation
  72
  73 type family Unsigned t :: *
  74 type instance Unsigned Int32 = Word32
  75
  76 type NTSTATUS = Unsigned #{type NTSTATUS}
  77
  78 type ULONG = WT.DWORD
  79
  80 foreign import #{WINDOWS_CCONV} "NtQueryObject"
  81   c_NtQueryObject :: WT.HANDLE
  82                   -> ObjectInformationClass
  83                   -> Ptr NT_OBJECT_NAME_INFORMATION
  84                   -> ULONG
  85                   -> Ptr ULONG
  86                   -> IO NTSTATUS
  87
  88 toIntegralSizedM :: forall a b . (Bits a, Integral a, Show a, Bits b, Integral b, Typeable b) => a -> IO b
  89 toIntegralSizedM v = case toIntegralSized v of
  90   Just res -> pure res
  91   Nothing -> fail ("Cannot cast from " ++ show v ++ " to " ++ show (typeRep (undefined :: Proxy b)))
  92
  93 getFileNameInformation :: WT.HANDLE -> IO String
  94 getFileNameInformation h =
  95   alloca $ \ (p_len :: Ptr ULONG) -> do
  96     checkNtStatus
  97       (== 0xC0000004) -- STATUS_INFO_LENGTH_MISMATCH
  98       $ c_NtQueryObject h hs_ObjectNameInformation nullPtr 0 p_len
  99     len <- peek p_len
 100     len_signed <- toIntegralSizedM len
 101     allocaBytesAligned
 102         len_signed
 103         (alignment (undefined :: NT_OBJECT_NAME_INFORMATION))
 104         $ \ p_oni -> do
 105       checkNtStatus
 106         (\s -> s >= 0 && s <= 0x7FFFFFFF) -- https://msdn.microsoft.com/en-us/library/windows/hardware/ff565436.aspx
 107         $ c_NtQueryObject h hs_ObjectNameInformation p_oni len p_len
 108       res <- peek p_len
 109       oni <- peek p_oni
 110       oni_length <- toIntegralSizedM (noniLength oni `div` 2)
 111       WT.peekTStringLen (noniBuffer oni, oni_length)
 112   where
 113     checkNtStatus :: (NTSTATUS -> Bool) -> IO NTSTATUS -> IO ()
 114     checkNtStatus p f = do
 115       s <- f
 116       if p s
 117         then pure ()
 118         else fail ("NtQueryObject(ObjectNameInformation) failed: " ++ showHex s "")