let easycgi_version = "1.23i";;

let pr = print_string;;
let pre = print_endline;;

pr "Content-type: text/html\n\n";;
flush stdout;;

Unix.dup2 Unix.stdout Unix.stderr;;
let prs = print_string;;

(*  This portion not used --- under testing
(* header handling code *)
 let header = ref "Content-type: text/html\n\n";; (* Default header data *)
 let header_sent = ref false;; (* flag: true if header is sent *)
 let (pin, pout) = Unix.pipe ();; (* pipe to redirect stdout till header is sent *)
 Unix.set_nonblock pin;; (* non blocking for polling with sigalarm timer *)

 let sout = Unix.dup Unix.stdout;; (* Save stdout *)
(* let serr = Unix.dup Unix.stderr;; (* Save stderr *) *)
 let prs s = ignore(Unix.write sout s 0 (String.length s));; (* helper func *)

Unix.dup2 pout Unix.stdout;; (* redirect stdout to the pipe *)
(*Unix.dup2 pout Unix.stderr;; (* redirect stderr to the pipe *)*)
 
 let start_timer () = Unix.setitimer Unix.ITIMER_REAL 
   {Unix.it_interval = 0.0001; Unix.it_value = 0.0001} ;;  (* Timer function *)
 let stop_timer () = ignore(Unix.setitimer Unix.ITIMER_REAL 
   {Unix.it_interval = 0.0; Unix.it_value = 0.0} );; (* reset timer  *)

 let __count = ref 10 ;;
 (* Sigalarm handling func *)
 let check_pin signal =
  flush_all ();
  if !__count > 0 && not !header_sent then (
(*prs ("count=" ^ (string_of_int !__count) ^ " \n");*)
    decr __count;
    let s = String.create 256 in
    let nc = ref 0 in
    (try 
      nc := Unix.read pin s 0 256; (* Try to read from pipe *)
(*prs ("nc=" ^ (string_of_int !nc) ^ " \n");*)
      stop_timer ();
      flush_all ();
      Unix.dup2 Unix.stdout Unix.stderr;    (* Redirect stderr to stdout *)
      Unix.dup2 sout Unix.stdout;    (* Restore stdout *)
      prs !header; (* Output header *)
      flush_all ();
      header_sent := true;
      if !nc > 0 then prs (substr s 0 !nc); (* send initial data to stdout *)
      (try while true do
        nc := Unix.read pin s 0 256;
        if !nc > 0 then prs (String.sub s 0 !nc); (* send the rest of data if any to stdout *)
      done; with _ -> ());
      flush_all ();
    with _ -> ignore (start_timer ()) ) (* restart timer if no data yet *)
  ) else (
(*prs "??? Why ???";*)
    stop_timer ();
  );;

 Sys.set_signal Sys.sigalrm (Sys.Signal_handle check_pin);; (* set signal func *)
 at_exit (fun () -> 
    stop_timer ();
    prs !header; (* Output header *)
    flush_all (); 
    Unix.dup2 Unix.stdout Unix.stderr;    (* Redirect stderr to stdout *)
    Unix.dup2 sout Unix.stdout;    (* Restore stdout *)
    let s = String.create 256 in
    let nc = ref 0 in
    header_sent := true;
    (try while true do
        nc := Unix.read pin s 0 256;
        if !nc > 0 then prs (String.sub s 0 !nc); (* send the rest of data if any to stdout *)
      done; with _ -> ());
      flush_all ();
  );; (* make sure to send header+data before exit *)

 start_timer ();; (* Everything ready. Start timer *)

 (* Now, before any out put will be kept in pipe
   and http response header will be prefixed without fail. 
   This mimics stupid behavior of PHP and facilitate
   initail adaptation of PHP user.  *)
      
*** End of testing code *** *)


let max_post = 2048000;; (* maximum post data size *)

(* Alias for string.length *)
let strlen = String.length;;

(* String.sub alias + accepting negative index *)
let substr0 s i len = 
  let slen = strlen s in
  if slen > 0 then (
    let l = if slen < len then slen else len in
    if i >= 0 then String.sub s i l
    else String.sub s (slen + i) l
  ) else ""
  ;;

let substr s i len = 
  let errpr es = 
    let ss = if (String.length s) > 20 then String.sub s 0 20 else s in
