Annotation of gforth/unix/socket.fs, revision 1.57

1.1       pazsan      1: \ socket interface
                      2: 
1.51      anton       3: \ Copyright (C) 1998,2000,2003,2005,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc.
1.1       pazsan      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.15      anton       9: \ as published by the Free Software Foundation, either version 3
1.1       pazsan     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.15      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1       pazsan     19: 
1.20      anton      20: c-library socket
1.16      anton      21: \c #include <netdb.h>
1.17      pazsan     22: \c #include <unistd.h>
                     23: c-function gethostname gethostname a n -- n ( c-addr u -- ior )
                     24: \c #include <errno.h>
1.24      pazsan     25: \c #define get_errno() errno
                     26: c-function errno get_errno -- n ( -- value )
1.16      anton      27: \c #include <sys/types.h>
                     28: \c #include <sys/socket.h>
                     29: c-function socket socket n n n -- n ( class type proto -- fd )
1.17      pazsan     30: c-function closesocket close n -- n ( fd -- ior )
1.16      anton      31: c-function connect connect n a n -- n ( fd sock size -- err )
1.17      pazsan     32: c-function send send n a n n -- n ( socket buffer count flags -- size )
                     33: c-function recv recv n a n n -- n ( socket buffer count flags -- size )
1.33      pazsan     34: c-function recvfrom recvfrom n a n n a a -- n ( socket buffer count flags srcaddr addrlen -- size )
1.34      pazsan     35: c-function sendto sendto n a n n a n -- n ( socket buffer count flags srcaddr addrlen -- size )
1.25      pazsan     36: c-function listen() listen n n -- n ( socket backlog -- err )
1.28      anton      37: c-function bind bind n a n -- n ( socket sockaddr socklen --- err )
1.18      pazsan     38: c-function accept() accept n a a -- n ( socket sockaddr addrlen -- fd )
1.16      anton      39: \c #include <stdio.h>
                     40: c-function fdopen fdopen n a -- a ( fd fileattr -- file )
1.17      pazsan     41: \c #include <fcntl.h>
                     42: c-function fcntl fcntl n n n -- n ( fd n1 n2 -- ior )
