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 destructors io.backend.unix
   5 io.encodings.ascii io.encodings.utf8 io.files io.pathnames io.sockets
   6 io.sockets.private kernel libc locals math namespaces sequences system
   7 unix unix.ffi vocabs ;
   8 IN: io.sockets.unix
   9
  10 : socket-fd ( domain type protocol -- fd )
  11     socket dup io-error <fd> init-fd |dispose ;
  12
  13 : get-socket-option ( fd level opt -- val )
  14     [ handle-fd ] 2dip -1 int <ref> [
  15         dup byte-length int <ref> getsockopt io-error
  16     ] keep int deref ;
  17
  18 : set-socket-option ( fd level opt -- )
  19     [ handle-fd ] 2dip 1 int <ref> dup byte-length setsockopt io-error ;
  20
  21 M: unix addrinfo-error-string
  22     gai_strerror ;
  23
  24 M: unix sockaddr-of-family
  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
  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)
  42     [ handle-fd ] dip empty-sockaddr/size int <ref>
  43     [ getsockname io-error ] keepd ;
  44
  45 M: object (get-remote-address)
  46     [ handle-fd ] dip empty-sockaddr/size int <ref>
  47     [ getpeername io-error ] keepd ;
  48
  49 : init-client-socket ( fd -- )
  50     SOL_SOCKET SO_OOBINLINE set-socket-option ;
  51
  52 : wait-to-connect ( port -- )
  53     dup +output+ wait-for-port
  54     dup handle>> SOL_SOCKET SO_ERROR get-socket-option
  55     [ drop ] [ (throw-errno) ] if-zero ; inline
  56
  57 M: object establish-connection
  58     2dup
  59     [ handle>> handle-fd ] [ make-sockaddr/size ] bi*
  60     connect 0 = [ 2drop ] [
  61         errno {
  62             { EINTR [ establish-connection ] }
  63             { EINPROGRESS [ drop wait-to-connect ] }
  64             [ (throw-errno) ]
  65         } case
  66     ] if ;
  67
  68 : ?bind-client ( socket -- )
  69     bind-local-address get [
  70         [ fd>> ] dip make-sockaddr/size
  71         [ bind ] unix-system-call drop
  72     ] [
  73         drop
  74     ] if* ; inline
  75
  76 M: object remote>handle
  77     [ protocol-family SOCK_STREAM ] [ protocol ] bi socket-fd
  78     [ init-client-socket ] [ ?bind-client ] [ ] tri ;
  79
  80 ! Server sockets - TCP and Unix domain
  81 : init-server-socket ( fd -- )
  82     SOL_SOCKET SO_REUSEADDR set-socket-option ;
  83
  84 : server-socket-fd ( addrspec type -- fd )
  85     [ dup protocol-family ] dip pick protocol socket-fd
  86     [ init-server-socket ] keep
  87     [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call drop ] keep ;
  88
  89 M: object (server)
  90     [
  91         SOCK_STREAM server-socket-fd
  92         dup handle-fd 128 [ listen ] unix-system-call drop
  93     ] with-destructors ;
  94
  95 : do-accept ( server addrspec -- fd sockaddr )
  96     [ handle>> handle-fd ] [ empty-sockaddr/size int <ref> ] bi*
  97     [ unix.ffi:accept ] keepd ; inline
  98
  99 M: object (accept)
 100     2dup do-accept over 0 >= [
 101         [ 2nip <fd> init-fd ] dip
 102     ] [
 103         errno {
 104             { EINTR [ 2drop (accept) ] }
 105             { EAGAIN [
 106                 2drop
 107                 [ drop +input+ wait-for-port ]
 108                 [ (accept) ]
 109                 2bi
 110             ] }
 111             [ (throw-errno) ]
 112         } case
 113     ] if ;
 114
 115 ! Datagram sockets - UDP and Unix domain
 116 M: unix (datagram)
 117     [ SOCK_DGRAM server-socket-fd ] with-destructors ;
 118
 119 M: unix (raw)
 120     [ SOCK_RAW server-socket-fd ] with-destructors ;
 121
 122 M: unix (broadcast)
 123     dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;
 124
 125 :: do-receive ( n buf port -- count sockaddr )
 126     port addr>> empty-sockaddr/size :> ( sockaddr len )
 127     port handle>> handle-fd ! s
 128     buf ! buf
 129     n ! nbytes
 130     0 ! flags
 131     sockaddr ! from
 132     len int <ref> ! fromlen
 133     recvfrom sockaddr ; inline
 134
 135 : (receive-loop) ( n buf datagram -- count sockaddr )
 136     3dup do-receive over 0 > [ 3nipd ] [
 137         2drop [ +input+ wait-for-port ] [ (receive-loop) ] bi
 138     ] if ; inline recursive
 139
 140 M: unix (receive-unsafe)
 141     (receive-loop) ;
 142
 143 :: do-send ( packet sockaddr len socket datagram -- )
 144     socket handle-fd packet dup length 0 sockaddr len sendto
 145     0 < [
 146         errno {
 147             { EINTR [
 148                 packet sockaddr len socket datagram do-send
 149             ] }
 150             { EAGAIN [
 151                 datagram +output+ wait-for-port
 152                 packet sockaddr len socket datagram do-send
 153             ] }
 154             [ (throw-errno) ]
 155         } case
 156     ] when ; inline recursive
 157
 158 M: unix (send)
 159     [ make-sockaddr/size-outgoing ] [ [ handle>> ] keep ] bi* do-send ;
 160
 161 ! Unix domain sockets
 162 M: local protocol-family drop PF_UNIX ;
 163
 164 M: local sockaddr-size drop sockaddr-un heap-size ;
 165
 166 M: local empty-sockaddr drop sockaddr-un new ;
 167
 168 M: local make-sockaddr
 169     path>> absolute-path
 170     dup length 1 + max-un-path > [ "Path too long" throw ] when
 171     sockaddr-un new
 172         AF_UNIX >>family
 173         swap utf8 string>alien >>path ;
 174
 175 M: local parse-sockaddr
 176     drop
 177     path>> utf8 alien>string <local> ;
 178
 179 M: unix host-name
 180     256 [ <byte-array> dup ] keep gethostname io-error
 181     ascii alien>string ;
 182
 183 os linux? [ "io.sockets.unix.linux" require ] when