prerr_string (" substr " ^ ss ^ ", " ^ (string_of_int i) ^ ", " ^ (string_of_int len) ^ ", " ^ es ^ "<br>\n");flush_all () in
  let slen = strlen s in
  if len < 0 then errpr "len < 0";
  if slen > 0 then (
    let l = if slen < len then (errpr "slen < len";slen) else len in
    if i >= 0 then ((if (i + l) > slen then errpr "i + l > slen");String.sub s i l )
    else ((if (slen + i + l) > slen then errpr "slen + i + l > slen"); String.sub s (slen + i) l)
  ) else ""
  ;;
  
let slice s n1 n2 =
  let len = strlen s in
  let nn1 = if n1 < 0 then (len + n1) else n1 in
  let nn2 = if n2 < 0 then len + n2 else if n2 = 0 then len else n2 in
  substr s nn1 (nn2 - nn1 ) ;;
      
let env s = 
    try Sys.getenv s
    with Not_found -> "";;

let prenv x = pre (env x) ;;

let pw = (Unix.getpwuid (Unix.getuid ()));;
let user = pw.Unix.pw_name;; (* User name *)
let home = pw.Unix.pw_dir;; (* home dir *)
let cwd = Unix.getcwd ();;

(* stat type checking *)
let is_dir pn = (Unix.lstat pn).Unix.st_kind = Unix.S_DIR;;
let is_file pn = (Unix.lstat pn).Unix.st_kind = Unix.S_REG;;
let is_link pn = (Unix.lstat pn).Unix.st_kind = Unix.S_LNK;;

let filesize pn = (Unix.lstat pn).Unix.st_size;;
let filemtime pn = (Unix.lstat pn).Unix.st_mtime;;
let fileatime pn = (Unix.lstat pn).Unix.st_atime;;
let filectime pn = (Unix.lstat pn).Unix.st_ctime;;


(* find string -> substring -> position (or  -1) *)
let find s ss =
  let i = ref 0 in
  let si = ref 0 in
  let len = strlen ss in
  if len = 0 then 0 else
    (let c = ss.[0] in
    try
      while (String.sub s !si len) <> ss do 
(*      while (substr s !si len) <> ss do *)
        si := String.index_from s !i c;
        i := !si + 1 
      done; !si
    with _ -> -1 );;

(* rfind string -> substring -> position (or  -1) *)
let rfind s ss =
  let len = strlen ss in
  if len = 0 then 0 else
    (let si = ref ((strlen s) - len) in
    let c = ss.[0] in
    try
      while (String.sub s !si len) <> ss do
(*      while (substr s !si len) <> ss do *)
        si := String.rindex_from s (!si - 1) c;
      done; !si
    with _ -> -1 );;

(* find all occurance of substring 'ss' in the string 's' 
   and return the list of matched positions. *)
let find_all s ss =
  let slen = strlen s in
  let sslen = strlen ss in
  let si = ref 0 in
  let r = ref [] in
  for i = 0 to (slen - sslen ) do
    while !si < sslen && s.[i + !si] = ss.[!si] do incr si done;
    if !si >= sslen then r := i :: !r; 
    si := 0
  done; List.rev !r ;;


(* replace all occerance of substring 'ss' in the string 's' 
   with the string 'sub' and return the result *)
let replace s ss sub =
  let slen = strlen s in
  let sslen = strlen ss in
  let sublen = strlen sub in
  let si = ref 0 and rsi = ref 0 in
  let r = find_all s ss in
  let rs = String.create (slen + ((sublen - sslen) * (List.length r))) in
  List.iter (fun i -> 
     if i <> !si then 
        (String.blit s !si rs !rsi (i - !si);rsi := !rsi + (i - !si)); 
     if sublen <> 0 then 
        (String.blit sub 0 rs !rsi sublen;rsi := !rsi + sublen);
     si := i + sslen
       ) r; 
  if !si < slen then String.blit s !si rs !rsi (slen - !si);
  rs ;;



(* Returns nth line in the string. Accepts negative index. *)
let nth_line s n =
  let len = strlen s in
  if n < 0 then (
    let r = Array.of_list (find_all s "\n") in
    let rlen = Array.length r in
    let nn = rlen + (if r.(rlen -1) = (len -1) then n  else n +1) in
    (match nn with    
       0  -> substr s 0 r.(0) 
      | _ when nn = rlen -> substr s (r.(nn -1) + 1)  (len - r.(nn -1) - 1)
      | _ ->  substr s (r.(nn -1) + 1)  (r.(nn) - r.(nn -1) -1) )
  ) else (   
    let ni = ref 0 and si = ref 0 and ei = ref ( -1) in
    try 
      while !ni <= n do 
        si := !ei + 1;
        ei := String.index_from s !si '\n';
        incr ni
      done; substr s !si (!ei - !si)
    with Not_found -> if !ni = n then substr s !si (len - !si)
      else raise Not_found
  )
  ;;

