Last active
July 30, 2017 15:53
-
-
Save PRotondo/4962437 to your computer and use it in GitHub Desktop.
Haskell traceroute over icmp
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/usr/bin/env runhaskell | |
-- Haskell traceroute over icmp | |
-- now with ByteString to avoid new errors produced | |
-- by the deprecated recvFrom from Network.Socket | |
import Control.Monad | |
import Data.Bits(complement) | |
import Data.ByteString(unpack,pack) | |
import Data.List | |
import Data.Monoid | |
import Data.Time | |
import Data.Word | |
import Network.BSD(getProtocolNumber) | |
import Network.Socket hiding (send, sendTo, recv, recvFrom) | |
import Network.Socket.ByteString | |
import System.Environment | |
import System.Process | |
import System.Timeout | |
import Text.Printf | |
sec = (*) 1000000 | |
main = withSocketsDo $ | |
do | |
s <- fmap head getArgs | |
addrinfos <- getAddrInfo Nothing (Just s) (Just "0") | |
let serveraddr = head addrinfos | |
let targetAddress = addrAddress serveraddr | |
printf "Haskell traceroute to target Adress: %s\n" $ show targetAddress | |
proto <- getProtocolNumber "icmp" | |
sock <- socket AF_INET Raw proto | |
setSocketOption sock ReuseAddr 1 | |
myAddress <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) Nothing (Just "3000") | |
bind sock (addrAddress . head $ myAddress) | |
try_ttl sock 1 targetAddress | |
close sock | |
where | |
try_ttl sock ttl addr = do | |
setSocketOption sock TimeToLive ttl | |
let checksum = fromIntegral . complement $ (( fromIntegral (14322 + ttl) ) :: Word16) -- no carry ... unless ttl is way too large | |
let msga = pack $ [8,0,fromIntegral $ div checksum 256,fromIntegral $ mod checksum 256,47,242,fromIntegral $ div ttl 256, fromIntegral $ mod ttl 256] -- id is hardcoded | |
info <- replicateM 3 $ measure msga sock addr -- try 3 times | |
let ans = msum $ map (\(_,a,_)->a) info | |
case ans of | |
Just (msg,foundAddress) -> do | |
let (t:c:_) = map toInteger $ drop 20 $ unpack $ msg -- should also look at id | |
let time = intercalate " " $ map prepare_time info | |
printf "#%i %s %s\n" ttl (takeWhile (/=':') $ show foundAddress) time | |
case (t,c) of | |
(11,0) -> try_ttl sock (succ ttl) addr -- Type: 11 (Time-to-live exceeded) | |
(3,0) -> printf "Destination network unreachable!\n" | |
(3,1) -> printf "Destination host unreachable!\n" | |
_ -> return () | |
_ -> printf "Timeout!\n" | |
measure msga sock addr = do | |
sendTo sock msga addr | |
start <- getCurrentTime | |
ans <- timeout (sec 2) $ recvFrom sock 1024 -- timeout after 2 seconds | |
stop <- getCurrentTime | |
return (start,ans,stop) | |
prepare_time (start,Just _,stop) = (++"ms") . init . show $ diffUTCTime stop start * 1000 | |
prepare_time _ = "*" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment