{-# LANGUAGE DeriveDataTypeable #-}

-- | We use our own functions for throwing exceptions in order to get
-- the actual error message via 'zmq_strerror'. 0MQ defines additional
-- error numbers besides those defined by the operating system, so
-- 'zmq_strerror' should be used in preference to 'strerror' which is
-- used by the standard throw* functions in 'Foreign.C.Error'.
--
-- /Warning/: This is an internal module and subject
-- to change without notice.
module System.ZMQ4.Internal.Error where

import Control.Applicative
import Control.Monad
import Control.Exception
import Text.Printf
import Data.Typeable (Typeable)

import Foreign hiding (throwIf, throwIf_, void)
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types (CInt)
import Prelude

import System.ZMQ4.Internal.Base

-- | ZMQError encapsulates information about errors, which occur
-- when using the native 0MQ API, such as error number and message.
data ZMQError = ZMQError
    { ZMQError -> Int
errno   :: Int     -- ^ Error number value.
    , ZMQError -> String
source  :: String  -- ^ Source where this error originates from.
    , ZMQError -> String
message :: String  -- ^ Actual error message.
    } deriving (ZMQError -> ZMQError -> Bool
(ZMQError -> ZMQError -> Bool)
-> (ZMQError -> ZMQError -> Bool) -> Eq ZMQError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZMQError -> ZMQError -> Bool
== :: ZMQError -> ZMQError -> Bool
$c/= :: ZMQError -> ZMQError -> Bool
/= :: ZMQError -> ZMQError -> Bool
Eq, Eq ZMQError
Eq ZMQError =>
(ZMQError -> ZMQError -> Ordering)
-> (ZMQError -> ZMQError -> Bool)
-> (ZMQError -> ZMQError -> Bool)
-> (ZMQError -> ZMQError -> Bool)
-> (ZMQError -> ZMQError -> Bool)
-> (ZMQError -> ZMQError -> ZMQError)
-> (ZMQError -> ZMQError -> ZMQError)
-> Ord ZMQError
ZMQError -> ZMQError -> Bool
ZMQError -> ZMQError -> Ordering
ZMQError -> ZMQError -> ZMQError
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 :: ZMQError -> ZMQError -> Ordering
compare :: ZMQError -> ZMQError -> Ordering
$c< :: ZMQError -> ZMQError -> Bool
< :: ZMQError -> ZMQError -> Bool
$c<= :: ZMQError -> ZMQError -> Bool
<= :: ZMQError -> ZMQError -> Bool
$c> :: ZMQError -> ZMQError -> Bool
> :: ZMQError -> ZMQError -> Bool
$c>= :: ZMQError -> ZMQError -> Bool
>= :: ZMQError -> ZMQError -> Bool
$cmax :: ZMQError -> ZMQError -> ZMQError
max :: ZMQError -> ZMQError -> ZMQError
$cmin :: ZMQError -> ZMQError -> ZMQError
min :: ZMQError -> ZMQError -> ZMQError
Ord, Typeable)

instance Show ZMQError where
    show :: ZMQError -> String
show ZMQError
e = String -> Int -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"ZMQError { errno = %d, source = \"%s\", message = \"%s\" }"
                (ZMQError -> Int
errno ZMQError
e) (ZMQError -> String
source ZMQError
e) (ZMQError -> String
message ZMQError
e)

instance Exception ZMQError

throwError :: String -> IO a
throwError :: forall a. String -> IO a
throwError String
src = do
    (Errno CInt
e) <- IO Errno
zmqErrno
    String
msg       <- CInt -> IO String
zmqErrnoMessage CInt
e
    ZMQError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ZMQError -> IO a) -> ZMQError -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> String -> String -> ZMQError
ZMQError (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
e) String
src String
msg

throwIf :: (a -> Bool) -> String -> IO a -> IO a
throwIf :: forall a. (a -> Bool) -> String -> IO a -> IO a
throwIf a -> Bool
p String
src IO a
act = do
    a
r <- IO a
act
    if a -> Bool
p a
r then String -> IO a
forall a. String -> IO a
throwError String
src else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

throwIf_ :: (a -> Bool) -> String -> IO a -> IO ()
throwIf_ :: forall a. (a -> Bool) -> String -> IO a -> IO ()
throwIf_ a -> Bool
p String
src IO a
act = IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
throwIf a -> Bool
p String
src IO a
act

throwIfRetry :: (a -> Bool) -> String -> IO a -> IO a
throwIfRetry :: forall a. (a -> Bool) -> String -> IO a -> IO a
throwIfRetry a -> Bool
p String
src IO a
act = do
    a
r <- IO a
act
    if a -> Bool
