open Printf
open Unix
open Tk
open Hyper
open Www
open Url
open Uri
open Document
open Http_headers
open Viewers

(* Navigation *)


type t = {
  nav_id : int;  (* key for the gfx cache *)
  nav_viewer_frame : Widget.widget;
  nav_error : Error.t;			(* popping error dialogs *)
  nav_add_hist : document_id -> string option -> unit;
  nav_show_current: display_info -> string option -> unit;
  nav_log : string -> unit;
  nav_new : Hyper.link -> unit;
  nav_add_active : Url.t -> (unit -> unit) -> unit;
  nav_rem_active : Url.t -> unit
 }


(* Copying a link to the X Selection *)
let copy_link nav h =
  try Frx_selection.set (Hyper.string_of h)
  with Invalid_link msg ->
    nav.nav_error#f (I18n.sprintf "Invalid link")

(* Save continuation
 * Note: the document may have also been cached
 *)
let saver wwwr dh = 
  match dh.document_status with
    200 -> Save.transfer wwwr dh
  | n ->
    if wwwr.www_error#choose 
      	 (I18n.sprintf "Request for %s\nreturned %d %s.\nDo you wish to save ?"
	     (Url.string_of wwwr.www_url) n (status_msg dh.document_headers))
    then Save.transfer wwwr dh
    else dclose true dh

exception Duplicate of Url.t

(* Some requests should not be looked for in the cache *)
let dont_check_cache wwwr =
  (match wwwr.www_link.h_method with
      POST _ -> true
    | _ -> false)

(* Simple implementation of HEAD *)

let display_headers dh =
  let mytop = Toplevel.create Widget.default_toplevel [] in
    Wm.title_set mytop 
       (sprintf "HEAD %s" (Url.string_of dh.document_id.document_url));
    let hs =
      List.map (function h -> Label.create mytop [Text h; Anchor W])
               dh.document_headers in
     pack (List.rev hs) [Fill Fill_X];
  let b = Button.create mytop
             [Command (fun _ -> destroy mytop); Text "Dismiss"] in
     pack [b] [Anchor Center]
 
(* Doesn't check cache ! *)
let rec head nav hlink = 
  let headlink = {
    h_uri = hlink.h_uri;
    h_context = hlink.h_context;
    h_method = HEAD
    } in
  try
    let wr = Plink.make headlink in
      wr.www_error <- nav.nav_error;
      match Retrieve.f wr (head nav)
        {document_finish = (fun _ -> nav.nav_rem_active wr.www_url);
	 document_process = 
	   (fun dh -> 
	      dclose true dh;
	      display_headers dh;
	      nav.nav_rem_active wr.www_url)}
      with
	   Retrieve.Started abort -> nav.nav_add_active wr.www_url abort
	 | Retrieve.InUse -> raise (Duplicate wr.www_url)

  with
    Invalid_link msg ->
      nav.nav_error#f (I18n.sprintf "Invalid link")
  | Invalid_request (wr, msg) ->
      nav.nav_error#f (I18n.sprintf "Invalid request %s\n%s"
		                    (Url.string_of wr.www_url) msg)
  | Duplicate url ->
       nav.nav_error#f (I18n.sprintf "The document %s\nis currently being retrieved for some other purpose.\nMMM cannot process your request until retrieval is completed." (Url.string_of url))

(* Important note: we assume two requests on the same url are identical
   (when we control emission of requests). This is not the case for 
   POST requests, because we would need to check the POST data.
   This means that you can't post twice *simultaneously* on the same
   url. Proper fix: change the equality semantics of active cnx *)


let user_navigation = ref []
let add_user_navigation (s : string) (f : Hyper.func) =
  user_navigation := (s,f) :: !user_navigation

let rec make_ctx nav did =
  {viewer_base = did;
   viewer_log = nav.nav_log;
   viewer_hyper = 
       ["goto", {hyper_visible = true; hyper_func = follow_link nav;
		 hyper_title = I18n.sprintf "Open this Link"};
	"save", {hyper_visible = true; hyper_func = save_link nav;
		 hyper_title = I18n.sprintf "Save this Link"};
	"gotonew",{hyper_visible = true; hyper_func = nav.nav_new;
		   hyper_title = I18n.sprintf "New window with this Link"};
	"head",{hyper_visible = true; hyper_func = head nav;
		hyper_title = I18n.sprintf "Headers of document"};
	"copy",{hyper_visible = true; hyper_func = copy_link nav;
		hyper_title = I18n.sprintf "Copy this Link to clipboard"}
       ] @ !user_navigation;
   viewer_params = []
  }


