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 alien.data ;
   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> dup byte-length setsockopt io-error ;
  21
  22 M: unix addrinfo-error ( n -- )
  23     [ gai_strerror throw ] unless-zero ;
  24
  25 M: unix sockaddr-of-family ( alien af -- addrspec )
  26     {
  27         { AF_INET [ sockaddr-in memory>struct ] }
  28         { AF_INET6 [ sockaddr-in6 memory>struct ] }
  29         { AF_UNIX [ sockaddr-un memory>struct ] }
  30         [ 2drop f ]
  31     } case ;
  32
  33 M: unix addrspec-of-family ( af -- addrspec )
  34     {
  35         { AF_INET [ T{ inet4 } ] }
  36         { AF_INET6 [ T{ inet6 } ] }
  37         { AF_UNIX [ T{ local } ] }
  38         [ drop f ]
  39     } case ;
  40
  41 ! Client sockets - TCP and Unix domain
  42 M: object (get-local-address) ( handle remote -- sockaddr )
  43     [ handle-fd ] dip empty-sockaddr/size <int>
  44     [ getsockname io-error ] 2keep drop ;
  45
  46 M: object (get-remote-address) ( handle local -- sockaddr )
  47     [ handle-fd ] dip empty-sockaddr/size <int>
  48     [ getpeername io-error ] 2keep drop ;
  49
  50 : init-client-socket ( fd -- )
  51     SOL_SOCKET SO_OOBINLINE set-socket-option ;
  52
  53 : wait-to-connect ( port -- )
  54     dup handle>> handle-fd f 0 write
  55     {
  56         { [ 0 = ] [ drop ] }
  57         { [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
  58         { [ errno EINTR = ] [ wait-to-connect ] }
  59         [ (io-error) ]
  60     } cond ;
  61
  62 M:: object establish-connection ( client-out remote -- )
  63     client-out remote
  64     [ drop ]
  65     [
  66         [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect
  67     ] 2bi
  68     {
  69         { [ 0 = ] [ drop ] }
  70         { [ errno EINTR = ] [ drop client-out remote establish-connection ] }
  71         { [ errno EINPROGRESS = ] [
  72             [ +output+ wait-for-port ] [ wait-to-connect ] bi
  73         ] }
  74         [ (io-error) ]
  75     } cond ;
  76
  77 : ?bind-client ( socket -- )
  78     bind-local-address get [
  79         [ fd>> ] dip make-sockaddr/size
  80         [ bind ] unix-system-call io-error
  81     ] [
  82         drop
  83     ] if* ; inline
  84
  85 M: object ((client)) ( addrspec -- fd )
  86     protocol-family SOCK_STREAM socket-fd
  87     [ init-client-socket ] [ ?bind-client ] [ ] tri ;
  88
  89 ! Server sockets - TCP and Unix domain
  90 : init-server-socket ( fd -- )
  91     SOL_SOCKET SO_REUSEADDR set-socket-option ;
  92
  93 : server-socket-fd ( addrspec type -- fd )
  94     [ dup protocol-family ] dip socket-fd
  95     [ init-server-socket ] keep
  96     [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call io-error ] keep ;
  97
  98 M: object (server) ( addrspec -- handle )
  99     [
 100         SOCK_STREAM server-socket-fd
 101         dup handle-fd 128 listen io-error
 102     ] with-destructors ;
 103
 104 : do-accept ( server addrspec -- fd sockaddr )
 105     [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
 106     [ accept ] 2keep drop ; inline
 107
 108 M: object (accept) ( server addrspec -- fd sockaddr )
 109     2dup do-accept
 110     {
 111         { [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
 112         { [ errno EINTR = ] [ 2drop (accept) ] }
 113         { [ errno EAGAIN = ] [
 114             2drop
 115             [ drop +input+ wait-for-port ]
 116             [ (accept) ]
 117             2bi
 118         ] }
 119         [ (io-error) ]
 120     } cond ;
 121
 122 ! Datagram sockets - UDP and Unix domain
 123 M: unix (datagram)
 124     [ SOCK_DGRAM server-socket-fd ] with-destructors ;
 125
 126 SYMBOL: receive-buffer
 127
 128 CONSTANT: packet-size 65536
 129
 130 [ packet-size malloc &free receive-buffer set-global ] "io.sockets.unix" add-startup-hook
 131
 132 :: do-receive ( port -- packet sockaddr )
 133     port addr>> empty-sockaddr/size :> ( sockaddr len )
 134     port handle>> handle-fd ! s
 135     receive-buffer get-global ! buf
 136     packet-size ! nbytes
 137     0 ! flags
 138     sockaddr ! from
 139     len <int> ! fromlen
 140     recvfrom dup 0 >=
 141     [ receive-buffer get-global swap memory>byte-array sockaddr ]
 142     [ drop f f ]
 143     if ;
 144
 145 M: unix (receive) ( datagram -- packet sockaddr )
 146     dup do-receive dup [ [ drop ] 2dip ] [
 147         2drop [ +input+ wait-for-port ] [ (receive) ] bi
 148     ] if ;
 149
 150 :: do-send ( packet sockaddr len socket datagram -- )
 151     socket handle-fd packet dup length 0 sockaddr len sendto
 152     0 < [
 153         errno EINTR = [
 154             packet sockaddr len socket datagram do-send
 155         ] [
 156             errno EAGAIN = [
 157                 datagram +output+ wait-for-port
 158                 packet sockaddr len socket datagram do-send
 159             ] [
 160                 (io-error)
 161             ] if
 162         ] if
 163     ] when ;
 164
 165 M: unix (send) ( packet addrspec datagram -- )
 166     [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
 167
 168 ! Unix domain sockets
 169 M: local protocol-family drop PF_UNIX ;
 170
 171 M: local sockaddr-size drop sockaddr-un heap-size ;
 172
 173 M: local empty-sockaddr drop sockaddr-un <struct> ;
 174
 175 M: local make-sockaddr
 176     path>> absolute-path
 177     dup length 1 + max-un-path > [ "Path too long" throw ] when
 178     sockaddr-un <struct>
 179         AF_UNIX >>family
 180         swap utf8 string>alien >>path ;
 181
 182 M: local parse-sockaddr
 183     drop
 184     path>> utf8 alien>string <local> ;