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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
open Sys
open Unix
module Ms = Map.Make(String)
module Mc = Map.Make(Char)
type 'a or_error = Ok of 'a | Error of string
let identity x = x
let try_finally body cleanup =
let res = try body ()
with exn -> cleanup (); raise exn in
cleanup ();
res
let exn_to_opt body =
try Some (body ())
with exn -> None
let exec cmd = execvp cmd.(0) cmd
let launch cmd =
if fork () = 0
then exec cmd
let print_usage () =
List.iter print_endline ["Usage: " ^ Sys.argv.(0) ^ " <title> <console>\n"
^ " Consoles: [gb gba]"];
exit 0
let die msg =
print_endline ("ERROR! (" ^ msg ^ ")"); exit (-1)
let get_or_die = function
| Ok x -> x
| Error msg -> die msg
let launch_get_output cmd =
let input_lines ic =
let rec aux lines =
try aux (input_line ic :: lines) with End_of_file -> lines in
aux [] in
let (ifd,ofd) = pipe () in
match fork () with
| 0 -> dup2 ofd stdout; dup2 ofd stderr;
close stdin; close ifd; close ofd;
exec cmd
| n -> close ofd;
let lns = input_lines (in_channel_of_descr ifd) in
close ifd; ignore (waitpid [] n);
lns
module Net = struct
let tcp_server s_handler addr =
let setup_tcp_socket addr =
let s = socket PF_INET SOCK_STREAM 0 in
try bind s addr;
listen s 10;
s
with z -> close s; raise z in
ignore (signal sigpipe Signal_ignore);
let ss = setup_tcp_socket addr in
while true do
let client = accept ss in
s_handler ss client
done
let double_fork server service (cfd, _ as client) =
let treat () = match fork () with
| 0 -> if fork () <> 0 then exit 0;
close server; service client; exit 0
| n -> ignore (waitpid [] n) in
try_finally treat (fun () -> close cfd)
let s_handler c_handler sock (_, caddr as client) =
print_endline
(match caddr with
| ADDR_INET (a,_) -> "Connected to " ^ string_of_inet_addr a
| ADDR_UNIX _ -> "Local connection (dafuq?)");
double_fork sock c_handler client
end
module type WM = sig
type wid
val pp_wid : wid -> string
val search_by_title : string -> wid list
val title : wid -> string
val focus : wid -> unit
val send : wid -> string -> unit
end
module Xdotool : WM = struct
type wid = string
let cmdname = "xdotool"
let delay = "200"
let pp_wid = identity
let search_by_title name =
launch_get_output [|cmdname; "search"; "--name"; name|]
let title wid =
List.hd (launch_get_output [|cmdname; "getwindowname"; wid|])
let focus wid =
launch [|cmdname; "windowfocus"; wid|]
let send wid keys =
launch [|cmdname; "type"; "--delay"; delay; keys|]
end
module Console : sig
type t = Gb | Gba
type key
val of_string : string -> t or_error
val pp : t -> string
val keys : t -> key list
end = struct
type t = Gb | Gba
type key =
| Kup | Kdown | Kleft | Kright
| Ka | Kb | Kl | Kr
| Kstart | Kselect
let of_string c = match c with
| "gb" -> Ok Gb
| "gba" -> Ok Gba
| _ -> Error ("console " ^ c ^ " not supported")
let pp = function
| Gb -> "gb (Game Boy)"
| Gba -> "gba (Game Boy Advanced)"
let keys = function
| Gb -> [Kup;Kdown;Kleft;Kright;Ka;Kb;Kstart]
| Gba -> [Kup;Kdown;Kleft;Kright;Ka;Kb;Kl;Kr;Kstart]
end
module Comm (Wm : WM) = struct
type mode = Cmd | Key
let pp_mode = function
| Cmd -> "cmd"
| Key -> "key"
type state = {
wid : Wm.wid;
mode : mode;
(* bds : char Bindings.t; *)
console : Console.t
}
let mk_state wid mode (* bds *) console =
{ wid = wid;
mode = mode;
(* bds = bds; *)
console = console }
let switch_mode st =
let mode' = match st.mode with Cmd -> Key | Key -> Cmd in
print_endline ("Mode switched to " ^ pp_mode mode');
{ st with mode = mode' }
let cmdmap =
let press k st = Wm.send st.wid k; st in
let default_cmds =
[("up","w"); ("down","s"); ("left","a"); ("right","d");
("a","u"); ("b","h"); ("l","i"); ("r","o"); ("start","j")] in
let keys = List.fold_left (fun m (k,v) -> Ms.add k (press v) m)
Ms.empty default_cmds in
let cmdbds = [("switch", switch_mode)] in
let cmds = List.fold_left (fun m (k,f) -> Ms.add k f m)
Ms.empty cmdbds in
Ms.fold Ms.add keys cmds
let find_window name =
let wids = Wm.search_by_title name in
let falses = [Sys.argv.(0); "mednafen"] in (* May have the same title *)
let falsewids = List.concat (List.map Wm.search_by_title falses) in
match List.filter (fun wid -> not (List.mem wid falsewids)) wids with
| [] -> Error "window not found"
| [x] -> Ok (x, Wm.title x)
| _ -> Error "multiple windows found ()" (* TODO print titles found *)
let c_handler st0 (cfd, _) =
dup2 cfd stdin; dup2 cfd stdout; dup2 cfd stderr; close cfd;
Wm.focus st0.wid;
let rec loop st =
match st.mode with
| Cmd ->
print_string "> ";
flush_all ();
let cmd = read_line () in
sleep 1;
let f = match exn_to_opt (fun () -> Ms.find cmd cmdmap) with
| None -> print_endline ("Unknown cmd '" ^ cmd ^ "'"); identity
| Some f -> f in
loop (f st)
| Key ->
print_string "> "; in
loop st0
(* Wm.send wid "awdwawdwawdwawdwa" *)
end
module MyWm = Xdotool
module MyComm = Comm(MyWm)
let () =
if Array.length Sys.argv <> 3 then print_usage ();
let addr = inet_addr_any in
let port = 8080 in
let inaddr = ADDR_INET (addr, port) in
let title = Sys.argv.(1) in
let console = get_or_die (Console.of_string Sys.argv.(2)) in
print_endline ("Using " ^ Console.pp console ^ " settings");
print_string ("Searching window with title '" ^ title ^ "'... ");
let (wid, title) = get_or_die (MyComm.find_window title) in
print_endline ("found '" ^ title ^ "' (WID " ^ MyWm.pp_wid wid ^ ")");
let st0 = MyComm.mk_state wid MyComm.Cmd console in
print_endline ("Starting server in port " ^ string_of_int port ^ "...");
Net.tcp_server (Net.s_handler (MyComm.c_handler st0)) inaddr
|
