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