├── .gitignore
├── .ocp-indent
├── CHANGES.md
├── LICENSE.md
├── README.md
├── _tags
├── aeio.opam
├── doc
    ├── api.odocl
    ├── dev.odocl
    └── style.css
├── dune
├── dune-project
├── src
    ├── aeio.ml
    ├── aeio.mli
    ├── aeio.mllib
    ├── aeio_stubs.c
    ├── libaeio.clib
    └── libaeio_stubs.clib
└── test
    ├── echo.ml
    ├── echo_bigstring.ml
    └── echo_cancel.ml


/.gitignore:
--------------------------------------------------------------------------------
1 | _build
2 | tmp
3 | *~
4 | \.\#*
5 | \#*#
6 | *.install
7 | *.native
8 | *.byte


--------------------------------------------------------------------------------
/.ocp-indent:
--------------------------------------------------------------------------------
1 | strict_with=always,match_clause=4,strict_else=never
2 | 


--------------------------------------------------------------------------------
/CHANGES.md:
--------------------------------------------------------------------------------
1 | vX.Y.Z YYYY-MM-DD Location
2 | --------------------------
3 | 
4 | First release. 
5 | 


--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2016 KC Sivaramakrishnan
 2 | 
 3 | Permission to use, copy, modify, and/or distribute this software for any
 4 | purpose with or without fee is hereby granted, provided that the above
 5 | copyright notice and this permission notice appear in all copies.
 6 | 
 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | aeio — Asynchronous effect-based IO
 2 | -------------------------------------------------------------------------------
 3 | This repository is no longer active. See the successor to `aeio`, [`eieio`](https://github.com/ocaml-multicore/eioio). 
 4 | 
 5 | -------------------------------------------------------------------------------
 6 | %%VERSION%%
 7 | 
 8 | aeio is TODO
 9 | 
10 | aeio is distributed under the ISC license.
11 | 
12 | Homepage: https://github.com/kayceesrk/aeio  
13 | 
14 | ## Installation
15 | 
16 | First [install multicore OCaml](https://github.com/ocamllabs/multicore-opam#install-multicore-ocaml). Then, aeio can be installed with `opam`:
17 | 
18 |     opam install aeio
19 | 
20 | If you don't use `opam` consult the [`opam`](opam) file for build
21 | instructions.
22 | 
23 | ## Documentation
24 | 
25 | The documentation and API reference is automatically generated by from
26 | the source interfaces. It can be consulted [online][doc].
27 | 
28 | [doc]: https://kayceesrk.github.io/ocaml-aeio/doc
29 | 
30 | ## Sample programs
31 | 
32 | If you installed aeio with `opam` sample programs are located in
33 | the directory `opam config var aeio:doc`.
34 | 
35 | In the distribution sample programs and tests are located in the
36 | [`test`](test) directory of the distribution. They can be built and run
37 | with:
38 | 
39 |     topkg build --tests true && topkg test 
40 | 


--------------------------------------------------------------------------------
/_tags:
--------------------------------------------------------------------------------
 1 | true : bin_annot, safe_string, package(bytes)
 2 | 
 3 | <src> : include
 4 | <test> : include
 5 | 
 6 | <src/*.{cma,cmxa}>: package(lwt.unix), use_aeio
 7 | <src/*.{cmxs}>: package(lwt.unix), link_aeio
 8 | <src/**>: package(lwt.unix)
 9 | 
10 | <test/echo*.*>: package(lwt.unix), link_aeio
11 | <test/echo*.byte>: custom
12 | 


--------------------------------------------------------------------------------
/aeio.opam:
--------------------------------------------------------------------------------
 1 | opam-version: "1.2"
 2 | maintainer: "KC Sivaramakrishnan <sk826@cl.cam.ac.uk>"
 3 | authors: ["KC Sivaramakrishnan <sk826@cl.cam.ac.uk>"]
 4 | homepage: "https://github.com/kayceesrk/ocaml-aeio"
 5 | doc: "https://kayceesrk.github.io/ocaml-aeio/doc"
 6 | license: "ISC"
 7 | dev-repo: "https://github.com/kayceesrk/ocaml-aeio.git"
 8 | bug-reports: "https://github.com/kayceesrk/ocaml-aeio/issues"
 9 | tags: []
10 | version: "0.3.1"
11 | available: [ ocaml-version >= "4.10.0"]
12 | depends: [
13 |   "ocamlfind" {build}
14 |   "ocamlbuild" {build}
15 |   "lwt"
16 |   "lwt-dllist"
17 | ]
18 | depopts: []
19 | build: [
20 |   ["dune" "subst"] {pinned}
21 |   ["dune" "build" "-p" name "-j" jobs]
22 | ]
23 | 


--------------------------------------------------------------------------------
/doc/api.odocl:
--------------------------------------------------------------------------------
1 | Aeio


--------------------------------------------------------------------------------
/doc/dev.odocl:
--------------------------------------------------------------------------------
1 | Aeio


--------------------------------------------------------------------------------
/doc/style.css:
--------------------------------------------------------------------------------
  1 | /* Copyright (c) 2016 Daniel C. Bünzli. All rights reserved.
  2 |    Distributed under the ISC license, see terms at the end of the file. */
  3 | 
  4 | /* Reset a few things. */
  5 | html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre,
  6 | a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp,
  7 | small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset,
  8 | form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td
  9 | { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%;
 10 |   font-weight: inherit; font-style:inherit; font-family:inherit;
 11 |   line-height: inherit; vertical-align: baseline; text-align:inherit;
 12 |   color:inherit; background: transparent; }
 13 | 
 14 | table { border-collapse: collapse; border-spacing: 0; }
 15 | 
 16 | /* Basic page layout */
 17 | 
 18 | body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left;
 19 |        margin: 1.375em 10%; min-width: 40ex; max-width: 72ex;
 20 |        color: black; background: transparent /* url(line-height-22.gif) */; }
 21 | 
 22 | b { font-weight: bold }
 23 | em { font-style: italic }
 24 | 
 25 | tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace;
 26 |                 font-size: 1em; }
 27 | pre code { font-size : inherit; }
 28 | .codepre { margin-bottom:1.375em /* after code example we introduce space. */ }
 29 | 
 30 | .superscript,.subscript
 31 | { font-size : 0.813em; line-height:0; margin-left:0.4ex;}
 32 | .superscript { vertical-align: super; }
 33 | .subscript { vertical-align: sub; }
 34 | 
 35 | /* ocamldoc markup workaround hacks */
 36 | 
 37 | hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br
 38 | { display: none } /* annoying */
 39 | 
 40 | div.info + br { display:block}
 41 | 
 42 | .codepre br + br { display: none }
 43 | h1 + pre { margin-bottom:1.375em} /* Toplevel module description */
 44 | 
 45 | /* Sections and document divisions */
 46 | 
 47 | /* .navbar { margin-bottom: -1.375em } */
 48 | h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */
 49 |      margin-top:0.917em; padding-top:0.875em;
 50 |      border-top-style:solid; border-width:1px; border-color:#AAA; }
 51 | h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em }
 52 | h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em }
 53 | h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em}
 54 | h4 { font-style: italic;  }
 55 | 
 56 | /* Used by OCaml's own library documentation. */
 57 |  h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em }
 58 |  .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em }
 59 | 
 60 | p { margin-top: 1.375em }
 61 | pre { margin-top: 1.375em }
 62 | .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */
 63 | td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */
 64 | 
 65 | ul, ol { margin-top:0.688em; padding-bottom:0.687em;
 66 | 	 list-style-position:outside}
 67 | ul + p, ol + p { margin-top: 0em }
 68 | ul { list-style-type: square }
 69 | 
 70 | 
 71 | /* h2 + ul, h3 + ul, p + ul { } */
 72 | ul > li { margin-left: 1.375em; }
 73 | ol > li { margin-left: 1.7em; }
 74 | /* Links */
 75 | 
 76 | a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none }
 77 | a:hover { text-decoration : underline }
 78 | *:target {background-color: #FFFF99;} /* anchor highlight */
 79 | 
 80 | /* Code */
 81 | 
 82 | .keyword { font-weight: bold; }
 83 | .comment { color : red }
 84 | .constructor { color : green }
 85 | .string { color : brown }
 86 | .warning { color : red ; font-weight : bold }
 87 | 
 88 | /* Functors */
 89 | 
 90 | .paramstable { border-style : hidden ; padding-bottom:1.375em}
 91 | .paramstable code { margin-left: 1ex; margin-right: 1ex }
 92 | .sig_block {margin-left: 1em}
 93 | 
 94 | /* Images */
 95 | 
 96 | img { margin-top: 1.375em }
 97 | 
 98 | /*---------------------------------------------------------------------------
 99 |    Copyright (c) 2016 Daniel C. Bünzli
100 | 
101 |    Permission to use, copy, modify, and/or distribute this software for any
102 |    purpose with or without fee is hereby granted, provided that the above
103 |    copyright notice and this permission notice appear in all copies.
104 | 
105 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
106 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
107 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
108 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
109 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
110 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
111 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
112 |   ---------------------------------------------------------------------------*/
113 | 


--------------------------------------------------------------------------------
/dune:
--------------------------------------------------------------------------------
 1 | (include_subdirs unqualified)
 2 | 
 3 | (env
 4 |  (dev
 5 |   (flags (:standard -warn-error -A))))
 6 | 
 7 | (library
 8 |  (name aeio)
 9 |  (public_name aeio)
10 |  (foreign_stubs (language c) (names aeio_stubs))
11 |  (modules aeio)
12 |  (libraries lwt lwt.unix lwt-dllist))
13 | 
14 | (executable
15 |  (name echo_bigstring)
16 |  (modules echo_bigstring)
17 |  (libraries lwt lwt.unix aeio))
18 |  
19 | (executable
20 |  (name echo)
21 |  (modules echo)
22 |  (libraries lwt lwt.unix aeio))
23 |  
24 | (executable
25 |  (name echo_cancel)
26 |  (modules echo_cancel)
27 |  (libraries lwt lwt.unix aeio)) 
28 | 


--------------------------------------------------------------------------------
/dune-project:
--------------------------------------------------------------------------------
1 | (lang dune 2.0)
2 | 
3 | (name aeio)
4 | 


--------------------------------------------------------------------------------
/src/aeio.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | (* Asynchronous IO scheduler.
  8 |  *
  9 |  * For each blocking action, if the action can be performed immediately, then it
 10 |  * is. Otherwise, the thread performing the blocking task is suspended and
 11 |  * automatically wakes up when the action completes. The suspend/resume is
 12 |  * transparent to the programmer.
 13 |  *)
 14 | 
 15 | (** Debug
 16 | 
 17 | let fiber_size k = Obj.size (Obj.field (Obj.repr k) 0)
 18 | 
 19 | 
 20 | let dprintf s =
 21 |   if debug then begin
 22 |     Printf.printf "[%d] " (get_tid ());
 23 |     Printf.printf s
 24 |   end else
 25 |     Printf.ifprintf stdout s
 26 | **)
 27 | 
 28 | (* Type declarations *)
 29 | 
 30 | type fd_status = FD_OPEN | FD_CLOSED
 31 | 
 32 | type file_descr =
 33 |   { fd : Unix.file_descr;
 34 |     mutable status : fd_status;
 35 |     mutable blocking : bool;
 36 | 	  mutable event_readable : Lwt_engine.event option;
 37 |   	mutable event_writable : Lwt_engine.event option;
 38 |     hooks_readable : (unit -> unit) Lwt_dllist.t;
 39 |     hooks_writable : (unit -> unit) Lwt_dllist.t }
 40 | 
 41 | let mk_chan fd =
 42 |   { fd; blocking = true; status = FD_OPEN;
 43 |     event_readable = None; event_writable = None;
 44 |     hooks_readable = Lwt_dllist.create ();
 45 |     hooks_writable = Lwt_dllist.create () }
 46 | 
 47 | let socket d t i =
 48 |   let fd = Unix.socket d t i in
 49 |   mk_chan fd
 50 | 
 51 | let set_nonblock ch =
 52 |   Unix.set_nonblock ch.fd;
 53 |   ch.blocking <- false
 54 | 
 55 | let get_unix_fd ch = ch.fd
 56 | 
 57 | exception Cancelled
 58 | exception Promise_cancelled
 59 | 
 60 | type thread_id = int
 61 | 
 62 | type cleanup = (unit -> unit) option ref
 63 | 
 64 | type cont = Cont : ('a, unit) continuation option ref -> cont
 65 | 
 66 | type _context =
 67 |   | Default   : (cont * local_state) Lwt_dllist.t -> _context
 68 |   | Cancelled : _context
 69 | 
 70 | and context = _context ref
 71 | 
 72 | and local_state =
 73 |   { mutable context   : context;
 74 |             cleanup   : cleanup;
 75 |             thread_id : thread_id }
 76 | 
 77 | type 'a _promise =
 78 |   | Done    of 'a
 79 |   | Error   of exn
 80 |   | Waiting of ((cont * local_state) Lwt_dllist.node * ('a, unit) continuation option ref) list
 81 | 
 82 | type 'a promise = 'a _promise ref
 83 | 
 84 | effect Async   : ('a -> 'b) * 'a * context option -> 'b promise
 85 | effect Await   : 'a promise -> 'a
 86 | effect Yield   : unit
 87 | effect Get_tid : int
 88 | 
 89 | effect Accept : file_descr -> (file_descr * Unix.sockaddr)
 90 | effect Recv   : file_descr * bytes * int * int * Unix.msg_flag list -> int
 91 | effect Send   : file_descr * bytes * int * int * Unix.msg_flag list -> int
 92 | effect Read   : file_descr * bytes * int * int -> int
 93 | effect Write  : file_descr * bytes * int * int -> int
 94 | effect Sleep  : float -> unit
 95 | 
 96 | effect Get_context    : context
 97 | effect Cancel_context : context -> unit
 98 | effect Get_num_async  : int
 99 | 
100 | type global_state =
101 |   {         run_q     : (unit -> unit) Lwt_dllist.t;
102 |     mutable num_async : int }
103 | 
104 | (* Wrappers for performing effects *)
105 | 
106 | let async ?ctxt f v =
107 |   perform (Async (f, v, ctxt))
108 | 
109 | let await p =
110 |   perform (Await p)
111 | 
112 | let yield () =
113 |   perform Yield
114 | 
115 | let accept fd =
116 |   perform (Accept fd)
117 | 
118 | let recv fd buf pos len mode =
119 |   perform (Recv (fd, buf, pos, len, mode))
120 | 
121 | let send fd buf pos len mode =
122 |   perform (Send (fd, buf, pos, len, mode))
123 | 
124 | let read fd buf pos len =
125 |   perform (Read (fd, buf, pos, len))
126 | 
127 | let write fd buf pos len =
128 |   perform (Write (fd, buf, pos, len))
129 | 
130 | let sleep timeout =
131 |   perform (Sleep timeout)
132 | 
133 | let get_tid () =
134 |   perform Get_tid
135 | 
136 | let live_async () =
137 |   perform Get_num_async
138 | 
139 | (* Stubs *)
140 | 
141 | external stub_read  : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_read"
142 | external stub_write : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_write"
143 | 
144 | (* Cancellation *)
145 | 
146 | let new_context () = ref (Default (Lwt_dllist.create ()))
147 | 
148 | let my_context () = perform Get_context
149 | 
150 | let cancel ctxt = perform (Cancel_context ctxt)
151 | 
152 | let handle_cancel lst gst k ctxt =
153 |   let cancel_fiber lst k =
154 |     lst.context <- new_context ();
155 |     begin match !(lst.cleanup) with
156 |     | None -> ()
157 |     | Some c -> c ()
158 |     end;
159 |     let k = match !k with
160 |     | None -> failwith "handle_cancel: impossible"
161 |     | Some k -> k
162 |     in
163 |     discontinue k Cancelled
164 |   in
165 |   match !ctxt with
166 |   | Default l ->
167 |       ctxt := Cancelled;
168 |       Lwt_dllist.iter_l (fun (Cont k, lst) -> ignore @@ Lwt_dllist.add_r (fun () ->
169 |         cancel_fiber lst k) gst.run_q) l;
170 |       if ctxt = lst.context then begin
171 |         cancel_fiber lst (ref (Some k))
172 |       end else continue k ()
173 |   | Cancelled -> ()
174 | 
175 | let live ctxt =
176 |   match !ctxt with
177 |   | Default _ -> true
178 |   | Cancelled -> false
179 | 
180 | let watch_for_cancellation lst k =
181 |   match !(lst.context) with
182 |   | Default s -> Lwt_dllist.add_r (Cont k, lst) s
183 |   | Cancelled -> failwith "Impossible happened"
184 | 
185 | (* IO loop *)
186 | 
187 | let clear_events ch =
188 |   Lwt_dllist.iter_node_l (fun node -> Lwt_dllist.remove node; Lwt_dllist.get node ()) ch.hooks_readable;
189 |   Lwt_dllist.iter_node_l (fun node -> Lwt_dllist.remove node; Lwt_dllist.get node ()) ch.hooks_writable;
190 |   begin
191 |     match ch.event_readable with
192 |     | Some ev ->
193 |         ch.event_readable <- None;
194 |         Lwt_engine.stop_event ev
195 |     | None -> ()
196 |   end;
197 |   begin
198 |     match ch.event_writable with
199 |     | Some ev ->
200 |         ch.event_writable <- None;
201 |         Lwt_engine.stop_event ev
202 |     | None -> ()
203 |   end
204 | 
205 | let close ch =
206 |   if ch.status = FD_OPEN then begin
207 |     clear_events ch;
208 |     Unix.close ch.fd;
209 |     ch.status <- FD_CLOSED
210 |   end
211 | 
212 | let shutdown ch sc =
213 |   if ch.status = FD_OPEN then begin
214 |     clear_events ch;
215 |     Unix.shutdown ch.fd sc;
216 |     ch.status <- FD_CLOSED
217 |   end
218 | 
219 | let rec schedule gst =
220 |   if Lwt_dllist.is_empty gst.run_q then (* No runnable threads *)
221 |     if Lwt_engine.readable_count () = 0 &&
222 |        Lwt_engine.writable_count () = 0 &&
223 |        Lwt_engine.timer_count () = 0 then () (* We are done *)
224 |     else perform_io gst
225 |   else (* Still have runnable threads *)
226 |     Lwt_dllist.take_l gst.run_q ()
227 | 
228 | and perform_io gst =
229 |   Lwt_engine.iter true;
230 |   schedule gst
231 | 
232 | (* Syscall wrappers *)
233 | 
234 | type syscall_kind =
235 |   | Syscall_read
236 |   | Syscall_write
237 | 
238 | external poll_rd : Unix.file_descr -> bool = "lwt_unix_readable"
239 | external poll_wr : Unix.file_descr -> bool = "lwt_unix_writable"
240 | 
241 | let register_readable ch seq =
242 |   if ch.event_readable = None then begin
243 |     let hook _ = Lwt_dllist.iter_l (fun f -> f ()) seq in
244 |     ch.event_readable <- Some (Lwt_engine.on_readable ch.fd hook)
245 |   end
246 | 
247 | let register_writable ch seq =
248 |   if ch.event_writable = None then
249 |     let hook _ = Lwt_dllist.iter_l (fun f -> f ()) seq in
250 |     ch.event_writable <- Some (Lwt_engine.on_writable ch.fd hook)
251 | 
252 | let try_syscall ch kind action =
253 |   assert (ch.status = FD_OPEN);
254 |   try
255 |     if not ch.blocking ||
256 |        (kind = Syscall_read && poll_rd ch.fd) ||
257 |        (kind = Syscall_write && poll_wr ch.fd) then
258 |       Some (action ())
259 |     else None
260 |   with
261 |   | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _)
262 |   | Sys_blocked_io -> None
263 | 
264 | let dummy = Lwt_dllist.add_r ignore (Lwt_dllist.create ())
265 | 
266 | let maybe_continue ctxt_node k v =
267 |   Lwt_dllist.remove ctxt_node;
268 |   match !k with
269 |   | None -> k := None
270 |   | Some k -> continue k v
271 | 
272 | let maybe_discontinue ctxt_node k v =
273 |   Lwt_dllist.remove ctxt_node;
274 |   match !k with
275 |   | None -> k := None
276 |   | Some k -> discontinue k v
277 | 
278 | let rec block_syscall cleanup ctxt_node gst ch kind action k =
279 |   let node = ref dummy in
280 |   let seq =
281 |     match kind with
282 |     | Syscall_read ->
283 |         register_readable ch ch.hooks_readable;
284 |         ch.hooks_readable
285 |     | Syscall_write ->
286 |         register_writable ch ch.hooks_writable;
287 |         ch.hooks_writable
288 |   in
289 |   node := Lwt_dllist.add_r (fun () ->
290 |     Lwt_dllist.remove !node;
291 |     begin match try_syscall ch kind action with
292 |     | None -> block_syscall cleanup ctxt_node gst ch kind action k
293 |     | Some res ->
294 |         cleanup := None;
295 |         ignore @@ Lwt_dllist.add_r (fun () ->
296 |           maybe_continue ctxt_node k res) gst.run_q
297 |     | exception e ->
298 |         cleanup := None;
299 |         ignore @@ Lwt_dllist.add_r (fun () ->
300 |           maybe_discontinue ctxt_node k e) gst.run_q
301 |     end) seq;
302 |   (* This needs to be run if the thread was cancelled. *)
303 |   cleanup := Some (fun () -> Lwt_dllist.remove !node)
304 | 
305 | let do_syscall cleanup ctxt_node gst ch kind action k =
306 |   match try_syscall ch kind action with
307 |   | Some res -> maybe_continue ctxt_node k res
308 |   | None ->
309 |       block_syscall cleanup ctxt_node gst ch kind action k;
310 |       schedule gst
311 |   | exception e -> maybe_discontinue ctxt_node k e
312 | 
313 | let block_sleep ctxt_node gst delay k =
314 |   ignore @@ Lwt_engine.on_timer delay false (fun ev ->
315 |     (* TODO: Should I stop immediately? *)
316 |     Lwt_engine.stop_event ev;
317 |     ignore @@ Lwt_dllist.add_r (maybe_continue ctxt_node k) gst.run_q)
318 | 
319 | (* Promises *)
320 | 
321 | let mk_promise () = ref (Waiting [])
322 | 
323 | let finish gst prom v =
324 |   match !prom with
325 |   | Waiting l ->
326 |       prom := Done v;
327 |       List.iter (fun (ctxt_node, k) ->
328 |         ignore @@ Lwt_dllist.add_r (fun () -> maybe_continue ctxt_node k v) gst.run_q) l
329 |   | _ -> failwith "Impossible: finish"
330 | 
331 | let abort gst prom e =
332 |   match !prom with
333 |   | Waiting l ->
334 |       prom := Error e;
335 |       List.iter (fun (ctxt_node, k) ->
336 |         ignore @@ Lwt_dllist.add_r (fun () -> maybe_discontinue ctxt_node k e) gst.run_q) l
337 |   | _ -> failwith "Impossible: abort"
338 | 
339 | let force lst gst prom k =
340 |   match !prom with
341 |   | Done v -> continue k v
342 |   | Error e -> discontinue k e
343 |   | Waiting l ->
344 |       let k = ref (Some k) in
345 |       let ctxt_node = watch_for_cancellation lst k in
346 |       prom := Waiting ((ctxt_node,k)::l);
347 |       schedule gst
348 | 
349 | module IVar = struct
350 | 
351 |   type 'a t = 'a _promise ref
352 | 
353 |   let create () = mk_promise ()
354 | 
355 |   effect Fill : 'a t * 'a -> unit
356 |   let fill iv v = perform (Fill (iv,v))
357 | 
358 |   effect Read : 'a t -> 'a
359 |   let read iv = perform (Read iv)
360 | end
361 | 
362 | module Bigstring = struct
363 |   type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
364 | 
365 |   type io_vector =
366 |     { buffer : t;
367 |       off : int;
368 |       len : int }
369 | 
370 |   effect Read : file_descr * t * int * int -> int
371 |   effect Write : file_descr * t * int * int -> int
372 |   effect Writev : file_descr * io_vector array -> int
373 | 
374 |   let read fd buf pos len = perform (Read (fd, buf, pos, len))
375 |   let read_all fd buf = read fd buf 0 (Lwt_bytes.length buf)
376 | 
377 |   let write fd buf pos len = perform (Write (fd, buf, pos, len))
378 |   let write_all fd buf = write fd buf 0 (Lwt_bytes.length buf)
379 | 
380 |   let writev fd iovecs = perform (Writev (fd, iovecs))
381 | 
382 |   external stub_read : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_read"
383 |   external stub_write : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_write"
384 |   external stub_writev : Unix.file_descr -> io_vector array -> int = "aeio_unix_bytes_writev"
385 | end
386 | 
387 | (* Main handler loop *)
388 | 
389 | let tid_counter = ref 0
390 | 
391 | let init () =
392 |   { run_q = Lwt_dllist.create ();
393 |     num_async = 0 }
394 | 
395 | let next_tid () =
396 |   let res = !tid_counter in
397 |   incr tid_counter;
398 |   res
399 | 
400 | let run ?engine main =
401 |   begin match engine with
402 |   | None -> ()
403 |   | Some `Select -> Lwt_engine.set @@ new Lwt_engine.select
404 |   | Some `Libev -> Lwt_engine.set @@ new Lwt_engine.libev ()
405 |   end;
406 |   let gst = init () in
407 |   let rec fork : 'a. local_state -> global_state -> 'a promise -> (unit -> 'a) -> unit =
408 |     fun lst gst prom f ->
409 |       gst.num_async <- gst.num_async + 1;
410 |       match f () with
411 |       | v ->
412 |           gst.num_async <- gst.num_async - 1;
413 |           finish gst prom v;
414 |           schedule gst
415 |       | exception Cancelled ->
416 |           gst.num_async <- gst.num_async - 1;
417 |           abort gst prom Promise_cancelled;
418 |           schedule gst
419 |       | exception e ->
420 |           gst.num_async <- gst.num_async - 1;
421 |           abort gst prom e;
422 |           schedule gst
423 |       | effect Yield k when live lst.context ->
424 |           let k = ref (Some k) in
425 |           let ctxt_node = watch_for_cancellation lst k in
426 |           ignore @@ Lwt_dllist.add_r (maybe_continue ctxt_node k) gst.run_q;
427 |           schedule gst
428 |       | effect (Async (f, v, c)) k when live lst.context ->
429 |           let k = ref (Some k) in
430 |           let ctxt_node = watch_for_cancellation lst k in
431 |           let ctxt =
432 |             match c with
433 |             | None -> lst.context
434 |             | Some ctxt -> ctxt
435 |           in
436 |           let prom = mk_promise () in
437 |           ignore @@ Lwt_dllist.add_r (fun () -> maybe_continue ctxt_node k prom) gst.run_q;
438 |           let lst =
439 |             {cleanup = ref None;
440 |              context = ctxt;
441 |              thread_id = next_tid ()}
442 |           in
443 |           fork lst gst prom (fun () -> f v)
444 |       | effect (Await prom) k when live lst.context ->
445 |           force lst gst prom k
446 |       | effect (IVar.Read iv) k when live lst.context ->
447 |           force lst gst iv k
448 |       | effect (IVar.Fill (iv,v)) k when live lst.context ->
449 |           finish gst iv v;
450 |           continue k ()
451 |       | effect (Accept ch) k when live lst.context ->
452 |           let k = ref (Some k) in
453 |           let ctxt_node = watch_for_cancellation lst k in
454 |           let action () =
455 |             let fd, sa = Unix.accept ch.fd in
456 |             (mk_chan fd, sa)
457 |           in
458 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_read action k
459 |       | effect (Recv (ch, buf, pos, len, mode)) k when live lst.context ->
460 |           let k = ref (Some k) in
461 |           let ctxt_node = watch_for_cancellation lst k in
462 |           let action () = Unix.recv ch.fd buf pos len mode in
463 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_read action k
464 |       | effect (Send (ch, buf, pos, len, mode)) k when live lst.context ->
465 |           let k = ref (Some k) in
466 |           let ctxt_node = watch_for_cancellation lst k in
467 |           let action () = Unix.send ch.fd buf pos len mode in
468 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_write action k
469 |       | effect (Read (ch, buf, pos, len)) k when live lst.context ->
470 |           let k = ref (Some k) in
471 |           let ctxt_node = watch_for_cancellation lst k in
472 |           let action () = stub_read ch.fd buf pos len in
473 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_read action k
474 |       | effect (Write (ch, buf, pos, len)) k when live lst.context ->
475 |           let k = ref (Some k) in
476 |           let ctxt_node = watch_for_cancellation lst k in
477 |           let action () = stub_write ch.fd buf pos len in
478 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_write action k
479 |       | effect (Bigstring.Read (ch, buf, pos, len)) k when live lst.context ->
480 |           let k = ref (Some k) in
481 |           let ctxt_node = watch_for_cancellation lst k in
482 |           let action () = Bigstring.stub_read ch.fd buf pos len in
483 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_read action k
484 |       | effect (Bigstring.Write (ch, buf, pos, len)) k when live lst.context ->
485 |           let k = ref (Some k) in
486 |           let ctxt_node = watch_for_cancellation lst k in
487 |           let action () = Bigstring.stub_write ch.fd buf pos len in
488 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_write action k
489 |       | effect (Bigstring.Writev (ch, iovecs)) k when live lst.context ->
490 |           let k = ref (Some k) in
491 |           let ctxt_node = watch_for_cancellation lst k in
492 |           let action () = Bigstring.stub_writev ch.fd iovecs in
493 |           do_syscall lst.cleanup ctxt_node gst ch Syscall_write action k
494 |       | effect (Sleep t) k when live lst.context ->
495 |           if t <= 0. then continue k ()
496 |           else begin
497 |             let k = ref (Some k) in
498 |             let ctxt_node = watch_for_cancellation lst k in
499 |             block_sleep ctxt_node gst t k;
500 |             schedule gst
501 |           end
502 |       | effect Get_context k when live lst.context ->
503 |           continue k lst.context
504 |       | effect (Cancel_context ctxt) k when live lst.context ->
505 |           handle_cancel lst gst k ctxt
506 |       | effect Get_tid k when live lst.context ->
507 |           continue k lst.thread_id
508 |       | effect Get_num_async k when live lst.context ->
509 |           continue k gst.num_async
510 |       | effect _ k when not(live lst.context) ->
511 |           discontinue k Cancelled
512 |   in
513 |   let prom = mk_promise () in
514 |   let context = new_context () in
515 |   let cleanup = ref None in
516 |   let lst = {context; cleanup; thread_id = next_tid ()} in
517 |   fork lst gst prom main
518 | 
519 | (*---------------------------------------------------------------------------
520 |    Copyright (c) 2016 KC Sivaramakrishnan
521 | 
522 |    Permission to use, copy, modify, and/or distribute this software for any
523 |    purpose with or without fee is hereby granted, provided that the above
524 |    copyright notice and this permission notice appear in all copies.
525 | 
526 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
527 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
528 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
529 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
530 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
531 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
532 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
533 |   ---------------------------------------------------------------------------*)
534 | 


--------------------------------------------------------------------------------
/src/aeio.mli:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | (** Asynchronous effect-based IO
  8 | 
  9 |     {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *)
 10 | 
 11 | (** {1 Aeio} *)
 12 | 
 13 | type file_descr 
 14 | (** The type of file descriptors. *)
 15 | 
 16 | val get_unix_fd : file_descr -> Unix.file_descr
 17 | (** Get the underlying unix file descriptor. *)
 18 | 
 19 | val socket : Unix.socket_domain -> Unix.socket_type -> int -> file_descr
 20 | (** Same as {!Unix.socket}. *)
 21 | 
 22 | val close : file_descr -> unit
 23 | (** Same as {!Unix.close}. *)
 24 | 
 25 | val shutdown : file_descr -> Unix.shutdown_command -> unit
 26 | (** Same as {!Unix.shutdown}. *)
 27 | 
 28 | val set_nonblock : file_descr -> unit
 29 | (** Same as {!Unix.set_nonblock}. *)
 30 | 
 31 | type 'a promise
 32 | (** The type of promise. *)
 33 | 
 34 | type context 
 35 | (** The type of cancellation context. *)
 36 | 
 37 | exception Cancelled
 38 | (** Raised in the cancelled fiber. Allows the fiber to dispose resources
 39 |     cleanly. *)
 40 | 
 41 | exception Promise_cancelled
 42 | (** Raised at {!await} if the promise was cancelled. *)
 43 | 
 44 | val new_context : unit -> context 
 45 | (** Creates a new cancellation context. *)
 46 | 
 47 | val my_context : unit -> context
 48 | (** Return the current cancellation context. *)
 49 | 
 50 | val cancel : context -> unit
 51 | (** Cancel the context. *)
 52 | 
 53 | val async : ?ctxt:context-> ('a -> 'b) -> 'a -> 'b promise
 54 | (** [async f v] spawns a fiber to run [f v] asynchronously. If no cancellation
 55 |     context was provided, then the new fiber shares the cancelallation context
 56 |     of the caller. *)
 57 | 
 58 | val await : 'a promise -> 'a 
 59 | (** Block until the result of a promise is available. Raises exception [e] if
 60 |     the promise raises [e]. 
 61 |     @raise Promise_cancelled if the promise was cancelled. *)
 62 | 
 63 | val yield : unit -> unit
 64 | (** Yield control. *)
 65 | 
 66 | val get_tid : unit -> int
 67 | (** Get the current fiber id. *)
 68 | 
 69 | val accept : file_descr -> file_descr * Unix.sockaddr
 70 | (** Similar to Unix.accept, but asynchronous. *)
 71 | 
 72 | val recv : file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int
 73 | (** Similar to Unix.recv, but asynchronous. *)
 74 | 
 75 | val send : file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int
 76 | (** Similar to Unix.send, but asynchronous. *)
 77 | 
 78 | val write : file_descr -> bytes -> int -> int -> int
 79 | (** Similar to Unix.write, but asynchronous. *)
 80 | 
 81 | val read  : file_descr -> bytes -> int -> int -> int
 82 | (** Similar to Unix.read, but asynchronous. *)
 83 | 
 84 | val sleep : float -> unit
 85 | (** [sleep t] suspends the fiber for [t] milliseconds. *)
 86 | 
 87 | val live_async : unit -> int
 88 | (** Get the number of asyncs currently alive. *)
 89 | 
 90 | module Bigstring : sig
 91 | 
 92 |   type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
 93 | 
 94 |   val read : file_descr -> t -> int -> int -> int
 95 | 
 96 |   val read_all : file_descr -> t -> int
 97 | 
 98 |   val write : file_descr -> t -> int -> int -> int
 99 | 
100 |   val write_all : file_descr -> t -> int
101 | 
102 |   type io_vector =
103 |     { buffer : t;
104 |       off : int;
105 |       len : int }
106 | 
107 |   val writev : file_descr -> io_vector array -> int
108 | end
109 | 
110 | module IVar : sig
111 |   type 'a t
112 |   val create : unit -> 'a t
113 |   val fill   : 'a t -> 'a -> unit
114 |   val read   : 'a t -> 'a
115 | end
116 | 
117 | val run : ?engine:[`Select | `Libev] -> (unit -> unit) -> unit
118 | (** Run the asynchronous program. *)
119 | 
120 | (*---------------------------------------------------------------------------
121 |    Copyright (c) 2016 KC Sivaramakrishnan
122 | 
123 |    Permission to use, copy, modify, and/or distribute this software for any
124 |    purpose with or without fee is hereby granted, provided that the above
125 |    copyright notice and this permission notice appear in all copies.
126 | 
127 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
128 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
129 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
130 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
131 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
132 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
133 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
134 |   ---------------------------------------------------------------------------*)
135 | 


--------------------------------------------------------------------------------
/src/aeio.mllib:
--------------------------------------------------------------------------------
1 | Aeio
2 | 


--------------------------------------------------------------------------------
/src/aeio_stubs.c:
--------------------------------------------------------------------------------
 1 | #include <caml/mlvalues.h>
 2 | #include <caml/memory.h>
 3 | #include <caml/unixsupport.h>
 4 | #include <caml/bigarray.h>
 5 | #include <sys/uio.h>
 6 | #include <stdio.h>
 7 | 
 8 | static void fill_iovecs (struct iovec* iovecs, value iovec_array, int count)
 9 | {
10 |   CAMLparam1 (iovec_array);
11 |   CAMLlocal2 (iovec, ba);
12 |   intnat i, offset, length;
13 | 
14 |   for (i = 0; i < count; i++) {
15 |     caml_read_field (iovec_array, i, &iovec);
16 |     caml_read_field (iovec, 0, &ba);
17 |     offset = Long_field (iovec, 1);
18 |     length = Long_field (iovec, 2);
19 | 
20 |     iovecs[i].iov_len = length;
21 |     /* XXX KC: Not safe under multicore. iov_base is not a gc root. */
22 |     iovecs[i].iov_base = &((char*)Caml_ba_data_val(ba))[offset];
23 |   }
24 | 
25 |   CAMLreturn0;
26 | }
27 | 
28 | CAMLprim value aeio_unix_bytes_writev (value fd, value iovec_array)
29 | {
30 |   CAMLparam2(fd, iovec_array);
31 |   int count = caml_array_length (iovec_array);
32 |   struct iovec iovecs[count];
33 | 
34 |   fill_iovecs(iovecs, iovec_array, count);
35 | 
36 |   ssize_t bytes_written = writev (Int_val(fd), iovecs, count);
37 |   if (bytes_written == -1)
38 |     uerror ("writev", Nothing);
39 | 
40 |   CAMLreturn(Val_long(bytes_written));
41 | }
42 | 


--------------------------------------------------------------------------------
/src/libaeio.clib:
--------------------------------------------------------------------------------
1 | aeio_stubs.o
2 | 


--------------------------------------------------------------------------------
/src/libaeio_stubs.clib:
--------------------------------------------------------------------------------
1 | aeio_stubs.o
2 | 


--------------------------------------------------------------------------------
/test/echo.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | (* A simple echo server.
  8 |  *
  9 |  * The server listens on localhost port 9301. It accepts multiple clients and
 10 |  * echoes back to the client any data sent to the server. This server is a
 11 |  * direct-style reimplementation of the echo server found at [1], which
 12 |  * illustrates the same server written in CPS style.
 13 |  *
 14 |  * Compiling
 15 |  * ---------
 16 |  *
 17 |  *   make
 18 |  *
 19 |  * Running
 20 |  * -------
 21 |  * The echo server can be tested with a telnet client by starting the server and
 22 |  * on the same machine, running:
 23 |  *
 24 |  *   telnet localhost 9301
 25 |  *
 26 |  * -----------------------
 27 |  * [1] http://www.mega-nerd.com/erikd/Blog/CodeHacking/Ocaml/ocaml_select.html
 28 |  * [2] https://github.com/ocamllabs/opam-repo-dev
 29 |  *)
 30 | 
 31 | open Printf
 32 | 
 33 | let send sock str =
 34 |   let len = Bytes.length str in
 35 |   let total = ref 0 in
 36 |   while !total < len do
 37 |     let write_count = Aeio.send sock str !total (len - !total) [] in
 38 |     total := write_count + !total
 39 |   done;
 40 |   !total
 41 | 
 42 | let recv sock maxlen =
 43 |   let str = Bytes.create maxlen in
 44 |   let recvlen = Aeio.recv sock str 0 maxlen [] in
 45 |   Bytes.sub str 0 recvlen
 46 | 
 47 | let close sock =
 48 |   try Aeio.shutdown sock Unix.SHUTDOWN_ALL
 49 |   with _ -> () ;
 50 |   Aeio.close sock
 51 | 
 52 | let string_of_sockaddr = function
 53 |   | Unix.ADDR_UNIX s -> s
 54 |   | Unix.ADDR_INET (inet,port) ->
 55 |       (Unix.string_of_inet_addr inet) ^ ":" ^ (string_of_int port)
 56 | 
 57 | (* Repeat what the client says until the client goes away. *)
 58 | let echo_server sock addr =
 59 |   let rec loop () = 
 60 |     let data = recv sock 1024 in
 61 |     if Bytes.length data > 0 then
 62 |       (ignore (send sock data);
 63 |        loop ())
 64 |     else
 65 |       let cn = string_of_sockaddr addr in
 66 |       (printf "echo_server : client (%s) disconnected.\n%!" cn;
 67 |        close sock)
 68 |   in
 69 |   try loop () with _ -> close sock
 70 | 
 71 | let server () =
 72 |   (* Server listens on localhost at 9301 *)
 73 |   let addr, port = Unix.inet_addr_loopback, 9301 in
 74 |   printf "Echo server listening on 127.0.0.1:%d\n%!" port;
 75 |   let saddr = Unix.ADDR_INET (addr, port) in
 76 |   let ssock = Aeio.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 77 |   let ssock_unix = Aeio.get_unix_fd ssock in
 78 | 
 79 |   (* configure socket *)
 80 |   Unix.setsockopt ssock_unix Unix.SO_REUSEADDR true;
 81 |   Unix.bind ssock_unix saddr;
 82 |   Unix.listen ssock_unix 20;
 83 |   Aeio.set_nonblock ssock;
 84 | 
 85 |   try
 86 |     (* Wait for clients, and fork off echo servers. *)
 87 |     while true do
 88 |       let client_sock, client_addr = Aeio.accept ssock in
 89 |       let cn = string_of_sockaddr client_addr in
 90 |       printf "server : client (%s) connected.\n%!" cn;
 91 |       Aeio.set_nonblock client_sock;
 92 |       ignore @@ Aeio.async (echo_server client_sock) client_addr
 93 |     done
 94 |   with
 95 |   | _ -> close ssock
 96 | 
 97 | (* Main *)
 98 | 
 99 | let print_usage_and_exit () =
100 |   print_endline @@ "Usage: " ^ Sys.argv.(0) ^ " [select|libev]";
101 |   exit(0)
102 | 
103 | let () =
104 |   if Array.length Sys.argv < 2 then
105 |     print_usage_and_exit ()
106 |   else 
107 |     match Sys.argv.(1) with
108 |     | "select" -> Lwt_engine.set (new Lwt_engine.select)
109 |     | "libev" -> Lwt_engine.set (new Lwt_engine.libev ())
110 |     | _ -> print_usage_and_exit ()
111 | 
112 | let () = 
113 |   Aeio.run server
114 | 
115 | (*---------------------------------------------------------------------------
116 |    Copyright (c) 2016 KC Sivaramakrishnan
117 | 
118 |    Permission to use, copy, modify, and/or distribute this software for any
119 |    purpose with or without fee is hereby granted, provided that the above
120 |    copyright notice and this permission notice appear in all copies.
121 | 
122 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
123 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
124 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
125 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
126 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
127 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
128 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
129 |   ---------------------------------------------------------------------------*)
130 | 


--------------------------------------------------------------------------------
/test/echo_bigstring.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | (* A simple echo server.
  8 |  *
  9 |  * The server listens on localhost port 9301. It accepts multiple clients and
 10 |  * echoes back to the client any data sent to the server. This server is a
 11 |  * direct-style reimplementation of the echo server found at [1], which
 12 |  * illustrates the same server written in CPS style.
 13 |  *
 14 |  * Compiling
 15 |  * ---------
 16 |  *
 17 |  *   make
 18 |  *
 19 |  * Running
 20 |  * -------
 21 |  * The echo server can be tested with a telnet client by starting the server and
 22 |  * on the same machine, running:
 23 |  *
 24 |  *   telnet localhost 9301
 25 |  *
 26 |  * -----------------------
 27 |  * [1] http://www.mega-nerd.com/erikd/Blog/CodeHacking/Ocaml/ocaml_select.html
 28 |  * [2] https://github.com/ocamllabs/opam-repo-dev
 29 |  *)
 30 | 
 31 | open Printf
 32 | 
 33 | module B = Lwt_bytes
 34 | 
 35 | let send sock str =
 36 |   let len = B.length str in
 37 |   let total = ref 0 in
 38 |   while !total < len do
 39 |     let write_count = Aeio.Bigstring.write sock str !total (len - !total) in
 40 |     total := write_count + !total
 41 |   done;
 42 |   !total
 43 | 
 44 | let recv sock maxlen =
 45 |   let str = B.create maxlen in
 46 |   let recvlen = Aeio.Bigstring.read_all sock str in
 47 |   for i = 0 to recvlen 
 48 |   do
 49 |     Printf.printf "%c" @@ Bigarray.Array1.get str i
 50 |   done;
 51 |   print_endline "";
 52 |   Bigarray.Array1.sub str 0 recvlen
 53 | 
 54 | let close sock =
 55 |   try Aeio.shutdown sock Unix.SHUTDOWN_ALL
 56 |   with _ -> () ;
 57 |   Aeio.close sock
 58 | 
 59 | let string_of_sockaddr = function
 60 |   | Unix.ADDR_UNIX s -> s
 61 |   | Unix.ADDR_INET (inet,port) ->
 62 |       (Unix.string_of_inet_addr inet) ^ ":" ^ (string_of_int port)
 63 | 
 64 | (* Repeat what the client says until the client goes away. *)
 65 | let echo_server sock addr =
 66 |   let rec loop () = 
 67 |     let data = recv sock 1024 in
 68 |     if B.length data > 0 then
 69 |       (ignore (send sock data);
 70 |        loop ())
 71 |     else
 72 |       let cn = string_of_sockaddr addr in
 73 |       (printf "echo_server : client (%s) disconnected.\n%!" cn;
 74 |        close sock)
 75 |   in
 76 |   try loop () with _ -> close sock
 77 | 
 78 | let server () =
 79 |   (* Server listens on localhost at 9301 *)
 80 |   let addr, port = Unix.inet_addr_loopback, 9301 in
 81 |   printf "Echo server listening on 127.0.0.1:%d\n%!" port;
 82 |   let saddr = Unix.ADDR_INET (addr, port) in
 83 |   let ssock = Aeio.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 84 |   let ssock_unix = Aeio.get_unix_fd ssock in
 85 | 
 86 |   (* configure socket *)
 87 |   Unix.setsockopt ssock_unix Unix.SO_REUSEADDR true;
 88 |   Unix.bind ssock_unix saddr;
 89 |   Unix.listen ssock_unix 20;
 90 |   Aeio.set_nonblock ssock;
 91 | 
 92 |   try
 93 |     (* Wait for clients, and fork off echo servers. *)
 94 |     while true do
 95 |       let client_sock, client_addr = Aeio.accept ssock in
 96 |       let cn = string_of_sockaddr client_addr in
 97 |       printf "server : client (%s) connected.\n%!" cn;
 98 |       Aeio.set_nonblock client_sock;
 99 |       ignore @@ Aeio.async (echo_server client_sock) client_addr
100 |     done
101 |   with
102 |   | _ -> close ssock
103 | 
104 | (* Main *)
105 | 
106 | let print_usage_and_exit () =
107 |   print_endline @@ "Usage: " ^ Sys.argv.(0) ^ " [select|libev]";
108 |   exit(0)
109 | 
110 | let () =
111 |   if Array.length Sys.argv < 2 then
112 |     print_usage_and_exit ()
113 |   else 
114 |     match Sys.argv.(1) with
115 |     | "select" -> Lwt_engine.set (new Lwt_engine.select)
116 |     | "libev" -> Lwt_engine.set (new Lwt_engine.libev ())
117 |     | _ -> print_usage_and_exit ()
118 | 
119 | let () = 
120 |   Aeio.run server
121 | 
122 | (*---------------------------------------------------------------------------
123 |    Copyright (c) 2016 KC Sivaramakrishnan
124 | 
125 |    Permission to use, copy, modify, and/or distribute this software for any
126 |    purpose with or without fee is hereby granted, provided that the above
127 |    copyright notice and this permission notice appear in all copies.
128 | 
129 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
130 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
131 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
132 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
133 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
134 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
135 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
136 |   ---------------------------------------------------------------------------*)
137 | 


--------------------------------------------------------------------------------
/test/echo_cancel.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2016 KC Sivaramakrishnan. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | (* A simple echo server.
  8 |  *
  9 |  * The server listens on localhost port 9301. It accepts multiple clients and
 10 |  * echoes back to the client any data sent to the server. This server is a
 11 |  * direct-style reimplementation of the echo server found at [1], which
 12 |  * illustrates the same server written in CPS style.
 13 |  *
 14 |  * Compiling
 15 |  * ---------
 16 |  *
 17 |  *   make
 18 |  *
 19 |  * Running
 20 |  * -------
 21 |  * The echo server can be tested with a telnet client by starting the server and
 22 |  * on the same machine, running:
 23 |  *
 24 |  *   telnet localhost 9301
 25 |  *
 26 |  * -----------------------
 27 |  * [1] http://www.mega-nerd.com/erikd/Blog/CodeHacking/Ocaml/ocaml_select.html
 28 |  * [2] https://github.com/ocamllabs/opam-repo-dev
 29 |  *)
 30 | 
 31 | open Printf
 32 | 
 33 | let send sock str =
 34 |   let len = Bytes.length str in
 35 |   let total = ref 0 in
 36 |   while !total < len do
 37 |     let write_count = Aeio.send sock str !total (len - !total) [] in
 38 |     total := write_count + !total
 39 |   done;
 40 |   !total
 41 | 
 42 | let recv sock maxlen =
 43 |   let str = Bytes.create maxlen in
 44 |   let recvlen = Aeio.recv sock str 0 maxlen [] in
 45 |   Bytes.sub str 0 recvlen
 46 | 
 47 | let close sock =
 48 |   try Aeio.shutdown sock Unix.SHUTDOWN_ALL
 49 |   with _ -> () ;
 50 |   Aeio.close sock
 51 | 
 52 | let string_of_sockaddr = function
 53 |   | Unix.ADDR_UNIX s -> s
 54 |   | Unix.ADDR_INET (inet,port) ->
 55 |       (Unix.string_of_inet_addr inet) ^ ":" ^ (string_of_int port)
 56 | 
 57 | (* Repeat what the client says until the client goes away. *)
 58 | let echo_server sock addr =
 59 |   let channel_name = string_of_sockaddr addr in
 60 |   let rec loop () =
 61 |     let data = recv sock 1024 in
 62 |     if Bytes.length data > 0 then begin
 63 |       if Bytes.length data = 2 then
 64 |         Aeio.cancel (Aeio.my_context ())
 65 |       else begin
 66 |         printf "echo_server : echo client=%s msg=%s%!" channel_name @@ Bytes.to_string data;
 67 |         ignore (send sock data);
 68 |         loop ()
 69 |       end
 70 |     end else
 71 |       (printf "echo_server : client=%s disconnected.\n%!" channel_name;
 72 |        close sock)
 73 |   in
 74 |   try loop ()
 75 |   with e ->
 76 |     begin if e = Aeio.Cancelled then 
 77 |       Printf.printf "echo_server : Server connection to client=%s cancelling..\n%!" channel_name;
 78 |     end;
 79 |     close sock;
 80 |     raise e
 81 | 
 82 | let server () =
 83 |   (* Server listens on localhost at 9301 *)
 84 |   let addr, port = Unix.inet_addr_loopback, 9301 in
 85 |   printf "Echo server listening on 127.0.0.1:%d\n%!" port;
 86 |   printf "Connect as `telnet localhost 9301`\n%!";
 87 |   let saddr = Unix.ADDR_INET (addr, port) in
 88 |   let ssock = Aeio.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 89 |   let ssock_unix = Aeio.get_unix_fd ssock in
 90 | 
 91 |   (* configure socket *)
 92 |   Unix.setsockopt ssock_unix Unix.SO_REUSEADDR true;
 93 |   Unix.bind ssock_unix saddr;
 94 |   Unix.listen ssock_unix 20;
 95 |   Aeio.set_nonblock ssock;
 96 | 
 97 |   try
 98 |     let ctxt = Aeio.my_context () in
 99 |     (* Wait for clients, and fork off echo servers. *)
100 |     while true do
101 |       let client_sock, client_addr = Aeio.accept ssock in
102 |       let cn = string_of_sockaddr client_addr in
103 |       printf "server : client (%s) connected.\n%!" cn;
104 |       Aeio.set_nonblock client_sock;
105 |       ignore @@ Aeio.async ~ctxt (echo_server client_sock) client_addr
106 |     done
107 |   with
108 |   | e -> 
109 |       begin if e = Aeio.Cancelled then 
110 |         Printf.printf "echo_server : server main thread cancelling..\n%!";
111 |       end;
112 |       close ssock;
113 |       raise e
114 | 
115 | (* Main *)
116 | 
117 | let print_usage_and_exit () =
118 |   print_endline @@ "Usage: " ^ Sys.argv.(0) ^ " [select|libev]";
119 |   exit(0)
120 | 
121 | let () =
122 |   if Array.length Sys.argv < 2 then
123 |     print_usage_and_exit ()
124 |   else 
125 |     match Sys.argv.(1) with
126 |     | "select" -> Lwt_engine.set (new Lwt_engine.select)
127 |     | "libev" -> Lwt_engine.set (new Lwt_engine.libev ())
128 |     | _ -> print_usage_and_exit ()
129 | 
130 | let () = 
131 |   Aeio.run server
132 | 
133 | (*---------------------------------------------------------------------------
134 |    Copyright (c) 2016 KC Sivaramakrishnan
135 | 
136 |    Permission to use, copy, modify, and/or distribute this software for any
137 |    purpose with or without fee is hereby granted, provided that the above
138 |    copyright notice and this permission notice appear in all copies.
139 | 
140 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
141 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
142 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
143 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
144 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
145 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
146 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
147 |   ---------------------------------------------------------------------------*)
148 | 


--------------------------------------------------------------------------------