acap.ml

   1 open Format;;
   2
   3 type c =
   4     { silence : string
   5     ; audio_running : bool
   6     }
   7
   8 type encset =
   9     { freq : int
  10     ; nchannels : int
  11     ; audiofmt : int
  12     }
  13
  14 let fail fmt = Printf.kprintf (fun s -> failwith s) fmt;;
  15 let log = printf;;
  16 let log fmt = Printf.kprintf ignore fmt;;
  17
  18 let r8 s o = Char.code s.[o];;
  19 let r16 s o = let b1 = r8 s o and b2 = r8 s (o+1) in (b1 lsl 8) lor b2;;
  20 let r16s s o = let i = r16 s 0 in i - ((i lor 0x8000) lsl 1);;
  21 let r32 s o =
  22   let w1 = r16 s o
  23   and w2 = r16 s (o+2) in
  24   Int32.logor (Int32.shift_left (Int32.of_int w1) 16) (Int32.of_int w2)
  25 ;;
  26 let rint s o = let l = r32 s o in Int32.to_int l;;
  27 let w8 s o i = s.[o] <- Char.chr (i land 255);;
  28 let w16 s o i = w8 s (o+1) i; w8 s o (i lsr 8);;
  29 let wint s o i = w16 s (o+2) i; w16 s o (i asr 16);;
  30 let w32 s o l =
  31   w16 s (o+2) (Int32.to_int l);
  32   w16 s o (Int32.to_int (Int32.shift_right l 16));
  33 ;;
  34
  35 let encodings t =
  36   let b = Buffer.create 20 in
  37   Buffer.add_string b "\002xyy";
  38   let c = "xxxx" in
  39   let nencodings = List.fold_left
  40     (fun n i -> w32 c 0 i; Buffer.add_string b c; succ n)
  41     0 [-259l]
  42   in
  43   let s = Buffer.contents b in
  44   w16 s 2 nencodings;
  45   s
  46 ;;
  47
  48 let setpixfmt =
  49   let s = String.create 20 in
  50   w8 s 0 0;
  51   w8 s 4 16;
  52   w8 s 5 2;
  53   w8 s 6 1;
  54   w8 s 7 1;
  55   w16 s 8 31;
  56   w16 s 10 63;
  57   w16 s 12 31;
  58   w8 s 14 11;
  59   w8 s 15 5;
  60   w8 s 16 0;
  61   s
  62 ;;
  63
  64 let setaudiofmt ~fmt ~nchannels ~freq =
  65   let s = String.create 10 in
  66   w8  s 0 255;
  67   w8  s 1 001;
  68   w16 s 2 002;
  69   w8  s 4 fmt;
  70   w8  s 5 nchannels;
  71   w32 s 6 freq;
  72   s
  73 ;;
  74
  75 let useaudio =
  76   let s = String.create 4 in
  77   w8  s 0 255;
  78   w8  s 1 001;
  79   w16 s 2 000;
  80   s
  81 ;;
  82
  83 let create_context ~w ~h ~encset =
  84   let bytes_per_frame =
  85     let sample_size =
  86       match encset.audiofmt with
  87       | 0 | 1 -> 1
  88       | 2 | 3 -> 2
  89       | 4 | 5 -> 4
  90       | _ -> fail "invalid audiofmt %d" encset.audiofmt
  91     in
  92     let _frame_size = sample_size * encset.nchannels in
  93     0
  94   in
  95   { audio_running = false
  96   ; silence =
  97       String.make bytes_per_frame '\000' (* wrong for unsigned *)
  98   }
  99 ;;
 100
 101 let reason pump =
 102   let n = rint (pump#get 4) 0 in
 103   let s = pump#get n in
 104   fail "Protocol failure, reason: `%S'" s;
 105 ;;
 106
 107 let rec handshake encset pump =
 108   let s = pump#get 12 in
 109   let maj, min =
 110     try
 111       let dec a b c = a*100 + b*10 + c in
 112       Scanf.sscanf s "RFB %1i%1i%1i.%1i%1i%1i\n"
 113         (fun a b c d e f -> dec a b c, dec d e f)
 114     with exn ->
 115       fail "can't parse ProtocolVersion `%S'" s
 116   in
 117
 118   if maj < 3 || (maj == 3 && min < 8)
 119   then fail "Too old of a protocol %d.%d" maj min;
 120
 121   pump#put"RFB 003.008\n";
 122   let s = let nsectypes = r8 (pump#get 1) 0 in pump#get nsectypes in
 123   (try ignore (String.index s '\001')
 124     with Not_found -> fail "None auth not found");
 125   pump#put "\001";
 126   if r32 (pump#get 4) 0 <> 0l then reason pump;
 127   pump#put "\001";
 128   serverinit encset pump
 129
 130 and serverinit encset pump =
 131   let s = pump#get 24 in
 132   let w = r16 s 0
 133   and h = r16 s 2
 134   and namelen = rint s 20 in
 135   let name = pump#get namelen in
 136   let () =
 137     printf "server is `%S'@." name;
 138     pump#put (encodings encset);
 139     pump#put setpixfmt;
 140   in
 141   let context = create_context ~w ~h ~encset in
 142   boot encset context pump
 143
 144 and boot encset t pump =
 145   let rec srv1 t =
 146     pump#run;
 147     match r8 (pump#get 1) 0 with
 148     | 000 -> framebuffer_update t
 149     | 255 -> aliguori t
 150     | msg -> fail "unexpected server message %x" msg
 151
 152   and framebuffer_update t =
 153     let nrects = r16 (pump#get 3) 1 in
 154     let rec loop t i = if i = nrects then t else
 155         let s = pump#get 12 in
 156         let e = r32 s 8 in
 157         match e with
 158         | -259l -> loop (audio_ack t) (i+1)
 159         | _  -> fail "rect with unhandled encoding %lx, %S" e s
 160     in
 161     let t = loop t 0 in
 162     srv1 t
 163
 164   and audio_ack t =
 165     let fmt = encset.audiofmt
 166     and nchannels = encset.nchannels
 167     and freq = Int32.of_int encset.freq in
 168     pump#put (setaudiofmt ~fmt ~nchannels ~freq);
 169     pump#put useaudio;
 170     t
 171
 172   and aliguori t =
 173     match r8 (pump#get 1) 0 with
 174     | 001 -> audio t
 175     | msg -> fail "unexpected aliguori message %x" msg
 176
 177   and audio t =
 178     match r16 (pump#get 2) 0 with
 179     | 000 -> srv1 { t with audio_running = false }
 180     | 001 -> srv1 { t with audio_running = true }
 181     | 002 -> audio_data t
 182     | msg -> fail "unexpected audio message %x" msg
 183
 184   and audio_data t =
 185     let nbytes = rint (pump#get 4) 0 in
 186     let audio = pump#get nbytes in
 187     pump#add_audio audio;
 188     srv1 t
 189   in
 190
 191   srv1 t;
 192 ;;
 193
 194 let vncopen addr =
 195   let sock, addr =
 196     if String.length addr > 5 && String.sub addr 0 5 = "unix:"
 197     then
 198       let path = String.sub addr 5 (String.length addr - 5) in
 199       let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
 200       sock, Unix.ADDR_UNIX path
 201     else
 202       let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 203       let addr, port =
 204         try
 205           let p = String.index addr ':' in
 206           let s = String.sub addr (p + 1) (String.length addr - p - 1) in
 207           let port =
 208             try int_of_string s with exn ->
 209               fail "can't parse port in `%S': %s"
 210                 addr (Printexc.to_string exn)
 211           in
 212           let addr = String.sub addr 0 p in
 213           addr, port
 214         with Not_found ->
 215           addr, 5900
 216       in
 217       let addr = (Unix.gethostbyname addr).Unix.h_addr_list.(0) in
 218       sock, Unix.ADDR_INET (addr, port)
 219   in
 220   Unix.connect sock addr;
 221   sock
 222 ;;
 223
 224 let pump encset sock =
 225   let null = Unix.openfile "/dev/null" [] 0 in
 226   let rapipe, wapipe = Unix.pipe () in
 227   let () =
 228     Unix.set_close_on_exec wapipe;
 229     Unix.set_close_on_exec sock;
 230     Unix.set_nonblock wapipe;
 231   in
 232   let _pid = Unix.create_process
 233     "/bin/sh"
 234     [| "/bin/sh"; "./acap.sh"; string_of_int (Obj.magic rapipe) |]
 235     null
 236     null
 237     Unix.stderr
 238   in
 239   let rw c f s =
 240     let rec loop p l =
 241       let n = f s p l in
 242       if n = 0 then fail "%s: end of file" c;
 243       if n = l then () else loop (p + n) (l - n)
 244     in loop 0 (String.length s)
 245   in
 246   let rec write s fd buf pos len () =
 247     let n =
 248       try
 249         let n = Unix.write fd buf pos len in
 250         if n = 0 then fail "EOF while writing %s" s;
 251         n
 252       with Unix.Unix_error (Unix.EAGAIN, _, _) -> 0
 253     in
 254     if n = 0 then `again else
 255       if n = len
 256       then `completed
 257       else `more (write s fd buf (pos+n) (len-n))
 258   in object (self)
 259     val al = ref []
 260
 261     method run =
 262       match !al with
 263       | [] -> ()
 264       | l ->
 265           let _, l, _ = Unix.select [] [wapipe] [] 0.0 in
 266           let rec loop = function
 267             | fd :: tl ->
 268                 let rec wrall accu = function
 269                   | [] -> List.rev accu
 270                   | f :: tl ->
 271                       match f () with
 272                       | `completed -> wrall accu tl
 273                       | `again -> f :: accu
 274                       | `more f -> f :: accu
 275                 in
 276                 al := wrall [] !al;
 277                 loop tl
 278             | [] -> ()
 279           in
 280           loop l
 281
 282     method add_audio data =
 283       al := !al @ [write "audio" wapipe data 0 (String.length data)]
 284
 285     method wait dur =
 286       let r, _, _ = Unix.select [sock] [] [] dur in
 287       r != []
 288
 289     method get n = let s = String.create n in rw "get" (Unix.read sock) s; s
 290     method put s = rw "put" (Unix.write sock) s
 291   end
 292 ;;
 293
 294 let main =
 295   let host = ref "localhost:5900" in
 296   Arg.parse (Arg.align [])
 297     (fun s -> host := s)
 298     "Usage: acap [host]\n";
 299   let encset =
 300     { nchannels = 2
 301     ; audiofmt = 3
 302     ; freq = 44100
 303     }
 304   in
 305   try
 306     let sock = vncopen !host in
 307     let pump = pump encset sock in
 308     handshake encset pump;
 309   with Unix.Unix_error (e, s1, s2) ->
 310     eprintf "%s(%s): %s@." s1 s2 (Unix.error_message e)
 311 ;;