ping (empty) → 0.1.0.0
raw patch · 11 files changed
+1046/−0 lines, 11 filesdep +basedep +cpudep +ipsetup-changed
Dependencies added: base, cpu, ip, posix-api, primitive, primitive-containers, stm, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- include/custom.h +55/−0
- ping.cabal +55/−0
- src/Network/Icmp/Common.hs +26/−0
- src/Network/Icmp/Marshal.hsc +74/−0
- src/Network/Icmp/Ping.hs +19/−0
- src/Network/Icmp/Ping/Hosts.hs +287/−0
- src/Network/Icmp/Ping/Multihosts.hs +346/−0
- src/Network/Icmp/Ping/Single.hs +147/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for ping++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ include/custom.h view
@@ -0,0 +1,55 @@+#include <stddef.h>++// 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"); \+ }+
+ ping.cabal view
@@ -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
+ src/Network/Icmp/Common.hs view
@@ -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++
+ src/Network/Icmp/Marshal.hsc view
@@ -0,0 +1,74 @@+{-# language DataKinds #-}++#include <netinet/ip_icmp.h>+#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}+
+ src/Network/Icmp/Ping.hs view
@@ -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(..))
+ src/Network/Icmp/Ping/Hosts.hs view
@@ -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+
+ src/Network/Icmp/Ping/Multihosts.hs view
@@ -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
+ src/Network/Icmp/Ping/Single.hs view
@@ -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+