(* Process *)

module Make(Dpkg : Dpkg.DB) =
  struct
    module Ara = Ara.Make(Dpkg);;
    module UEF = Url_encoded_form;;
    open Html;;
    open Debug;;
    open Dpkg;;
    open Ara;;
    module C = Cache.Make(String)(struct type t = Dpkg.IS.u let compare = compare end);;

    let info = Log.info;;
    let cache = C.create (Some 1024);;

    let identity x = x;;
    exception Value_not_unique of string;;
    let get_unique_value
      ~(converter : string -> 'a)
      ?(default : 'a option)
      ky vr =
      try
        let s = UEF.SM.find ky vr in
        if UEF.SS.cardinal s = 1 then
          converter (UEF.SS.choose s)
        else
          raise (Value_not_unique ky)
      with
      | Not_found ->
          match default with
          | None -> raise Not_found
          | Some d -> d
    ;;
    let plural x = if x = 1 then "" else "s";;

    exception No_variables_allowed of string;;
    exception Variable_not_found of string;;

    let compression_buffer = Dpkg.IS.create_compression_buffer ();;

    (*** eval *)
    let eval db q w =
      let x =
        try
          Dpkg.IS.decompress compression_buffer (C.find cache w)
        with
        | Not_found ->
            let x =
              Ara.eval_statement db
                ~get:(fun id -> raise (Variable_not_found id))
                ~set:(fun id -> raise (No_variables_allowed id)) (* XXX *)
                q
            in
            C.add cache w (Dpkg.IS.compress compression_buffer x);
            x
      in
      Ara.sorted_list_of_query db x
      (*Ara.compute_query db
        ~get:(fun id -> raise (Variable_not_found id))
        ~set:(fun id -> raise (No_variables_allowed id)) (* XXX *)
        q*)
    ;;
    (* ***)

    let default_field_order = ["Package"],["Description"];;

    (*** compute_fields *)
    let compute_fields ?(field_order=default_field_order) db =
      let (pre_fields, post_fields) = field_order in
      let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in
      let pre_fields = convert pre_fields
      and post_fields = convert post_fields
      in
      let fields = get_fields db in
      let rec other i r =
        if i = Array.length fields then
          r
        else
            other (i + 1)
              (if List.mem i pre_fields or List.mem i post_fields then
                r
              else
                i::r)
      in
      let other_fields = other 0 [] in
      (pre_fields, other_fields, post_fields)
    ;;
    (* ***)

    let ara_head title =
      { default_head with
        title = title;
        author = "Ara HTTP Daemon by Oguz Berke Durak";
        charset = ISO_8859_1;
        style_sheet = Some("/stylesheet") }
    ;;

    let builtin_style_sheet = "\
      body { font-family: helvetica, sans-serif; }\n\
      div.query { font-family: courier, sans-serif; \n\
                  background-color: #ffff00;\n\
                  color: #000000; }\n\
      div.query span.highlight { background-color: #ff0000; }\n\
      ";;

    let style_sheet () =
      try
        Http.File(Config.current#get_string "ara_httpd.interface.stylesheet")
      with
      | Not_found -> Http.String(builtin_style_sheet)
    ;;

    let process db = function
    | Http.Get x,hdrs ->
      let x = Util.delete_first_chars 1 x in (* fishy *)
      let (path,args) = Util.split_once_at ((=) '?') x in
      info (sf "Path=%S args=%S" path args);
      let vars = UEF.parse_form_from_string args in
      match path with
      | "stylesheet" -> Http.Okay(Http.Text_Css, style_sheet ())
      | "show" ->
        let i = get_unique_value ~converter:int_of_string "package" vars in
        let (pre_fields, other_fields, post_fields) = compute_fields db in
        let p = Dpkg.get_package db i in
        let title =
          sf "Package information for %s (%s)" (Dpkg.name_of db i) (Dpkg.version_of db i);
        in
        let pf = new Dpkg.paragraph_folder in
        Http.Okay(Http.Text_Html, Http.Html
          { head = ara_head title;
            body =
              Seq[
                H(1,T(title));
                P(
                Table(
                  [C_color(Rgb.red, C_header(C_contents(T "Field")));
                    C_color(Rgb.green, C_header(C_contents(T "Contents")))]::
                  (let dn = Dpkg.get_display_names db in
                   List.fold_left (fun r j ->
                     let x = Dpkg.get_field db i j in
                     if x = "" then
                       r
                     else
                       begin
                         pf#reset;
                         pf#add_string x;
                         let y = pf#get in
                         [C_color(Rgb.red,   C_contents(T dn.(j)));
                          C_color(Rgb.green, C_contents(T y))]::r
                       end)
                     []
                     (List.rev (pre_fields@other_fields@post_fields)))))] })
      | "search" ->
        let result,query = 
          try
            let w = get_unique_value ~converter:identity "query" vars in
            let m = String.length w in
            try
              let q = statement_of_string w in
              let xl = eval db q w in
              let xlc = Ara.filter_old_versions db xl in
              let lxl = List.length xl
              and lxlc = List.length xlc
              in
              let per_page = 15 in
              let start = get_unique_value ~converter:int_of_string ~default:0 "start" vars
              and stop = get_unique_value ~converter:int_of_string
                         ~default:(min lxl (per_page - 1)) "stop" vars
              in
              let start = max 0 start in
              let stop = min (max start (min (start + per_page - 1) stop)) (lxl - 1) in
              let xl = Util.list_sub_rev xl start stop in
              let navig = 
               P(Seq[
                 Anchor("search?"^
                   (UEF.encode_form_from_list
                     ["query", [w];
                      "start", [sf "%d" (start-per_page)];
                      "stop",  [sf "%d" (start-1)]]),
                   T "<< Prev <<");
                 Anchor("search?"^
                   (UEF.encode_form_from_list
                     ["query", [w];
                      "start", [sf "%d" (start+per_page)];
                      "stop",  [sf "%d" (start+2 * per_page-1)]]),
                   T ">> Next >>")])
              in
              Seq[
                P(T(sf "Total %d package%s (and %d version%s).  Showing %d to %d."
                       lxlc (plural lxlc) lxl (plural lxl)
                       start stop));
                navig;
                P(
                Table(
                  [C_color(Rgb.red, C_header(C_contents(T "Package")));
                    C_color(Rgb.green, C_header(C_contents(T "Version")));
                    C_color(Rgb.yellow, C_header(C_contents(T "Description")))]::
                  (let df = Dpkg.field_of_string db "description" in
                   List.fold_left (fun r i ->
                     let p = Dpkg.name_of db i in
                     let v = Dpkg.version_of db i in
                     let des = Dpkg.get_field db i df in
                     [C_color(Rgb.red, C_contents(
                       Anchor("show?"^(UEF.encode_form_from_list ["package",[sf "%d" i]]),
                              T p)));
                      C_color(Rgb.green,  C_contents(T v));
                      C_color(Rgb.yellow, C_contents(T (Util.first_line des)))]::r) [] xl)));
                navig],w
            with
            | Parse_error(i,j,x) ->
              P(
                if i = j then
                  if i >= m - 1 then
                    Seq[T "There is a parse error at the end of your query.";
                        Div("query",[
                          P(Seq[T w;
                              Span("highlight", T "?")])])]
                  else
                    Seq[T (sf "There is a parse error at character %d in your query: %s."
                              (i + 1) x);
                      Div("query",[
                        P(Seq[
                          if i > 0 then T(String.sub w 0 (min (m - 1) i)) else Nop;
                          if i < m then Span("highlight", T(String.sub w i 1)) else Nop;
                          if i + 1 < m then T(String.sub w (j + 1) (m - j - 1)) else Nop])])]
                else
                  begin
                    Seq[T (sf "There is a parse error between characters %d and %d in your query: %s."
                              (i + 1) (j + 1) x);
                        Div("query",
                          [P(Seq[
                            if i > 0 then T(String.sub w 0 (min (m - 1) i)) else Nop;
                            if i < m then
                              Span("highlight",
                                   T(String.sub w i ((min (m - 1) j) - i + 1)))
                            else
                              Nop;
                            if j + 1 < m then
                              T(String.sub w (j + 1) (m - j - 1))
                            else
                              Nop])])]
                  end),w
            | x -> P(T(sf "Error: %s." (Printexc.to_string x))),w
          with
          | Not_found -> P(T "Please type your query."),"tetris & section=games"
        in
        let doc =
          {
            head = ara_head "Search Debian packages using Ara";
            body =
              Seq[
                H(1,T("Search Debian packages using ara"));
                (*P(T("Hello.  You just suck.  Motherfucker !"));
                P(Seq[T("You just said: ");
                  Table(
                    [[C_color(Rgb.red, C_header(C_contents(T "Key")));
                      C_color(Rgb.green, C_header(C_contents(T "Value")))]]@
                    (Url_encoded_form.SM.fold (fun k v r ->
                      Url_encoded_form.SS.fold
                        (fun v r -> [C_color(Rgb.red, C_contents(T k));
                                     C_color(Rgb.green, C_contents(T v))]::r) v r)
                        vars []));
                Pre(x)]); *)
                result;
                Form(GET, "search",
                  P(Seq[
                     I_button("action", "Search");
                     I_reset("Clear");
                     BR;
                     I_text_area("query",4,80,query)]));
                P(Seq[T "For help on the syntax, please read the ";
                      Anchor("http://ara.alioth.debian.org/ara.html", T "manual page");
                      T ".";
                      BR;
                      T "You can also get the stand-alone CLI or GTK2 versions ";
                      Anchor("http://ara.alioth.debian.org/", T "ara or xara");
                      T "."]);
                Div("statistics",[
                  P(T(
                      let (accesses,size,ratio) = C.statistics cache in
                      sf "Total %d accesses, cache size %d, hit ratio %.3f." accesses size ratio))]);
                ]
              }
        in
        Http.Okay(Http.Text_Html, Http.Html doc)
      | "compact" ->
          let (rsz1,vsz1) = Util.proc_get_rsz_vsz () in
          Gc.compact ();
          let (rsz2,vsz2) = Util.proc_get_rsz_vsz () in
          Http.Okay(Http.Text_Html, Http.Html
            {
              head = ara_head "Mother fucking piece of shit";
              body =
                Seq[
                  H(1,T("Memory compaction"));
                  P(T(sf "Compaction saved %d resident and %d virtual pages.\n
                          Currently, %d resident and %d virtual pages are used."
                         (rsz1 - rsz2)
                         (vsz1 - vsz2)
                         rsz2 vsz2))] })
      | "shit" ->
        let doc =
          {
            head = ara_head "Mother fucking piece of shit";
            body =
              Seq[
                H(1,T("Are you stupid ?"));
                P(T("Hello.  You just suck.  Motherfucker !"))] }
        in
        Http.Okay(Http.Text_Html, Http.Html doc)
      | x -> Http.Error(Http.Document_not_found,x)
    ;;
  end
;;
