USING: accessors alien.c-types alien.syntax arrays byte-arrays
classes.struct combinators destructors endian fry
generalizations io.backend.unix io.sockets io.sockets.private
kernel math pack sequences random unix unix.ffi ;


FROM: unix.ffi => socket sockaddr-in AF_INET getpid ;
FROM: unix.types => in_addr_t ;
FROM: namespaces => set get ;
FROM: sequences => short ;

IN: ping

LIBRARY: libc

STRUCT: protoent
    { p_name c-string }
    { p_aliases c-string* }
    { p_proto int } ;

FUNCTION: protoent* getprotobyname ( c-string name ) ;

CONSTANT: SOCK_RAW 3

: IPPROTO_ICMP ( -- proto )
    "icmp" getprotobyname p_proto>> ;

USE: io.ports
USE: io.sockets.unix

: socket-fd ( domain type proto -- fd )
    socket dup io-error <fd> init-fd |dispose ;

: server-socket-fd ( addrspec type proto -- fd )
    [ dup protocol-family ] 2dip socket-fd
    [ init-server-socket ] keep [
        handle-fd swap make-sockaddr/size
        [ bind ] unix-system-call drop
    ] keep ;

: (icmp) ( addr -- raw )
    ! [ SOCK_RAW IPPROTO_ICMP server-socket-fd ] with-destructors ;
    [ SOCK_DGRAM IPPROTO_ICMP server-socket-fd ] with-destructors ;

: <icmp> ( addr -- fd )
    [
        [ (icmp) |dispose ] keep
        [ drop datagram-port <port> ] [ get-local-address ] 2bi
        >>addr
    ] with-destructors ;




: (checksum) ( data -- x )
    [ 0 ] dip [ dup empty? not ] [
        2 short cut dup length 1 = [ B{ 0 } append ] when [
            [ unsigned-endian> ] with-big-endian +
        ] dip
    ] while drop
    [ -16 shift ] [ HEX: ffff bitand ] bi +
    dup -16 shift +
    HEX: ffff bitand bitnot ; ! two's complement 16-bit?

TUPLE: request type code checksum identifier sequence data ;

: <request> ( -- request )
    8 0 0 16 random-bits 0 { } request boa {
        [ data>> ]
        [ type>> ]
        [ code>> ]
        [ checksum>> ]
        [ identifier>> ]
        [ sequence>> ]
    } cleave '[ _ _ _ _ _ ] "CCSSS" pack-be prepend
    [ (checksum) 1array "S" pack-be 2 4 ] keep replace-slice ;

TUPLE: reply type code checksum identifier sequence data ;

: <reply> ( data -- reply )
    20 cut nip 8 cut [ "CCSSS" unpack-be 5 firstn ] dip
    reply boa ;

: ping ( host -- reply )
    0 <inet> resolve-host [ inet4? ] filter random
    f 0 <inet4> <icmp> [
        [ <request> ] 2dip [ send ] [ receive drop ] bi
    ] with-disposal <reply> ;

: local-ping ( -- reply )
    "127.0.0.1" ping ;