extra/ping/ping.factor

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