let extension s =
  try 
    let exti = (String.rindex s '.') + 1  in ();
    let extii = (try (String.rindex s '/') + 2 
      with _ -> -1 ) in
    if exti > extii then substr s exti ((strlen s) - exti )  
      else ""
  with _ -> "";;

(* remove '//' '/./' '/../' making necessary adjustments *)
let normpath p =
(*  pr "normpath p=";pre p; *)
  let len = strlen p in
  if len < 2 then p else begin
    let abs = if p.[0] = '/' then true else false in
    let on = ref false in
    let r = ref "" in
    let ti = ref 0 and dot = ref 0 and back = ref 0 in
    let pl = ref [] in
    for i = 0 to (len -1) do
      if !on then ( (* valid pathname segment *)
        if p.[i] = '/' then ( on := false; pl := (!ti,i)::!pl  )
      ) else ( (* '/' or "." or ".." *)
        match p.[i] with '/' -> if !dot = 2 then (
           if abs=false && (List.length !pl) = 0 then incr back
           else if (List.length !pl) > 0 then pl := List.tl !pl ); dot := 0
          | '.' -> if !dot = 0 then (ti := i;incr dot) else 
             if !dot = 2 then (on := true ; dot := 0) else incr dot
          | _ -> on := true; if !dot = 0 then ti := i
      )
    done ; 
    if !on then pl := (!ti,(len - 1))::!pl else if !dot = 2 then
      if abs=false && (List.length !pl) = 0 then incr back
      else if (List.length !pl) > 0 then pl := List.tl !pl; 
    List.iter (fun (s, e) -> r := (substr p s (e-s +1)) ^ !r) !pl;
    if abs = false && !back > 0 then (
      for i=1 to !back do r := "../" ^ !r done
    );
    if abs then "/" ^ !r else !r
  end;;

(* join two paths *)
let path_join p1 p2 = normpath (Filename.concat p1 p2) ;;


let readwriteline_chan f ic oc=
  try
    while true do
      output_string oc (f (input_line ic))
    done
  with End_of_file -> ()

      
let replace_file sreg templ file =
  let regexp = Str.regexp sreg in
  let bakfile = (file ^ ".bak") and tmpfile = (file ^ ".tmp") in
  if (Filename.check_suffix file ".bak") || (Filename.check_suffix file ".tmp")
  then ()
  else
    let ic = open_in_bin file in
    let oc = open_out_bin tmpfile in
    readwriteline_chan (Str.global_replace regexp templ) ic oc;
(*     print_endline file; *)
    close_in ic;  close_out oc ;
    if Sys.file_exists bakfile then Unix.unlink bakfile;
    Unix.rename file bakfile;
    Unix.rename tmpfile file
    ;;
  
let rec walkdir f path =
  let last_pos = (strlen path)-1 in
  let path = if path.[last_pos]='/' then substr path 0 last_pos else path in
  let list = ref [] and count = ref 0 in
  let dir = Unix.opendir path in
  try
    while true do
      match Unix.readdir dir with
        "." | ".." -> ()
      | filename -> 
        let npath = (path ^ "/" ^ filename) in
         if not ((Unix.lstat npath).Unix.st_kind = Unix.S_DIR) 
           then (list := (path ^ "/" ^ filename) :: !list; count := !count + 1)
           else walkdir f npath
    done
   with End_of_file -> List.iter f !list;
(*   print_string (string_of_int !count);
   print_string ", ";*)
   ;; 

(* print_endline "Starting..."   ;; *)

(* walkdir print_endline "./CTB/";; *)
(* walkdir (replace "html" "XXXhtmlXXX") "./CT";; *)
(* walkdir (replace_file "html" "XXXhtmlXXX") "./CTB/";; *)
(* walkdir (replace_file Sys.argv.(1) Sys.argv.(2)) Sys.argv.(3);; *)
(* print_endline "END"   ;; *)


(* module Url = struct *)
  let hex_digits =
    [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7';
       '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F' |];;

  let to_hex2 k =
    (* Converts k to a 2-digit hex string *)
    let s = String.create 2 in
    s.[0] <- hex_digits.( (k lsr 4) land 15 );
    s.[1] <- hex_digits.( k land 15 );
    s ;;

  let of_hex1 c =
    match c with
	('0'..'9') -> Char.code c - Char.code '0'
      | ('A'..'F') -> Char.code c - Char.code 'A' + 10
      | ('a'..'f') -> Char.code c - Char.code 'a' + 10
      | _ ->
	raise Not_found ;;

  let url_encoding_re =
    Str.regexp "[^A-Za-z0-9_.!*-]";;

  let unsafe_chars_html4 = "<>\"&\000\001\002\003\004\005\006\007\008\011\012\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\127" ;;