and dispatch_viewer addhist nav dh =
  let ctx = make_ctx nav dh.document_id in
    match Viewers.view nav.nav_viewer_frame ctx dh with
       None -> () (* external viewer *)
     | Some di ->
	Gcache.add nav.nav_id dh.document_id di;
	if addhist then nav.nav_add_hist dh.document_id dh.document_fragment;
	nav.nav_show_current di dh.document_fragment;

and view_request addhist nav wr =
  try
    match wr.www_url.protocol with
      MAILTO -> Mailto.f wr
	(* mailto: is really a pain. It doesn't fit the retrieval semantics
	   of WWW requests. *)
    | _ ->
      if dont_check_cache wr then
       (* since we don't know yet which viewer will be run, we can't do
          anything about the history *)
	 match Retrieve.f wr
		(* retry *) (follow_link nav)
		{document_finish =
		    (fun _ -> nav.nav_rem_active wr.www_url);
		 document_process =
		    (fun dh ->
			dispatch_viewer addhist nav dh;
                        nav.nav_rem_active wr.www_url)}
         with
	      Retrieve.Started abort -> nav.nav_add_active wr.www_url abort
	    | Retrieve.InUse -> raise (Duplicate wr.www_url)
      else 
       (* If the the document can be cached, then it is with stamp no_stamp *)
       let did = {document_url = wr.www_url; document_stamp = no_stamp} in
       (* Do we have a 'visible version' of the document ? *)
       try
	 let di = Gcache.find nav.nav_id did in
	  if addhist then nav.nav_add_hist did wr.www_fragment;
	  (* make it our current displayed document, since it is available *)
	  nav.nav_show_current di wr.www_fragment
       with
         Not_found ->
           try
	     let doc = Cache.find did in
	     try (* display it from source *)
	       dispatch_viewer addhist nav (Cache.make_handle wr doc)
	     with
	       Sys_error s ->
		wr.www_error#f (I18n.sprintf
		    "Error occurred during save of temporary buffer (%s)" s)
	     | Unix_error (_,_,_) ->
		wr.www_error#f (I18n.sprintf 
		    "Error occurred when opening temporary file")
           with 
	     Not_found -> (* we don't have the document *)
	       match Retrieve.f wr 
                         (* retry *) (follow_link nav)
		{document_finish =
		    (fun _ -> nav.nav_rem_active wr.www_url);
		 document_process =
		    (fun dh ->
			dispatch_viewer addhist nav dh;
                        nav.nav_rem_active wr.www_url)}
               with
	      Retrieve.Started abort -> nav.nav_add_active wr.www_url abort
	    | Retrieve.InUse -> raise (Duplicate wr.www_url)
  with
    Duplicate url ->
       wr.www_error#f (I18n.sprintf "The document %s\nis currently being retrieved for some other purpose.\nMMM cannot process your request until retrieval is completed." (Url.string_of url))

and follow_link nav h =
  try
   (* Convert the link into a request *)
    let wr = Plink.make h in
      wr.www_error <- nav.nav_error;
      view_request true nav wr
  with
    Invalid_link msg ->
      nav.nav_error#f (I18n.sprintf "Invalid link")
  | Invalid_request (wr, msg) ->
      nav.nav_error#f (I18n.sprintf "Invalid request %s\n%s"
		                    (Url.string_of wr.www_url) msg)

and save_request nav wr =
  try
    match wr.www_url.protocol with
      MAILTO ->
	raise (Invalid_request (wr, I18n.sprintf "Can't save a mailto: url"))
    | _ ->
      if dont_check_cache wr then
       (* since we don't know yet which viewer will be run, we can't do
          anything about the history *)
	 match Retrieve.f wr
		(* retry *) (save_link nav)
		{document_finish =
		    (fun _ -> nav.nav_rem_active wr.www_url);
		 document_process = 
		    (fun dh ->
			saver wr dh;
                        nav.nav_rem_active wr.www_url)}
         with
	      Retrieve.Started abort ->
	         nav.nav_add_active wr.www_url abort
	    | Retrieve.InUse -> raise (Duplicate wr.www_url)
      else 
       (* If the the document can be cached, then it is with stamp no_stamp *)
       let did = {document_url = wr.www_url; document_stamp = no_stamp} in
	try
	  let doc = Cache.find did in
	  try (* display it from source *)
	    saver wr (Cache.make_handle wr doc)
	  with
	    Sys_error s ->
	     wr.www_error#f (I18n.sprintf
		 "Error occurred during save of temporary buffer (%s)" s)
	  | Unix_error (_,_,_) ->
	     wr.www_error#f (I18n.sprintf 
		 "Error occurred when opening temporary file")
	with 
	  Not_found -> (* we don't have the document *)
	    match Retrieve.f wr 
		      (* retry *) (save_link nav)
		{document_finish =
		    (fun _ -> nav.nav_rem_active wr.www_url);
		 document_process = 
		    (fun dh ->
			saver wr dh;
                        nav.nav_rem_active wr.www_url)}
            with
	   Retrieve.Started abort ->
	         nav.nav_add_active wr.www_url abort
	 | Retrieve.InUse -> raise (Duplicate wr.www_url)
  with
    Duplicate url ->
       wr.www_error#f (I18n.sprintf "The document %s\nis currently being retrieved for some other purpose.\nMMM cannot process your request until retrieval is completed." (Url.string_of url))

and save_link nav h =
  try
   (* Convert the link into a request *)
    let wr = Plink.make h in
      wr.www_error <- nav.nav_error;
      save_request nav wr
  with
    Invalid_link msg ->
      nav.nav_error#f (I18n.sprintf "Invalid link")
  | Invalid_request (wr, msg) ->
      nav.nav_error#f (I18n.sprintf "Invalid request %s\n%s"
		                    (Url.string_of wr.www_url) msg)

