extras/ping.lisp

   1 (in-package :iolib.sockets)
   2
   3 (defcstruct ip-header
   4   (ver-ihl  :uint8)
   5   (tos      :uint8)
   6   (length   :uint16)
   7   (id       :uint16)
   8   (offset   :uint16)
   9   (ttl      :uint8)
  10   (protocol :uint8)
  11   (checksum :uint16)
  12   (saddr    :uint32)
  13   (daddr    :uint32))
  14
  15 (defcstruct icmp-header
  16   (type     :uint8)
  17   (code     :uint8)
  18   (checksum :uint16)
  19   (quench   :uint32))
  20
  21 (defun write-ip-header (ip-header total-length target-ip)
  22   (with-foreign-slots ((ver-ihl length id offset ttl protocol daddr)
  23                        ip-header (:struct ip-header))
  24     (setf ver-ihl  #x45       ; Version 4, header length 5 words(20 bytes)
  25           length   total-length
  26           offset   #b01000000 ; Don't fragment
  27           ttl      64
  28           protocol ipproto-icmp
  29           daddr    (htonl target-ip))))
  30
  31 (defun compute-icmp-checksum (icmp-header packet-size)
  32   (let* ((sum1
  33            (loop :for offset :from 0 :below (/ packet-size 2)
  34                  :sum (mem-aref icmp-header :uint16 offset)))
  35          (sum2 (+ (ash sum1 -16)
  36                   (logand sum1 #xFFFF))))
  37     (logand #xFFFF (lognot (+ sum2 (ash sum2 -16))))))
  38
  39 (defun write-icmp-header (icmp-header packet-size id seqno)
  40   (with-foreign-slots ((type quench checksum)
  41                        icmp-header (:struct icmp-header))
  42     (let ((new-quench
  43             (+ (ash id 16) seqno)))
  44       (setf type     icmp-echo-request
  45             quench   (htonl new-quench))
  46       (setf checksum (compute-icmp-checksum icmp-header packet-size)))))
  47
  48 (defun ping (target &key (id #xFF) (seqno 1))
  49   (with-open-socket (socket :address-family :ipv4 :type :raw :protocol ipproto-icmp
  50                             :include-headers t)
  51     (let* ((payload-size 4)
  52            (icmp-packet-size (+ (isys:sizeof '(:struct icmp-header)) payload-size))
  53            (frame-size (+ (isys:sizeof '(:struct ip-header)) icmp-packet-size)))
  54       (with-foreign-object (frame :uint8 frame-size)
  55         (isys:bzero frame frame-size)
  56         (let* ((ip-header frame)
  57                (icmp-header (cffi:inc-pointer ip-header (isys:sizeof '(:struct ip-header))))
  58                (payload (cffi:inc-pointer icmp-header (isys:sizeof '(:struct icmp-header)))))
  59           (write-ip-header ip-header frame-size (dotted-to-integer target))
  60           (setf (mem-ref payload :uint32) (htonl #x1A2B3C4D))
  61           (write-icmp-header icmp-header icmp-packet-size id seqno)
  62           (send-to socket frame :end frame-size :remote-host target)
  63           (iolib/multiplex:wait-until-fd-ready (socket-os-fd socket) :input)
  64           (receive-from socket :size (* 64 1024)))))))