let arg = 
   try  Sys.argv.(1)
   with _ -> "No arg";;


let encode s =
  let buf = Buffer.create (strlen s) in
  String.iter (fun c -> 
      match c with
      '0'..'9' | 'A'..'Z' | 'a'..'z' | '_' | '.' | '*' | '!' | '-' | '/' -> 
             Buffer.add_char buf c
      | _ -> Buffer.add_char buf '%';
             Buffer.add_string  buf (to_hex2 (int_of_char c))
  ) s; 
  Buffer.contents buf;;      

      
let url_decoding_re =
    Str.regexp "%0d%0a\\|%0D%0A\\|\r\n\\|\\+\\|%[0-9a-fA-f][0-9a-fA-f]\\|%u[0-9a-fA-f][0-9a-fA-f][0-9a-fA-f][0-9a-fA-f]";;

let decode s =
    Str.global_substitute
      url_decoding_re
      (fun s -> 
        let ss = Str.matched_string s in
        match ss with
          "\r\n" | "%0D%0A" | "%0d%0a" -> "\n"
          |"+" -> " "
          | _ ->
            let k1 = of_hex1 ss.[1] in
            let k2 = of_hex1 ss.[2] in
            String.make 1 (char_of_int((k1 lsl 4) lor k2))     
    )  s ;; 

let udecode s =
    Str.global_substitute
      url_decoding_re
      (fun s -> 
        let ss = Str.matched_string s in

        match ss with
          "\r\n" | "%0D%0A" | "%0d%0a" -> "\n"
          |"+" -> " "
          | _ ->
            match ss.[1] with
              'u' ->
                  let k1 = of_hex1 ss.[2] in
                  let k2 = of_hex1 ss.[3] in
                  let k3 = of_hex1 ss.[4] in
                  let k4 = of_hex1 ss.[5] in
                  (String.make 1 (char_of_int((k1 lsl 4) lor k2)) ^ 
                      String.make 1 (char_of_int((k3 lsl 4) lor k4)) )
              | _  ->
                  let k1 = of_hex1 ss.[1] in
                  let k2 = of_hex1 ss.[2] in
                  String.make 1 (char_of_int((k1 lsl 4) lor k2))
      )  s ;;

   
let split_name_is_value s =
  try
    let p = String.index s '=' in
    (decode (substr s 0 p), decode (substr s (p+1) (strlen s - p - 1) ))
  with
      Not_found -> (decode s ,"")
(*       | _ -> pre ("Error split_name_is_value:" ^ s);(s,"") *)
;;
      
(* let kv = List.map split_name_is_value pairs;; *)
(* List.iter (fun (x,y) -> pre ((henc x) ^ "," ^ (henc y))) kv;; *)

let henc s =
  let buf = Buffer.create (strlen s) in
  String.iter (fun c -> 
      match c with
      '&' -> Buffer.add_string  buf "&amp;"
      | '<' -> Buffer.add_string  buf "&lt;"
      | '>' -> Buffer.add_string  buf "&gt;"
      | '"' -> Buffer.add_string  buf "&quot;" (*'"'*)
      | '\'' -> Buffer.add_string  buf "&#39;"
  (*    | '\n' -> Buffer.add_string  buf "\r\n" *)
      | _ -> Buffer.add_char buf c
  ) s; 
  Buffer.contents buf;;      

let filesave fn s = 
  let out = open_out fn in
  output_string out s;
  close_out out;;

let fileread fn = 
     let ic = open_in fn in
     let size = in_channel_length ic in
     let s = String.create size in
     really_input ic s 0 size;
     s
  ;;

(* "filecopy"  copied from :
    http://pauillac.inria.fr/~remy/poly/system/camlunix/fich.html#toc13
   and added st_perm copying. *)
let filecopy input_name output_name =
   let buffer_size = 8192 in
   let buffer = String.create buffer_size in
     let fd_in = Unix.openfile input_name [Unix.O_RDONLY] 0 in
     let perm = (Unix.lstat input_name).Unix.st_perm in
     let fd_out = Unix.openfile output_name 
        [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] perm in
     Unix.fchmod fd_out perm;
     let rec copy_loop () =
       match Unix.read fd_in buffer 0 buffer_size with
         0 -> ()
       | r -> ignore (Unix.write fd_out buffer 0 r); copy_loop () in
     copy_loop ();
     Unix.close fd_in;
     Unix.close fd_out;;

