{-# language BangPatterns #-}
{-# language LambdaCase #-}
{-# language MagicHash #-}
{-# language ScopedTypeVariables #-}
{-# language UnboxedTuples #-}
{-# language EmptyCase #-}
module Network.Icmp.Ping.Single
( host
) where
import Control.Applicative ((<|>))
import Control.Concurrent (threadWaitWrite,threadWaitReadSTM)
import Control.Concurrent.STM.TVar (readTVar,registerDelay)
import Control.Exception (onException,mask)
import Data.Functor (($>))
import Data.Word (Word64,Word8)
import Foreign.C.Error (Errno(..),eAGAIN,eWOULDBLOCK,eACCES)
import Foreign.C.Types (CSize(..))
import GHC.Clock (getMonotonicTimeNSec)
import GHC.IO (IO(..))
import Net.Types (IPv4(..))
import Network.Icmp.Common (IcmpException(..))
import Network.Icmp.Marshal (peekIcmpHeaderPayload,peekIcmpHeaderType)
import Network.Icmp.Marshal (peekIcmpHeaderSequenceNumber)
import Network.Icmp.Marshal (sizeOfIcmpHeader,pokeIcmpHeader)
import Posix.Socket (SocketAddressInternet(..))
import System.Endian (toBE32)
import System.Posix.Types (Fd(..))
import qualified Control.Monad.STM as STM
import qualified Data.Primitive as PM
import qualified Linux.Socket as SCK
import qualified Posix.Socket as SCK
fullPacketSize :: Int
fullPacketSize = sizeOfIcmpHeader + 4
host ::
Int
-> IPv4
-> IO (Either IcmpException (Maybe Word64))
host !maxWaitTime (IPv4 !w) = if maxWaitTime <= 0
then pure (Right Nothing)
else do
mask $ \restore -> SCK.uninterruptibleSocket SCK.internet SCK.datagram SCK.icmp >>= \case
Left (Errno e) -> pure (Left (IcmpExceptionSocket e))
Right sock -> do
elapsed <- restore
( do let sockaddr = SCK.encodeSocketAddressInternet
(SocketAddressInternet { port = 0, address = toBE32 w })
buffer <- PM.newByteArray fullPacketSize
PM.setByteArray buffer 0 sizeOfIcmpHeader (0 :: Word8)
pokeIcmpHeader buffer 0 w
start <- getMonotonicTimeNSec
mwriteError <- writeWhenReady
(SCK.uninterruptibleSendToMutableByteArray sock buffer 0 (intToCSize fullPacketSize) SCK.dontWait sockaddr)
(threadWaitWrite sock)
case mwriteError of
Left (Errno e)
| Errno e == eACCES -> pure (Right Nothing)
| otherwise -> pure (Left (IcmpExceptionSend e))
Right sentBytes -> do
if sentBytes == intToCSize fullPacketSize
then do
isReady <- waitForRead maxWaitTime sock
if isReady
then do
r <- SCK.uninterruptibleReceiveFromMutableByteArray_ sock buffer 0 (intToCSize fullPacketSize) SCK.dontWait
case r of
Left (Errno e) -> pure (Left (IcmpExceptionReceive e))
Right receivedBytes -> if receivedBytes == intToCSize fullPacketSize
then do
sequenceNumber' <- peekIcmpHeaderSequenceNumber buffer
payload' <- peekIcmpHeaderPayload buffer
typ <- peekIcmpHeaderType buffer
if sequenceNumber' == 0 && payload' == w && typ == 0
then do
end <- getMonotonicTimeNSec
let !delta = end - start
pure (Right (Just delta))
else pure (Right Nothing)
else pure (Right Nothing)
else pure (Right Nothing)
else pure (Left (IcmpExceptionSendBytes sentBytes))
)
`onException`
(SCK.uninterruptibleClose sock)
SCK.uninterruptibleClose sock >>= \case
Left (Errno e) -> pure (Left (IcmpExceptionClose e))
Right _ -> pure elapsed
waitForRead ::
Int
-> Fd
-> IO Bool
waitForRead !maxWaitTime !sock = do
(isReadyAction,deregister) <- threadWaitReadSTM sock
delay <- registerDelay maxWaitTime
isContentReady <- STM.atomically $
(isReadyAction $> True)
<|>
(do isDone <- readTVar delay
STM.check isDone
pure False
)
deregister
pure isContentReady
writeWhenReady
:: IO (Either Errno CSize)
-> IO ()
-> IO (Either Errno CSize)
writeWhenReady f wait = f >>= \case
Left e1 -> if e1 == eWOULDBLOCK || e1 == eAGAIN
then wait *> f
else pure (Left e1)
Right i -> pure (Right i)
intToCSize :: Int -> CSize
intToCSize = fromIntegral