-- | Internal functions
module Network.Transport.Internal
  ( -- * Encoders/decoders
    encodeWord32
  , decodeWord32
  , encodeEnum32
  , decodeNum32
  , encodeWord16
  , decodeWord16
  , encodeEnum16
  , decodeNum16
  , prependLength
    -- * Miscellaneous abstractions
  , mapIOException
  , tryIO
  , tryToEnum
  , timeoutMaybe
  , asyncWhenCancelled
  -- * Replicated functionality from "base"
  , void
  , forkIOWithUnmask
    -- * Debugging
  , tlog
  ) where

#if ! MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif

import Foreign.Storable (pokeByteOff, peekByteOff)
import Foreign.ForeignPtr (withForeignPtr)
import Data.ByteString (ByteString)
import Data.List (foldl')
import qualified Data.ByteString as BS (length)
import qualified Data.ByteString.Internal as BSI
  ( unsafeCreate
  , toForeignPtr
  )
import Data.Word (Word32, Word16)
import Control.Applicative ((<$>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Exception
  ( IOException
  , SomeException
  , AsyncException
  , Exception
  , catch
  , try
  , throw
  , throwIO
  , mask_
  )
import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
import GHC.IO (unsafeUnmask)
import System.IO.Unsafe (unsafeDupablePerformIO)
import System.Timeout (timeout)
--import Control.Concurrent (myThreadId)

#ifdef mingw32_HOST_OS

foreign import stdcall unsafe "htonl" htonl :: Word32 -> Word32
foreign import stdcall unsafe "ntohl" ntohl :: Word32 -> Word32
foreign import stdcall unsafe "htons" htons :: Word16 -> Word16
foreign import stdcall unsafe "ntohs" ntohs :: Word16 -> Word16

#else

foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32
foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32
foreign import ccall unsafe "htons" htons :: Word16 -> Word16
foreign import ccall unsafe "ntohs" ntohs :: Word16 -> Word16

#endif

-- | Serialize 32-bit to network byte order
encodeWord32 :: Word32 -> ByteString
encodeWord32 :: Word32 -> ByteString
encodeWord32 Word32
w32 =
  Int -> (Ptr Word8 -> IO ()) -> ByteString
BSI.unsafeCreate Int
4 forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p ->
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
p Int
0 (Word32 -> Word32
htonl Word32
w32)

-- | Deserialize 32-bit from network byte order
-- Throws an IO exception if this is not exactly 32 bits.
decodeWord32 :: ByteString -> Word32
decodeWord32 :: ByteString -> Word32
decodeWord32 ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs forall a. Eq a => a -> a -> Bool
/= Int
4 = forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"decodeWord32: not 4 bytes"
  | Bool
otherwise         = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
      let (ForeignPtr Word8
fp, Int
offset, Int
_) = ByteString -> (ForeignPtr Word8, Int, Int)
BSI.toForeignPtr ByteString
bs
      forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Word32 -> Word32
ntohl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
p Int
offset

-- | Serialize 16-bit to network byte order
encodeWord16 :: Word16 -> ByteString
encodeWord16 :: Word16 -> ByteString
encodeWord16 Word16
w16 =
  Int -> (Ptr Word8 -> IO ()) -> ByteString
BSI.unsafeCreate Int
2 forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p ->
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
p Int
0 (Word16 -> Word16
htons Word16
w16)

-- | Deserialize 16-bit from network byte order
-- Throws an IO exception if this is not exactly 16 bits.
decodeWord16 :: ByteString -> Word16
decodeWord16 :: ByteString -> Word16
decodeWord16 ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs forall a. Eq a => a -> a -> Bool
/= Int
2 = forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"decodeWord16: not 2 bytes"
  | Bool
otherwise         = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
      let (ForeignPtr Word8
fp, Int
offset, Int
_) = ByteString -> (ForeignPtr Word8, Int, Int)
BSI.toForeignPtr ByteString
bs
      forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Word16 -> Word16
ntohs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
p Int
offset

-- | Encode an Enum in 32 bits by encoding its signed Int equivalent (beware
-- of truncation, an Enum may contain more than 2^32 points).
encodeEnum32 :: Enum a => a -> ByteString
encodeEnum32 :: forall a. Enum a => a -> ByteString
encodeEnum32 = Word32 -> ByteString
encodeWord32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

-- | Decode any Num type from 32 bits by using fromIntegral to convert from
--   a Word32.
decodeNum32 :: Num a => ByteString -> a
decodeNum32 :: forall a. Num a => ByteString -> a
decodeNum32 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word32
decodeWord32

-- | Encode an Enum in 16 bits by encoding its signed Int equivalent (beware
-- of truncation, an Enum may contain more than 2^16 points).
encodeEnum16 :: Enum a => a -> ByteString
encodeEnum16 :: forall a. Enum a => a -> ByteString
encodeEnum16 = Word16 -> ByteString
encodeWord16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

-- | Decode any Num type from 16 bits by using fromIntegral to convert from
-- a Word16.
decodeNum16 :: Num a => ByteString -> a
decodeNum16 :: forall a. Num a => ByteString -> a
decodeNum16 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word16
decodeWord16

-- | Prepend a list of bytestrings with their total length
--   Will be an exception in case of overflow: the sum of the lengths of
--   the ByteStrings overflows Int, or that sum overflows Word32.
prependLength :: [ByteString] -> [ByteString]
prependLength :: [ByteString] -> [ByteString]
prependLength [ByteString]
bss = case Maybe Word32
word32Length of
    Maybe Word32
Nothing -> forall {a}. a
overflow
    Just Word32
w32 -> Word32 -> ByteString
encodeWord32 Word32
w32 forall a. a -> [a] -> [a]
: [ByteString]
bss
  where
    intLength :: Int
    intLength :: Int
intLength = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
safeAdd Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Int
BS.length forall a b. (a -> b) -> a -> b
$ [ByteString]
bss
    word32Length :: Maybe Word32
    word32Length :: Maybe Word32
word32Length = forall a. (Enum a, Bounded a) => Int -> Maybe a
tryToEnum Int
intLength
    -- Non-negative integer addition with overflow check.
    safeAdd :: Int -> Int -> Int
    safeAdd :: Int -> Int -> Int
safeAdd Int
i Int
j
      | Int
r forall a. Ord a => a -> a -> Bool
>= Int
0    = Int
r
      | Bool
otherwise = forall {a}. a
overflow
      where
      r :: Int
r = Int
i forall a. Num a => a -> a -> a
+ Int
j
    overflow :: a
overflow = forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"prependLength: input is too long (overflow)"

-- | Translate exceptions that arise in IO computations
mapIOException :: Exception e => (IOException -> e) -> IO a -> IO a
mapIOException :: forall e a. Exception e => (IOError -> e) -> IO a -> IO a
mapIOException IOError -> e
f IO a
p = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
p (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> e
f)

-- | Like 'try', but lifted and specialized to IOExceptions
tryIO :: MonadIO m => IO a -> m (Either IOException a)
tryIO :: forall (m :: * -> *) a. MonadIO m => IO a -> m (Either IOError a)
tryIO = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try

-- | Logging (for debugging)
tlog :: MonadIO m => String -> m ()
tlog :: forall (m :: * -> *). MonadIO m => String -> m ()
tlog String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-
tlog msg = liftIO $ do
  tid <- myThreadId
  putStrLn $ show tid ++ ": "  ++ msg
-}

-- | Not all versions of "base" export 'void'
void :: Monad m => m a -> m ()
void :: forall (m :: * -> *) a. Monad m => m a -> m ()
void m a
p = m a
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | This was introduced in "base" some time after 7.0.4
forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (forall a. IO a -> IO a) -> IO ()
io = IO () -> IO ThreadId
forkIO ((forall a. IO a -> IO a) -> IO ()
io forall a. IO a -> IO a
unsafeUnmask)

-- | Safe version of 'toEnum'
tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a
tryToEnum :: forall a. (Enum a, Bounded a) => Int -> Maybe a
tryToEnum = forall b. Enum b => b -> b -> Int -> Maybe b
go forall a. Bounded a => a
minBound forall a. Bounded a => a
maxBound
  where
    go :: Enum b => b -> b -> Int -> Maybe b
    go :: forall b. Enum b => b -> b -> Int -> Maybe b
go b
lo b
hi Int
n = if forall a. Enum a => a -> Int
fromEnum b
lo forall a. Ord a => a -> a -> Bool
<= Int
n Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= forall a. Enum a => a -> Int
fromEnum b
hi then forall a. a -> Maybe a
Just (forall a. Enum a => Int -> a
toEnum Int
n) else forall a. Maybe a
Nothing

-- | If the timeout value is not Nothing, wrap the given computation with a
-- timeout and it if times out throw the specified exception. Identity
-- otherwise.
timeoutMaybe :: Exception e => Maybe Int -> e -> IO a -> IO a
timeoutMaybe :: forall e a. Exception e => Maybe Int -> e -> IO a -> IO a
timeoutMaybe Maybe Int
Nothing  e
_ IO a
f = IO a
f
timeoutMaybe (Just Int
n) e
e IO a
f = do
  Maybe a
ma <- forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n IO a
f
  case Maybe a
ma of
    Maybe a
Nothing -> forall e a. Exception e => e -> IO a
throwIO e
e
    Just a
a  -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | @asyncWhenCancelled g f@ runs f in a separate thread and waits for it
-- to complete. If f throws an exception we catch it and rethrow it in the
-- current thread. If the current thread is interrupted before f completes,
-- we run the specified clean up handler (if f throws an exception we assume
-- that no cleanup is necessary).
asyncWhenCancelled :: forall a. (a -> IO ()) -> IO a -> IO a
asyncWhenCancelled :: forall a. (a -> IO ()) -> IO a -> IO a
asyncWhenCancelled a -> IO ()
g IO a
f = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    MVar (Either SomeException a)
mvar <- forall a. IO (MVar a)
newEmptyMVar
    IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try IO a
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException a)
mvar
    -- takeMVar is interruptible (even inside a mask_)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall a. MVar a -> IO a
takeMVar MVar (Either SomeException a)
mvar) (MVar (Either SomeException a)
-> AsyncException -> IO (Either SomeException a)
exceptionHandler MVar (Either SomeException a)
mvar) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return
  where
    exceptionHandler :: MVar (Either SomeException a)
                     -> AsyncException
                     -> IO (Either SomeException a)
    exceptionHandler :: MVar (Either SomeException a)
-> AsyncException -> IO (Either SomeException a)
exceptionHandler MVar (Either SomeException a)
mvar AsyncException
ex = do
      IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Either SomeException a)
mvar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> IO ()
g
      forall e a. Exception e => e -> IO a
throwIO AsyncException
ex