p a
r then IO Errno
zmqErrno IO Errno -> (Errno -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Errno -> IO a
k else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  where
    k :: Errno -> IO a
k Errno
e | Errno
e Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR = (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
throwIfRetry a -> Bool
p String
src IO a
act
        | Bool
otherwise  = String -> IO a
forall a. String -> IO a
throwError String
src

throwIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
throwIfRetry_ :: forall a. (a -> Bool) -> String -> IO a -> IO ()
throwIfRetry_ a -> Bool
p String
src IO a
act = IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
throwIfRetry a -> Bool
p String
src IO a
act

throwIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a
throwIfMinus1 :: forall a. (Eq a, Num a) => String -> IO a -> IO a
throwIfMinus1 = (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
throwIf (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1)

throwIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO ()
throwIfMinus1_ :: forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwIfMinus1_ = (a -> Bool) -> String -> IO a -> IO ()
forall a. (a -> Bool) -> String -> IO a -> IO ()
throwIf_ (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1)

throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
throwIfNull :: forall a. String -> IO (Ptr a) -> IO (Ptr a)
throwIfNull = (Ptr a -> Bool) -> String -> IO (Ptr a) -> IO (Ptr a)
forall a. (a -> Bool) -> String -> IO a -> IO a
throwIf (Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr)

throwIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a
throwIfMinus1Retry :: forall a. (Eq a, Num a) => String -> IO a -> IO a
throwIfMinus1Retry = (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
throwIfRetry (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1)

throwIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO ()
throwIfMinus1Retry_ :: forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwIfMinus1Retry_ = (a -> Bool) -> String -> IO a -> IO ()
forall a. (a -> Bool) -> String -> IO a -> IO ()
throwIfRetry_ (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1)

throwIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a
throwIfRetryMayBlock :: forall a b. (a -> Bool) -> String -> IO a -> IO b -> IO a
throwIfRetryMayBlock a -> Bool
p String
src IO a
f IO b
on_block = do
    a
r <- IO a
f
    if a -> Bool
p a
r then IO Errno
zmqErrno IO Errno -> (Errno -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Errno -> IO a
k else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  where
    k :: Errno -> IO a
k Errno
e | Errno
e Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR                      = (a -> Bool) -> String -> IO a -> IO b -> IO a
forall a b. (a -> Bool) -> String -> IO a -> IO b -> IO a
throwIfRetryMayBlock a -> Bool
p String
src IO a
f IO b
on_block
        | Errno
e Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eWOULDBLOCK Bool -> Bool -> Bool
|| Errno
e Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eAGAIN = IO b
on_block IO b -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> Bool) -> String -> IO a -> IO b -> IO a
forall a b. (a -> Bool) -> String -> IO a -> IO b -> IO a
throwIfRetryMayBlock a -> Bool
p String
src IO a
f IO b
on_block
        | Bool
otherwise                       = String -> IO a
forall a. String -> IO a
throwError String
src

throwIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
throwIfRetryMayBlock_ :: forall a b. (a -> Bool) -> String -> IO a -> IO b -> IO ()
throwIfRetryMayBlock_ a -> Bool
p String
src IO a
f IO b
on_block = IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> String -> IO a -> IO b -> IO a
forall a b. (a -> Bool) -> String -> IO a -> IO b -> IO a
throwIfRetryMayBlock a -> Bool
p String
src IO a
f IO b
on_block

throwIfMinus1RetryMayBlock :: (Eq a, Num a) => String -> IO a -> IO b -> IO a
throwIfMinus1RetryMayBlock :: forall a b. (Eq a, Num a) => String -> IO a -> IO b -> IO a
throwIfMinus1RetryMayBlock = (a -> Bool) -> String -> IO a -> IO b -> IO a
forall a b. (a -> Bool) -> String -> IO a -> IO b -> IO a
throwIfRetryMayBlock (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1)

throwIfMinus1RetryMayBlock_ :: (Eq a, Num a) => String -> IO a -> IO b -> IO ()
throwIfMinus1RetryMayBlock_ :: forall a b. (Eq a, Num a) => String -> IO a -> IO b -> IO ()
throwIfMinus1RetryMayBlock_ = (a -> Bool) -> String -> IO a -> IO b -> IO ()
forall a b. (a -> Bool) -> String -> IO a -> IO b -> IO ()
throwIfRetryMayBlock_ (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1)

zmqErrnoMessage :: CInt -> IO String
zmqErrnoMessage :: CInt -> IO String
zmqErrnoMessage CInt
e = CInt -> IO CString
c_zmq_strerror CInt
e IO CString -> (CString -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString

zmqErrno :: IO Errno
zmqErrno :: IO Errno
zmqErrno = CInt -> Errno
Errno (CInt -> Errno) -> IO CInt -> IO Errno
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CInt
c_zmq_errno