terminal.ml (20082B)
1 (* Unison file synchronizer: src/terminal.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 (* Parsing messages from OpenSSH *) 19 (* Examples. 20 21 "tjim@saul.cis.upenn.edu's password: " (to stdout) 22 23 24 "Permission denied, please try again." (to stderr ...) 25 "tjim@saul.cis.upenn.edu's password: " (... to stdout) 26 27 28 "Permission denied (publickey,gssapi,password,hostbased)." (to stderr) 29 30 31 "The authenticity of host 'saul.cis.upenn.edu (158.130.12.4)' can't be established. 32 RSA key fingerprint is d1:d8:5e:08:8c:ae:56:15:66:af:4b:55:53:2a:bc:38. 33 Are you sure you want to continue connecting (yes/no)? " (to stdout) 34 35 36 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 37 @ WARNING: REMOTE HOST IDENTIFICATION HAS CHANGED! @ 38 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 39 IT IS POSSIBLE THAT SOMEONE IS DOING SOMETHING NASTY! 40 Someone could be eavesdropping on you right now (man-in-the-middle attack)! 41 It is also possible that the RSA host key has just been changed. 42 The fingerprint for the RSA key sent by the remote host is 43 d1:d8:5e:08:8c:ae:56:15:66:af:4b:55:53:2a:bc:38. 44 Please contact your system administrator. 45 Add correct host key in /Users/trevor/.ssh/known_hosts to get rid of this message. 46 Offending key in /Users/trevor/.ssh/known_hosts:22 47 RSA host key for saul.cis.upenn.edu has changed and you have requested strict checking. 48 Host key verification failed." (to stderr) 49 *) 50 51 let passwordRx = 52 Rx.rx ".*assword:[ ]*" 53 let passphraseRx = 54 Rx.rx "Enter passphrase for key.*" 55 let authenticityRx = 56 Rx.rx "The authenticity of host .* continue connecting \\(yes/no\\)\\? " 57 let password s = Rx.match_string passwordRx s 58 let passphrase s = Rx.match_string passphraseRx s 59 let authenticity s = Rx.match_string authenticityRx s 60 61 (* Create a new process with a new controlling terminal, useful for 62 SSH password interaction. 63 *) 64 65 (* Implemented in file pty.c *) 66 type pty 67 external win_openpty : unit -> (Unix.file_descr * Unix.file_descr) 68 * pty * (Unix.file_descr * Unix.file_descr) = "win_openpty" 69 external win_closepty : pty -> unit = "win_closepty" 70 let win_openpty () = try Some (win_openpty ()) with Unix.Unix_error _ -> None 71 72 external dumpFd : Unix.file_descr -> int = "%identity" 73 external setControllingTerminal : Unix.file_descr -> unit = 74 "setControllingTerminal" 75 external c_openpty : unit -> Unix.file_descr * Unix.file_descr = 76 "c_openpty" 77 let openpty() = try Some (c_openpty ()) with Unix.Unix_error _ -> None 78 79 (* Utility functions copied from ocaml's unix.ml because they are not exported :-| *) 80 (* Duplicate [fd] if needed to make sure it isn't one of the 81 standard descriptors (stdin, stdout, stderr). 82 Note that this function always leaves the standard descriptors open, 83 the caller must take care of closing them if needed. 84 The "cloexec" mode doesn't matter, because 85 the descriptor returned by [dup] will be closed before the [exec], 86 and because no other thread is running concurrently 87 (we are in the child process of a fork). 88 *) 89 let rec file_descr_not_standard fd = 90 if dumpFd fd >= 3 then fd else file_descr_not_standard (Unix.dup fd) 91 92 let safe_close fd = try Unix.close fd with Unix.Unix_error _ -> () 93 94 let perform_redirections new_stdin new_stdout new_stderr = 95 let new_stdin = file_descr_not_standard new_stdin in 96 let new_stdout = file_descr_not_standard new_stdout in 97 let new_stderr = file_descr_not_standard new_stderr in 98 (* The three dup2 close the original stdin, stdout, stderr, 99 which are the descriptors possibly left open 100 by file_descr_not_standard *) 101 Unix.dup2 ~cloexec:false new_stdin Unix.stdin; 102 Unix.dup2 ~cloexec:false new_stdout Unix.stdout; 103 Unix.dup2 ~cloexec:false new_stderr Unix.stderr; 104 safe_close new_stdin; 105 safe_close new_stdout; 106 safe_close new_stderr 107 108 let rec safe_waitpid pid = 109 (* This function is intentionally synchronous so that it can be run during 110 cleanup code when Lwt threads might be stopped or otherwise be in an 111 unreliable state. *) 112 let kill_noerr si = try Unix.kill pid si with Unix.Unix_error _ -> () in 113 let t = Unix.gettimeofday () in 114 let rec aux st = 115 match Unix.waitpid [Unix.WNOHANG] pid with 116 | (0, _) -> 117 Unix.sleepf 0.002; 118 let dt = Unix.gettimeofday () -. t in 119 if dt >= 0.5 && st = 0 then begin 120 kill_noerr Sys.(if win32 then sigkill else sigterm); 121 aux 1 122 end else if dt >= 2.0 && st = 1 then begin 123 kill_noerr Sys.sigkill; 124 aux 2 125 end else 126 aux st 127 | (_, r) -> r 128 | exception Unix.Unix_error (EINTR, _, _) -> aux st 129 in 130 aux 0 131 132 let term_sessions = Hashtbl.create 3 133 134 external win_create_process_pty : 135 string -> string -> pty -> Unix.file_descr -> Unix.file_descr -> int = 136 "w_create_process_pty" 137 138 let make_cmdline args = 139 let maybe_quote f = 140 if String.contains f ' ' || String.contains f '\"' 141 then Filename.quote f 142 else f in 143 String.concat " " (List.map maybe_quote (Array.to_list args)) 144 145 let create_process_pty prog args pty fd1 fd2 = 146 win_create_process_pty prog (make_cmdline args) pty fd1 fd2 147 148 let protect f g = 149 try f () with Sys_error _ | Unix.Unix_error _ as e -> 150 begin try g () with Sys_error _ | Unix.Unix_error _ -> () end; 151 raise e 152 153 let finally f g = 154 try let r = f () in g (); r with Sys_error _ | Unix.Unix_error _ as e -> 155 begin try g () with Sys_error _ | Unix.Unix_error _ -> () end; 156 raise e 157 158 external win_alloc_console : unit -> Unix.file_descr option = "win_alloc_console" 159 160 let fallback_session cmd args new_stdin new_stdout new_stderr = 161 if Sys.win32 then begin 162 (* OCaml's [Unix.create_process] hides the Windows console window of 163 the child process unless the parent process already has a console. 164 This is unsuitable for running interactive child processes like 165 the ssh client. To make it possible to use the ssh client without pty, 166 we have to open a Windows console window before launching the child 167 process. Unfortunately, we can't know if the ssh client (or any other 168 remote shell client) requires user interaction via the Windows console 169 or not. 170 171 Ignore any errors because it is almost certain that the error indicates 172 that a console already exists (and we can't do anything about other 173 errors anyway). 174 175 If a new console was allocated and [Unix.stderr] is invalid (which 176 will happen in Windows for GUI without a console unless stderr is 177 redirected elsewhere; this is checked in the C stub) then also 178 redirect [Unix.stderr] to the new console. [new_stderr] is most likely 179 [Unix.stderr] and will therefore be associated with the new console. *) 180 try 181 match win_alloc_console () with 182 | None -> () 183 | Some fd -> try Unix.dup2 fd Unix.stderr with Unix.Unix_error _ -> () 184 with Unix.Unix_error _ -> () 185 end; 186 let childPid = 187 System.create_process cmd args new_stdin new_stdout new_stderr in 188 Hashtbl.add term_sessions childPid (fun () -> ignore (safe_waitpid childPid)); 189 (None, childPid) 190 191 let win_create_session cmd args new_stdin new_stdout new_stderr = 192 match win_openpty () with 193 | None -> fallback_session cmd args new_stdin new_stdout new_stderr 194 | Some ((masterIn, masterOut), pty, (conIn, conOut)) -> 195 safe_close conIn; 196 let create_proc () = 197 (* Child's stderr is always connected to pty (conOut, effectively). *) 198 create_process_pty cmd args pty new_stdin new_stdout in 199 let childPid = 200 protect (fun () -> finally create_proc 201 (fun () -> safe_close conOut)) 202 (fun () -> safe_close masterOut; 203 safe_close masterIn) 204 in 205 let fdIn = Lwt_unix.of_unix_file_descr masterIn 206 and fdOut = Lwt_unix.of_unix_file_descr masterOut in 207 let ret = Some (fdIn, fdOut) in 208 Hashtbl.add term_sessions childPid 209 (fun () -> finally (fun () -> win_closepty pty) 210 (fun () -> finally (fun () -> Lwt_unix.close fdOut) 211 (fun () -> Lwt_unix.close fdIn))); 212 (ret, childPid) 213 214 (* Like Unix.create_process except that we also try to set up a 215 controlling terminal for the new process. If successful, a file 216 descriptor for the master end of the controlling terminal is 217 returned. *) 218 let unix_create_session cmd args new_stdin new_stdout new_stderr = 219 match openpty () with 220 None -> fallback_session cmd args new_stdin new_stdout new_stderr 221 | Some (masterFd, slaveFd) -> 222 Unix.set_close_on_exec masterFd; 223 Unix.set_close_on_exec slaveFd; 224 flush_all (); (* Clear buffers to avoid risk of double flushing by child. 225 Even this is not sufficient, strictly speaking, as there is a window 226 of opportunity to fill the buffer between flushing and calling fork. *) 227 begin match Unix.fork () with 228 0 -> 229 begin try 230 (* Child process stderr must redirected as early as possible to 231 make sure all error output is captured and visible in GUI. *) 232 Unix.dup2 ~cloexec:false slaveFd Unix.stderr; 233 (* new_stderr will be used by parent process only. *) 234 if new_stderr <> Unix.stderr then safe_close new_stderr; 235 Unix.close masterFd; 236 (* [Unix.setsid] is not implemented on Cygwin, reason unknown. 237 It will be called by [setControllingTerminal] instead. *) 238 if not Sys.cygwin then ignore (Unix.setsid ()); 239 setControllingTerminal slaveFd; 240 (* WARNING: SETTING ECHO TO FALSE! *) 241 let tio = Unix.tcgetattr slaveFd in 242 tio.Unix.c_echo <- false; 243 Unix.tcsetattr slaveFd Unix.TCSANOW tio; 244 (* Redirect ssh authentication errors to controlling terminal, 245 instead of new_stderr, so that they can be captured by GUI. 246 This will inevitably also redirect the remote stderr to GUI 247 as ssh's own error output is mixed with remote stderr output. *) 248 perform_redirections new_stdin new_stdout slaveFd; 249 Unix.execvp cmd args (* never returns *) 250 with Unix.Unix_error (e, s1, s2) -> 251 Printf.eprintf "Error in create_session child: [%s] (%s) %s\n" 252 s1 s2 (Unix.error_message e); 253 flush stderr; 254 (* FIXME: this should be Unix._exit (available from OCaml 4.12) 255 which doesn't flush buffers (or run other exit handlers). 256 When [_exit] is eventually used then to _completely_ avoid risk 257 of double flushing, [Unix.write Unix.stderr] should be used 258 above instead of [eprintf]. Using [_exit] and not using any 259 [Stdlib.out_channel] will avoid all buffering and exit handler 260 issues. *) 261 exit 127 262 end 263 | childPid -> 264 (* Keep a file descriptor so that we do not get EIO errors 265 when the OpenSSH 5.6 child process closes the file 266 descriptor before opening /dev/tty. *) 267 (* Unix.close slaveFd; *) 268 let fd = Lwt_unix.of_unix_file_descr masterFd in 269 let ret = Some (fd, fd) in 270 Hashtbl.add term_sessions childPid 271 (fun () -> safe_close slaveFd; 272 finally (fun () -> Lwt_unix.close fd) 273 (fun () -> ignore (safe_waitpid childPid))); 274 (ret, childPid) 275 end 276 277 let create_session = 278 match Sys.os_type with 279 | "Win32" -> win_create_session 280 | _ -> unix_create_session 281 282 let close_session pid = 283 try 284 let cleanup = Hashtbl.find term_sessions pid in 285 Hashtbl.remove term_sessions pid; 286 cleanup () 287 with Not_found -> 288 raise (Unix.Unix_error (Unix.ESRCH, "Terminal.close_session", "")) 289 290 let (>>=) = Lwt.bind 291 292 (* OpenSSH on Windows is known to produce at least the following escape 293 sequences. Examples of raw output with OCaml string escapes, starting from 294 beginning of line and ending at end of line, newline excluded: 295 296 \027[2J\027[m\027[H\027]0;C:\\WINDOWS\\System32\\OpenSSH\\ssh.exe\007\027[?25h 297 298 The authenticity of host 'example.com (127.0.0.1)' can't be established.\r\nECDSA key fingerprint is SHA256:CxGGHIVL7YDoSAtAzkIJNNaheGW7dDa7m7H+antMzDv. \r\nAre you sure you want to continue connecting (yes/no/[fingerprint])?\027[10X\027[1C 299 300 Most of these sequences are clearly useless for Unison and can be safely 301 ignored. The final sequence CSI 10 X CSI 1 C is a bit weird. In this 302 context, CSI 1 C can be interpreted as 1 space, although this is not 303 universal. 304 305 Some versions may have also emitted CSI ! p (VT220 soft reset) but this 306 no longer seems to be the case. *) 307 308 type controlSt = No | Escape | EscapeSeq | CSI | OSC | StringSeq | OSCEsc | StringEsc 309 310 (* A very primitive and minimal parser of ANSI X3.64/ECMA-48 control sequences. 311 It parses 7-bit control characters (C0) only. 8-bit control characters (C1) 312 are intentionally not parsed. 313 The vast majority of sequences are just ignored. *) 314 let parseCtrlSeq s = 315 let s' = Buffer.create (String.length s) in 316 let add_char = Buffer.add_char s' in 317 let params = Buffer.create 32 in 318 let params_add_char = Buffer.add_char params in 319 let st = ref No in 320 let state x = st := x in 321 let parseEsc ch = 322 Buffer.clear params; 323 match ch with 324 | '\032'..'\047' -> state EscapeSeq 325 | '[' -> state CSI 326 | ']' -> state OSC 327 | 'X' | '^' | '_' -> state StringSeq 328 | _ -> state No 329 in 330 let parseCh ch = 331 match !st with 332 | No when ch = '\027' -> state Escape 333 | No -> add_char ch 334 | Escape -> parseEsc ch 335 | EscapeSeq -> 336 begin 337 match ch with 338 | '\024' | '\026' -> state No (* CAN, SUB *) 339 | '\000'..'\025' -> add_char ch (* Control characters (roughly) *) 340 | '\027' -> state Escape 341 | '\048'..'\126' -> state No (* Final *) 342 | '\127'..'\255' -> state No (* Invalid *) 343 | _ -> () 344 end 345 | CSI -> 346 begin 347 match ch with 348 | '\024' | '\026' -> state No (* CAN, SUB *) 349 | '\000'..'\025' -> add_char ch (* Control characters (roughly) *) 350 | '\027' -> state Escape 351 | '\064'..'\126' -> (* Final *) 352 begin 353 state No; 354 match ch with 355 | 'C' -> (* cursor forward *) 356 let n = 357 try int_of_string (Buffer.contents params) 358 with Failure _ -> 1 in 359 for _ = 1 to n do add_char ' ' done 360 | _ -> () 361 end 362 | '\127'..'\255' -> state No (* Invalid *) 363 | _ -> params_add_char ch 364 end 365 | OSC -> 366 begin 367 match ch with 368 | '\024' | '\026' -> state No (* CAN, SUB *) 369 | '\007' -> state No (* BEL *) 370 | '\000'..'\025' -> add_char ch (* Control characters (roughly) *) 371 | '\027' -> state OSCEsc 372 | _ -> () 373 end 374 | OSCEsc -> 375 begin 376 match ch with 377 | '\\' -> state No (* String terminator *) 378 | _ -> parseEsc ch 379 end 380 | StringSeq -> 381 begin 382 match ch with 383 | '\024' | '\026' -> state No (* CAN, SUB *) 384 | '\000'..'\025' -> add_char ch (* Control characters (roughly) *) 385 | '\027' -> state StringEsc 386 | _ -> () 387 end 388 | StringEsc -> 389 begin 390 match ch with 391 | '\\' -> state No (* String terminator *) 392 | _ -> parseEsc ch 393 end 394 in 395 String.iter parseCh s; 396 Buffer.contents s' 397 398 let processEscapes s = 399 parseCtrlSeq s 400 401 (* Wait until there is input. If there is terminal input s, 402 return Some s. Otherwise, return None. *) 403 let rec termInput (fdTerm, _) fdInput = 404 let buf = Bytes.create 10000 in 405 let rec readPrompt () = 406 Lwt_unix.read fdTerm buf 0 10000 >>= fun len -> 407 if len = 0 then 408 (* The remote end is dead *) 409 Lwt.return None 410 else 411 let query = Bytes.sub_string buf 0 len in 412 if query = "\r\n" || query = "\n" || query = "\r" then 413 readPrompt () 414 else 415 Lwt.return (Some (processEscapes query)) 416 in 417 let connectionEstablished () = 418 Lwt_unix.wait_read fdInput >>= fun () -> Lwt.return None 419 in 420 Lwt_unix.run 421 (Lwt.choose 422 [readPrompt (); connectionEstablished ()]) 423 424 type termInteract = { 425 userInput : string -> (string -> unit) -> unit; 426 endInput : unit -> unit } 427 428 (* Read messages from the terminal and use the callback to get an answer *) 429 let handlePasswordRequests (fdIn, fdOut) {userInput; endInput} = 430 let scrollback = Buffer.create 32 in 431 let extract () = 432 let s = Buffer.contents scrollback in 433 let () = Buffer.clear scrollback in 434 s 435 in 436 let blen = 10000 in 437 let buf = Bytes.create blen in 438 let ended = ref false in 439 let closeInput () = 440 ended := true; 441 endInput () 442 in 443 let terminalError loc e = 444 closeInput (); 445 Util.encodeException loc `Fatal e 446 in 447 let sendResponse s = 448 Lwt.catch 449 (fun () -> 450 if !ended then Lwt.return 0 451 else Lwt_unix.write_substring fdOut (s ^ "\n") 0 (String.length s + 1)) 452 (terminalError "writing to shell terminal") 453 in 454 let promptUser () = 455 let query = extract () in 456 if query = "\r\n" || query = "\n" || query = "\r" then () 457 else 458 (* There is a tiny, almost non-existent risk of a broken escape sequence 459 at the very beginning or the very end of the buffer (this can happen 460 if bytes read from the pty end in the middle of a sequence and before 461 reading any further we charge ahead with processing what we've read). 462 Given that it's almost certainly ssh we're dealing with, this risk can 463 safely be ignored. *) 464 let querytext = processEscapes query in 465 if querytext = "" || String.trim querytext = "" then () 466 else 467 userInput querytext (fun s -> Lwt.ignore_result (sendResponse s)) 468 in 469 let rec loop () = 470 (* When reading from a pty, the reading loop will not stop even when the 471 remote shell process dies. The reading will end (return 0 or an error) 472 when the pty is closed. 473 The only way to stop the reading loop without closing the pty is to 474 signal [connectionReady] or [closeInput]. *) 475 Lwt.catch 476 (fun () -> Lwt_unix.read fdIn buf 0 blen) 477 (fun ex -> if !ended then Lwt.return 0 else Lwt.fail ex) 478 >>= function 479 | 0 -> Lwt.return () 480 | len -> 481 Buffer.add_string scrollback (Bytes.sub_string buf 0 len); 482 if !ended then begin (* The shell connection has been established *) 483 Lwt.return () 484 end else begin 485 Lwt.ignore_result (Lwt_unix.sleep 0.05 >>= fun () -> (* Give time for connection checks *) 486 Lwt.return (if not !ended then promptUser ())); 487 loop () 488 end 489 in 490 let readTerm = Lwt.catch loop (terminalError "reading from shell terminal") in 491 let handleReqs = readTerm >>= fun () -> Lwt.return (extract ()) in 492 let connectionReady () = closeInput (); extract () in 493 let extractRemainingOutput () = 494 closeInput (); 495 (* Give a final chance of reading the error output from the ssh process. *) 496 let timeout = Lwt_unix.sleep 0.3 in 497 Lwt.choose [readTerm; timeout] >>= fun () -> 498 Lwt.return (Util.trimWhitespace (processEscapes (extract ()))) 499 in 500 (connectionReady, handleReqs, extractRemainingOutput)