diff --git a/ping.cabal b/ping.cabal --- a/ping.cabal +++ b/ping.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ping -version: 0.1.0.0 +version: 0.1.0.1 synopsis: icmp echo requests description: This library provides functions that have similar behavior as the @@ -30,7 +30,17 @@ CHANGELOG.md include/custom.h +flag debug + manual: True + description: Print debug output + default: False + library + hs-source-dirs: src + if flag(debug) + hs-source-dirs: src-debug + else + hs-source-dirs: src-production build-depends: , base >= 4.11.1 && <5 , ip >= 1.4 @@ -47,7 +57,7 @@ Network.Icmp.Ping.Hosts Network.Icmp.Ping.Multihosts Network.Icmp.Common - hs-source-dirs: src + Network.Icmp.Ping.Debug default-language: Haskell2010 build-tools: hsc2hs ghc-options: -O2 -Wall diff --git a/src-debug/Network/Icmp/Ping/Debug.hs b/src-debug/Network/Icmp/Ping/Debug.hs new file mode 100644 --- /dev/null +++ b/src-debug/Network/Icmp/Ping/Debug.hs @@ -0,0 +1,6 @@ +module Network.Icmp.Ping.Debug + ( debug + ) where + +debug :: String -> IO () +debug = putStrLn diff --git a/src-production/Network/Icmp/Ping/Debug.hs b/src-production/Network/Icmp/Ping/Debug.hs new file mode 100644 --- /dev/null +++ b/src-production/Network/Icmp/Ping/Debug.hs @@ -0,0 +1,7 @@ +module Network.Icmp.Ping.Debug + ( debug + ) where + +debug :: String -> IO () +debug _ = pure () + diff --git a/src/Network/Icmp/Ping.hs b/src/Network/Icmp/Ping.hs --- a/src/Network/Icmp/Ping.hs +++ b/src/Network/Icmp/Ping.hs @@ -12,6 +12,8 @@ -- 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? +-- +-- I think this has been solved. import qualified Network.Icmp.Ping.Single as S import qualified Network.Icmp.Ping.Hosts as H diff --git a/src/Network/Icmp/Ping/Hosts.hs b/src/Network/Icmp/Ping/Hosts.hs --- a/src/Network/Icmp/Ping/Hosts.hs +++ b/src/Network/Icmp/Ping/Hosts.hs @@ -31,10 +31,11 @@ import GHC.Exts (RealWorld) import GHC.IO (IO(..)) import Net.Types (IPv4(..),IPv4Range) +import Network.Icmp.Common (IcmpException(..)) import Network.Icmp.Marshal (peekIcmpHeaderPayload,peekIcmpHeaderType) import Network.Icmp.Marshal (peekIcmpHeaderSequenceNumber) import Network.Icmp.Marshal (sizeOfIcmpHeader,pokeIcmpHeader) -import Network.Icmp.Common (IcmpException(..)) +import Network.Icmp.Ping.Debug (debug) import Posix.Socket (SocketAddressInternet(..)) import System.Endian (toBE32) import System.Posix.Types (Fd(..)) @@ -47,10 +48,6 @@ 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 diff --git a/src/Network/Icmp/Ping/Multihosts.hs b/src/Network/Icmp/Ping/Multihosts.hs --- a/src/Network/Icmp/Ping/Multihosts.hs +++ b/src/Network/Icmp/Ping/Multihosts.hs @@ -29,6 +29,7 @@ import Network.Icmp.Marshal (peekIcmpHeaderPayload) import Network.Icmp.Marshal (peekIcmpHeaderSequenceNumber) import Network.Icmp.Marshal (sizeOfIcmpHeader,pokeIcmpHeader) +import Network.Icmp.Ping.Debug (debug) import Posix.Socket (SocketAddressInternet(..)) import System.Endian (toBE32) import System.Posix.Types (Fd(..)) @@ -51,10 +52,6 @@ -- 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 @@ -64,11 +61,13 @@ -- 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. + Bool -- Should we attempt to read? + -> Int -- Maximum number of microseconds to wait. -> Fd -- Socket -> IO Bool -waitForRead !maxWaitTime !sock = if maxWaitTime > 0 +waitForRead !shouldRead !maxWaitTime !sock = if maxWaitTime > 0 && shouldRead then do + debug ("About to wait for " ++ show maxWaitTime ++ " microseconds") (isReadyAction,deregister) <- threadWaitReadSTM sock delay <- registerDelay maxWaitTime isContentReady <- STM.atomically $ @@ -135,6 +134,8 @@ m <- PM.newPrimArray (totalPings + 4) PM.setPrimArray m 0 (totalPings + 4) (0 :: Word64) debug ("Sending initial to " ++ show theHost) + -- We intentionally discard the time that performSend tells + -- us to wait until since we can easily calculate this number. performSend 0 now0 nanoPause sock totalPings theHost buffer m >>= \case Left err -> pure (Left err) Right _ -> pure (Right m) @@ -144,7 +145,14 @@ Right working -> do let go :: Word64 -> Word64 -> IO (Either IcmpException ()) go !currentPause !nextTime = do - waitForRead (word64ToInt (div currentPause 1000)) sock >>= \case + -- Since currentPause is represent an an unsigned type, + -- it jumps up to near the max bound when we end up + -- exceeding the amount of time we are supposed to take. + -- The identifier shouldRead becomes False when this happens, + -- and we move on to the next round of updates. + let shouldRead = currentPause <= nanoPause + let microPause = div currentPause 1000 + waitForRead shouldRead (word64ToInt microPause) sock >>= \case True -> do debug "Receiving in poll loop" r <- SCK.unsafeReceiveFromMutableByteArray_ sock buffer 0 (intToCSize fullPacketSize) SCK.dontWait diff --git a/src/Network/Icmp/Ping/Single.hs b/src/Network/Icmp/Ping/Single.hs --- a/src/Network/Icmp/Ping/Single.hs +++ b/src/Network/Icmp/Ping/Single.hs @@ -20,10 +20,10 @@ 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 Network.Icmp.Common (IcmpException(..)) import Posix.Socket (SocketAddressInternet(..)) import System.Endian (toBE32) import System.Posix.Types (Fd(..))