(*
 * Other navigation functions
 *)

(* Used outside an hyperlink *)
let absolutegoto nav uri =
   follow_link  nav { h_uri = uri; h_context = None; h_method = GET}

(* Used by navigators for back/forward/reload *)
let historygoto nav did frag nocache =
  Log.debug "historygoto";
  if did.document_stamp = no_stamp then
    (* we can safely consider this as normal navigation *)
    let uri = match frag with
	       None -> Url.string_of did.document_url
	     | Some f ->
	        sprintf "%s#%s" (Url.string_of did.document_url) f 
    in
    try 
     let wwwr = Www.make { h_uri = uri;
			   h_context = None;
			   h_method = GET} in
       if nocache then
	   wwwr.www_headers <- "Pragma: no-cache" :: wwwr.www_headers;
       view_request false nav wwwr;
       true
     with Invalid_link (msg) ->
	  nav.nav_error#f (I18n.sprintf "Invalid link");
	  false
	| Duplicate url ->
	   Error.default#f (I18n.sprintf "The document %s\nis currently being retrieved for some other purpose.\nMMM cannot process your request until retrieval is completed." (Url.string_of url));
 	   false
  else begin
    (* the url is a "non-unique" document, that is, its url is not
       enough to retrieve the document. We should not attempt to
       reload or retrieve if flushed from the cache
    *)
    try
      let di = Gcache.find nav.nav_id did in
	 nav.nav_show_current di frag;
	 true
    with
      Not_found ->
        nav.nav_error#f 
	 (I18n.sprintf "Document cannot be reloaded from its url\n(probably a POST request)");
        false
   end



(*
 * Conditional GET
 *)
(* this is called only if code is 200 *)
let updater nav did wr dh =
  (* kill the previous displayed window *)
  Gcache.displace nav.nav_id did;
  (* call the viewer (because you can only update visible documents !) *)
  wr.www_logging <- nav.nav_log;
  dispatch_viewer false nav dh

(* Assumes that the document is actually here in the cache *)
let rec update nav did nocache =
  if did.document_stamp = no_stamp then
    (* getting the source forces waiting of pending cnx if any *)
    try
      let doc = Cache.find did in
       try
        (* find the date of previous download, (or last-modified ?) *)
      	let date_received = get_header "date" doc.document_info
	(* make a request for the document *)
        and wwwr = Www.make {  h_uri = Url.string_of did.document_url;
			       h_context = None;
			       h_method = GET}
        (* Do we really want this ? *)
        and retry link =
	   let url = Lexurl.make (Hyper.resolve link).uri_url in
               update nav {document_url = url;
      	       	       	   document_stamp = no_stamp}
                          nocache in
	(* setup additional headers *)
	 wwwr.www_headers <-
	   ("If-Modified-Since: "^date_received) :: wwwr.www_headers;
	 if nocache then
	   wwwr.www_headers <- "Pragma: no-cache" :: wwwr.www_headers;
	(* the continuations *)
         match Retrieve.f wwwr retry 
      	       	     {document_finish = (fun _ -> ());
		      document_process = updater nav did wwwr} with
	       Retrieve.Started _ -> ()
	     | Retrieve.InUse ->
	         nav.nav_error#f (I18n.sprintf "The document %s\nis currently being retrieved for some other purpose.\nMMM cannot process your request until retrieval is completed." (Url.string_of did.document_url))
       with
       	 Not_found ->
	   nav.nav_error#f ("Document has no Date: header.")
    with
      Not_found ->
        nav.nav_error#f (I18n.sprintf "Document has been flushed from cache")
  | Invalid_link msg ->
      nav.nav_error#f (I18n.sprintf "Invalid link")
  | Invalid_request (wr, msg) ->
      nav.nav_error#f (I18n.sprintf "Invalid request %s\n%s"
		                    (Url.string_of wr.www_url) msg)
  else
    nav.nav_error#f 
       (I18n.sprintf "Can't update document\n(probably a POST request)")
