implemented pagination

diff --git a/helm/searchEngine/html/moogle.html b/helm/searchEngine/html/moogle.html
index 862e425b6f00d4ec3d1c0ebfbd171058f793cf1e..3c76f8b852ccf66be7acd05ed9a3fe28aaf403b5 100644 (file)
--- a/helm/searchEngine/html/moogle.html
+++ b/helm/searchEngine/html/moogle.html
@@ -71,6 +71,11 @@
 <font size="-1">
 @RESULTS@
 </font>
+<font size="-1">
+  <div class='bottombar'>
+    Page: @PREV_LINK@ <b>@PAGE@/@PAGES@</b> @NEXT_LINK@
+  </div>
+</font>
 </body>
 </html>
 

diff --git a/helm/searchEngine/mooglePp.ml b/helm/searchEngine/mooglePp.ml
index 807fcc219180dc68989c88a6082b4d9c486a74c0..998274e08525e60bd7d38a297d210ea1ae419d87 100644 (file)
--- a/helm/searchEngine/mooglePp.ml
+++ b/helm/searchEngine/mooglePp.ml
@@ -12,34 +12,47 @@ let pp_request (req: Http_types.request) =
 let pp_error title msg =
   sprintf "<hr size='1' /><div><b class='error'>%s:</b> %s</div>" title msg
 
+let paginate ~size ~page l =
+  let min = 1 + (page-1) * size in
+  let max = page * size in
+  let rec aux i l =
+    match (i, l) with
+    | _, [] -> []
+    | i, hd :: tl when i < min -> aux (i+1) tl
+    | i, hd :: tl when i >= min && i <= max -> hd :: aux (i+1) tl
+    | i, hd :: tl -> []
+  in
+  assert (size > 0 && page > 0);
+  aux 1 l
+
   (** pretty print a list of URIs to an HELM theory file *)
-let theory_of_result req result =
-  let max_results_no =
-    Helm_registry.get_opt_default Helm_registry.get_int 10
-      "search_engine.max_results_no"
+let theory_of_result (req: Http_types.request) page result =
+  let results_per_page =
+    Helm_registry.get_int "search_engine.results_per_page"
+  in
+  let results_no = List.length result in
+  let result = paginate ~size:results_per_page ~page result in
+  let query_kind = pp_request req in
+  let template query_kind summary results =
+    sprintf
+      "<div class='resultsbar'>
+        <table width='100%%'>
+         <tr>
+          <td class='left'><b class='query_kind'>%s</b></td>
+          <td class='right'>%s</td>
+         </tr>
+        </table>
+       </div>
+       <br />
+       <div>
+       %s
+       </div>"
+       query_kind summary results
   in
- let results_no = List.length result in
- let query_kind = pp_request req in
- let template query_kind summary results =
-   sprintf
-    "<div class='resultsbar'>
-      <table width='100%%'>
-       <tr>
-        <td class='left'><b class='query_kind'>%s</b></td>
-        <td class='right'>%s</td>
-       </tr>
-      </table>
-     </div>
-     <br />
-     <div>
-     %s
-     </div>"
-     query_kind summary results
- in
   if results_no > 0 then
-   let mode = if results_no > max_results_no then "linkonly" else "typeonly" in
+   let mode = "typeonly" in
    let results =
