basis/io/unix/sockets/sockets.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.c-types alien.strings generic kernel math
   4 namespaces threads sequences byte-arrays io.ports
   5 io.binary io.unix.backend io.streams.duplex
   6 io.backend io.ports io.files io.files.private
   7 io.encodings.utf8 math.parser continuations libc combinators
   8 system accessors qualified destructors unix locals init ;
   9
  10 EXCLUDE: io => read write close ;
  11 EXCLUDE: io.sockets => accept ;
  12
  13 IN: io.unix.sockets
  14
  15 : socket-fd ( domain type -- fd )
  16     0 socket dup io-error <fd> init-fd |dispose ;
  17
  18 : set-socket-option ( fd level opt -- )
  19     >r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
  20
  21 M: unix addrinfo-error ( n -- )
  22     dup zero? [ drop ] [ gai_strerror throw ] if ;
  23
  24 ! Client sockets - TCP and Unix domain
  25 M: object (get-local-address) ( handle remote -- sockaddr )
  26     >r handle-fd r> empty-sockaddr/size <int>
  27     [ getsockname io-error ] 2keep drop ;
  28
  29 M: object (get-remote-address) ( handle local -- sockaddr )
  30     >r handle-fd r> empty-sockaddr/size <int>
  31     [ getpeername io-error ] 2keep drop ;
  32
  33 : init-client-socket ( fd -- )
  34     SOL_SOCKET SO_OOBINLINE set-socket-option ;
  35
  36 : wait-to-connect ( port -- )
  37     dup handle>> handle-fd f 0 write
  38     {
  39         { [ 0 = ] [ drop ] }
  40         { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
  41         { [ err_no EINTR = ] [ wait-to-connect ] }
  42         [ (io-error) ]
  43     } cond ;
  44
  45 M: object establish-connection ( client-out remote -- )
  46     [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
  47     {
  48         { [ 0 = ] [ drop ] }
  49         { [ err_no EINPROGRESS = ] [
  50             [ +output+ wait-for-port ] [ wait-to-connect ] bi
  51         ] }
  52         [ (io-error) ]
  53     } cond ;
  54
  55 M: object ((client)) ( addrspec -- fd )
  56     protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
  57
  58 ! Server sockets - TCP and Unix domain
  59 : init-server-socket ( fd -- )
  60     SOL_SOCKET SO_REUSEADDR set-socket-option ;
  61
  62 : server-socket-fd ( addrspec type -- fd )
  63     >r dup protocol-family r> socket-fd
  64     dup init-server-socket
  65     dup handle-fd rot make-sockaddr/size bind io-error ;
  66
  67 M: object (server) ( addrspec -- handle )
  68     [
  69         SOCK_STREAM server-socket-fd
  70         dup handle-fd 128 listen io-error
  71     ] with-destructors ;
  72
  73 : do-accept ( server addrspec -- fd sockaddr )
  74     [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
  75     [ accept ] 2keep drop ; inline
  76
  77 M: object (accept) ( server addrspec -- fd sockaddr )
  78     2dup do-accept
  79     {
  80         { [ over 0 >= ] [ >r 2nip <fd> init-fd r> ] }
  81         { [ err_no EINTR = ] [ 2drop (accept) ] }
  82         { [ err_no EAGAIN = ] [
  83             2drop
  84             [ drop +input+ wait-for-port ]
  85             [ (accept) ]
  86             2bi
  87         ] }
  88         [ (io-error) ]
  89     } cond ;
  90
  91 ! Datagram sockets - UDP and Unix domain
  92 M: unix (datagram)
  93     [ SOCK_DGRAM server-socket-fd ] with-destructors ;
  94
  95 SYMBOL: receive-buffer
  96
  97 : packet-size 65536 ; inline
  98
  99 [ packet-size malloc receive-buffer set-global ] "io.unix.sockets" add-init-hook
 100
 101 :: do-receive ( port -- packet sockaddr )
 102     port addr>> empty-sockaddr/size [| sockaddr len |
 103         port handle>> handle-fd ! s
 104         receive-buffer get-global ! buf
 105         packet-size ! nbytes
 106         0 ! flags
 107         sockaddr ! from
 108         len <int> ! fromlen
 109         recvfrom dup 0 >= [
 110             receive-buffer get-global swap memory>byte-array sockaddr
 111         ] [
 112             drop f f
 113         ] if
 114     ] call ;
 115
 116 M: unix (receive) ( datagram -- packet sockaddr )
 117     dup do-receive dup [ rot drop ] [
 118         2drop [ +input+ wait-for-port ] [ (receive) ] bi
 119     ] if ;
 120
 121 :: do-send ( packet sockaddr len socket datagram -- )
 122     socket handle-fd packet dup length 0 sockaddr len sendto
 123     0 < [
 124         err_no EINTR = [
 125             packet sockaddr len socket datagram do-send
 126         ] [
 127             err_no EAGAIN = [
 128                 datagram +output+ wait-for-port
 129                 packet sockaddr len socket datagram do-send
 130             ] [
 131                 (io-error)
 132             ] if
 133         ] if
 134     ] when ;
 135
 136 M: unix (send) ( packet addrspec datagram -- )
 137     [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
 138
 139 ! Unix domain sockets
 140 M: local protocol-family drop PF_UNIX ;
 141
 142 M: local sockaddr-size drop "sockaddr-un" heap-size ;
 143
 144 M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
 145
 146 M: local make-sockaddr
 147     path>> (normalize-path)
 148     dup length 1 + max-un-path > [ "Path too long" throw ] when
 149     "sockaddr-un" <c-object>
 150     AF_UNIX over set-sockaddr-un-family
 151     dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
 152
 153 M: local parse-sockaddr
 154     drop
 155     sockaddr-un-path utf8 alien>string <local> ;