1 (* Copyright (C
) 2012,2013,2015,2017 Matthew Fluet
.
2 * Copyright (C
) 2002-2008 Henry Cejtin
, Matthew Fluet
, Suresh
3 * Jagannathan
, and Stephen Weeks
.
5 * MLton is released under a BSD
-style license
.
6 * See the file MLton
-LICENSE for details
.
9 structure Socket
:> SOCKET_EXTRA
=
12 structure Prim
= PrimitiveFFI
.Socket
13 structure Error
= Posix
.Error
14 structure Syscall
= Error
.SysCall
15 structure FileSys
= Posix
.FileSys
17 structure Sock
= Net
.Sock
19 val fromRep
= Sock
.fromRep
20 val toRep
= Sock
.toRep
21 val sockToWord
= C_Sock
.castToSysWord
o Sock
.toRep
22 val wordToSock
= Sock
.fromRep
o C_Sock
.castFromSysWord
23 val sockToFD
= PrePosix
.FileDesc
.fromRep
o Sock
.toRep
24 val fdToSock
= Sock
.fromRep
o PrePosix
.FileDesc
.toRep
26 type pre_sock_addr
= Word8.word array
27 datatype sock_addr
= SA
of Word8.word vector
28 fun unpackSockAddr (SA sa
) = sa
29 fun newSockAddr (): (pre_sock_addr
* C_Socklen
.t ref
* (unit
-> sock_addr
)) =
31 val salen
= C_Size
.toInt Prim
.sockAddrStorageLen
32 val sa
= Array
.array (salen
, 0wx0
: Word8.word)
33 val salenRef
= ref (C_Socklen
.fromInt salen
)
36 (ArraySlice
.slice (sa
, 0, SOME (C_Socklen
.toInt (!salenRef
)))))
38 (sa
, salenRef
, finish
)
40 datatype dgram
= DGRAM (* phantom
*)
41 datatype stream
= MODE (* phantom
*)
42 datatype passive
= PASSIVE (* phantom
*)
43 datatype active
= ACTIVE (* phantom
*)
45 structure AddrFamily
= Net
.AddrFamily
48 type addr_family
= AddrFamily
.t
49 val names
: (string * addr_family
) list
=
50 ("UNIX", AddrFamily
.fromRep Prim
.AF
.UNIX
) ::
51 ("INET", AddrFamily
.fromRep Prim
.AF
.INET
) ::
52 ("INET6", AddrFamily
.fromRep Prim
.AF
.INET6
) ::
53 ("UNSPEC", AddrFamily
.fromRep Prim
.AF
.UNSPEC
) ::
57 case List.find (fn (_
, af
) => af
= af
') names
of
58 SOME (name
, _
) => name
59 | NONE
=> raise (Fail
"Internal error: bogus addr_family")
60 fun fromString name
' =
61 case List.find (fn (name
, _
) => name
= name
') names
of
62 SOME (_
, af
) => SOME af
66 structure SockType
= Net
.SockType
69 type sock_type
= SockType
.t
70 val toRep
= SockType
.toRep
71 val fromRep
= SockType
.fromRep
72 val stream
= SockType
.fromRep Prim
.SOCK
.STREAM
73 val dgram
= SockType
.fromRep Prim
.SOCK
.DGRAM
74 val names
: (string * sock_type
) list
=
80 case List.find (fn (_
, st
) => st
= st
') names
of
81 SOME (name
, _
) => name
82 | NONE
=> raise (Fail
"Internal error: bogus sock_type")
83 fun fromString name
' =
84 case List.find (fn (name
, _
) => name
= name
') names
of
85 SOME (_
, st
) => SOME st
88 structure SOCKExtra
= SOCK
93 type optname
= C_Int
.t
94 type request
= C_Int
.t
96 fun getSockOptC_Int (level
: level
, optname
: optname
) s
: C_Int
.t
=
98 val optval
= ref (C_Int
.fromInt
0)
101 (fn () => Prim
.Ctl
.getSockOptC_Int (Sock
.toRep s
, level
, optname
, optval
))
105 fun setSockOptC_Int (level
: level
, optname
: optname
) (s
, optval
: C_Int
.t
) : unit
=
109 (fn () => Prim
.Ctl
.setSockOptC_Int (Sock
.toRep s
, level
, optname
, optval
))
114 fun getSockOptBool (level
: level
, optname
: optname
) s
: bool =
115 if getSockOptC_Int (level
, optname
) s
= 0 then false else true
116 fun setSockOptBool (level
: level
, optname
: optname
) (s
, optval
: bool) : unit
=
117 setSockOptC_Int (level
, optname
) (s
, if optval
then C_Int
.fromInt
1 else C_Int
.fromInt
0)
118 fun gsSockOptBool (level
: level
, optname
: optname
) =
119 (getSockOptBool (level
, optname
), setSockOptBool (level
, optname
))
121 fun getSockOptInt (level
: level
, optname
: optname
) s
: int =
122 C_Int
.toInt (getSockOptC_Int (level
, optname
) s
)
123 fun setSockOptInt (level
: level
, optname
: optname
) (s
, optval
: int) : unit
=
124 setSockOptC_Int (level
, optname
) (s
, C_Int
.fromInt optval
)
125 fun gsSockOptInt (level
: level
, optname
: optname
) =
126 (getSockOptInt (level
, optname
), setSockOptInt (level
, optname
))
128 fun getSockOptTimeOption (level
: level
, optname
: optname
) s
: Time
.time option
=
130 val optval_l_onoff
= ref (C_Int
.fromInt
0)
131 val optval_l_linger
= ref (C_Int
.fromInt
0)
134 (fn () => Prim
.Ctl
.getSockOptC_Linger (Sock
.toRep s
, level
, optname
,
135 optval_l_onoff
, optval_l_linger
))
138 if ! optval_l_onoff
= 0
140 else SOME (Time
.fromSeconds (C_Int
.toLarge (! optval_l_linger
)))
142 fun setSockOptTimeOption (level
: level
, optname
: optname
) (s
, optval
: Time
.time option
) : unit
=
144 val (optval_l_onoff
, optval_l_linger
) =
146 NONE
=> (C_Int
.fromInt
0, C_Int
.fromInt
0)
147 | SOME t
=> (C_Int
.fromInt
1, C_Int
.fromLarge (Time
.toSeconds t
))
150 (fn () => Prim
.Ctl
.setSockOptC_Linger (Sock
.toRep s
, level
, optname
,
151 optval_l_onoff
, optval_l_linger
))
157 val (getDEBUG
, setDEBUG
) = gsSockOptBool (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_DEBUG
)
158 val (getREUSEADDR
, setREUSEADDR
) = gsSockOptBool (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_REUSEADDR
)
159 val (getKEEPALIVE
, setKEEPALIVE
) = gsSockOptBool (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_KEEPALIVE
)
160 val (getDONTROUTE
, setDONTROUTE
) = gsSockOptBool (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_DONTROUTE
)
161 val getLINGER
= getSockOptTimeOption (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_LINGER
)
162 val setLINGER
= setSockOptTimeOption (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_LINGER
)
163 val (getBROADCAST
, setBROADCAST
) = gsSockOptBool (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_BROADCAST
)
164 val (getOOBINLINE
, setOOBINLINE
) = gsSockOptBool (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_OOBINLINE
)
165 val (getSNDBUF
, setSNDBUF
) = gsSockOptInt (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_SNDBUF
)
166 val (getRCVBUF
, setRCVBUF
) = gsSockOptInt (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_RCVBUF
)
167 fun getTYPE s
= SOCK
.fromRep (getSockOptC_Int (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_TYPE
) s
)
170 val se
= getSockOptC_Int (Prim
.Ctl
.SOL_SOCKET
, Prim
.Ctl
.SO_ERROR
) s
171 val se
= PrePosix
.SysError
.fromRep se
173 if PosixError
.cleared
= se
175 else SOME (Error
.errorMsg se
, SOME se
)
176 end handle Error
.SysErr z
=> SOME z
179 fun getName (s
, f
: C_Sock
.t
* pre_sock_addr
* C_Socklen
.t ref
-> C_Int
.int C_Errno
.t
) =
181 val (sa
, salen
, finish
) = newSockAddr ()
182 val () = Syscall
.simple (fn () => f (Sock
.toRep s
, sa
, salen
))
187 fun getPeerName s
= getName (s
, Prim
.Ctl
.getPeerName
)
188 fun getSockName s
= getName (s
, Prim
.Ctl
.getSockName
)
192 val argp
= ref (C_Int
.fromInt ~
1)
193 val () = Syscall
.simple (fn () => Prim
.Ctl
.getNREAD (Sock
.toRep s
, argp
))
199 val argp
= ref (C_Int
.fromInt ~
1)
200 val () = Syscall
.simple (fn () => Prim
.Ctl
.getATMARK (Sock
.toRep s
, argp
))
202 if C_Int
.toInt (!argp
) = 0 then false else true
210 val getERROR
= isSome
o CtlExtra
.getERROR
213 fun sameAddr (SA sa1
, SA sa2
) = sa1
= sa2
215 fun familyOfAddr (SA sa
) = AddrFamily
.fromRep (Prim
.familyOfAddr sa
)
217 fun bind (s
, SA sa
) =
218 Syscall
.simple (fn () => Prim
.bind (Sock
.toRep s
, sa
, C_Socklen
.fromInt (Vector.length sa
)))
221 Syscall
.simple (fn () => Prim
.listen (Sock
.toRep s
, C_Int
.fromInt n
))
223 fun nonBlock
' ({restart
: bool},
224 errVal
: ''a
, f
: unit
-> ''a C_Errno
.t
, post
: ''a
-> 'b
, again
, no
: 'b
) =
226 ({clear
= false, restart
= restart
, errVal
= errVal
}, fn () =>
229 handlers
= [(again
, fn () => no
)]})
231 fun nonBlock (errVal
, f
, post
, no
) =
232 nonBlock
' ({restart
= true}, errVal
, f
, post
, Error
.again
, no
)
235 structure PIO
= PrimitiveFFI
.Posix
.IO
236 structure OS
= Primitive
.MLton
.Platform
.OS
237 structure MinGW
= PrimitiveFFI
.MinGW
239 fun withNonBlockNormal (s
, f
: unit
-> 'a
) =
241 val fd
= Sock
.toRep s
243 Syscall
.simpleResultRestart (fn () => PIO
.fcntl2 (fd
, PIO
.F_GETFL
))
245 Syscall
.simpleRestart
247 PIO
.fcntl3 (fd
, PIO
.F_SETFL
,
248 C_Int
.orb (flags
, PrimitiveFFI
.Posix
.FileSys
.O
.NONBLOCK
)))
252 Syscall
.simpleRestart (fn () => PIO
.fcntl3 (fd
, PIO
.F_SETFL
, flags
)))
255 fun withNonBlockMinGW (s
, f
: unit
-> 'a
) =
257 val fd
= Sock
.toRep s
258 val () = MinGW
.setNonBlock fd
261 (f
, fn () => MinGW
.clearNonBlock fd
)
264 val withNonBlock
= fn x
=>
266 OS
.MinGW
=> withNonBlockMinGW x
267 | _
=> withNonBlockNormal x
270 fun connect (s
, SA sa
) =
271 Syscall
.simple (fn () => Prim
.connect (Sock
.toRep s
, sa
, C_Socklen
.fromInt (Vector.length sa
)))
273 fun connectNB (s
, SA sa
) =
275 ({restart
= false}, C_Int
.fromInt ~
1, fn () =>
276 withNonBlock (s
, fn () => Prim
.connect (Sock
.toRep s
, sa
, C_Socklen
.fromInt (Vector.length sa
))),
278 Error
.inprogress
, false)
282 val (sa
, salen
, finish
) = newSockAddr ()
283 val s
= Syscall
.simpleResultRestart (fn () => Prim
.accept (Sock
.toRep s
, sa
, salen
))
285 (Sock
.fromRep s
, finish ())
290 val (sa
, salen
, finish
) = newSockAddr ()
294 fn () => withNonBlock (s
, fn () => Prim
.accept (Sock
.toRep s
, sa
, salen
)),
295 fn s
=> SOME (Sock
.fromRep s
, finish ()),
299 fun close s
= Syscall
.simple (fn () => Prim
.close (Sock
.toRep s
))
301 datatype shutdown_mode
= NO_RECVS | NO_SENDS | NO_RECVS_OR_SENDS
303 fun shutdownModeToHow m
=
305 NO_RECVS
=> Prim
.SHUT_RD
306 | NO_SENDS
=> Prim
.SHUT_WR
307 | NO_RECVS_OR_SENDS
=> Prim
.SHUT_RDWR
309 fun shutdown (s
, m
) =
310 let val m
= shutdownModeToHow m
311 in Syscall
.simple (fn () => Prim
.shutdown (Sock
.toRep s
, m
))
314 type sock_desc
= FileSys
.file_desc
316 fun sockDesc sock
= sockToFD sock
318 fun sameDesc (desc1
, desc2
) = desc1
= desc2
320 fun select
{rds
: sock_desc list
,
323 timeout
: Time
.time option
} =
328 val vec
= Vector.fromList l
329 val arr
= Array
.array (Vector.length vec
, 0: C_Int
.t
)
331 (PrePosix
.FileDesc
.vectorToRep vec
, arr
)
334 val (read_vec
, read_arr
) = mk rds
335 val (write_vec
, write_arr
) = mk wrs
336 val (except_vec
, except_arr
) = mk exs
340 NONE
=> Prim
.setTimeoutNull
342 if Time
.< (t
, Time
.zeroTime
)
343 then Error
.raiseSys Error
.inval
345 val q
= LargeInt
.quot (Time
.toMicroseconds t
, 1000000)
346 val q
= C_Time
.fromLargeInt q
347 val r
= LargeInt
.rem (Time
.toMicroseconds t
, 1000000)
348 val r
= C_SUSeconds
.fromLargeInt r
350 fn () => Prim
.setTimeout (q
, r
)
351 end handle Overflow
=> Error
.raiseSys Error
.inval
356 ; Prim
.select (read_vec
, write_vec
, except_vec
,
357 read_arr
, write_arr
, except_arr
)))
358 val (rds
, wrs
, exs
) =
365 (List.foldl (fn (sd
, (l
, i
)) =>
366 (if Array
.sub (arr
, i
) <> (0: C_Int
.t
) then sd
::l
else l
, i
+ 1))
372 mk (exs
, except_arr
))
380 val ioDesc
= FileSys
.fdToIOD
o sockDesc
382 type out_flags
= {don
't_route
: bool, oob
: bool}
384 val no_out_flags
= {don
't_route
= false, oob
= false}
386 fun mk_out_flags
{don
't_route
, oob
} =
387 C_Int
.orb (if don
't_route
then Prim
.MSG_DONTROUTE
else 0x0,
388 C_Int
.orb (if oob
then Prim
.MSG_OOB
else 0x0,
392 fun make (toPoly
, base
, primSend
, primSendTo
) =
394 val base
= fn sl
=> let val (buf
, i
, sz
) = base sl
395 in (toPoly buf
, i
, sz
)
397 fun send
' (s
, sl
, out_flags
) =
399 val (buf
, i
, sz
) = base sl
401 (C_SSize
.toInt
o Syscall
.simpleResultRestart
')
402 ({errVal
= C_SSize
.castFromFixedInt ~
1}, fn () =>
403 primSend (Sock
.toRep s
, buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
404 mk_out_flags out_flags
))
406 fun send (sock
, buf
) = send
' (sock
, buf
, no_out_flags
)
407 fun sendNB
' (s
, sl
, out_flags
) =
409 val (buf
, i
, sz
) = base sl
412 (C_SSize
.castFromFixedInt ~
1,
414 primSend (Sock
.toRep s
, buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
415 C_Int
.orb (Prim
.MSG_DONTWAIT
, mk_out_flags out_flags
)),
416 SOME
o C_SSize
.toInt
,
419 fun sendNB (sock
, sl
) = sendNB
' (sock
, sl
, no_out_flags
)
420 fun sendTo
' (s
, SA sa
, sl
, out_flags
) =
422 val (buf
, i
, sz
) = base sl
424 Syscall
.simpleRestart
'
425 ({errVal
= C_SSize
.castFromFixedInt ~
1}, fn () =>
426 primSendTo (Sock
.toRep s
, buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
427 mk_out_flags out_flags
,
428 sa
, C_Socklen
.fromInt (Vector.length sa
)))
430 fun sendTo (sock
, sock_addr
, sl
) =
431 sendTo
' (sock
, sock_addr
, sl
, no_out_flags
)
432 fun sendToNB
' (s
, SA sa
, sl
, out_flags
) =
434 val (buf
, i
, sz
) = base sl
437 (C_SSize
.castFromFixedInt ~
1,
439 primSendTo (Sock
.toRep s
, buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
440 C_Int
.orb (Prim
.MSG_DONTWAIT
, mk_out_flags out_flags
),
441 sa
, C_Socklen
.fromInt (Vector.length sa
)),
445 fun sendToNB (sock
, sa
, sl
) =
446 sendToNB
' (sock
, sa
, sl
, no_out_flags
)
448 (send
, send
', sendNB
, sendNB
', sendTo
, sendTo
', sendToNB
, sendToNB
')
451 val (sendArr
, sendArr
', sendArrNB
, sendArrNB
',
452 sendArrTo
, sendArrTo
', sendArrToNB
, sendArrToNB
') =
453 make (Word8Array
.toPoly
, Word8ArraySlice
.base
, Prim
.sendArr
, Prim
.sendArrTo
)
454 val (sendVec
, sendVec
', sendVecNB
, sendVecNB
',
455 sendVecTo
, sendVecTo
', sendVecToNB
, sendVecToNB
') =
456 make (Word8Vector
.toPoly
, Word8VectorSlice
.base
, Prim
.sendVec
, Prim
.sendVecTo
)
459 type in_flags
= {peek
: bool, oob
: bool}
461 val no_in_flags
= {peek
= false, oob
= false}
463 fun mk_in_flags
{peek
, oob
} =
464 C_Int
.orb (if peek
then Prim
.MSG_PEEK
else 0x0,
465 C_Int
.orb (if oob
then Prim
.MSG_OOB
else 0x0,
468 fun recvArr
' (s
, sl
, in_flags
) =
470 val (buf
, i
, sz
) = Word8ArraySlice
.base sl
472 (C_SSize
.toInt
o Syscall
.simpleResultRestart
')
473 ({errVal
= C_SSize
.castFromFixedInt ~
1}, fn () =>
474 Prim
.recv (Sock
.toRep s
, Word8Array
.toPoly buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
475 mk_in_flags in_flags
))
478 fun getVec (a
, n
, bytesRead
) =
480 then Word8Vector
.unsafeFromArray a
481 else Word8ArraySlice
.vector (Word8ArraySlice
.slice (a
, 0, SOME bytesRead
))
483 fun recvVec
' (sock
, n
, in_flags
) =
485 val a
= Word8Array
.alloc n
487 recvArr
' (sock
, Word8ArraySlice
.full a
, in_flags
)
489 getVec (a
, n
, bytesRead
)
492 fun recvArr (sock
, sl
) = recvArr
' (sock
, sl
, no_in_flags
)
494 fun recvVec (sock
, n
) = recvVec
' (sock
, n
, no_in_flags
)
496 fun recvArrFrom
' (s
, sl
, in_flags
) =
498 val (buf
, i
, sz
) = Word8ArraySlice
.base sl
499 val (sa
, salen
, finish
) = newSockAddr ()
501 (C_SSize
.toInt
o Syscall
.simpleResultRestart
')
502 ({errVal
= C_SSize
.castFromFixedInt ~
1}, fn () =>
503 Prim
.recvFrom (Sock
.toRep s
, Word8Array
.toPoly buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
504 mk_in_flags in_flags
,
510 fun recvVecFrom
' (sock
, n
, in_flags
) =
512 val a
= Word8Array
.alloc n
513 val (bytesRead
, sock_addr
) =
514 recvArrFrom
' (sock
, Word8ArraySlice
.full a
, in_flags
)
516 (getVec (a
, n
, bytesRead
), sock_addr
)
519 fun recvArrFrom (sock
, sl
) = recvArrFrom
' (sock
, sl
, no_in_flags
)
521 fun recvVecFrom (sock
, n
) = recvVecFrom
' (sock
, n
, no_in_flags
)
523 fun mk_in_flagsNB in_flags
= C_Int
.orb (mk_in_flags in_flags
, Prim
.MSG_DONTWAIT
)
525 fun recvArrNB
' (s
, sl
, in_flags
) =
527 val (buf
, i
, sz
) = Word8ArraySlice
.base sl
530 (C_SSize
.castFromFixedInt ~
1,
531 fn () => Prim
.recv (Sock
.toRep s
, Word8Array
.toPoly buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
532 mk_in_flagsNB in_flags
),
533 SOME
o C_SSize
.toInt
,
537 fun recvVecNB
' (s
, n
, in_flags
) =
539 val a
= Word8Array
.alloc n
542 (C_SSize
.castFromFixedInt ~
1,
543 fn () => Prim
.recv (Sock
.toRep s
, Word8Array
.toPoly a
, 0, C_Size
.fromInt n
,
544 mk_in_flagsNB in_flags
),
545 fn bytesRead
=> SOME (getVec (a
, n
, C_SSize
.toInt bytesRead
)),
549 fun recvArrNB (sock
, sl
) = recvArrNB
' (sock
, sl
, no_in_flags
)
551 fun recvVecNB (sock
, n
) = recvVecNB
' (sock
, n
, no_in_flags
)
553 fun recvArrFromNB
' (s
, sl
, in_flags
) =
555 val (buf
, i
, sz
) = Word8ArraySlice
.base sl
556 val (sa
, salen
, finish
) = newSockAddr ()
559 (C_SSize
.castFromFixedInt ~
1,
560 fn () => Prim
.recvFrom (Sock
.toRep s
, Word8Array
.toPoly buf
, C_Int
.fromInt i
, C_Size
.fromInt sz
,
561 mk_in_flagsNB in_flags
, sa
, salen
),
562 fn n
=> SOME (C_SSize
.toInt n
, finish ()),
566 fun recvVecFromNB
' (s
, n
, in_flags
) =
568 val a
= Word8Array
.alloc n
569 val (sa
, salen
, finish
) = newSockAddr ()
572 (C_SSize
.castFromFixedInt ~
1,
573 fn () => Prim
.recvFrom (Sock
.toRep s
, Word8Array
.toPoly a
, 0, C_Size
.fromInt n
,
574 mk_in_flagsNB in_flags
, sa
, salen
),
575 fn bytesRead
=> SOME (getVec (a
, n
, C_SSize
.toInt bytesRead
), finish ()),
579 fun recvArrFromNB (sock
, sl
) = recvArrFromNB
' (sock
, sl
, no_in_flags
)
581 fun recvVecFromNB (sock
, n
) = recvVecFromNB
' (sock
, n
, no_in_flags
)
584 type ('af
, 'sock_type
) sock
= sock
586 type 'af sock_addr
= sock_addr
588 type 'mode stream
= stream