-    let idx = ref (results_no + 1) in
+    let idx = ref ((page - 1) * results_per_page + List.length result + 1) in
      List.fold_right
       (fun uri i ->
         decr idx ;

diff --git a/helm/searchEngine/mooglePp.mli b/helm/searchEngine/mooglePp.mli
index 1cea1074fc806e60188297638cb4bb9fece82bb4..18a169d0b19cfead7992fec94d2e790596cd49ad 100644 (file)
--- a/helm/searchEngine/mooglePp.mli
+++ b/helm/searchEngine/mooglePp.mli
@@ -1,3 +1,3 @@
 val pp_error : string -> string -> string
-val theory_of_result : Http_types.request -> string list -> string
+val theory_of_result : Http_types.request -> int -> string list -> string
 val html_of_interpretations: (string * string) list list -> string

diff --git a/helm/searchEngine/searchEngine.conf.xml.sample b/helm/searchEngine/searchEngine.conf.xml.sample
index 728b7c632a2ebc925f9bc9daeb22618e6c815a84..99b87d2591a63e1809b972ff805045c2daa9dd3f 100644 (file)
--- a/helm/searchEngine/searchEngine.conf.xml.sample
+++ b/helm/searchEngine/searchEngine.conf.xml.sample
@@ -12,5 +12,6 @@
   <section name="search_engine">
     <key name="html_dir">html</key>
     <key name="port">58085</key>
+    <key name="results_per_page">10</key>
   </section>
 </helm_registry>

diff --git a/helm/searchEngine/searchEngine.ml b/helm/searchEngine/searchEngine.ml
index 758d57e0a12199b98e59b98e0335c9404d0820b4..8bcd141b0fdfe218c15cfc2a90d454cc49395d39 100644 (file)
--- a/helm/searchEngine/searchEngine.ml
+++ b/helm/searchEngine/searchEngine.ml
@@ -38,24 +38,19 @@ exception Invalid_action of string  (* invalid action for "/search" method *)
 let daemon_name = "Moogle"
 let configuration_file = "/projects/helm/etc/moogle.conf.xml" 
 
-let expression_tag_RE = Pcre.regexp "@EXPRESSION@"
-let action_tag_RE = Pcre.regexp "@ACTION@"
-let advanced_tag_RE = Pcre.regexp "@ADVANCED@"
-let advanced_checked_RE = Pcre.regexp "@ADVANCED_CHECKED@"
-let simple_checked_RE = Pcre.regexp "@SIMPLE_CHECKED@"
-let title_tag_RE = Pcre.regexp "@TITLE@"
-let no_choices_tag_RE = Pcre.regexp "@NO_CHOICES@"
-let current_choices_tag_RE = Pcre.regexp "@CURRENT_CHOICES@"
-let choices_tag_RE = Pcre.regexp "@CHOICES@"
-let msg_tag_RE = Pcre.regexp "@MSG@"
-let id_to_uris_RE = Pcre.regexp "@ID_TO_URIS@"
-let id_RE = Pcre.regexp "@ID@"
-let iden_tag_RE = Pcre.regexp "@IDEN@"
-let interpretations_RE = Pcre.regexp "@INTERPRETATIONS@"
-let interpretations_labels_RE = Pcre.regexp "@INTERPRETATIONS_LABELS@"
-let results_RE = Pcre.regexp "@RESULTS@"
-let new_aliases_RE = Pcre.regexp "@NEW_ALIASES@"
-let search_engine_url_RE = Pcre.regexp "@SEARCH_ENGINE_URL@"
+let placeholders = [
+  "EXPRESSION"; "ACTION"; "ADVANCED"; "ADVANCED_CHECKED"; "SIMPLE_CHECKED";
+  "TITLE"; "NO_CHOICES"; "CURRENT_CHOICES"; "CHOICES"; "MSG"; "ID_TO_URIS";
+  "ID"; "IDEN"; "INTERPRETATIONS"; "INTERPRETATIONS_LABELS"; "RESULTS";
+  "NEW_ALIASES"; "SEARCH_ENGINE_URL"; "PREV_LINK"; "PAGE"; "PAGES"; "NEXT_LINK"
+]
+
+let tag =
+  let regexps = Hashtbl.create 25 in
+  List.iter
+    (fun tag -> Hashtbl.add regexps tag (Pcre.regexp (sprintf "@%s@" tag)))
+    placeholders;
+  Hashtbl.find regexps
 
   (* First of all we load the configuration *)
 let _ = Helm_registry.load_from configuration_file
@@ -70,6 +65,7 @@ let my_own_url =
  let hostname = input_line ic in
  ignore (Unix.close_process_in ic);
  sprintf "http://%s:%d" hostname port
+let _ = Helm_registry.set "search_engine.my_own_url" my_own_url
 
 let bad_request body outchan =
   Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) ~body
@@ -112,30 +108,67 @@ let add_param_substs params =
       (fun ((key,_) as p) -> Pcre.pmatch ~pat:"^param\\." key)
       params)
 
+let page_RE = Pcre.regexp "&param\\.page=\\d+"
+
 let send_results results
   ?(id_to_uris = CicTextualParser2.EnvironmentP3.of_string "") 
    (req: Http_types.request) outchan
   =
+  let page_link anchor page =
+    try
+      let this = req#param "this" in
+      let target =
+        if Pcre.pmatch ~rex:page_RE this then
+          Pcre.replace ~rex:page_RE ~templ:(sprintf "&param.page=%d" page)
+            this
+        else
+          sprintf "%s&param.page=%d" this page
+      in
+      let target = Pcre.replace ~pat:"&" ~templ:"&" target in
+      sprintf "<a href=\"%s\">%s</a>" target anchor
+    with Http_types.Param_not_found _ -> ""
+  in
   Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
   Http_daemon.send_header "Content-Type" "text/xml" outchan;
   Http_daemon.send_CRLF outchan ;
-  let results_string =
+  let subst, results_string =
     match results with