(* let system = (fun s -> 
  pr "<PRE>";
  flush stdout;
  let r = Unix.system s in
  pr "</PRE>";
  r
  );;
*)
let close_pin chan =
 let stat = Unix.close_process_in chan in
  (match stat with
     Unix.WEXITED 0 -> ("")
     | Unix.WEXITED i ->
       ("command failed with code " ^ string_of_int i)
     | Unix.WSIGNALED i ->
       ("command killed by signal " ^ string_of_int i)
     | Unix.WSTOPPED i ->
        ("command stopped by signal " ^ string_of_int i));;

let systemf f cmd = 
  let ic = Unix.open_process_in cmd in
  (try 
    while true do
      f (input_line ic)
    done
  with _ -> () );
  close_pin ic;;

let prsystem cmd= 
  pr "<pre>";
  let r = systemf (fun s -> pre (henc s)) cmd in
  if r <> "" then pre(r);
  pr "</pre>"

let system cmd = 
  let s = String.create 2048 in
  let buf = Buffer.create 2048 in
  let ic = Unix.open_process_in cmd in
  let c = ref 1 in
  while !c <> 0 do
    c := input ic s 0 2048;
    Buffer.add_string buf (String.sub s 0 !c)
  done;
  let r = close_pin ic in
  if r <> "" then prerr_string r;
  Buffer.contents buf;;

let status_cmd = "date;hostname;uptime;ps auxww"
let server_status () = prsystem status_cmd

(*server_status ();;*)
(*system "ls -alt";;*)
 

let chop s = if s = "" then "" else substr s 0 ((strlen s) - 1);;

      
let qs = 
  match (env "REQUEST_METHOD") with
   "POST" -> 
     let cls = env "CONTENT_LENGTH" in
     let cl = if cls <> "" && (int_of_string cls) < max_post then 
           int_of_string cls else max_post in
     let rb = ref 0 and rbs = ref 1 in
     let sb = String.make cl ' ' in
     (try
       while  !rbs <> 0 && !rb < cl do
         rbs := (Unix.read Unix.stdin sb !rb (cl - !rb));
         rb := !rb + !rbs;
       done; ()
     with  _ -> () ); 
     sb
   | _ -> env "QUERY_STRING" ;;


(* pre qs;; 
let kv = 
    List.map split_name_is_value (split_pairs qs);;
       
List.iter (fun (x,y) -> pre ((henc x) ^ " = " ^ (henc y))) kv;; 
*)

module SMap = Map.Make(String)

let split_pairs s =
  if s ="" then [] else (
    let i = ref 0 and list = ref [] in
    try
      while true do
        let p = String.index_from s !i '&' in
        list := (substr s !i (p - !i)) :: !list;
        i := p +1
      done; 
      !list
    with
        Not_found ->     
        list := (substr s !i (strlen s - !i)) :: !list;
        !list
  );;


let split_add s m =
  try
    let p = String.index s '=' in
    let k = decode (substr s 0 p) in
    let v = decode (substr s (p+1) (strlen s - p - 1) ) in
(*    if SMap.mem k m then SMap.replace k (v ^ (Smap.find k m)) m
    else *)
      SMap.add k v m
  with
      Not_found -> if s <> "" then SMap.add (decode s) "" m else m
  ;;
      
let formdat = 
  (List.fold_right (fun s m -> split_add s m) (split_pairs qs)  SMap.empty);;

let form s = 
  try SMap.find s formdat
  with Not_found -> "";;



let script = env "SCRIPT_NAME";;

let docroot = 
   let dre = env "DOCUMENT_ROOT" in
   if (find cwd home) = 0 then (
(*prs "fin cwd home - 0";     *)
     let hlen = strlen home in
     let drt = substr cwd hlen ((strlen cwd) - hlen) in
     let ri = try String.index_from drt 1 '/' with _ -> 0 in
     let drx = path_join home  (if ri = 0 then drt else substr drt 0 ri ) in
   
     if (try ((Unix.lstat dre).Unix.st_ino = (Unix.lstat drx).Unix.st_ino) with _ -> false )
     then drx else dre
   ) else dre
   ;;

let wpath p =
  if (find p docroot) = 0 then slice p (strlen docroot) 0 else "/ERROR/";;

flush_all ();;