MultiByte.hsc

{- |
   Module      :  System.Win32.Error.MutiByte
   Copyright   :  2012 shelarcy
   License     :  BSD-style

   Maintainer  :  shelarcy@gmail.com
   Stability   :  Provisional
   Portability :  Non-portable (Win32 API)

   MutiByte support version of error handling for foreign calls to the Win32 API.
-}
module System.Win32.Error.MultiByte where
import Control.Concurrent        ( threadDelay)
import Control.Exception         ( throwIO )
import Control.Monad             ( void )
import Data.Char                 ( isSpace )
import Foreign.C.Error           ( getErrno, errnoToIOError )
import Foreign.Ptr               ( Ptr )
import qualified Numeric         ( showHex )
import System.IO.Error           ( ioeSetErrorString )
import System.Win32.Types hiding ( failIf, failIf_, failIfNull
                                 , failIfZero, failIfFalse_
                                 , failUnlessSuccess, failUnlessSuccessOr
                                 , errorWin, failWith)
import System.Win32.Encoding

#include <windows.h>

----------------------------------------------------------------
-- MultiByte version of 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 ()

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
  cp <- getCurrentCodePage
  failWithInternal getErrorMessage (encodeMultiByteIO cp) fn_name err_code

failWithInternal :: (ErrCode -> IO LPWSTR) -> (String -> IO String) -> String -> ErrCode -> IO a
failWithInternal msg conv fn_name err_code = do
  c_msg <- msg err_code
  msg <- if c_msg == nullPtr
           then return $ "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
  c_maperrno -- turn GetLastError() into errno, which errnoToIOError knows
             -- how to convert to an IOException we can throw.
             -- XXX we should really do this directly.
  errno <- getErrno
  let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
  msg'' <- conv msg' -- convert to multibytes message
  let ioerror = errnoToIOError fn_name errno Nothing Nothing
                  `ioeSetErrorString` msg''
  throwIO ioerror

-- | like failIfFalse_, but retried on sharing violations.
-- This is necessary for many file operations; see
--   <http://support.microsoft.com/kb/316609>
--
failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a
failIfWithRetry cond msg action = retryOrFail retries
  where
    delay   = 100*1000 -- in ms, we use threadDelay
    retries = 20 :: Int
      -- KB article recommends 250/5

    -- retryOrFail :: Int -> IO a
    retryOrFail times
      | times <= 0 = errorWin msg
      | otherwise  = do
         ret <- action
         if not (cond ret)
            then return ret
            else do
              err_code <- getLastError
              if err_code == (# const ERROR_SHARING_VIOLATION)
                then do threadDelay delay; retryOrFail (times - 1)
                else errorWin msg

failIfWithRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
failIfWithRetry_ cond msg action = void $ failIfWithRetry cond msg action

failIfFalseWithRetry_ :: String -> IO Bool -> IO ()
failIfFalseWithRetry_ = failIfWithRetry_ not