extra/ping/ping.factor

   1 ! Copyright (C) 2010 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: accessors byte-arrays calendar checksums
   4 checksums.internet combinators combinators.smart continuations
   5 destructors io.sockets io.sockets.icmp io.timeouts kernel
   6 locals pack random sequences system ;
   7 IN: ping
   8
   9 <PRIVATE
  10
  11 TUPLE: echo type identifier sequence data ;
  12
  13 : <echo> ( sequence data -- echo )
  14     [ 8 16 random-bits ] 2dip echo boa ;
  15
  16 : echo>byte-array ( echo -- byte-array )
  17     [
  18         [
  19             [ type>> 0 0 ] ! code checksum
  20             [ identifier>> ]
  21             [ sequence>> ] tri
  22         ] output>array "CCSSS" pack-be
  23     ] [ data>> ] bi append [
  24         internet checksum-bytes 2 4
  25     ] keep replace-slice ;
  26
  27 : byte-array>echo ( byte-array -- echo )
  28     dup internet checksum-bytes B{ 0 0 } assert=
  29     8 cut [
  30         "CCSSS" unpack-be { 0 3 4 } swap nths first3
  31     ] dip echo boa ;
  32
  33 : send-ping ( addr raw -- )
  34     [ 0 { } <echo> echo>byte-array ] 2dip send ;
  35
  36 :: recv-ping ( addr raw -- echo )
  37     raw receive addr = [
  38         20 tail byte-array>echo
  39     ] [
  40         drop addr raw recv-ping
  41     ] if ;
  42
  43 PRIVATE>
  44
  45 HOOK: <ping-port> os ( inet -- port )
  46
  47 M: object <ping-port> <raw> ;
  48
  49 M: macosx <ping-port> <datagram> ;
  50
  51 : ping ( host -- reply )
  52     <icmp> resolve-host [ icmp4? ] filter random
  53     f <icmp4> <ping-port>
  54         1 seconds over set-timeout
  55     [ [ send-ping ] [ recv-ping ] 2bi ] with-disposal ;
  56
  57 : local-ping ( -- reply )
  58     "127.0.0.1" ping ;
  59
  60 : alive? ( host -- ? )
  61     [ ping drop t ] [ 2drop f ] recover ;
  62