Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/dbm-type-blame/system/Basis/Implementation/Sockets/socket.sml
ViewVC logotype

Annotation of /sml/branches/dbm-type-blame/system/Basis/Implementation/Sockets/socket.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3594 - (view) (download)

1 : dbm 3594 (* socket.sml
2 : mblume 1389 *
3 : dbm 3594 * COPYRIGHT (c) 2011 The Fellowship of SML/NJ (http://www.smlnj.org)
4 :     * All rights reserved.
5 : mblume 1389 *)
6 :    
7 :     local
8 :     structure Int = IntImp
9 :     structure OS = OSImp
10 :     in
11 :     structure SocketImp : SOCKET =
12 :     struct
13 :    
14 :     structure CI = CInterface
15 :     structure W8A = Word8Array
16 :     structure W8V = Word8Vector
17 :    
18 :     fun sockFn x = CI.c_function "SMLNJ-Sockets" x
19 :    
20 :     type w8vector = W8V.vector
21 :     type w8array = W8A.array
22 :    
23 :     (* the system's representation of a socket *)
24 : mblume 1393 type sockFD = Socket.sockFD
25 : mblume 1389
26 :     (* to inherit the various socket related types *)
27 : mblume 1393 open Socket
28 : mblume 1389
29 :     (* bind socket C functions *)
30 :     fun netdbFun x = CI.c_function "SMLNJ-Sockets" x
31 :    
32 :     (* val dummyAddr = ADDR(W8V.fromList[]) *)
33 :    
34 :     (* address families *)
35 :     structure AF =
36 :     struct
37 : mblume 1393 open AF
38 : mblume 1389 val listAddrFamilies : unit -> CI.system_const list
39 :     = sockFn "listAddrFamilies"
40 :     fun list () =
41 :     List.map (fn arg => (#2 arg, AF arg)) (listAddrFamilies ())
42 :     fun toString (AF(_, name)) = name
43 :     fun fromString name = (
44 :     case CI.findSysConst(name, listAddrFamilies ())
45 :     of NONE => NONE
46 :     | (SOME af) => SOME(AF af)
47 :     (* end case *))
48 :     end
49 :    
50 :     (* socket types *)
51 :     structure SOCK =
52 :     struct
53 : mblume 1393 open SOCK
54 : mblume 1389 val listSockTypes : unit -> CI.system_const list
55 :     = sockFn "listSockTypes"
56 :     val stream = SOCKTY(CI.bindSysConst ("STREAM", listSockTypes ()))
57 :     val dgram = SOCKTY(CI.bindSysConst ("DGRAM", listSockTypes ()))
58 :     fun list () =
59 :     List.map (fn arg => (#2 arg, SOCKTY arg)) (listSockTypes ())
60 :     fun toString (SOCKTY(_, name)) = name
61 :     fun fromString name = (case CI.findSysConst(name, listSockTypes ())
62 :     of NONE => NONE
63 :     | (SOME ty) => SOME(SOCKTY ty)
64 :     (* end case *))
65 :     end
66 :    
67 :     (* socket control operations *)
68 :     structure Ctl =
69 :     struct
70 :     local
71 : mblume 1393 fun getOpt ctlFn (Socket.SOCK { fd, ... }) = ctlFn(fd, NONE)
72 :     fun setOpt ctlFn (Socket.SOCK { fd, ... }, value) =
73 : mblume 1389 ignore(ctlFn(fd, SOME value))
74 :     val ctlDEBUG : (sockFD * bool option) -> bool =
75 :     sockFn "ctlDEBUG"
76 :     val ctlREUSEADDR : (sockFD * bool option) -> bool =
77 :     sockFn "ctlREUSEADDR"
78 :     val ctlKEEPALIVE : (sockFD * bool option) -> bool =
79 :     sockFn "ctlKEEPALIVE"
80 :     val ctlDONTROUTE : (sockFD * bool option) -> bool =
81 :     sockFn "ctlDONTROUTE"
82 :     val ctlLINGER : (sockFD * int option option) -> int option =
83 :     sockFn "ctlLINGER"
84 :     val ctlBROADCAST : (sockFD * bool option) -> bool =
85 :     sockFn "ctlBROADCAST"
86 :     val ctlOOBINLINE : (sockFD * bool option) -> bool =
87 :     sockFn "ctlOOBINLINE"
88 :     val ctlSNDBUF : (sockFD * int option) -> int =
89 :     sockFn "ctlSNDBUF"
90 :     val ctlRCVBUF : (sockFD * int option) -> int =
91 :     sockFn "ctlSNDBUF"
92 :     in
93 :     (* get/set socket options *)
94 :     fun getDEBUG x = getOpt ctlDEBUG x
95 :     fun setDEBUG x = setOpt ctlDEBUG x
96 :     fun getREUSEADDR x = getOpt ctlREUSEADDR x
97 :     fun setREUSEADDR x = setOpt ctlREUSEADDR x
98 :     fun getKEEPALIVE x = getOpt ctlKEEPALIVE x
99 :     fun setKEEPALIVE x = setOpt ctlKEEPALIVE x
100 :     fun getDONTROUTE x = getOpt ctlDONTROUTE x
101 :     fun setDONTROUTE x = setOpt ctlDONTROUTE x
102 :     fun getLINGER sock = (case (getOpt ctlLINGER sock)
103 :     of NONE => NONE
104 :     | (SOME t) => SOME (TimeImp.fromSeconds (Int.toLarge t))
105 :     (* end case *))
106 :     (* NOTE: probably shoud do some range checking on the argument *)
107 :     fun setLINGER (sock, NONE) = setOpt ctlLINGER (sock, NONE)
108 :     | setLINGER (sock, SOME t) =
109 :     setOpt ctlLINGER (sock,SOME(Int.fromLarge(TimeImp.toSeconds t)))
110 :     fun getBROADCAST x = getOpt ctlBROADCAST x
111 :     fun setBROADCAST x = setOpt ctlBROADCAST x
112 :     fun getOOBINLINE x = getOpt ctlOOBINLINE x
113 :     fun setOOBINLINE x = setOpt ctlOOBINLINE x
114 :     fun getSNDBUF x = getOpt ctlSNDBUF x
115 :     (* NOTE: probably shoud do some range checking on the argument *)
116 :     fun setSNDBUF x = setOpt ctlSNDBUF x
117 :     fun getRCVBUF x = getOpt ctlRCVBUF x
118 :     (* NOTE: probably shoud do some range checking on the argument *)
119 :     fun setRCVBUF x = setOpt ctlRCVBUF x
120 :     local
121 :     val getTYPE' : sockFD -> CI.system_const = sockFn "getTYPE"
122 :     val getERROR' : sockFD -> bool = sockFn "getERROR"
123 :     in
124 : mblume 1393 fun getTYPE (SOCK { fd, ... }) = SOCK.SOCKTY(getTYPE' fd)
125 : mblume 1389 fun getERROR (SOCK { fd, ... }) = getERROR' fd
126 :     end (* local *)
127 :    
128 :     local
129 :     val getPeerName' : sockFD -> addr = sockFn "getPeerName"
130 :     val getSockName' : sockFD -> addr = sockFn "getSockName"
131 :     fun getName f (SOCK { fd, ... }) = ADDR (f fd)
132 :     in
133 :     fun getPeerName sock = getName getPeerName' sock
134 :     fun getSockName sock = getName getSockName' sock
135 :     end
136 :    
137 :     local
138 :     val getNREAD' : sockFD -> int = sockFn "getNREAD"
139 :     val getATMARK' : sockFD -> bool = sockFn "getATMARK"
140 :     in
141 :     fun getNREAD (SOCK { fd, ... }) = getNREAD' fd
142 :     fun getATMARK (SOCK { fd, ... }) = getATMARK' fd
143 :     end
144 :    
145 :     end (* local *)
146 :     end (* Ctl *)
147 :    
148 :    
149 :     val setNBIO' : (sockFD * bool) -> unit = sockFn "setNBIO"
150 :     (*
151 :     fun setNBIO (SOCK fd, flg) = setNBIO'(fd, flg)
152 :     *)
153 :    
154 :     (* extract a blocking file descriptor; implicitly set socket to
155 :     * blocking mode if necessary: *)
156 :     fun fdB (SOCK { fd, nb = nbr as ref nb }) =
157 :     if nb then (setNBIO' (fd, false); nbr := false; fd) else fd
158 :    
159 :     (* same for non-blocking *)
160 : dbm 3594 fun fdNB (SOCK{fd, nb = nbr as ref nb }) =
161 : mblume 1389 if nb then fd else (setNBIO' (fd, true); nbr := true; fd)
162 :    
163 :     val wrapNB_o = OpsysDetails.wrapNB_o
164 :     val wrapNB_b = OpsysDetails.wrapNB_b
165 :    
166 : dbm 3594 fun sockB fd = SOCK{ fd = fd, nb = ref false }
167 : mblume 1389
168 :     (* socket address operations *)
169 :     fun sameAddr (ADDR a1, ADDR a2) = (a1 = a2)
170 :     local
171 :     val getAddrFamily : addr -> af = sockFn "getAddrFamily"
172 :     in
173 : mblume 1393 fun familyOfAddr (ADDR a) = AF.AF(getAddrFamily a)
174 : mblume 1389 end
175 :    
176 :     (* socket management *)
177 :     local
178 :     val accept' : int -> (int * addr) = sockFn "accept"
179 : dbm 3594 val bind' : (int * addr) -> unit = sockFn "bind"
180 : mblume 1389 val connect' : (int * addr) -> unit = sockFn "connect"
181 :     val listen' : (int * int) -> unit = sockFn "listen"
182 :     val close' : int -> unit = sockFn "close"
183 :     in
184 :    
185 : dbm 3594 fun bind (SOCK{ fd, ... }, ADDR addr) = bind' (fd, addr)
186 : mblume 1389 (** Should do some range checking on backLog *)
187 : dbm 3594 fun listen (SOCK{ fd, ... }, backLog) = listen' (fd, backLog)
188 : mblume 1389
189 :     fun accept0 (sock, getfd) s = let
190 : dbm 3594 val (newFD, addr) = accept' (getfd s)
191 :     in
192 :     (sock newFD, ADDR addr)
193 :     end
194 : mblume 1389 fun accept s = accept0 (sockB, fdB) s
195 : dbm 3594 fun acceptNB s = wrapNB_o (accept0 (sockB, fdNB)) s
196 : mblume 1389
197 :     fun connect0 getfd (s, ADDR addr) = connect' (getfd s, addr)
198 :     fun connect arg = connect0 fdB arg
199 :     fun connectNB arg = wrapNB_b (connect0 fdNB) arg
200 :    
201 :     fun close (SOCK { fd, ... }) = close' fd
202 :     end
203 :    
204 :     local
205 :     val shutdown' : (int * int) -> unit = sockFn "shutdown"
206 :     fun how NO_RECVS = 0
207 :     | how NO_SENDS = 1
208 :     | how NO_RECVS_OR_SENDS = 2
209 :     in
210 : dbm 3594 fun shutdown (SOCK{ fd, ... }, mode) = shutdown' (fd, how mode)
211 : mblume 1389 end
212 :    
213 : dbm 3594 fun ioDesc (SOCK{ fd, ... }) = OpsysDetails.mkIODesc fd
214 : mblume 1389
215 :     fun pollDesc sock = Option.valOf (OS.IO.pollDesc (ioDesc sock)) (** delete **)
216 :     (* for now we implement select in terms of polling... *)
217 :     val sockDesc = ioDesc
218 :     fun sameDesc (d1, d2) = OS.IO.compare (d1, d2) = EQUAL
219 :     fun select { rds, wrs, exs, timeout } = let
220 :     fun rd d = Option.map OS.IO.pollIn (OS.IO.pollDesc d)
221 :     handle OS.IO.Poll => NONE
222 :     fun wr d = Option.map OS.IO.pollOut (OS.IO.pollDesc d)
223 :     handle OS.IO.Poll => NONE
224 :     fun ex d = Option.map OS.IO.pollPri (OS.IO.pollDesc d)
225 :     handle OS.IO.Poll => NONE
226 :     val dl =
227 :     List.mapPartial rd rds @
228 :     List.mapPartial wr wrs @
229 :     List.mapPartial ex exs
230 :     val il = OS.IO.poll (dl, timeout)
231 :     fun split3 ([], rds, wrs, exs) = { rds = rds, wrs = wrs, exs = exs }
232 :     | split3 (i :: is, rds, wrs, exs) = let
233 :     val d = OS.IO.pollToIODesc (OS.IO.infoToPollDesc i)
234 :     in
235 :     if OS.IO.isIn i then split3 (is, d :: rds, wrs, exs)
236 :     else if OS.IO.isOut i then split3 (is, rds, d :: wrs, exs)
237 :     else split3 (is, rds, wrs, d :: exs)
238 :     end
239 :     in
240 :     split3 (rev il, [], [], [])
241 :     end
242 :    
243 :     val vbuf = Word8VectorSlice.base
244 :     val abuf = Word8ArraySlice.base
245 :    
246 :     (* default flags *)
247 :     val dfltDon'tRoute = false
248 :     val dfltOOB = false
249 :     val dfltPeek = false
250 :    
251 :     (* Sock output operations *)
252 :     local
253 :     val sendV : (int * w8vector * int * int * bool * bool) -> int
254 :     = sockFn "sendBuf"
255 :     val sendA : (int * w8array * int * int * bool * bool) -> int
256 :     = sockFn "sendBuf"
257 :     in
258 :    
259 :     fun sendVec0 getfd (s, buffer) = let
260 :     val fd = getfd s
261 :     val (vec, i, len) = vbuf buffer
262 :     in
263 :     if (len > 0) then sendV (fd, vec, i, len, dfltDon'tRoute, dfltOOB) else 0
264 :     end
265 :     fun sendVec arg = sendVec0 fdB arg
266 :     fun sendVecNB arg = wrapNB_o (sendVec0 fdNB) arg
267 :    
268 :     fun sendVec'0 getfd (sock, buffer, {don't_route, oob}) = let
269 :     val fd = getfd sock
270 :     val (vec, i, len) = vbuf buffer
271 :     in
272 :     if (len > 0) then sendV (fd, vec, i, len, don't_route, oob) else 0
273 :     end
274 :     fun sendVec' arg = sendVec'0 fdB arg
275 :     fun sendVecNB' arg = wrapNB_o (sendVec'0 fdNB) arg
276 :    
277 :     fun sendArr0 getfd (sock, buffer) = let
278 :     val fd = getfd sock
279 :     val (arr, i, len) = abuf buffer
280 :     in
281 :     if (len > 0) then sendA (fd, arr, i, len, dfltDon'tRoute, dfltOOB)
282 :     else 0
283 :     end
284 :     fun sendArr arg = sendArr0 fdB arg
285 :     fun sendArrNB arg = wrapNB_o (sendArr0 fdNB) arg
286 :    
287 :     fun sendArr'0 getfd (sock, buffer, {don't_route, oob}) = let
288 :     val fd = getfd sock
289 :     val (arr, i, len) = abuf buffer
290 :     in
291 :     if (len > 0) then sendA (fd, arr, i, len, don't_route, oob) else 0
292 :     end
293 :     fun sendArr' arg = sendArr'0 fdB arg
294 :     fun sendArrNB' arg = wrapNB_o (sendArr'0 fdNB) arg
295 :     end (* local *)
296 :    
297 :     local
298 :     val sendToV : (int * w8vector * int * int * bool * bool * addr) -> int
299 :     = sockFn "sendBufTo"
300 :     val sendToA : (int * w8array * int * int * bool * bool * addr) -> int
301 :     = sockFn "sendBufTo"
302 :     in
303 :     fun sendVecTo0 getfd (sock, ADDR addr, buffer) = let
304 :     val fd = getfd sock
305 :     val (vec, i, len) = vbuf buffer
306 :     in
307 :     if (len > 0) then
308 :     sendToV(fd, vec, i, len, dfltDon'tRoute, dfltOOB, addr)
309 :     else 0;
310 :     ()
311 :     end
312 :     fun sendVecTo arg = sendVecTo0 fdB arg
313 :     fun sendVecToNB arg = wrapNB_b (sendVecTo0 fdNB) arg
314 :    
315 :     fun sendVecTo'0 getfd (sock, ADDR addr, buffer, {don't_route, oob}) = let
316 :     val fd = getfd sock
317 :     val (vec, i, len) = vbuf buffer
318 :     in
319 :     if (len > 0) then
320 :     sendToV(fd, vec, i, len, don't_route, oob, addr)
321 :     else 0;
322 :     ()
323 :     end
324 :     fun sendVecTo' arg = sendVecTo'0 fdB arg
325 :     fun sendVecToNB' arg = wrapNB_b (sendVecTo'0 fdNB) arg
326 :    
327 :     fun sendArrTo0 getfd (sock, ADDR addr, buffer) = let
328 :     val fd = getfd sock
329 :     val (arr, i, len) = abuf buffer
330 :     in
331 :     if (len > 0) then
332 :     sendToA(fd, arr, i, len, dfltDon'tRoute, dfltOOB, addr)
333 :     else 0;
334 :     ()
335 :     end
336 :     fun sendArrTo arg = sendArrTo0 fdB arg
337 :     fun sendArrToNB arg = wrapNB_b (sendArrTo0 fdNB) arg
338 :    
339 :     fun sendArrTo'0 getfd (sock, ADDR addr, buffer, {don't_route, oob}) = let
340 :     val fd = getfd sock
341 :     val (arr, i, len) = abuf buffer
342 :     in
343 :     if (len > 0) then
344 :     sendToA(fd, arr, i, len, don't_route, oob, addr)
345 :     else 0;
346 :     ()
347 :     end
348 :     fun sendArrTo' arg = sendArrTo'0 fdB arg
349 :     fun sendArrToNB' arg = wrapNB_b (sendArrTo'0 fdNB) arg
350 :     end (* local *)
351 :    
352 :     (* Sock input operations *)
353 :     local
354 :     val recvV' : (int * int * bool * bool) -> w8vector
355 :     = sockFn "recv"
356 :     fun recvV _ (_, 0, _, _) = W8V.fromList[]
357 :     | recvV getfd (sock, nbytes, peek, oob) =
358 :     if nbytes < 0 then raise Size
359 :     else recvV' (getfd sock, nbytes, peek, oob)
360 :     val recvA : (int * w8array * int * int * bool * bool) -> int
361 :     = sockFn "recvBuf"
362 :     in
363 :     fun recvVec0 getfd (sock, sz) = recvV getfd (sock, sz, dfltPeek, dfltOOB)
364 :     fun recvVec arg = recvVec0 fdB arg
365 :     fun recvVecNB arg = wrapNB_o (recvVec0 fdNB) arg
366 :    
367 :     fun recvVec'0 getfd (sock, sz, {peek, oob}) =
368 :     recvV getfd (sock, sz, peek, oob)
369 :     fun recvVec' arg = recvVec'0 fdB arg
370 :     fun recvVecNB' arg = wrapNB_o (recvVec'0 fdNB) arg
371 :    
372 :     fun recvArr0 getfd (sock, buffer) = let
373 :     val fd = getfd sock
374 :     val (buf, i, sz) = abuf buffer
375 :     in
376 :     if sz > 0 then recvA (fd, buf, i, sz, dfltPeek, dfltOOB) else 0
377 :     end
378 :     fun recvArr arg = recvArr0 fdB arg
379 :     fun recvArrNB arg = wrapNB_o (recvArr0 fdNB) arg
380 :    
381 :     fun recvArr'0 getfd (sock, buffer, {peek, oob}) = let
382 :     val fd = getfd sock
383 :     val (buf, i, sz) = abuf buffer
384 :     in
385 :     if sz > 0 then recvA (fd, buf, i, sz, peek, oob) else 0
386 :     end
387 :     fun recvArr' arg = recvArr'0 fdB arg
388 :     fun recvArrNB' arg = wrapNB_o (recvArr'0 fdNB) arg
389 :     end (* local *)
390 :    
391 :     local
392 :     val recvFromV' : (int * int * bool * bool) -> (w8vector * addr)
393 :     = sockFn "recvFrom"
394 :     fun recvFromV _ (_, 0, _, _) = (W8V.fromList[], (ADDR(W8V.fromList[])))
395 :     | recvFromV getfd (sock, sz, peek, oob) =
396 :     if sz < 0 then raise Size
397 :     else let val fd = getfd sock
398 :     val (data, addr) = recvFromV' (fd, sz, peek, oob)
399 :     in
400 :     (data, ADDR addr)
401 :     end
402 :     val recvFromA : (int * w8array * int * int * bool * bool) -> (int * addr)
403 :     = sockFn "recvBufFrom"
404 :     in
405 :     fun recvVecFrom0 getfd (sock, sz) =
406 :     recvFromV getfd (sock, sz, dfltPeek, dfltOOB)
407 :     fun recvVecFrom arg = recvVecFrom0 fdB arg
408 :     fun recvVecFromNB arg = wrapNB_o (recvVecFrom0 fdNB) arg
409 :    
410 :     fun recvVecFrom'0 getfd (sock, sz, {peek, oob}) =
411 :     recvFromV getfd (sock, sz, peek, oob)
412 :     fun recvVecFrom' arg = recvVecFrom'0 fdB arg
413 :     fun recvVecFromNB' arg = wrapNB_o (recvVecFrom'0 fdNB) arg
414 :    
415 :     fun recvArrFrom0 getfd (sock, asl) = let
416 :     val fd = getfd sock
417 :     val (buf, i, sz) = abuf asl
418 :     in
419 :     if sz > 0 then let
420 :     val (n, addr) = recvFromA(fd, buf, i, sz, dfltPeek, dfltOOB)
421 :     in
422 :     (n, ADDR addr)
423 :     end
424 :     else (0, ADDR(W8V.fromList[]))
425 :     end
426 :     fun recvArrFrom arg = recvArrFrom0 fdB arg
427 :     fun recvArrFromNB arg = wrapNB_o (recvArrFrom0 fdNB) arg
428 :    
429 :     fun recvArrFrom'0 getfd (sock, asl, {peek, oob}) = let
430 :     val fd = getfd sock
431 :     val (buf, i, sz) = abuf asl
432 :     in
433 :     if sz > 0 then let
434 :     val (n, addr) = recvFromA(fd, buf, i, sz, peek, oob)
435 :     in
436 :     (n, ADDR addr)
437 :     end
438 :     else (0, (ADDR(W8V.fromList[])))
439 :     end
440 :     fun recvArrFrom' arg = recvArrFrom'0 fdB arg
441 :     fun recvArrFromNB' arg = wrapNB_o (recvArrFrom'0 fdNB) arg
442 :     end (* local *)
443 :    
444 :     end (* Socket *)
445 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0