1.16      anton      43: \c #include <arpa/inet.h>
                     44: c-function htonl htonl n -- n ( x -- x' )
                     45: c-function htons htons n -- n ( x -- x' )
                     46: c-function ntohl ntohl n -- n ( x -- x' )
1.23      pazsan     47: \c #define fileno1(file) fileno((FILE*)(file))
                     48: c-function fileno fileno1 a -- n ( file* -- fd )
1.35      pazsan     49: \c #include <poll.h>
                     50: c-function poll poll a n n -- n ( fds nfds timeout -- r )
1.56      pazsan     51: e? os-type s" linux" string-prefix? [IF]
1.42      pazsan     52:     c-function ppoll ppoll a n a a -- n ( fds nfds timeout_ts sigmask -- r )
1.52      pazsan     53:     \c #include <sys/epoll.h>
                     54:     c-function epoll_create epoll_create n -- n ( n -- epfd )
                     55:     c-function epoll_ctl epoll_ctl n n n a -- n ( epfd op fd event -- r )
                     56:     c-function epoll_wait epoll_wait n a n n -- n ( epfd events maxevs timeout -- r )
1.53      pazsan     57:     s" uname -r" r/o open-pipe throw
                     58:     dup >r slurp-fid r> close-pipe throw drop
                     59:     2dup s" 3." string-prefix? >r drop free throw r> [IF]
                     60:        c-function recvmmsg recvmmsg n a n n a -- n ( sockfd hdr vlen flag timeout -- r )
                     61:        c-function sendmmsg sendmmsg n a n n -- n ( sockfd hdr vlen flag -- r )
                     62:     [THEN]
1.42      pazsan     63: [THEN]
1.36      pazsan     64: \c #include <netdb.h>
                     65: c-function getaddrinfo getaddrinfo a a a a -- n ( node service hints res -- r )
                     66: c-function freeaddrinfo freeaddrinfo a -- void ( res -- )
                     67: c-function gai_strerror gai_strerror n -- a ( errcode -- addr )
1.41      pazsan     68: c-function setsockopt setsockopt n n n a n -- n ( sockfd level optname optval optlen -- r )
1.20      anton      69: end-c-library
1.4       pazsan     70: 
1.56      pazsan     71: e? os-type s" darwin" string-prefix? [IF] : darwin ; [THEN]
1.49      pazsan     72: 
1.4       pazsan     73: 4 4 2Constant int%
1.8       pazsan     74: 2 2 2Constant short%
1.37      pazsan     75: int% 2Constant size_t%
1.1       pazsan     76: 
                     77: struct
                     78:     cell% field h_name
                     79:     cell% field h_aliases
1.4       pazsan     80:     int% field h_addrtype
                     81:     int% field h_length
1.1       pazsan     82:     cell% field h_addr_list
                     83: end-struct hostent
                     84: 
                     85: struct
1.8       pazsan     86:     short% field family
                     87:     short% field port
1.4       pazsan     88:     int% field sin_addr
1.42      pazsan     89:     int% 2* field padding
1.41      pazsan     90: end-struct sockaddr_in4
                     91: 
                     92: struct
                     93:     short% field sin6_family
                     94:     short% field sin6_port
                     95:     int% field sin6_flowinfo
                     96:     int% 4 * field sin6_addr
                     97:     int% field sin6_scope_id
                     98: end-struct sockaddr_in6
                     99: 
                    100: sockaddr_in4 %alignment sockaddr_in6 %alignment max
                    101: sockaddr_in4 %size sockaddr_in6 %size max 2Constant sockaddr_in
1.1       pazsan    102: 
1.35      pazsan    103: struct
                    104:     int% field fd
                    105:     short% field events
                    106:     short% field revents
                    107: end-struct pollfd
                    108: 
1.36      pazsan    109: struct
                    110:     int% field ai_flags
                    111:     int% field ai_family
                    112:     int% field ai_socktype
                    113:     int% field ai_protocol
                    114:     size_t% field ai_addrlen
1.49      pazsan    115: [IFDEF] darwin
1.42      pazsan    116:     cell% field ai_canonname
                    117:     cell% field ai_addr
                    118: [ELSE]
1.36      pazsan    119:     cell% field ai_addr
                    120:     cell% field ai_canonname
1.42      pazsan    121: [THEN]
1.36      pazsan    122:     cell% field ai_next
                    123: end-struct addrinfo
                    124: 
1.56      pazsan    125: e? os-type s" linux" string-prefix? [IF]
1.52      pazsan    126:     struct
                    127:        cell% field iov_base
1.53      pazsan    128:        cell% field iov_len
1.52      pazsan    129:     end-struct iovec
                    130:     struct
                    131:        cell% field msg_name
1.53      pazsan    132:        cell% field msg_namelen
1.52      pazsan    133:        cell% field msg_iov \ iovec structures
1.53      pazsan    134:        cell% field msg_iovlen
1.52      pazsan    135:        cell% field msg_control
1.53      pazsan    136:        cell% field msg_controllen
                    137:        cell% field msg_flags
                    138:        cell% field msg_len
1.52      pazsan    139:     end-struct mmsghdr
                    140: [THEN]
                    141: 
1.12      anton     142: ' family alias family+port \ 0.6.2 32-bit field; used by itools
                    143: 
1.1       pazsan    144: Create sockaddr-tmp
                    145: sockaddr-tmp sockaddr_in %size dup allot erase
1.38      pazsan    146: Create hints
                    147: hints addrinfo %size dup allot erase
                    148: Variable addrres
1.41      pazsan    149: Variable sockopt-on
1.1       pazsan    150: 
                    151: : c-string ( addr u -- addr' )
                    152:     tuck pad swap move pad + 0 swap c! pad ;
                    153: 
1.54      pazsan    154:      0 Constant PF_UNSPEC
                    155:      2 Constant PF_INET
1.46      pazsan    156: [IFDEF] darwin
1.54      pazsan    157:     30 Constant PF_INET6
                    158:  $0210 Constant AF_INET
                    159:  $1E1C Constant AF_INET6
                    160:     27 Constant IPV6_V6ONLY
                    161:     35 Constant EWOULDBLOCK
                    162:    $40 Constant MSG_WAITALL
                    163:   $006 Constant O_NONBLOCK|O_RDWR
                    164:  $1006 Constant SO_RCVTIMEO
1.57    ! pazsan    165:      4 Constant SO_REUSEADDR
1.54      pazsan    166:  $FFFF Constant SOL_SOCKET
1.42      pazsan    167: [ELSE]
1.54      pazsan    168:     10 Constant PF_INET6
                    169:      2 Constant AF_INET
                    170:     10 Constant AF_INET6
                    171:     26 Constant IPV6_V6ONLY
                    172:     11 Constant EWOULDBLOCK
                    173:   $100 Constant MSG_WAITALL
1.52      pazsan    174: $10000 Constant MSG_WAITFORONE
1.54      pazsan    175:   $802 Constant O_NONBLOCK|O_RDWR
                    176:     20 Constant SO_RCVTIMEO
1.57    ! pazsan    177:      2 Constant SO_REUSEADDR
1.54      pazsan    178:      1 Constant SOL_SOCKET
1.42      pazsan    179: [THEN]
1.17      pazsan    180:    1 Constant SOCK_STREAM
1.33      pazsan    181:    2 Constant SOCK_DGRAM
1.44      pazsan    182:    0 Constant IPPROTO_IP
1.41      pazsan    183:   41 Constant IPPROTO_IPV6
1.44      pazsan    184:   10 Constant IP_MTU_DISCOVER
                    185:   23 Constant IPV6_MTU_DISCOVER
1.47      pazsan    186:   67 Constant IP_DONTFRAG
1.45      pazsan    187:    2 Constant IP_PMTUDISC_DO
1.17      pazsan    188:    4 Constant F_SETFL
1.35      pazsan    189: $001 Constant POLLIN
                    190: $002 Constant POLLPRI
                    191: $004 Constant POLLOUT
                    192: 
1.30      anton     193: 2variable socket-timeout-d 2000. socket-timeout-d 2!
1.1       pazsan    194: 
1.8       pazsan    195: : new-socket ( -- socket )
1.33      pazsan    196:     PF_INET SOCK_STREAM 0 socket
                    197:     dup 0<= abort" no free socket" ;
                    198: 
1.41      pazsan    199: : new-socket6 ( -- socket )
                    200:     PF_INET6 SOCK_STREAM 0 socket
                    201:     dup 0<= abort" no free socket"
                    202:     dup IPPROTO_IPV6 IPV6_V6ONLY sockopt-on dup on 4 setsockopt drop ;
                    203: 
1.33      pazsan    204: : new-udp-socket ( -- socket )
                    205:     PF_INET SOCK_DGRAM 0 socket
1.44      pazsan    206:     dup 0<= abort" no free socket"
1.47      pazsan    207: [IFDEF] darwin
1.48      pazsan    208: \    dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
                    209: \    setsockopt drop
1.47      pazsan    210: [ELSE]
1.46      pazsan    211:     dup IPPROTO_IP IP_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
1.48      pazsan    212:     setsockopt drop
                    213: [THEN] ;
1.8       pazsan    214: 
1.41      pazsan    215: : new-udp-socket6 ( -- socket )
                    216:     PF_INET6 SOCK_DGRAM 0 socket
                    217:     dup 0<= abort" no free socket"
1.47      pazsan    218: [IFDEF] darwin
1.48      pazsan    219: \    dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
                    220: \    setsockopt drop
1.47      pazsan    221: [ELSE]
1.46      pazsan    222:     dup IPPROTO_IPV6 IPV6_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
1.48      pazsan    223:     setsockopt drop
1.47      pazsan    224: [THEN]
1.41      pazsan    225:     dup IPPROTO_IPV6 IPV6_V6ONLY sockopt-on dup on 4 setsockopt drop ;
1.33      pazsan    226: 
1.53      pazsan    227: : new-udp-socket46 ( -- socket )
                    228:     PF_INET6 SOCK_DGRAM 0 socket
                    229:     dup 0<= abort" no free socket"
                    230: [IFDEF] darwin
                    231: \    dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
                    232: \    setsockopt drop
                    233: [ELSE]
                    234:     dup IPPROTO_IPV6 IPV6_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
                    235:     setsockopt drop
                    236: [THEN]
                    237: ;
                    238: 
1.38      pazsan    239: \ getaddrinfo based open-socket
                    240: 
                    241: : >hints ( socktype -- )
                    242:     hints addrinfo %size erase
                    243:     PF_UNSPEC hints ai_family l!
                    244:     hints ai_socktype l! ;
                    245: 
                    246: : get-info ( addr u port -- info )
                    247:     base @ >r  decimal  0 <<# 0 hold #s #>  r> base ! drop
                    248:     >r c-string r> hints addrres getaddrinfo #>>
                    249:     ?dup IF
                    250:        gai_strerror cstring>sstring type
                    251:        true abort" getaddrinfo failed"  THEN
                    252:     addrres @ ;
                    253: 
                    254: : get-socket ( info -- socket )  dup >r >r
                    255:     BEGIN  r@  WHILE
                    256:            r@ ai_family l@ r@ ai_socktype l@ r@ ai_protocol l@ socket
                    257:            dup 0>= IF
1.43      pazsan    258:                dup r@ ai_addr @ r@ ai_addrlen l@ connect
1.38      pazsan    259:                IF
                    260:                    closesocket drop
                    261:                ELSE
                    262:                    s" w+" c-string fdopen
                    263:                    rdrop r> freeaddrinfo  EXIT
                    264:                THEN
                    265:            ELSE  drop  THEN
                    266:            r> ai_next @ >r  REPEAT
                    267:     rdrop r> freeaddrinfo true abort" can't connect" ;
                    268: 
                    269: : open-socket ( addr u port -- fid )
                    270:     SOCK_STREAM >hints  get-info  get-socket ;
                    271: 
                    272: : open-udp-socket ( addr u port -- fid )
                    273:     SOCK_DGRAM >hints  get-info  get-socket ;
                    274: 
1.18      pazsan    275: : create-server  ( port# -- lsocket )
1.33      pazsan    276:     sockaddr-tmp sockaddr_in %size erase
1.42      pazsan    277:     AF_INET sockaddr-tmp family w!
1.33      pazsan    278:     htons   sockaddr-tmp port w!
                    279:     new-socket
                    280:     dup 0< abort" no free socket" >r
1.57    ! pazsan    281:     r@ SOL_SOCKET SO_REUSEADDR sockopt-on 1 over ! 4 setsockopt drop
1.41      pazsan    282:     r@ sockaddr-tmp sockaddr_in4 %size bind 0= IF  r> exit  ENDIF
                    283:     r> drop true abort" bind :: failed" ;
                    284: 
                    285: : create-server6  ( port# -- lsocket )
                    286:     sockaddr-tmp sockaddr_in %size erase
1.42      pazsan    287:     AF_INET6 sockaddr-tmp family w!
1.41      pazsan    288:     htons   sockaddr-tmp port w!
                    289:     new-socket6
                    290:     dup 0< abort" no free socket" >r
                    291:     r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF  r> exit  ENDIF
1.33      pazsan    292:     r> drop true abort" bind :: failed" ;
                    293: 
                    294: : create-udp-server  ( port# -- lsocket )
                    295:     sockaddr-tmp sockaddr_in %size erase
1.42      pazsan    296:     AF_INET sockaddr-tmp family w!
1.33      pazsan    297:     htons   sockaddr-tmp port w!
                    298:     new-udp-socket
1.18      pazsan    299:     dup 0< abort" no free socket" >r
1.41      pazsan    300:     r@ sockaddr-tmp sockaddr_in4 %size bind 0= IF  r> exit  ENDIF
                    301:     r> drop true abort" bind :: failed" ;
                    302: 
                    303: : create-udp-server6  ( port# -- lsocket )
1.55      pazsan    304:     sockaddr-tmp sockaddr_in6 %size erase
1.42      pazsan    305:     AF_INET6 sockaddr-tmp family w!
1.41      pazsan    306:     htons   sockaddr-tmp port w!
                    307:     new-udp-socket6
                    308:     dup 0< abort" no free socket" >r
                    309:     r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF  r> exit  ENDIF
1.18      pazsan    310:     r> drop true abort" bind :: failed" ;
                    311: 
1.53      pazsan    312: : create-udp-server46  ( port# -- lsocket )
1.55      pazsan    313:     sockaddr-tmp sockaddr_in6 %size erase
1.53      pazsan    314:     AF_INET6 sockaddr-tmp family w!
                    315:     htons   sockaddr-tmp port w!
                    316:     new-udp-socket46
                    317:     dup 0< abort" no free socket" >r
                    318:     r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF  r> exit  ENDIF
                    319:     r> drop true abort" bind :: failed" ;
                    320: 
1.17      pazsan    321: \ from itools.frt
                    322: 
1.18      pazsan    323: ' open-socket Alias open-service
                    324: 
1.17      pazsan    325: : $put ( c-addr1 u1 c-addr2 -- ) swap cmove ;
                    326: 
                    327: : $+   ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
                    328:     { c-addr1 u1 c-addr2 u2 }
                    329:     u1 u2 + allocate throw 
                    330:     c-addr1 u1  2 pick       $put 
                    331:     c-addr2 u2  2 pick u1 +  $put  
                    332:     u1 u2 + ;
                    333: 
1.19      pazsan    334: Create hostname$ 0 c, 255 chars allot
1.18      pazsan    335: Create alen   16 ,
                    336: Create crlf 2 c, 13 c, 10 c,
                    337: 
                    338: : listen ( lsocket /queue -- )
                    339:     listen() 0< abort" listen :: failed" ;
1.17      pazsan    340: 
1.18      pazsan    341: \ This call blocks the server until a client appears. The client uses socket to
                    342: \ converse with the server.
                    343: : accept-socket ( lsocket -- socket )
                    344:     16 alen !
                    345:     sockaddr-tmp alen accept() 
                    346:     dup 0< IF  errno cr ." accept() :: error #" .  
                    347:        abort" accept :: failed"  
                    348:     ENDIF   s" w+" c-string fdopen ;
1.17      pazsan    349: 
                    350: : +cr  ( c-addr1 u1 -- c-addr2 u2 ) crlf count $+ ;
                    351: 
                    352: : blocking-mode ( socket flag -- ) >r fileno
                    353:     f_setfl r> IF  0  
                    354:     ELSE  o_nonblock|o_rdwr  
                    355:     THEN  
                    356:     fcntl 0< abort" blocking-mode failed" ;
                    357: 
1.19      pazsan    358: : hostname ( -- c-addr u )
                    359:     hostname$ c@ 0= IF
                    360:        hostname$ 1+ 255 gethostname drop
                    361:        hostname$ 1+ 255 0 scan nip 255 swap - hostname$ c!
                    362:     THEN
                    363:     hostname$ count ;
1.30      anton     364: : set-socket-timeout ( u -- ) 200 + s>d socket-timeout-d 2! ;
                    365: : get-socket-timeout ( -- u ) socket-timeout-d 2@ drop 200 - ;
1.17      pazsan    366: : write-socket ( c-addr size socket -- ) fileno -rot 0 send 0< throw ;
                    367: : close-socket ( socket -- ) fileno closesocket drop ;
                    368: 
                    369: : (rs)  ( socket c-addr maxlen -- c-addr size ) 
                    370:     2 pick >r r@ false blocking-mode  rot fileno -rot
                    371:     over >r msg_waitall recv
                    372:     dup 0<  IF  0 max
                    373:        errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
                    374:     THEN
                    375:     r> swap
                    376:     r> true blocking-mode ;
                    377: 
                    378: : read-socket ( socket c-addr maxlen -- c-addr u )
1.30      anton     379:     utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
1.17      pazsan    380:     BEGIN 
                    381:        socket c-addr maxlen (rs) dup 0=
1.30      anton     382:        utime tmax d< and 
1.17      pazsan    383:     WHILE 
                    384:            2drop
                    385:     REPEAT ;
1.33      pazsan    386: 
                    387: : (rs-from)  ( socket c-addr maxlen -- c-addr size ) 
                    388:     2 pick >r  r@ false blocking-mode  rot fileno -rot
                    389:     over >r msg_waitall sockaddr-tmp alen  recvfrom
                    390:     dup 0<  IF  0 max
                    391:        errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
                    392:     THEN
                    393:     r> swap
                    394:     r> true blocking-mode ;
                    395: 
                    396: : read-socket-from ( socket c-addr maxlen -- c-addr u )
                    397:     utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
                    398:     BEGIN 
                    399:        socket c-addr maxlen (rs-from) dup 0=
                    400:        utime tmax d< and 
                    401:     WHILE 
                    402:            2drop
                    403:     REPEAT ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>