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