diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ping + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Andrew Martin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Martin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/include/custom.h b/include/custom.h new file mode 100644 --- /dev/null +++ b/include/custom.h @@ -0,0 +1,55 @@ +#include + +// This include file lets us use hsc2hs to generate code working +// with ByteArray (through Data.Primitive) instead of Ptr. + +// The macro FIELD_SIZEOF is defined in the linux kernel. +// It is written out here for portability. +#define INTERNAL_FIELD_SIZEOF(t, f) (sizeof(((t*)0)->f)) + +// This is a lot like peek except that it is designed to +// work with ByteArray instead of Ptr. GHC requires that all +// indexing into ByteArrays is aligned. So, we do some trickery +// based on the size of what the user is requesting. +#define hsc_read(t, f) \ + switch (INTERNAL_FIELD_SIZEOF(t,f)) { \ + case 1: \ + hsc_printf ("(\\hsc_arr -> readByteArray hsc_arr %ld)", (long) offsetof (t, f)); \ + break; \ + case 2: \ + if (offsetof (t, f) % 2 == 0) \ + hsc_printf ("(\\hsc_arr -> readByteArray hsc_arr %ld)", ((long) offsetof (t, f)) / 2); \ + else \ + hsc_printf ("BAD_READ_ALIGNMENT"); \ + break; \ + default: \ + hsc_printf ("(BAD_READ_SIZE_%ld)", (long) INTERNAL_FIELD_SIZEOF(t,f)); \ + break; \ + } + +#define hsc_write(t, f) \ + switch (INTERNAL_FIELD_SIZEOF(t,f)) { \ + case 1: \ + hsc_printf ("(\\hsc_arr -> writeByteArray hsc_arr %ld)", (long) offsetof (t, f)); \ + break; \ + case 2: \ + if (offsetof (t, f) % 2 == 0) \ + hsc_printf ("(\\hsc_arr -> writeByteArray hsc_arr %ld)", ((long) offsetof (t, f)) / 2); \ + else \ + hsc_printf ("BAD_WRITE_ALIGNMENT"); \ + break; \ + default: \ + hsc_printf ("(BAD_WRITE_SIZE_%ld)", (long) INTERNAL_FIELD_SIZEOF(t,f)); \ + break; \ + } + +// Compute an element offset from a byte offset and the element size. +// This causes a compile-time failure if the element size does not +// divide evenly into the byte offset. This is commonly used as: +#define hsc_elementize(boff, sz) \ + if ((boff) % (sz) == 0) { \ + hsc_printf ("%ld", ((boff) / (sz))); \ + } else { \ + hsc_printf ("BAD_ELEMENT_OFFSET"); \ + } + diff --git a/ping.cabal b/ping.cabal new file mode 100644 --- /dev/null +++ b/ping.cabal @@ -0,0 +1,55 @@ +cabal-version: 2.2 +name: ping +version: 0.1.0.0 +synopsis: icmp echo requests +description: + This library provides functions that have similar behavior as the + unix command-line utility ping. In particular, both emit ICMP echo requests + and wait for responses. This library uses a haskell implementation of ICMP + rather than invoking `/bin/ping`. This avoids the costly process of starting + a child process. Additionally, there are greater opportunities for reusing + sockets. The cost of this is that the user must ensure that one of these + is true: + . + * The kernel parameter `net.ipv4.ping_group_range` has been configured + to allow pings to all IP addresses. (preferred solution) + . + * The process is running with the the `CAP_NET_RAW` capability. + . + * The process is running as root. (worst solution) + . +homepage: https://github.com/andrewthad/ping +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2018 Andrew Martin +category: Network +build-type: Simple +extra-source-files: + CHANGELOG.md + include/custom.h + +library + build-depends: + , base >= 4.11.1 && <5 + , ip >= 1.4 + , cpu >= 0.1.2 + , posix-api >= 0.1 + , primitive >= 0.6.4 + , primitive-containers >= 0.3.1 + , stm >= 2.5 + , transformers >= 0.5.5 + exposed-modules: Network.Icmp.Ping + other-modules: + Network.Icmp.Marshal + Network.Icmp.Ping.Single + Network.Icmp.Ping.Hosts + Network.Icmp.Ping.Multihosts + Network.Icmp.Common + hs-source-dirs: src + default-language: Haskell2010 + build-tools: hsc2hs + ghc-options: -O2 -Wall + include-dirs: include + includes: custom.h diff --git a/src/Network/Icmp/Common.hs b/src/Network/Icmp/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/Icmp/Common.hs @@ -0,0 +1,26 @@ +module Network.Icmp.Common + ( IcmpException(..) + ) where + +import Foreign.C.Types (CSize,CInt) +import Control.Exception (Exception) + +data IcmpException + = IcmpExceptionSocket !CInt + -- ^ Could not create the socket + | IcmpExceptionSend !CInt + -- ^ Unable to send when the event manager indicated that the socket + -- was ready for writes. + | IcmpExceptionSendBytes !CSize + -- ^ Unable to send the entirity on an ICMP request. The field is + -- the number of bytes actually sent. + | IcmpExceptionReceive !CInt + -- ^ Unable to receive when the event manager indicated that the socket + -- was ready for reads. + | IcmpExceptionClose !CInt + -- ^ Could not close the socket. + deriving (Show,Eq) + +instance Exception IcmpException + + diff --git a/src/Network/Icmp/Marshal.hsc b/src/Network/Icmp/Marshal.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Icmp/Marshal.hsc @@ -0,0 +1,74 @@ +{-# language DataKinds #-} + +#include +#include "custom.h" + +module Network.Icmp.Marshal + ( pokeIcmpHeader + , peekIcmpHeaderSequenceNumber + , peekIcmpHeaderPayload + , peekIcmpHeaderType + , sizeOfIcmpHeader + ) where + +import Data.Word (Word32,Word16,Word8) +import GHC.Exts (RealWorld) + +import Data.Primitive (MutableByteArray) +import Data.Primitive (readByteArray,writeByteArray) + +-- The linux kernel (version 4.19.9) defines icmphdr as: +-- +-- struct icmphdr { +-- __u8 type; +-- __u8 code; +-- __sum16 checksum; +-- union { +-- struct { +-- __be16 id; +-- __be16 sequence; +-- } echo; +-- __be32 gateway; +-- struct { +-- __be16 __unused; +-- __be16 mtu; +-- } frag; +-- __u8 reserved[4]; +-- } un; +-- }; + +sizeOfIcmpHeader :: Int +sizeOfIcmpHeader = #{size struct icmphdr} + +-- This sets the type to ICMP_ECHO and the sequence number to +-- user-specified values. The sequence number is supposed to be +-- in network byte order, but this does not actually matter. +-- If it is mangled on the way out, it will also be +-- mangled when we receive it. +-- +-- Why is the identifier (un.echo.id) missing? Linux overwrites +-- the identifier regardless of what the user puts there. This +-- makes sense since the operating system wants to make it as +-- easy as possible to hand the reply to the right process. +pokeIcmpHeader :: + MutableByteArray RealWorld + -> Word16 -- sequence number + -> Word32 -- payload, we use this as a bigger sequence number + -> IO () +pokeIcmpHeader ptr sequenceNumber payload = do + #{write struct icmphdr, type} ptr (#{const ICMP_ECHO} :: Word8) + #{write struct icmphdr, un.echo.sequence} ptr sequenceNumber + writeByteArray ptr #{elementize sizeof (struct icmphdr), 4} payload + +peekIcmpHeaderType :: MutableByteArray RealWorld -> IO Word8 +peekIcmpHeaderType ptr = do + #{read struct icmphdr, type} ptr + +peekIcmpHeaderSequenceNumber :: MutableByteArray RealWorld -> IO Word16 +peekIcmpHeaderSequenceNumber ptr = do + #{read struct icmphdr, un.echo.sequence} ptr + +peekIcmpHeaderPayload :: MutableByteArray RealWorld -> IO Word32 +peekIcmpHeaderPayload ptr = do + readByteArray ptr #{elementize sizeof (struct icmphdr), 4} + diff --git a/src/Network/Icmp/Ping.hs b/src/Network/Icmp/Ping.hs new file mode 100644 --- /dev/null +++ b/src/Network/Icmp/Ping.hs @@ -0,0 +1,19 @@ +module Network.Icmp.Ping + ( -- * Functions + S.host + , H.hosts + , H.range + , M.multihosts + , M.multirange + -- * Exceptions + , IcmpException(..) + ) where + +-- TODO: Figure out a more graceful way to fail when someone tries +-- to ping the broadcast address. Can this be distinguished from the +-- error message that we get when the sysctl thing is not set? + +import qualified Network.Icmp.Ping.Single as S +import qualified Network.Icmp.Ping.Hosts as H +import qualified Network.Icmp.Ping.Multihosts as M +import Network.Icmp.Common (IcmpException(..)) diff --git a/src/Network/Icmp/Ping/Hosts.hs b/src/Network/Icmp/Ping/Hosts.hs new file mode 100644 --- /dev/null +++ b/src/Network/Icmp/Ping/Hosts.hs @@ -0,0 +1,287 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language ScopedTypeVariables #-} +{-# language UnboxedTuples #-} +{-# language EmptyCase #-} + +module Network.Icmp.Ping.Hosts + ( hosts + , range + ) where + +-- TODO: The functions in this module currently do not finish +-- promptly when they have the opportunity to. If all hosts +-- respond, it would be better to go ahead and finish rather +-- than waiting around. The use of adjustManyInline makes this +-- a little trickier than it would otherwise be. + +import Control.Applicative ((<|>)) +import Control.Concurrent (threadWaitReadSTM,threadWaitWriteSTM) +import Control.Concurrent.STM.TVar (readTVar,registerDelay) +import Control.Exception (onException,mask) +import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.), testBit) +import Data.Functor (($>)) +import Data.Primitive (PrimArray,MutableByteArray) +import Data.Word (Word64,Word8,Word16,Word32) +import Foreign.C.Error (Errno(..),eACCES) +import Foreign.C.Types (CSize(..)) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Exts (RealWorld) +import GHC.IO (IO(..)) +import Net.Types (IPv4(..),IPv4Range) +import Network.Icmp.Marshal (peekIcmpHeaderPayload,peekIcmpHeaderType) +import Network.Icmp.Marshal (peekIcmpHeaderSequenceNumber) +import Network.Icmp.Marshal (sizeOfIcmpHeader,pokeIcmpHeader) +import Network.Icmp.Common (IcmpException(..)) +import Posix.Socket (SocketAddressInternet(..)) +import System.Endian (toBE32) +import System.Posix.Types (Fd(..)) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Control.Monad.STM as STM +import qualified Data.Map.Unboxed.Unboxed as MUU +import qualified Data.Primitive as PM +import qualified Data.Set.Unboxed as SU +import qualified Linux.Socket as SCK +import qualified Posix.Socket as SCK +import qualified Net.IPv4 as IPv4 + +debug :: String -> IO () +debug _ = pure () +-- debug = putStrLn + +fullPacketSize :: Int +fullPacketSize = sizeOfIcmpHeader + 4 + +-- Wait up to a specified maximum number of microseconds +-- for a socket to have data ready to be read. Returns +-- True if there is something on the buffer to be read +-- and False if nothing showed up in time. +waitForRead :: + Int -- Maximum number of microseconds to wait. + -> Fd -- Socket + -> 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 + +-- Wait for read or write to be available on the socket. +-- Returns True if read became available and False if +-- write became available. +waitForReadWrite :: Fd -> IO Bool +waitForReadWrite sock = do + (isReadyRead,deregisterRead) <- threadWaitReadSTM sock + (isReadyWrite,deregisterWrite) <- threadWaitWriteSTM sock + r <- STM.atomically ((isReadyRead $> True) <|> (isReadyWrite $> False)) + deregisterRead + deregisterWrite + pure r + +-- | Ping a range of hosts simultaneously. +range :: + Int -- ^ Microseconds to wait for response + -> IPv4Range -- ^ Range + -> IO (Either IcmpException (MUU.Map IPv4 Word64)) -- ^ Elapsed nanoseconds for responding hosts +range !pause !r = hosts pause $ coerceIPv4Set + (SU.enumFromTo + (getIPv4 (IPv4.lowerInclusive r)) + (getIPv4 (IPv4.upperInclusive r)) + ) + +-- The existence of this function is a little disappointing. I suspect that +-- there is a better way to do this (probably by writing version of +-- Data.Set.Unboxed.enumFromTo that works without a Num constraint), +-- but I am choosing the easiest path for now. +-- +-- TODO: There is a better way. I need to rewrite +-- Data.Primitive.Contiguous.fromList to be compatible with +-- list fusion. Then Data.Set.Unboxed.enumFromTo can use +-- that, and everything should work out alright. Well, we +-- still must perform an extra check to ensure that the +-- enum instance is compatible with the Ord instance, +-- but that's not too bad. +coerceIPv4Set :: SU.Set Word32 -> SU.Set IPv4 +coerceIPv4Set = unsafeCoerce + +-- | Ping a set of hosts simultaneously. Performs one ping +-- for each host and reports the elapsed nanoseconds for the +-- response. If a key is missing from the resulting map, it +-- indicates that a response was not received from that host. +hosts :: + Int -- ^ Microseconds to wait for response + -> SU.Set IPv4 -- ^ Hosts + -> IO (Either IcmpException (MUU.Map IPv4 Word64)) -- ^ Elapsed nanoseconds for responding hosts +hosts !pause !theHosts = do + mask $ \restore -> SCK.socket SCK.internet SCK.datagram SCK.icmp >>= \case + Left (Errno e) -> pure (Left (IcmpExceptionSocket e)) + Right sock -> do + durations <- restore + ( do let hostsArr = SU.toArray theHosts + !buffer <- PM.newByteArray fullPacketSize + (m,r) <- MUU.adjustManyInline + (\adjust -> hostsStepA buffer sock pause hostsArr (PM.sizeofPrimArray hostsArr) adjust + ) (MUU.fromSet (const initialStatus) theHosts) + pure $ case r of + Left pair -> Left pair + Right _ -> Right + ( MUU.mapMaybe + (\w -> case testBit w 47 of + True -> Just (extractTimestamp w) + False -> Nothing + ) m + ) + ) + `onException` + (SCK.unsafeClose sock) + SCK.unsafeClose sock >>= \case + Left (Errno e) -> pure (Left (IcmpExceptionClose e)) + Right _ -> pure durations + +hostsStepA :: MutableByteArray RealWorld -> Fd -> Int -> PrimArray IPv4 -> Int -> (IPv4 -> (Word64 -> IO Word64) -> IO ()) -> IO (Either IcmpException ()) +hostsStepA !buffer !sock !pause !hostsArr !hostsLen adjust = go 0 where + go !ix = if ix < hostsLen + then do + debug "waiting for read-write" + waitForReadWrite sock >>= \case + True -> do + debug "ready for read" + r <- SCK.unsafeReceiveFromMutableByteArray_ 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 + payload' <- peekIcmpHeaderPayload buffer + adjust (IPv4 payload') $ \w -> case extractStatus w of + 0b01 -> do + sequenceNumber' <- peekIcmpHeaderSequenceNumber buffer + if sequenceNumber' == extractSequenceNumber w + then do + end <- getMonotonicTimeNSec + pure (completeStatus ((end .&. 0x3FFFFFFFFFFF) - extractTimestamp w)) + else pure w + _ -> + -- In this case, we did not send an icmp echo request + -- but we received a response (00). Or we've already received + -- a response (1x). Pretty weird, and it + -- suggests foul play, but we simply ignore the response. + pure w + go ix + else do + -- If the repsonse is malformed, we leave the result in + -- the map alone. It will be purged at the end. + go ix + False -> do + debug "ready for write" + let host = PM.indexPrimArray hostsArr ix + PM.setByteArray buffer 0 sizeOfIcmpHeader (0 :: Word8) + pokeIcmpHeader buffer (intToWord16 ix) (getIPv4 host) + let sockaddr = SCK.encodeSocketAddressInternet + (SocketAddressInternet { port = 0, address = toBE32 (getIPv4 host) }) + mwriteError <- SCK.unsafeSendToMutableByteArray sock buffer 0 (intToCSize fullPacketSize) SCK.dontWait sockaddr + case mwriteError of + Left (Errno e) + -- When you try to send a packet to a broadcast address, the kernel + -- gives you an EACCES failure. Including a broadcast address in a + -- range is actually somewhat common though. For example, if we try + -- to ping everything on our local network 192.168.1.0/24, we are + -- going to send an ICMP echo request to 192.168.1.0, which the kernel + -- does not like. This is fine though. We just ignore these failures + -- rather than having them abort the entire function. + | Errno e == eACCES -> go (ix + 1) + | otherwise -> pure (Left (IcmpExceptionSend e)) + Right sentBytes -> if sentBytes == intToCSize fullPacketSize + then do + start <- getMonotonicTimeNSec + adjust host (\_ -> pure (pendingStatus (intToWord16 ix) start)) + go (ix + 1) + else do + -- could not send out the full packet, should not happen + pure (Left (IcmpExceptionSendBytes sentBytes)) + else hostsStepB buffer sock pause adjust =<< getMonotonicTimeNSec + +-- We start calling this once we run out of hosts to send to. At this point, +-- all responses need to come in soon. We get the current time and count down +-- from this, requiring any outstanding replies to show up within that time +-- frame. +hostsStepB :: MutableByteArray RealWorld -> Fd -> Int -> (IPv4 -> (Word64 -> IO Word64) -> IO ()) -> Word64 -> IO (Either IcmpException ()) +hostsStepB !buffer !sock !pause !adjust !initialTime = go initialTime where + go !currentTime = do + debug "Step B iteration" + let remainingMicroseconds = pause - word64ToInt (div (currentTime - initialTime) 1000) + if remainingMicroseconds > 0 + then do + isReady <- waitForRead remainingMicroseconds sock + if isReady + then do + r <- SCK.unsafeReceiveFromMutableByteArray_ 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 + payload' <- peekIcmpHeaderPayload buffer + end <- getMonotonicTimeNSec + peekIcmpHeaderType buffer >>= \case + 0 -> do + adjust (IPv4 payload') $ \w -> case extractStatus w of + 0b01 -> do + sequenceNumber' <- peekIcmpHeaderSequenceNumber buffer + if sequenceNumber' == extractSequenceNumber w + then pure (completeStatus ((end .&. 0x3FFFFFFFFFFF) - extractTimestamp w)) + else pure w + _ -> pure w + go end + _ -> go end + else go =<< getMonotonicTimeNSec -- response was wrong size + else pure (Right ()) + else pure (Right ()) + +-- We use the lower 46 bits for the timestamp. We use the upper 16 +-- for the sequence number. Bits 46 and 47 are set to 1x when we have have +-- received a response successfully. It is 01 when we are awaiting a response. It +-- is 00 when nothing has been sent. +pendingStatus :: Word16 -> Word64 -> Word64 +pendingStatus seqNum timestamp = + 0x400000000000 .|. (timestamp .&. 0x3FFFFFFFFFFF) .|. (unsafeShiftL (word16ToWord64 seqNum) 48) + +completeStatus :: Word64 -> Word64 +completeStatus timestamp = 0xC00000000000 .|. timestamp + +initialStatus :: Word64 +initialStatus = 0 + +extractStatus :: Word64 -> Word64 +extractStatus w = + unsafeShiftR (0xC00000000000 .&. w) 46 + +extractSequenceNumber :: Word64 -> Word16 +extractSequenceNumber w = word64ToWord16 (unsafeShiftR w 48) + +extractTimestamp :: Word64 -> Word64 +extractTimestamp w = (w .&. 0x3FFFFFFFFFFF) + +word64ToWord16 :: Word64 -> Word16 +word64ToWord16 = fromIntegral + +word16ToWord64 :: Word16 -> Word64 +word16ToWord64 = fromIntegral + +intToWord16 :: Int -> Word16 +intToWord16 = fromIntegral + +word64ToInt :: Word64 -> Int +word64ToInt = fromIntegral + +intToCSize :: Int -> CSize +intToCSize = fromIntegral + diff --git a/src/Network/Icmp/Ping/Multihosts.hs b/src/Network/Icmp/Ping/Multihosts.hs new file mode 100644 --- /dev/null +++ b/src/Network/Icmp/Ping/Multihosts.hs @@ -0,0 +1,346 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language ScopedTypeVariables #-} +{-# language UnboxedTuples #-} +{-# language EmptyCase #-} + +module Network.Icmp.Ping.Multihosts + ( multihosts + , multirange + ) where + +import Control.Applicative ((<|>)) +import Control.Concurrent (threadWaitReadSTM,threadWaitWrite) +import Control.Concurrent.STM.TVar (readTVar,registerDelay) +import Control.Exception (onException,mask) +import Control.Monad.Trans.Except (ExceptT(..),runExceptT) +import Data.Functor (($>)) +import Data.Primitive (PrimArray,MutableByteArray,MutablePrimArray) +import Data.Word (Word64,Word8,Word16,Word32) +import Foreign.C.Error (Errno(..),eAGAIN,eWOULDBLOCK,eACCES) +import Foreign.C.Types (CSize(..)) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Exts (RealWorld) +import GHC.IO (IO(..)) +import Net.Types (IPv4(..),IPv4Range) +import Network.Icmp.Common (IcmpException(..)) +import Network.Icmp.Marshal (peekIcmpHeaderPayload) +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 Unsafe.Coerce (unsafeCoerce) + +import qualified Control.Monad.STM as STM +import qualified Data.Map.Unboxed.Unlifted as MUN +import qualified Data.Primitive as PM +import qualified Data.Set.Unboxed as SU +import qualified Linux.Socket as SCK +import qualified Net.IPv4 as IPv4 +import qualified Posix.Socket as SCK + +-- TODO: The repeated reallocation for the SockAddr seems +-- a little wasteful. Two possible options are: +-- +-- * Use a mutable buffer instead (posix-api doesn't currently support this) +-- * Cache the sockaddrs on a per-host basis. +-- +-- I lean toward the first option since it would also +-- reduce allocations in Network.Icmp.Ping.Hosts. + +debug :: String -> IO () +debug _ = pure () +-- debug = putStrLn + +-- Why plus 4? We have 4 extra bytes for the IPv4 address. +fullPacketSize :: Int +fullPacketSize = sizeOfIcmpHeader + 4 + +-- Wait up to a specified maximum number of microseconds +-- for a socket to have data ready to be read. Returns +-- True if there is something on the buffer to be read +-- and False if nothing showed up in time. +waitForRead :: + Int -- Maximum number of microseconds to wait. + -> Fd -- Socket + -> IO Bool +waitForRead !maxWaitTime !sock = if maxWaitTime > 0 + then 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 + else pure False + +-- | Ping a group of hosts simultaneously. Performs a configurable +-- number of pings for each host and reports the elapsed nanoseconds +-- for each response. If the array of durations is smaller than the +-- total number of pings, it indicates that some ICMP requests for +-- that host were lost or corrupted. +-- +-- The function also accepts an cutoff for unresponsive hosts. If +-- a host does not respond to the initial number of pings equal to +-- the cutoff, this function does not attempt further pings to the +-- host. Consider the case in which this function performs 20 pings +-- per host with a 5e6 microsecond timeout. Without the unresponsive +-- cutoff, a single nonresponsive host would cause this function to +-- always run for 100 seconds. However, with the cutoff set to 3, +-- this function would stop trying pinging the host after there +-- was no response to any of the first 3 pings. However if there +-- were a response to any of the first 3 pings, then all 20 pings +-- would continue to be sent. This does not necessarily guarantee +-- that this function would run for less than 100 seconds. A host +-- might respond to the initial ping and then go offline. Or a host +-- might take just under 5 seconds to respond to each ping. However, +-- both of these situations are uncommon. What is much more common +-- is that someone includes a bad IP address in the list of hosts, +-- and a low cutoff can considerably reduce the amount of time wasted +-- on such pings. To prevent the cutoff behavior, set it to the number +-- of pings per host. +multihosts :: + Int -- ^ Microseconds to wait for response + -> Int -- ^ Microsecond delay between pings to same host + -> Int -- ^ Number of pings per host + -> Int -- ^ Nonresponsive cutoff + -> SU.Set IPv4 -- ^ Hosts + -> IO (Either IcmpException (MUN.Map IPv4 (PrimArray Word64))) +-- Implementation notes: We have a prim array of durations. Each of these +-- has enough space to hold all the timestamps for each ping. Additionally, +-- they have 4 extra slots at the end: attempted pings, successful pings, +-- last send timestamp, and state (pending send/recv). These are removed +-- at the end by resizeMutablePrimArray, but they are the per-host state +-- over the course of the loop's execution. +multihosts !pause !successPause' !totalPings !cutoff !theHosts + | pause <= 0 || totalPings <= 0 || cutoff <= 0 || SU.null theHosts = pure (Right mempty) + | otherwise = let !successPause = max successPause' 0 in mask $ \restore -> SCK.socket SCK.internet SCK.datagram SCK.icmp >>= \case + Left (Errno e) -> pure (Left (IcmpExceptionSocket e)) + Right sock -> do + !now0 <- getMonotonicTimeNSec + !buffer <- PM.newByteArray fullPacketSize + !durations <- restore + ( do let nanoPause = intToWord64 pause * 1000 + let nanoSuccessPause = intToWord64 successPause * 1000 + eworking <- runExceptT $ MUN.fromSetP + (\theHost -> ExceptT $ do + m <- PM.newPrimArray (totalPings + 4) + PM.setPrimArray m 0 (totalPings + 4) (0 :: Word64) + debug ("Sending initial to " ++ show theHost) + performSend 0 now0 nanoPause sock totalPings theHost buffer m >>= \case + Left err -> pure (Left err) + Right _ -> pure (Right m) + ) theHosts + case eworking of + Left err -> pure (Left err) + Right working -> do + let go :: Word64 -> Word64 -> IO (Either IcmpException ()) + go !currentPause !nextTime = do + waitForRead (word64ToInt (div currentPause 1000)) sock >>= \case + True -> do + debug "Receiving in poll loop" + r <- SCK.unsafeReceiveFromMutableByteArray_ 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 + payload' <- peekIcmpHeaderPayload buffer + end <- getMonotonicTimeNSec + case MUN.lookup (IPv4 payload') working of + Nothing -> go (end - nextTime) nextTime + Just durations -> do + sequenceNumber' <- peekIcmpHeaderSequenceNumber buffer + sequenceNumber <- PM.readPrimArray durations (totalPings + 0) + if word16ToWord64 sequenceNumber' == sequenceNumber + then do + sentTime <- PM.readPrimArray durations (totalPings + 2) + successes <- PM.readPrimArray durations (totalPings + 1) + PM.writePrimArray durations (word64ToInt successes) (end - sentTime) + PM.writePrimArray durations (totalPings + 1) (successes + 1) + PM.writePrimArray durations (totalPings + 2) end + PM.writePrimArray durations (totalPings + 3) pendingSend + let possibleNextTime = end + nanoSuccessPause + if possibleNextTime < nextTime + then go nanoSuccessPause possibleNextTime + else go (nextTime - end) nextTime + else go (nextTime - end) nextTime + else do + end <- getMonotonicTimeNSec + go (nextTime - end) nextTime + False -> do + debug "Updating in poll loop" + currentTime <- getMonotonicTimeNSec + r <- runExceptT $ MUN.foldlMapWithKeyM' + (step sock nanoPause nanoSuccessPause totalPings cutoff buffer currentTime) + working + case r of + Left e -> pure (Left e) + Right (Time futureTime) -> if futureTime == maxBound + then pure (Right ()) + else do + debug ("Waiting for " ++ show (futureTime - currentTime) ++ " nanoseconds before spanning for expirations") + go (futureTime - currentTime) futureTime + now1 <- getMonotonicTimeNSec + go nanoPause (now1 + nanoPause) >>= \case + Left e -> pure (Left e) + Right _ -> fmap Right + ( MUN.mapMaybeP + (\durations -> do + successes <- PM.readPrimArray durations (totalPings + 1) + if successes == 0 + then pure Nothing + else fmap Just (PM.resizeMutablePrimArray durations (word64ToInt successes) >>= PM.unsafeFreezePrimArray) + ) working + ) + ) + `onException` + (SCK.unsafeClose sock) + SCK.unsafeClose sock >>= \case + Left (Errno e) -> pure (Left (IcmpExceptionClose e)) + Right _ -> pure durations + +newtype Time = Time Word64 + +instance Semigroup Time where + Time a <> Time b = Time (min a b) + +instance Monoid Time where + mempty = Time maxBound + +step :: + Fd -- socket + -> Word64 -- Nanoseconds to wait for response + -> Word64 -- Nanosecond delay between pings to same host + -> Int -- Number of pings per host + -> Int -- Nonresponsive cutoff + -> MutableByteArray RealWorld -- buffer + -> Word64 -- current time + -> IPv4 -- destination address + -> MutablePrimArray RealWorld Word64 -- durations and metadata + -> ExceptT IcmpException IO Time +step !sock !pause !successPause !totalPings !cutoff !buffer !now !theHost !durations = ExceptT $ do + attemptedPings <- PM.readPrimArray durations (totalPings + 0) + if word64ToInt attemptedPings < totalPings + then do + successPings <- PM.readPrimArray durations (totalPings + 1) + debug ("Detected " ++ show attemptedPings ++ " attempted pings and " ++ show successPings ++ " successes") + if word64ToInt attemptedPings >= cutoff && successPings == 0 + then pure (Right mempty) + else do + -- The time metadata may refer to either the last time a packet + -- was sent or the last time a packet was received. We + -- can figure out which one by using theState. + theState <- PM.readPrimArray durations (totalPings + 3) + if theState == pendingReceive + then do + sendTime <- PM.readPrimArray durations (totalPings + 2) + if sendTime + pause < now + then performSend attemptedPings now pause sock totalPings theHost buffer durations + else pure (Right (Time (sendTime + pause))) + else do + receiveTime <- PM.readPrimArray durations (totalPings + 2) + if receiveTime + successPause < now + then performSend attemptedPings now pause sock totalPings theHost buffer durations + else pure (Right (Time (receiveTime + successPause))) + else pure (Right mempty) + +performSend :: Word64 -> Word64 -> Word64 -> Fd -> Int -> IPv4 -> MutableByteArray RealWorld -> MutablePrimArray RealWorld Word64 -> IO (Either IcmpException Time) +performSend attemptedPings now pause sock totalPings theHost buffer durations = do + PM.writePrimArray durations (totalPings + 2) now + PM.writePrimArray durations (totalPings + 0) (attemptedPings + 1) + PM.setByteArray buffer 0 sizeOfIcmpHeader (0 :: Word8) + pokeIcmpHeader buffer (word64ToWord16 (attemptedPings + 1)) (getIPv4 theHost) + let sockaddr = SCK.encodeSocketAddressInternet + (SocketAddressInternet { port = 0, address = toBE32 (getIPv4 theHost) }) + mwriteError <- writeWhenReady + (SCK.unsafeSendToMutableByteArray sock buffer 0 (intToCSize fullPacketSize) SCK.dontWait sockaddr) + (threadWaitWrite sock) + case mwriteError of + Left (Errno e) + -- When you try to send a packet to a broadcast address, the kernel + -- gives you an EACCES failure. Including a broadcast address in a + | Errno e == eACCES -> do + PM.writePrimArray durations (totalPings + 0) (intToWord64 totalPings) + PM.writePrimArray durations (totalPings + 3) pendingSend + pure (Right mempty) + | otherwise -> pure (Left (IcmpExceptionSend e)) + Right sentBytes -> if sentBytes == intToCSize fullPacketSize + then do + PM.writePrimArray durations (totalPings + 3) pendingReceive + pure (Right (Time (now + pause))) + else pure (Left (IcmpExceptionSendBytes sentBytes)) + +pendingReceive :: Word64 +pendingReceive = 0 + +pendingSend :: Word64 +pendingSend = 1 + +word64ToWord16 :: Word64 -> Word16 +word64ToWord16 = fromIntegral + +word16ToWord64 :: Word16 -> Word64 +word16ToWord64 = fromIntegral + +intToWord64 :: Int -> Word64 +intToWord64 = fromIntegral + +word64ToInt :: Word64 -> Int +word64ToInt = fromIntegral + +intToCSize :: Int -> CSize +intToCSize = fromIntegral + +-- This is heavily adapted from throwErrnoIfRetryMayBlock in Foreign.C.Error. +-- It only attempts the write twice. If it does not work after the wait +-- function (always threadWaitWrite) returns, it reports an error. Also, +-- this one does not recover from EINTR. I am not sure when that is present +-- in throwErrnoIfRetryMayBlock, but I suspect it is for Windows. This +-- code is not expected to run on Windows. +writeWhenReady + :: IO (Either Errno CSize) -- the 'IO' operation to be executed + -> IO () -- action to execute before retrying if immediate retry would block + -> 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) + +-- | Send multiple pings to each host in a range of hosts simultaneously. +multirange :: + Int -- ^ Microseconds to wait for response + -> Int -- ^ Microsecond delay between pings to same host + -> Int -- ^ Number of pings per host + -> Int -- ^ Nonresponsive cutoff + -> IPv4Range -- ^ Range + -> IO (Either IcmpException (MUN.Map IPv4 (PrimArray Word64))) -- ^ Elapsed nanoseconds for responsive hosts +multirange !pause !successPause !totalPings !cutoff !r = + multihosts pause successPause totalPings cutoff $ coerceIPv4Set + (SU.enumFromTo + (getIPv4 (IPv4.lowerInclusive r)) + (getIPv4 (IPv4.upperInclusive r)) + ) + +-- The existence of this function is a little disappointing. I suspect that +-- there is a better way to do this (probably by writing version of +-- Data.Set.Unboxed.enumFromTo that works without a Num constraint), +-- but I am choosing the easiest path for now. +-- +-- TODO: There is a better way. I need to rewrite +-- Data.Primitive.Contiguous.fromList to be compatible with +-- list fusion. Then Data.Set.Unboxed.enumFromTo can use +-- that, and everything should work out alright. Well, we +-- still must perform an extra check to ensure that the +-- enum instance is compatible with the Ord instance, +-- but that's not too bad. +coerceIPv4Set :: SU.Set Word32 -> SU.Set IPv4 +coerceIPv4Set = unsafeCoerce diff --git a/src/Network/Icmp/Ping/Single.hs b/src/Network/Icmp/Ping/Single.hs new file mode 100644 --- /dev/null +++ b/src/Network/Icmp/Ping/Single.hs @@ -0,0 +1,147 @@ +{-# 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.Marshal (peekIcmpHeaderPayload,peekIcmpHeaderType) +import Network.Icmp.Marshal (peekIcmpHeaderSequenceNumber) +import Network.Icmp.Marshal (sizeOfIcmpHeader,pokeIcmpHeader) +import Network.Icmp.Common (IcmpException(..)) +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 + +-- | Ping an IPv4 address. Blocks until a response is received. +host :: + Int -- ^ Microseconds to wait for response + -> IPv4 -- ^ Host + -> IO (Either IcmpException (Maybe Word64)) -- ^ Elapsed nanoseconds +host !maxWaitTime (IPv4 !w) = if maxWaitTime <= 0 + then pure (Right Nothing) + else do + -- If a socket cannot be opened, there is not a sensible way for the + -- caller to recover. We return a structured error in case the user + -- has a fancy way to display the failure. The user will likely need to + -- rerun the program with CAP_NET_RAW or as root or after adjusting + -- net.ipv4.ping_group_range with sysctl. + mask $ \restore -> SCK.socket 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 + -- We only zero out the header, not the payload. + PM.setByteArray buffer 0 sizeOfIcmpHeader (0 :: Word8) + pokeIcmpHeader buffer 0 w + start <- getMonotonicTimeNSec + mwriteError <- writeWhenReady + (SCK.unsafeSendToMutableByteArray sock buffer 0 (intToCSize fullPacketSize) SCK.dontWait sockaddr) + (threadWaitWrite sock) + case mwriteError of + Left (Errno e) + -- When you try to send a packet to a broadcast address, the kernel + -- gives you an EACCES failure. + | 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.unsafeReceiveFromMutableByteArray_ 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) -- response was for a different request + else pure (Right Nothing) -- response was the wrong size + else pure (Right Nothing) -- did not receive a reply in time + else pure (Left (IcmpExceptionSendBytes sentBytes)) -- could not send out the full packet, should not happen + ) + `onException` + -- In the exceptional case, we throw away any errors returned + -- by unsafeClose (not that we expect to see any). We do this + -- because there is no other sensible behavior. We would much + -- rather preserve the original exception. + (SCK.unsafeClose sock) + -- It is not neccessary to use closeFdWith here since the socket + -- cannot possibly be seen by more than one thread. + SCK.unsafeClose sock >>= \case + Left (Errno e) -> pure (Left (IcmpExceptionClose e)) + Right _ -> pure elapsed + +-- Wait up to a specified maximum number of microseconds +-- for a socket to have data ready to be read. Returns +-- True if there is something on the buffer to be read +-- and False if nothing showed up in time. +waitForRead :: + Int -- Maximum number of microseconds to wait. + -> Fd -- Socket + -> 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 + +-- This is heavily adapted from throwErrnoIfRetryMayBlock in Foreign.C.Error. +-- It only attempts the write twice. If it does not work after the wait +-- function (always threadWaitWrite) returns, it reports an error. Also, +-- this one does not recover from EINTR. I am not sure when that is present +-- in throwErrnoIfRetryMayBlock, but I suspect it is for Windows. This +-- code is not expected to run on Windows. +writeWhenReady + :: IO (Either Errno CSize) -- the 'IO' operation to be executed + -> IO () -- action to execute before retrying if immediate retry would block + -> 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 +