System/Win32/WindowsString/Types.hsc
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Win32.Types
-- Copyright : (c) Alastair Reid, 1997-2003
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>
-- Stability : provisional
-- Portability : portable
--
-- A collection of FFI declarations for interfacing with Win32.
--
-----------------------------------------------------------------------------
module System.Win32.WindowsString.Types
( module System.Win32.WindowsString.Types
, module System.Win32.Types
) where
import System.Win32.Types hiding (
withTString
, withTStringLen
, peekTString
, peekTStringLen
, newTString
, failIf
, failIf_
, failIfNeg
, failIfNull
, failIfZero
, failIfFalse_
, failUnlessSuccess
, failUnlessSuccessOr
, errorWin
, failWith
, try
, withFilePath
, useAsCWStringSafe
)
import Foreign.C.Types (CUIntPtr(..))
import Foreign.C.String (CWString)
import qualified System.OsPath.Windows as WS
import System.OsPath.Windows (WindowsPath)
import System.OsString.Windows (decodeWith, encodeWith)
import System.OsString.Internal.Types
#if MIN_VERSION_filepath(1, 5, 0)
import "os-string" System.OsString.Encoding.Internal (decodeWithBaseWindows)
import qualified "os-string" System.OsString.Data.ByteString.Short.Word16 as SBS
import "os-string" System.OsString.Data.ByteString.Short.Word16 (
#else
import "filepath" System.OsPath.Encoding.Internal (decodeWithBaseWindows)
import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as SBS
import "filepath" System.OsPath.Data.ByteString.Short.Word16 (
#endif
packCWString,
packCWStringLen,
useAsCWString,
useAsCWStringLen,
newCWString
)
import Data.Bifunctor (first)
import Data.Char (isSpace)
import Numeric (showHex)
import qualified System.IO as IO ()
import System.IO.Error (ioeSetErrorString)
import Foreign (allocaArray)
import Foreign.Ptr ( Ptr )
import Foreign.C.Error ( errnoToIOError )
import Control.Exception ( throwIO )
import qualified Control.Exception as EX
import GHC.Ptr (castPtr)
import GHC.IO.Exception
#if !MIN_VERSION_base(4,8,0)
import Data.Word (Word)
#endif
import GHC.IO.Encoding.UTF16 ( mkUTF16le )
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
#include <fcntl.h>
#include <windows.h>
#include <wchar.h>
##include "windows_cconv.h"
----------------------------------------------------------------
-- Chars and strings
----------------------------------------------------------------
withTString :: WindowsString -> (LPTSTR -> IO a) -> IO a
withFilePath :: WindowsPath -> (LPTSTR -> IO a) -> IO a
withTStringLen :: WindowsString -> ((LPTSTR, Int) -> IO a) -> IO a
peekTString :: LPCTSTR -> IO WindowsString
peekTStringLen :: (LPCTSTR, Int) -> IO WindowsString
newTString :: WindowsString -> IO LPCTSTR
-- UTF-16 version:
-- the casts are from 'Ptr Word16' to 'Ptr CWchar', which is safe
withTString (WindowsString str) f = useAsCWString str (\ptr -> f (castPtr ptr))
withFilePath path = useAsCWStringSafe path
withTStringLen (WindowsString str) f = useAsCWStringLen str (\(ptr, len) -> f (castPtr ptr, len))
peekTString = fmap WindowsString . packCWString . castPtr
peekTStringLen = fmap WindowsString . packCWStringLen . first castPtr
newTString (WindowsString str) = fmap castPtr $ newCWString str
foreign import ccall unsafe "wchar.h wcslen" c_wcslen
:: CWString -> IO SIZE_T
-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are
-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
useAsCWStringSafe :: WindowsPath -> (CWString -> IO a) -> IO a
useAsCWStringSafe wp@(WS path) f = useAsCWString path $ \(castPtr -> ptr) -> do
let len = SBS.numWord16 path
clen <- c_wcslen ptr
if clen == fromIntegral len
then f ptr
else do
path' <- either (const (_toStr wp)) id <$> (EX.try @IOException) (decodeWithBaseWindows path)
ioError (err path')
where
_toStr = fmap WS.toChar . WS.unpack
err path' =
IOError
{ ioe_handle = Nothing
, ioe_type = InvalidArgument
, ioe_location = "useAsCWStringSafe"
, ioe_description = "Windows filepaths must not contain internal NUL codepoints."
, ioe_errno = Nothing
, ioe_filename = Just path'
}
----------------------------------------------------------------
-- Errors
----------------------------------------------------------------
failIf :: (a -> Bool) -> String -> IO a -> IO a
failIf p wh act = do
v <- act
if p v then errorWin wh else return v
failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
failIf_ p wh act = do
v <- act
if p v then errorWin wh else return ()
failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a
failIfNeg = failIf (< 0)
failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
failIfNull = failIf (== nullPtr)
failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
failIfZero = failIf (== 0)
failIfFalse_ :: String -> IO Bool -> IO ()
failIfFalse_ = failIf_ not
failUnlessSuccess :: String -> IO ErrCode -> IO ()
failUnlessSuccess fn_name act = do
r <- act
if r == 0 then return () else failWith fn_name r
failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
failUnlessSuccessOr val fn_name act = do
r <- act
if r == 0 then return False
else if r == val then return True
else failWith fn_name r
errorWin :: String -> IO a
errorWin fn_name = do
err_code <- getLastError
failWith fn_name err_code
failWith :: String -> ErrCode -> IO a
failWith fn_name err_code = do
c_msg <- getErrorMessage err_code
msg <- either (fail . show) pure . decodeWith (mkUTF16le TransliterateCodingFailure) =<< if c_msg == nullPtr
then either (fail . show) pure . encodeWith (mkUTF16le TransliterateCodingFailure) $ "Error 0x" ++ Numeric.showHex err_code ""
else do msg <- peekTString c_msg
-- We ignore failure of freeing c_msg, given we're already failing
_ <- localFree c_msg
return msg
-- turn GetLastError() into errno, which errnoToIOError knows how to convert
-- to an IOException we can throw.
errno <- c_maperrno_func err_code
let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
ioerror = errnoToIOError fn_name errno Nothing Nothing
`ioeSetErrorString` msg'
throwIO ioerror
-- Support for API calls that are passed a fixed-size buffer and tell
-- you via the return value if the buffer was too small. In that
-- case, we double the buffer size and try again.
try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString
try loc f n = do
e <- allocaArray (fromIntegral n) $ \lptstr -> do
r <- failIfZero loc $ f lptstr n
if (r > n) then return (Left r) else do
str <- peekTStringLen (lptstr, fromIntegral r)
return (Right str)
case e of
Left n' -> try loc f n'
Right str -> return str