-    | `Results r -> MooglePp.theory_of_result req r
-    | `Error msg -> msg
+    | `Results results ->
+        let page = try int_of_string (req#param "page") with _ -> 1 in
+        let results_no = List.length results in
+        let results_per_page =
+          Helm_registry.get_int "search_engine.results_per_page"
+        in
+        let pages =
+          if results_no mod results_per_page = 0 then
+            results_no / results_per_page
+          else
+            results_no / results_per_page + 1
+        in
+        ([ tag "PAGE", string_of_int page; tag "PAGES", string_of_int pages ] @
+         [ tag "PREV_LINK",
+           if page > 1 then page_link "Prev" (page-1) else "" ] @
+         [ tag "NEXT_LINK",
+           if page < pages then page_link "Next" (page+1) else "" ]),
+        MooglePp.theory_of_result req page results
+    | `Error msg ->
+        [ tag "PAGE", ""; tag "PAGES", "";
+          tag "PREV_LINK", ""; tag "NEXT_LINK", "" ],
+        msg
   in
   let subst =
-    (search_engine_url_RE, my_own_url) ::
-    (results_RE, results_string) ::
-    (advanced_tag_RE, req#param "advanced") ::
-    (expression_tag_RE, req#param "expression") ::
+    (tag "SEARCH_ENGINE_URL", my_own_url) ::
+    (tag "RESULTS", results_string) ::
+    (tag "ADVANCED", req#param "advanced") ::
+    (tag "EXPRESSION", req#param "expression") ::
     add_param_substs req#params @
     (if req#param "advanced" = "no" then
-      [ simple_checked_RE, "checked='true'";
-        advanced_checked_RE, "" ]
+      [ tag "SIMPLE_CHECKED", "checked='true'";
+        tag "ADVANCED_CHECKED", "" ]
     else
-      [ simple_checked_RE, "";
-        advanced_checked_RE, "checked='true'" ])
+      [ tag "SIMPLE_CHECKED", "";
+        tag "ADVANCED_CHECKED", "checked='true'" ]) @
+    subst
   in
   iter_file
     (fun line ->
@@ -145,7 +178,8 @@ let send_results results
       let processed_line =
         apply_substs
           (* CSC: Bug here: this is a string, not an array! *)
-          ((new_aliases_RE, "'" ^ javascript_quote new_aliases ^ "'")::subst) 
+          ((tag "NEW_ALIASES", "'" ^ javascript_quote new_aliases ^ "'") ::
+            subst) 
           line
       in
       output_string outchan (processed_line ^ "\n"))
@@ -212,11 +246,11 @@ let exec_action dbh (req: Http_types.request) outchan =
               (fun line ->
                  let processed_line =
                    apply_substs
-                     [advanced_tag_RE, req#param "advanced";
-                      interpretations_RE, html_interpretations;
-                      current_choices_tag_RE, req#param "choices";
-                      expression_tag_RE, req#param "expression";
-                      action_tag_RE, string_tail req#path ]
+                     [tag "ADVANCED", req#param "advanced";
+                      tag "INTERPRETATIONS", html_interpretations;
+                      tag "CURRENT_CHOICES", req#param "choices";
+                      tag "EXPRESSION", req#param "expression";
+                      tag "ACTION", string_tail req#path ]
                       line
                  in
                  output_string outchan (processed_line ^ "\n"))
@@ -269,8 +303,7 @@ let callback dbh (req: Http_types.request) outchan =
     | "/getpage" ->
           (* TODO implement "is_permitted" *)
         (let is_permitted _ = true in
-        let remove_fragment uri = Pcre.replace ~pat:"#.*" uri in
-        let page = remove_fragment (req#param "url") in
+        let page = req#param "url" in
         let preprocess =
           (try
             bool_of_string (req#param "preprocess")
@@ -278,7 +311,7 @@ let callback dbh (req: Http_types.request) outchan =
         in
         (match page with
         | page when is_permitted page ->
-            (let fname = sprintf "%s/%s" pages_dir (remove_fragment page) in
+            (let fname = sprintf "%s/%s" pages_dir page in
             Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
             Http_daemon.send_header "Content-Type" "text/html" outchan;
             Http_daemon.send_CRLF outchan;
@@ -287,9 +320,9 @@ let callback dbh (req: Http_types.request) outchan =
                 (fun line ->
                   output_string outchan
                     ((apply_substs
-                       ((search_engine_url_RE, my_own_url) ::
-                        (advanced_tag_RE, "no") ::
-                        (results_RE, "") ::
+                       ((tag "SEARCH_ENGINE_URL", my_own_url) ::
+                        (tag "ADVANCED", "no") ::
+                        (tag "RESULTS", "") ::
                         add_param_substs req#params)
                        line) ^
                     "\n"))