(* HTTP Basic Authentication *)
open Printf
open Tk
open Unix
open Http_headers
open Url
open Www

(* Authorizations are remembered on the base of the directory url and realm
 * They are kept during the whole MMM session, with expiration
 *)

type authSpace = {
   auth_proxy : bool;
   auth_host : string;
   auth_port : int;
   auth_dir : string;
   auth_realm : string
  }

type authEntry = {
   auth_cookie : string;
   mutable auth_lastused : int
   }

let authorizations = Hashtbl.create 37


let get space = 
  let entry = Hashtbl.find authorizations space in
    entry.auth_lastused <- Unix.time();
    entry.auth_cookie

(* Lifetime, in minutes. Default is one hour *)
let lifetime = ref 60


let rec lookup space = 
  (* Printf.eprintf "%s\n" space.auth_dir; flush Pervasives.stderr; *)
  try
    Hashtbl.find authorizations space
  with
    Not_found ->
     if space.auth_dir = "/" or space.auth_dir = "." 
     then raise Not_found 
     else
      let newdir = Filename.dirname space.auth_dir in
      	lookup {auth_proxy = space.auth_proxy;
      	        auth_host = space.auth_host;
	        auth_port = space.auth_port;
		auth_dir = newdir;
		auth_realm = space.auth_realm}


let ask_cookie forwhere =
  try
    let u,p = Frx_req.open_passwd forwhere in
      Base64.encode (u^":"^p)
  with
    Failure "cancelled" -> failwith "cancelled"
  | _ -> Error.default#f (I18n.sprintf "Error in base 64 encoding");
        failwith "cancelled"

let replace kind cookie l =
  let rec repl acc = function
    [] -> (kind,cookie)::acc
  | (k,_)::l when k = kind -> repl (acc) l
  | p::l -> repl (p::acc) l in
  repl [] l
  

let add space cookie =
  Log.debug "adding cookie";
  Hashtbl.add authorizations 
      space 
      {auth_cookie = cookie; auth_lastused = Unix.time()}

(* Kind is either: realm or proxy *)
let check wwwr challenge authspace =
  let kind = if authspace.auth_proxy then "proxy" else "realm" in
  match challenge.challenge_scheme with
    AuthExtend _ -> (* we don't know how to do this *) 
       None
  | AuthBasic -> (* params are gleefully ignored *)
     try (* if the passwd request is cancelled *)
      let cookie, isnew =
        if List.mem_assoc kind wwwr.www_auth then begin
           (* we already tried, so the authorization is bad ! *)
           Hashtbl.remove authorizations authspace; (* in case *)
           ask_cookie (I18n.sprintf "Authorization for %s \"%s\" on \
                                             %s:%d/%s" 
                            kind challenge.challenge_realm 
                            authspace.auth_host authspace.auth_port 
                            authspace.auth_dir),
           true
           end
       else (* ah, it is our first try,  get the authorization *)
         if authspace.auth_proxy then 
            ask_cookie (I18n.sprintf "Authorization for %s \"%s\" on \
                                             %s:%d/%s" 
                            kind challenge.challenge_realm
                            authspace.auth_host authspace.auth_port 
                            authspace.auth_dir),
            true
         else
           try 
             let entry = lookup authspace in
              entry.auth_lastused <- Unix.time();
              entry.auth_cookie, false
           with Not_found ->
            ask_cookie (I18n.sprintf "Authorization for %s \"%s\" on \
                                             %s:%d/%s" 
                            kind challenge.challenge_realm
                            authspace.auth_host authspace.auth_port 
                            authspace.auth_dir),
            true
      in
      wwwr.www_auth <- replace kind cookie wwwr.www_auth;
      Some (cookie, isnew, authspace)
     with
      Failure "cancelled" -> None


(* Authorisation control *)
(* needs to be refined *)
let edit () =
  let top =
    Toplevel.create Widget.default_toplevel 
      	  [Class "MMMAuthorizations"] in
    Wm.title_set top (I18n.sprintf "Authorizations");
    let f,lb = Frx_listbox.new_scrollable_listbox top [TextWidth 40] in
      Hashtbl.iter (fun space cookie ->
      	Listbox.insert lb End
	  [Printf.sprintf "(%s) http://%s:%d/%s" 
	     space.auth_realm space.auth_host space.auth_port space.auth_dir])
      	authorizations;
    let buts = Frame.create top [] in
    let clearb = Button.create_named buts "clear"
       [Text (I18n.sprintf "Clear"); 
      	Command (fun _ -> Hashtbl.clear authorizations; destroy top)]
    and dismissb = Button.create_named buts "dismiss"
       [Text (I18n.sprintf "Dismiss"); Command (fun _ -> destroy top)] in
      pack [clearb] [Side Side_Left; Expand true];
      pack [dismissb] [Side Side_Right; Expand true];
      pack [buts][Side Side_Bottom; Fill Fill_X];
      pack [f][Side Side_Top; Fill Fill_Both; Expand true]

(* Saving authorizations to file *)
let auth_file = ref ""

let save () =
 if !auth_file <> "" then
  let auth_file = Msys.tilde_subst !auth_file in
  try
    let o = openfile auth_file [O_WRONLY; O_CREAT] 0o600 in
    let oc = out_channel_of_descr o in
      output_value oc authorizations;
      flush oc;
      close o
  with
    Unix_error(e,_,_) ->
      Error.default#f (I18n.sprintf "Error in authorisation save\n%s" 
      	       	  (Unix.error_message e))
  | Sys_error s ->
      Error.default#f (I18n.sprintf "Error in authorisation save\n%s" s)

 else 
   Error.default#f (I18n.sprintf "No authorisation file defined")

let load () =
  if !auth_file <> "" then
    let auth_file = Msys.tilde_subst !auth_file in
    try
      let ic = open_in auth_file in
      let table = input_value ic
      and time = Unix.time() in
      	Hashtbl.iter
          (fun spacerealm entry ->
	       entry.auth_lastused <- time;
	       Hashtbl.add authorizations spacerealm entry)
          table;
	close_in ic
    with
      Sys_error s ->
      	Error.default#f (I18n.sprintf "Error in authorisation load\n%s" s)
 else 
   Error.default#f (I18n.sprintf "No authorisation file defined")


let init () =
  let check () =
    let remove = ref []
    and lifetime = 60 * !lifetime
    and time = Unix.time () in
    Hashtbl.iter 
      (fun space entry ->
      	let expiration_time = entry.auth_lastused + lifetime in
	if time > expiration_time then remove := space :: !remove)
      authorizations;
    List.iter (Hashtbl.remove authorizations) !remove
  in
  let rec tim () =
    Timer.add (!lifetime * 30000) (fun () -> check(); tim ()); ()
  in
  tim ()


       
