1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
type priority = Non_blocking | Maybe_blocking
let io_priority = Non_blocking
(* Create scheduler *)
let scheduler = Duppy.create ()
(* Create two queues,
* one for non blocking events
* and another for blocking
* events *)
let new_queue ~priority ~name () =
let log = Printf.printf "%s: %s\n%!" name in
let priorities p = p = priority in
let queue () = Duppy.queue scheduler ~log ~priorities name in
Thread.create queue ()
let th =
ignore (new_queue ~priority:Non_blocking ~name:"Non blocking queue" ());
ignore (new_queue ~priority:Maybe_blocking ~name:"Maybe blocking queue #1" ());
new_queue ~priority:Maybe_blocking ~name:"Maybe blocking queue #2" ()
let exec_command s () =
let chan = Unix.open_process_in s in
let rec aux () =
match try Some (input_line chan) with End_of_file -> None with
| None -> []
| Some s -> s :: aux ()
in
let l = aux () in
ignore (Unix.close_process_in chan);
Duppy.Monad.return (String.concat "\r\n" l)
let commands = Hashtbl.create 10
let () =
Hashtbl.add commands "hello" (false, fun () -> Duppy.Monad.return "world");
Hashtbl.add commands "foo" (false, fun () -> Duppy.Monad.return "bar");
Hashtbl.add commands "uptime" (true, exec_command "uptime");
Hashtbl.add commands "date" (true, exec_command "date");
Hashtbl.add commands "whoami" (true, exec_command "whoami");
Hashtbl.add commands "sleep" (true, exec_command "sleep 15");
Hashtbl.add commands "exit" (true, fun () -> Duppy.Monad.raise ())
(* Add commands here *)
let help = Buffer.create 10
let () =
Buffer.add_string help "List of commands:";
Hashtbl.iter
(fun x _ -> Buffer.add_string help (Printf.sprintf "\r\n%s" x))
commands;
Hashtbl.add commands "help"
(false, fun () -> Duppy.Monad.return (Buffer.contents help))
let handle_client socket =
let on_error e =
match e with
| Duppy.Io.Io_error -> Printf.printf "Client disconnected"
| Duppy.Io.Unix (c, p, m) ->
Printf.printf "%s" (Printexc.to_string (Unix.Unix_error (c, p, m)))
| Duppy.Io.Unknown e -> Printf.printf "%s" (Printexc.to_string e)
| Duppy.Io.Timeout -> Printf.printf "Timeout"
in
let h = { Duppy.Monad.Io.scheduler; socket; data = ""; on_error } in
(* Read and process lines *)
let rec exec () =
let __pa_duppy_0 =
Duppy.Monad.Io.read ?timeout:None ~priority:io_priority
~marker:(Duppy.Io.Split "[\r\n]+") h
in
Duppy.Monad.bind __pa_duppy_0 (fun req ->
let __pa_duppy_0 =
try
let blocking, command = Hashtbl.find commands req in
if not blocking then command ()
else Duppy.Monad.Io.exec ~priority:Maybe_blocking h (command ())
with Not_found ->
Duppy.Monad.return
"ERROR: unknown command, type \"help\" to get a list of commands."
in
Duppy.Monad.bind __pa_duppy_0 (fun ans ->
Duppy.Monad.bind
(Duppy.Monad.bind
(Duppy.Monad.Io.write ?timeout:None ~priority:io_priority h
(Bytes.unsafe_of_string "BEGIN\r\n"))
(fun () ->
Duppy.Monad.bind
(Duppy.Monad.Io.write ?timeout:None ~priority:io_priority h
(Bytes.unsafe_of_string ans))
(fun () ->
Duppy.Monad.Io.write ?timeout:None ~priority:io_priority
h
(Bytes.unsafe_of_string "\r\nEND\r\n"))))
(fun () -> exec ())))
in
let close () = try Unix.close socket with _ -> () in
let return () =
let on_error e =
on_error e;
close ()
in
Duppy.Io.write ~priority:io_priority ~on_error ~exec:close scheduler
~string:(Bytes.unsafe_of_string "Bye!\r\n")
socket
in
Duppy.Monad.run ~return ~raise:close (exec ())
open Unix
let port = 4123
let bind_addr_inet = inet_addr_of_string "0.0.0.0"
let bind_addr = ADDR_INET (bind_addr_inet, port)
let max_conn = 10
let sock = socket PF_INET SOCK_STREAM 0
let () =
setsockopt sock SO_REUSEADDR true;
let rec incoming _ =
( try
let s, caller = accept sock in
let ip =
let a =
match caller with ADDR_INET (a, _) -> a | _ -> assert false
in
try (gethostbyaddr a).h_name with Not_found -> string_of_inet_addr a
in
Printf.printf "New client: %s\n" ip;
handle_client s
with e ->
Printf.printf "Failed to accept new client: %S\n" (Printexc.to_string e)
);
[
{
Duppy.Task.priority = io_priority;
Duppy.Task.events = [`Read sock];
Duppy.Task.handler = incoming;
};
]
in
( try bind sock bind_addr
with Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
failwith (Printf.sprintf "port %d already taken" port) );
listen sock max_conn;
Duppy.Task.add scheduler
{
Duppy.Task.priority = io_priority;
Duppy.Task.events = [`Read sock];
Duppy.Task.handler = incoming;
};
Thread.join th
|
