src/oldocsigenmod/ocsigen.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * Module ocsigen.ml
   4  * Copyright (C) 2005 Vincent Balat
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU Lesser General Public License as published by
   8  * the Free Software Foundation, with linking exception;
   9  * either version 2.1 of the License, or (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU Lesser General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU Lesser General Public License
  17  * along with this program; if not, write to the Free Software
  18  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  19  *)
  20
  21 open Ocsigen_http_frame
  22 open Ocsigen_http_com
  23 open Lwt
  24 open Ocsigen_lib
  25 open Ocsigen_extensions
  26 open Ocsigenmod
  27 open Lazy
  28
  29 let _ = Random.self_init ()
  30
  31 let get_config () = !Ocsigenmod.config
  32
  33 type url_path = Ocsigen_extensions.url_path
  34 type server_params = Ocsigenmod.server_params
  35
  36 let get_user_agent (ri,_,_) = ri.ri_user_agent
  37 let get_full_url (ri,_,_) = ri.ri_url_string
  38 let get_ip (ri,_,_) = ri.ri_ip
  39 let get_inet_addr (ri,_,_) = ri.ri_inet_addr
  40 let get_get_params (ri,_,_) = force ri.ri_get_params
  41 let get_post_params (ri,_,_) = force ri.ri_post_params
  42 let get_current_url (ri,_,_) = ri.ri_path
  43 let get_hostname (ri,_,_) = ri.ri_host
  44 let get_port (ri,_,_) = ri.ri_port
  45
  46 let get_tmp_filename fi = fi.tmp_filename
  47 let get_filesize fi = fi.filesize
  48 let get_original_filename fi = fi.original_filename
  49
  50 let sync f sp g p = Lwt.return (f sp g p)
  51
  52 let counter = let c = ref (Random.int 1000000) in fun () -> c := !c + 1 ; !c
  53
  54 let new_state =
  55   let c : internal_state ref = ref (Random.int 1000000) in
  56   fun () -> c := !c + 1 ; Some !c
  57
  58
  59 (** Type of names in a formular *)
  60 type 'a param_name = string
  61
  62 type ('a,'b) binsum = Inj1 of 'a | Inj2 of 'b;;
  63
  64 (* This is a generalized algebraic datatype *)
  65 type ('a,+'tipo,+'names) params_type =
  66     (* 'tipo is [`WithSuffix] or [`WithoutSuffix] *)
  67     TProd of (* 'a1 *) ('a,'tipo,'names) params_type * (* 'a2 *) ('a,'tipo,'names) params_type (* 'a = 'a1 * 'a2 ; 'names = 'names1 * 'names2 *)
  68   | TOption of (* 'a1 *) ('a,'tipo,'names) params_type (* 'a = 'a1 option *)
  69   | TList of 'a param_name * (* 'a1 *) ('a,'tipo,'names) params_type (* 'a = 'a1 list *)
  70   | TSum of (* 'a1 *) ('a,'tipo,'names) params_type * (* 'a2 *) ('a,'tipo,'names) params_type (* 'a = ('a1, 'a2) binsum *)
  71   | TString of string param_name (* 'a = string *)
  72   | TInt of int param_name (* 'a = int *)
  73   | TFloat of float param_name (* 'a = float *)
  74   | TBool of bool param_name (* 'a = bool *)
  75   | TFile of file_info param_name (* 'a = file_info *)
  76   | TUserType of ('a param_name * (string -> 'a) * ('a -> string)) (* 'a = 'a *)
  77   | TSuffix (* 'a = string *)
  78   | TUnit (* 'a = unit *);;
  79
  80 type 'an listnames =
  81     {it:'el 'a. ('an -> 'el -> 'a list) -> 'el list -> 'a list -> 'a list}
  82
  83 (* As GADT are not implemented in OCaml for the while, we define our own
  84    constructors for params_type *)
  85 let int (n : string) : (int,[`WithoutSuffix], int param_name) params_type = TInt n
  86 let float (n : string) : (float,[`WithoutSuffix], float param_name) params_type = TFloat n
  87 let bool (n : string) : (bool,[`WithoutSuffix], bool param_name) params_type= TBool n
  88 let string (n : string) : (string,[`WithoutSuffix], string param_name) params_type =
  89   TString n
  90 let file (n : string) : (file_info ,[`WithoutSuffix], file_info param_name) params_type =
  91   TFile n
  92 let radio_answer (n : string) : (string option,[`WithoutSuffix], string option param_name) params_type= TString n
  93 let unit : (unit,[`WithoutSuffix], unit param_name) params_type = TUnit
  94 let user_type
  95     (of_string : string -> 'a) (from_string : 'a -> string) (n : string)
  96     : ('a,[`WithoutSuffix], 'a param_name) params_type =
  97   Obj.magic (TUserType (n,of_string,from_string))
  98 let sum (t1 : ('a,[`WithoutSuffix], 'an) params_type)
  99     (t2 : ('b,[`WithoutSuffix], 'bn) params_type)
 100     : (('a,'b) binsum,[`WithoutSuffix], 'an * 'bn) params_type =
 101   Obj.magic (TSum (t1, t2))
 102 let prod (t1 : ('a,[`WithoutSuffix], 'an) params_type)
 103     (t2 : ('b,[<`WithoutSuffix], 'bn) params_type)
 104     : (('a * 'b),[`WithoutSuffix], 'an * 'bn) params_type =
 105   Obj.magic (TProd ((Obj.magic t1), (Obj.magic t2)))
 106 let opt (t : ('a,[`WithoutSuffix], 'an) params_type)
 107     : ('a option,[`WithoutSuffix], 'an) params_type =
 108   Obj.magic (TOption t)
 109 let list (n : string) (t : ('a,[`WithoutSuffix], 'an) params_type)
 110     : ('a list,[`WithoutSuffix], 'an listnames) params_type =
 111   Obj.magic (TList (n,t))
 112 let ( ** ) = prod
 113
 114 let suffix_only : (string, [`WithSuffix], string param_name) params_type =
 115   (Obj.magic TSuffix)
 116 let suffix (t : ('a,[`WithoutSuffix], 'an) params_type) :
 117     ((string * 'a), [`WithSuffix], string param_name * 'an) params_type =
 118   (Obj.magic (TProd (Obj.magic TSuffix, Obj.magic t)))
 119
 120 let make_list_suffix i = "["^(string_of_int i)^"]"
 121
 122 let add_to_string s1 sep = function
 123     "" -> s1
 124   | s2 -> s1^sep^s2
 125
 126 let concat_strings s1 sep s2 = match s1,s2 with
 127   _,"" -> s1
 128 | "",_ -> s2
 129 | _ -> s1^sep^s2
 130
 131 (* The following function reconstruct the value of parameters
 132    from expected type and GET or POST parameters *)
 133 type 'a res_reconstr_param =
 134     Res_ of ('a *
 135                (string * string) list *
 136                (string * file_info) list)
 137   | Errors_ of (string * exn) list
 138
 139 let reconstruct_params
 140     (typ : ('a,[<`WithSuffix|`WithoutSuffix],'b) params_type)
 141     params files urlsuffix : 'a =
 142   let rec aux_list t params files name pref suff =
 143     let rec aa i lp fl pref suff =
 144       try
 145         match aux t lp fl pref (suff^(make_list_suffix i)) with
 146           Res_ (v,lp2,f) ->
 147             (match aa (i+1) lp2 f pref suff with
 148               Res_ (v2,lp3,f2) -> Res_ ((Obj.magic (v::v2)),lp3,f2)
 149             | err -> err)
 150         | Errors_ errs ->
 151             (match aa (i+1) lp fl pref suff with
 152               Res_ _ -> Errors_ errs
 153             | Errors_ errs2 -> Errors_ (errs@errs2))
 154       with Not_found -> Res_ ((Obj.magic []),lp,files)
 155     in
 156     aa 0 params files (pref^name^".") suff
 157   and aux (typ : ('a,[<`WithSuffix|`WithoutSuffix],'b) params_type)
 158       params files pref suff : 'a res_reconstr_param =
 159     match typ with
 160       TProd (t1, t2) ->
 161         (match aux t1 params files pref suff with
 162           Res_ (v1,l1,f) ->
 163             (match aux t2 l1 f pref suff with
 164               Res_ (v2,l2,f2) -> Res_ ((Obj.magic (v1,v2)),l2,f2)
 165             | err -> err)
 166         | Errors_ errs ->
 167             (match aux t2 params files pref suff with
 168               Res_ _ -> Errors_ errs
 169             | Errors_ errs2 -> Errors_ (errs2@errs)))
 170     | TOption t ->
 171         (try
 172           (match aux t params files pref suff with
 173             Res_ (v,l,f) -> Res_ ((Obj.magic (Some v)),l,f)
 174           | err -> err)
 175         with Not_found -> Res_ ((Obj.magic None), params,files))
 176     | TBool name ->
 177         (try
 178           let v,l = (list_assoc_remove (pref^name^suff) params) in
 179           Res_ ((Obj.magic true),l,files)
 180         with Not_found -> Res_ ((Obj.magic false), params, files))
 181     | TList (n,t) -> Obj.magic (aux_list t params files n pref suff)
 182     | TSum (t1, t2) ->
 183         (try
 184           match aux t1 params files pref suff with
 185             Res_ (v,l,files) -> Res_ ((Obj.magic (Inj1 v)),l,files)
 186           | err -> err
 187         with Not_found ->
 188           (match aux t2 params files pref suff with
 189             Res_ (v,l,files) -> Res_ ((Obj.magic (Inj2 v)),l,files)
 190           | err -> err))
 191     | TString name ->
 192         let v,l = list_assoc_remove (pref^name^suff) params in
 193         Res_ ((Obj.magic v),l,files)
 194     | TInt name ->
 195         let v,l = (list_assoc_remove (pref^name^suff) params) in
 196         (try (Res_ ((Obj.magic (int_of_string v)),l,files))
 197         with e -> Errors_ [(pref^name^suff),e])
 198     | TFloat name ->
 199         let v,l = (list_assoc_remove (pref^name^suff) params) in
 200         (try (Res_ ((Obj.magic (float_of_string v)),l,files))
 201         with e -> Errors_ [(pref^name^suff),e])
 202     | TFile name ->
 203         let v,f = list_assoc_remove (pref^name^suff) files in
 204         Res_ ((Obj.magic v),params,f)
 205     | TUserType (name, of_string, string_of) ->
 206         let v,l = (list_assoc_remove (pref^name^suff) params) in
 207         (try (Res_ ((Obj.magic (of_string v)),l,files))
 208         with e -> Errors_ [(pref^name^suff),e])
 209     | TUnit -> Res_ ((Obj.magic ()), params, files)
 210     | TSuffix -> raise (Eliom_lib.Eliom_Internal_Error "Bad use of suffix")
 211   in
 212   let aux2 typ =
 213     match Obj.magic (aux typ params files "" "") with
 214       Res_ (v,l,files) ->
 215         if (l,files) = ([], [])
 216         then v
 217         else raise Ocsigen_Wrong_parameter
 218     | Errors_ errs -> raise (Ocsigen_Typing_Error errs)
 219   in
 220   try
 221     match typ with
 222       TProd(TSuffix,t) -> Obj.magic ((string_of_url_path urlsuffix), aux2 t)
 223     | TSuffix -> Obj.magic (string_of_url_path urlsuffix)
 224     | _ -> Obj.magic (aux2 typ)
 225   with Not_found -> raise Ocsigen_Wrong_parameter
 226
 227 (* The following function takes a 'a params_type and a 'a and
 228    constructs the string of parameters (GET or POST)
 229    (This is a marshalling function towards HTTP parameters format) *)
 230 let construct_params (typ : ('a, [<`WithSuffix|`WithoutSuffix],'b) params_type)
 231     (params : 'a) : string * string =
 232   let rec aux typ params pref suff =
 233     match typ with
 234       TProd (t1, t2) ->
 235         let s1 = aux t1 (fst (Obj.magic params)) pref suff
 236         and s2 = aux t2 (snd (Obj.magic params)) pref suff in
 237         (concat_strings s1 "&" s2)
 238     | TOption t -> (match ((Obj.magic params) : 'zozo option) with None -> ""
 239       | Some v -> aux t v pref suff)
 240     | TBool name ->
 241         (if ((Obj.magic params) : bool)
 242         then pref^name^suff^"="^"on"
 243         else "")
 244     | TList (list_name, t) ->
 245         let pref2 = pref^list_name^suff^"." in
 246         fst
 247           (List.fold_left
 248              (fun (s,i) p ->
 249                let ss =
 250                  aux t p pref2 (suff^(make_list_suffix i)) in
 251                ((concat_strings s "&" ss),(i+1))) ("",0) (Obj.magic params))
 252     | TSum (t1, t2) -> (match Obj.magic params with
 253         Inj1 v -> aux t1 v pref suff
 254       | Inj2 v -> aux t2 v pref suff)
 255     | TString name -> pref^name^suff^"="^(Obj.magic params)
 256     | TInt name -> pref^name^suff^"="^(string_of_int (Obj.magic params))
 257     | TFloat name -> pref^name^suff^"="^(string_of_float (Obj.magic params))
 258     | TFile name ->
 259         raise (Failure
 260                  "Constructing an URL with file parameters not implemented")
 261     | TUserType (name, of_string, string_of) ->
 262         pref^name^suff^"="^(string_of (Obj.magic params))
 263     | TUnit -> ""
 264     | TSuffix -> raise (Eliom_lib.Eliom_Internal_Error "Bad use of suffix")
 265   in
 266   match typ with
 267     TProd(TSuffix,t) ->
 268       (fst (Obj.magic params)),(aux t (snd (Obj.magic params)) "" "")
 269   | TSuffix -> (Obj.magic params),""
 270   | _ -> "",(aux typ params "" "")
 271
 272
 273 (*****************************************************************************)
 274 (* Building href *)
 275 let rec string_of_url_path_suff u = function
 276     None -> string_of_url_path u
 277   | Some suff -> let deb = (string_of_url_path u) in
 278     if deb = "" then string_of_url_path suff else deb^(string_of_url_path suff)
 279
 280 let reconstruct_absolute_url_path current_url = string_of_url_path_suff
 281
 282 let reconstruct_relative_url_path current_url u suff =
 283   let rec drop cururl desturl = match cururl, desturl with
 284   | a::l, [b] -> l, desturl
 285   | [a], m -> [], m
 286   | a::l, b::m when a = b -> drop l m
 287   | a::l, m -> l, m
 288   | [], m -> [], m
 289   in let rec makedotdot = function
 290     | [] -> ""
 291 (*    | [a] -> "" *)
 292     | _::l -> "../"^(makedotdot l)
 293   in
 294   let aremonter, aaller = drop current_url u
 295   in let s = (makedotdot aremonter)^(string_of_url_path_suff aaller suff) in
 296 (*  Ocsigen_messages.debug ((string_of_url_path current_url)^"->"^(string_of_url_path u)^"="^s);*)
 297   if s = "" then defaultpagename else s
 298
 299 let rec relative_url_path_to_myself = function
 300     []
 301   | [""] -> defaultpagename
 302   | [a] -> a
 303   | a::l -> relative_url_path_to_myself l
 304 (*****************************************************************************)
 305
 306
 307 (** Typed services *)
 308 type internal_service_kind = [`Public_Service | `Local_Service]
 309 type service_kind =
 310     [ `Internal_Service of internal_service_kind
 311     | `External_Service]
 312
 313 type ('get,'post,+'kind,+'tipo,+'getnames,+'postnames) service =
 314     {url: url_path; (* name of the service without parameters *)
 315         (* unique_id is here only for registering on top of this service *)
 316      unique_id: int;
 317      url_prefix: bool;
 318      external_service: bool;
 319      url_state: internal_state option;
 320      (* 'kind is just a type information: it can be only
 321         `Internal_Service `Public_Service or `Internal_Service `Local_Service
 322         or `External_Service, so that we can't use session services as fallbacks for
 323         other session services. If it is a session service, it contains a value
 324         (internal state) that will allow to differenciate between
 325         services that have the same url.
 326       *)
 327      get_params_type: ('get,'tipo,'getnames) params_type;
 328      post_params_type: ('post,[`WithoutSuffix],'postnames) params_type;
 329    }
 330
 331
 332
 333
 334 (*****************************************************************************)
 335 (*****************************************************************************)
 336 (* Page registration, handling of links and forms                            *)
 337 (*****************************************************************************)
 338 (*****************************************************************************)
 339
 340 (** Satic directories **)
 341       let static_dir (ri,curdir,sesstab) :
 342           (string, unit, [`Internal_Service of [`Public_Service]],[`WithSuffix],string param_name, unit param_name) service =
 343         {url = curdir;
 344          unique_id = counter ();
 345          url_state = None;
 346          url_prefix = true;
 347          external_service = false;
 348          get_params_type = suffix_only;
 349          post_params_type = unit
 350        }
 351
 352 (** Close a session *)
 353       let close_session (_,_,sesstab) = sesstab := empty_tables ()
 354
 355
 356 (** Actions *)
 357 (** actions (new 10/05) *)
 358 type ('post,'pn) action =
 359     {action_name: string;
 360      action_params_type: ('post,[`WithoutSuffix],'pn) params_type}
 361
 362 let new_action_name () = string_of_int (counter ())
 363
 364 let new_action
 365     ~(post_params : ('post,[`WithoutSuffix],'pn) params_type) =
 366   {
 367    action_name = new_action_name ();
 368    action_params_type = post_params;
 369  }
 370
 371 let register_action_aux
 372     current_dir tables ~action actionfun =
 373   add_action tables current_dir
 374     action.action_name
 375     (fun ((ri,_,_) as h) ->
 376       (force ri.ri_post_params) >>=
 377       (fun post_params ->
 378         (force ri.ri_files) >>=
 379         (fun files ->
 380           actionfun h
 381             (reconstruct_params
 382                action.action_params_type
 383                post_params
 384                files
 385                []))))
 386
 387 let register_action
 388     ~(action : ('post,'pn) action)
 389     (actionfun : (server_params -> 'post -> unit Lwt.t)) : unit =
 390   if global_register_allowed () then
 391     (* if during_initialisation () then *)
 392     let (globtables,_),curdir = get_current_hostdir () in
 393     register_action_aux curdir globtables action actionfun
 394   else raise Ocsigen_service_or_action_created_outside_site_loading
 395
 396 let register_new_action ~post_params actionfun =
 397   let a = new_action post_params in
 398   register_action a actionfun;
 399   a
 400
 401 let register_action_for_session (ri,curdir,sesstab) ~action actionfun =
 402   register_action_aux curdir
 403     !sesstab action actionfun
 404
 405 let register_new_action_for_session sp ~post_params actionfun =
 406   let a = new_action post_params in
 407   register_action_for_session sp a actionfun;
 408   a
 409
 410
 411 (****************************************************************************)
 412 (****************************************************************************)
 413
 414 (** Definition of services *)
 415 (** Create a service *)
 416 let new_service_aux_aux
 417     ~(url : url_path)
 418     ~prefix
 419     ~external_service
 420     ~(get_params : ('get,[<`WithoutSuffix|`WithSuffix] as 'tipo,'gn) params_type)
 421     ~(post_params : ('post,[`WithoutSuffix],'pn) params_type)
 422     : ('get,'post,'kind,'tipo,'gn,'pn) service =
 423 (* ici faire une vérification "duplicate parameter" ? *)
 424   {url = url;
 425    unique_id = counter ();
 426    url_prefix = prefix;
 427    url_state = None;
 428    external_service = external_service;
 429    get_params_type = get_params;
 430    post_params_type = post_params;
 431  }
 432
 433 let new_service_aux
 434     ~(url : url_path)
 435     ~prefix
 436     ~(get_params : ('get,[<`WithoutSuffix|`WithSuffix] as 'tipo,'gn) params_type)
 437     : ('get,unit,[`Internal_Service of 'popo],'tipo,'gn,unit param_name) service =
 438   if global_register_allowed () then
 439     let _,curdir = get_current_hostdir () in
 440     let full_path = curdir@(change_empty_list url) in
 441     let u = new_service_aux_aux
 442         ~url:full_path
 443         ~prefix
 444         ~external_service:false
 445         ~get_params
 446         ~post_params:unit
 447     in
 448     add_unregistered (u.url,u.unique_id); u
 449   else raise Ocsigen_service_or_action_created_outside_site_loading
 450
 451 let new_external_service
 452     ~(url : url_path)
 453     ?(prefix=false)
 454     ~(get_params : ('get,[<`WithoutSuffix|`WithSuffix] as 'tipo,'gn) params_type)
 455     ~(post_params : ('post,[`WithoutSuffix],'pn) params_type)
 456     ()
 457     : ('get,'post,[`External_Service],'tipo,'gn,'pn) service =
 458   new_service_aux_aux
 459     ~url
 460     ~prefix
 461     ~external_service:true
 462     ~get_params
 463     ~post_params
 464
 465 let new_service
 466     ~(url : url_path)
 467     ?(prefix=false)
 468     ~(get_params : ('get,[<`WithoutSuffix|`WithSuffix] as 'tipo,'gn) params_type)
 469     ()
 470     : ('get,unit,[`Internal_Service of [`Public_Service]],'tipo,'gn, unit param_name) service =
 471   new_service_aux ~url ~prefix ~get_params
 472
 473 let new_auxiliary_service
 474     ~(fallback : ('get,unit, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn) service)
 475     : ('get,unit,[`Internal_Service of [`Local_Service]],'tipo,'gn,'pn) service =
 476   {fallback with url_state = new_state ()}
 477
 478
 479 (****************************************************************************)(** Register an service with post parameters in the server *)
 480 let new_post_service_aux
 481     ~(fallback : ('get, unit, [`Internal_Service of [`Public_Service]],'tipo,'gn,unit param_name) service)
 482     ~(post_params : ('post,[`WithoutSuffix],'pn) params_type)
 483     : ('get, 'post, [`Internal_Service of [`Public_Service]], 'tipo,'gn,'pn) service =
 484 (* ici faire une vérification "duplicate parameter" ? *)
 485   {url = fallback.url;
 486    unique_id = counter ();
 487    url_prefix = fallback.url_prefix;
 488    external_service = false;
 489    url_state = None;
 490    get_params_type = fallback.get_params_type;
 491    post_params_type = post_params;
 492  }
 493
 494 let new_post_service
 495     ~(fallback : ('get, unit, [`Internal_Service of [`Public_Service]],'tipo,'gn,unit param_name) service)
 496     ~(post_params : ('post,[`WithoutSuffix],'pn) params_type)
 497     : ('get, 'post, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn) service =
 498   if global_register_allowed () then
 499     let u = new_post_service_aux fallback post_params in
 500     add_unregistered (u.url,u.unique_id); u
 501   else raise Ocsigen_service_or_action_created_outside_site_loading
 502
 503 let new_post_auxiliary_service
 504     ~(fallback : ('get, 'post1, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn1) service)
 505     ~(post_params : ('post,[`WithoutSuffix],'pn2) params_type)
 506     : ('get, 'post, [`Internal_Service of [`Local_Service]],'tipo,'gn,'pn2) service =
 507   {fallback with
 508    url_state = new_state ();
 509    post_params_type = post_params;
 510  }
 511
 512
 513
 514 (****************************************************************************)
 515
 516 module type REGCREATE =
 517   sig
 518
 519     type page
 520
 521     val headers : Http_headers.t
 522     val send : content:page -> Ocsigen_senders.send_page_type
 523
 524   end
 525
 526
 527 module type FORMCREATE =
 528   sig
 529
 530     type form_content_elt
 531     type form_content_elt_list
 532     type form_elt
 533     type a_content_elt
 534     type a_content_elt_list
 535     type a_elt
 536     type a_elt_list
 537     type div_content_elt
 538     type div_content_elt_list
 539     type uri
 540     type link_elt
 541     type script_elt
 542     type textarea_elt
 543     type select_elt
 544     type input_elt
 545     type pcdata_elt
 546
 547     type a_attrib_t
 548     type form_attrib_t
 549     type input_attrib_t
 550     type textarea_attrib_t
 551     type select_attrib_t
 552     type link_attrib_t
 553     type script_attrib_t
 554     type input_type_t
 555
 556     val hidden : input_type_t
 557     val text : input_type_t
 558     val password : input_type_t
 559     val checkbox : input_type_t
 560     val radio : input_type_t
 561     val submit : input_type_t
 562     val file : input_type_t
 563
 564     val empty_seq : form_content_elt_list
 565     val cons_form : form_content_elt -> form_content_elt_list -> form_content_elt_list
 566
 567     val make_a : ?a:a_attrib_t -> href:string -> a_content_elt_list -> a_elt
 568     val make_get_form : ?a:form_attrib_t ->
 569       action:string ->
 570         form_content_elt -> form_content_elt_list -> form_elt
 571     val make_post_form : ?a:form_attrib_t ->
 572       action:string -> ?id:string -> ?inline:bool ->
 573         form_content_elt -> form_content_elt_list -> form_elt
 574     val make_hidden_field : input_elt -> form_content_elt
 575     val remove_first : form_content_elt_list -> form_content_elt * form_content_elt_list
 576     val make_input : ?a:input_attrib_t -> ?checked:bool ->
 577       typ:input_type_t -> ?name:string ->
 578         ?value:string -> unit -> input_elt
 579     val make_textarea : ?a:textarea_attrib_t ->
 580       name:string -> rows:int -> cols:int ->
 581         pcdata_elt ->
 582           textarea_elt
 583      val make_select : ?a:select_attrib_t ->
 584        name:string ->
 585        ?selected:((string option * string) option)
 586          -> (string option * string) -> ((string option * string) list) ->
 587        select_elt
 588     val make_div : classe:(string list) -> a_elt -> form_content_elt
 589     val uri_of_string : string -> uri
 590
 591
 592     val make_css_link : ?a:link_attrib_t -> uri -> link_elt
 593
 594     val make_js_script : ?a:script_attrib_t -> uri -> script_elt
 595
 596   end
 597
 598 module type OCSIGENFORMSIG =
 599   sig
 600
 601     type form_content_elt
 602     type form_content_elt_list
 603     type form_elt
 604     type a_content_elt
 605     type a_content_elt_list
 606     type a_elt
 607     type a_elt_list
 608     type div_content_elt
 609     type div_content_elt_list
 610     type uri
 611     type link_elt
 612     type script_elt
 613     type textarea_elt
 614     type select_elt
 615     type input_elt
 616     type pcdata_elt
 617
 618     type a_attrib_t
 619     type form_attrib_t
 620     type input_attrib_t
 621     type textarea_attrib_t
 622     type select_attrib_t
 623     type link_attrib_t
 624     type script_attrib_t
 625     type input_type_t
 626
 627     val a :
 628         ?a:a_attrib_t ->
 629           ('a, unit, 'b, [< `WithSuffix | `WithoutSuffix ], 'c, 'd) service ->
 630             server_params -> a_content_elt_list -> 'a -> a_elt
 631     val get_form :
 632         ?a:form_attrib_t ->
 633           ('a, unit, 'b, 'c, 'd, unit param_name) service ->
 634             server_params ->
 635               ('d -> form_content_elt_list) -> form_elt
 636     val post_form :
 637         ?a:form_attrib_t ->
 638           ('a, 'b, 'c, [< `WithSuffix | `WithoutSuffix ], 'd, 'e) service ->
 639             server_params ->
 640               ('e -> form_content_elt_list) -> 'a -> form_elt
 641     val make_uri :
 642         ('a, unit, 'b, [< `WithSuffix | `WithoutSuffix ], 'c, 'd) service ->
 643           server_params -> 'a -> uri
 644     val action_a :
 645         ?a:a_attrib_t ->
 646           ?reload:bool ->
 647             ('a, 'b) action ->
 648               server_params -> a_content_elt_list -> form_elt
 649     val action_form :
 650         ?a:form_attrib_t ->
 651           ?reload:bool ->
 652             ('a, 'b) action ->
 653               server_params ->
 654                 ('b -> form_content_elt_list) -> form_elt
 655     val js_script :
 656         ?a:script_attrib_t -> uri -> script_elt
 657     val css_link : ?a:link_attrib_t -> uri -> link_elt
 658
 659     val int_input :
 660         ?a:input_attrib_t -> ?value:int -> int param_name -> input_elt
 661     val float_input :
 662         ?a:input_attrib_t -> ?value:float -> float param_name -> input_elt
 663     val string_input :
 664         ?a:input_attrib_t -> ?value:string -> string param_name -> input_elt
 665     val user_type_input :
 666         ?a:input_attrib_t -> ?value:'a -> ('a -> string) ->
 667           'a param_name -> input_elt
 668     val int_password_input :
 669         ?a:input_attrib_t -> ?value:int -> int param_name -> input_elt
 670     val float_password_input :
 671         ?a:input_attrib_t -> ?value:float -> float param_name -> input_elt
 672     val string_password_input :
 673         ?a:input_attrib_t -> ?value:string -> string param_name -> input_elt
 674     val user_type_password_input :
 675         ?a:input_attrib_t -> ?value:'a -> ('a -> string) ->
 676           'a param_name -> input_elt
 677     val hidden_int_input :
 678         ?a:input_attrib_t -> int param_name -> int -> input_elt
 679     val hidden_float_input :
 680         ?a:input_attrib_t -> float param_name -> float -> input_elt
 681     val hidden_string_input :
 682         ?a:input_attrib_t -> string param_name -> string -> input_elt
 683     val hidden_user_type_input :
 684         ?a:input_attrib_t -> ('a -> string) -> 'a param_name -> 'a -> input_elt
 685     val bool_checkbox :
 686         ?a:input_attrib_t -> ?checked:bool -> bool param_name -> input_elt
 687     val string_radio :
 688         ?a:input_attrib_t -> ?checked:bool ->
 689           string option param_name -> string -> input_elt
 690     val int_radio :
 691         ?a:input_attrib_t -> ?checked:bool ->
 692            int option param_name -> int -> input_elt
 693     val float_radio :
 694         ?a:input_attrib_t -> ?checked:bool ->
 695            float option param_name -> float -> input_elt
 696     val user_type_radio :
 697         ?a:input_attrib_t -> ?checked:bool -> ('a -> string) ->
 698            'a option param_name -> 'a -> input_elt
 699     val textarea :
 700         ?a:textarea_attrib_t ->
 701           string param_name ->
 702             rows:int -> cols:int -> pcdata_elt -> textarea_elt
 703     val select :
 704       ?a:select_attrib_t ->
 705       ?selected:((string option * string) option)
 706       -> (string option * string) -> ((string option * string) list) ->
 707       string param_name
 708       -> select_elt
 709     val submit_input : ?a:input_attrib_t -> string -> input_elt
 710     val file_input : ?a:input_attrib_t -> ?value:string ->
 711                             file_info param_name-> input_elt
 712   end
 713
 714 module type OCSIGENREGSIG =
 715   sig
 716     type page
 717
 718     val register_service :
 719         service:('a, 'b, [ `Internal_Service of 'c ],
 720                  [< `WithSuffix | `WithoutSuffix ], 'd, 'e) service ->
 721                    ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 722                      (server_params -> 'a -> 'b -> page Lwt.t) -> unit
 723     val register_service_for_session :
 724         server_params ->
 725           service:('a, 'b, [ `Internal_Service of 'c ],
 726                    [< `WithSuffix | `WithoutSuffix ], 'd, 'e)
 727             service ->
 728               ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 729                 (server_params -> 'a -> 'b -> page Lwt.t) -> unit
 730     val register_new_service :
 731         url:url_path ->
 732           ?prefix:bool ->
 733             get_params:('a, [< `WithSuffix | `WithoutSuffix ] as 'b, 'c)
 734               params_type ->
 735                 ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 736                   (server_params -> 'a -> unit -> page Lwt.t) ->
 737                     ('a, unit, [ `Internal_Service of [ `Public_Service ] ], 'b, 'c,
 738                      unit param_name)
 739                       service
 740     val register_new_auxiliary_service :
 741         fallback:('a, unit, [ `Internal_Service of [ `Public_Service ] ],
 742                   [< `WithSuffix | `WithoutSuffix ] as 'b, 'c, 'd)
 743         service ->
 744           ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 745             (server_params -> 'a -> unit -> page Lwt.t) ->
 746               ('a, unit, [ `Internal_Service of [ `Local_Service ] ], 'b, 'c, 'd)
 747                 service
 748     val register_new_auxiliary_service_for_session :
 749         server_params ->
 750           fallback:('a, unit, [ `Internal_Service of [ `Public_Service ] ],
 751                     [< `WithSuffix | `WithoutSuffix ] as 'b, 'c, 'd)
 752             service ->
 753               ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 754                 (server_params -> 'a -> unit -> page Lwt.t) ->
 755                   ('a, unit, [ `Internal_Service of [ `Local_Service ] ], 'b, 'c, 'd)
 756                     service
 757
 758
 759
 760     val register_new_post_service :
 761         fallback:('a, unit, [ `Internal_Service of [ `Public_Service ] ],
 762                   [< `WithSuffix | `WithoutSuffix ] as 'b, 'c,
 763                   unit param_name)
 764         service ->
 765           post_params:('d, [ `WithoutSuffix ], 'e) params_type ->
 766             ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 767               (server_params -> 'a -> 'd -> page Lwt.t) ->
 768                 ('a, 'd, [ `Internal_Service of [ `Public_Service ] ], 'b, 'c, 'e)
 769                   service
 770     val register_new_post_auxiliary_service :
 771         fallback:('a, 'b, [ `Internal_Service of [ `Public_Service ] ],
 772                   [< `WithSuffix | `WithoutSuffix ] as 'c, 'd, 'e)
 773         service ->
 774           post_params:('f, [ `WithoutSuffix ], 'g) params_type ->
 775             ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 776               (server_params -> 'a -> 'f -> page Lwt.t) ->
 777                 ('a, 'f, [ `Internal_Service of [ `Local_Service ] ], 'c, 'd, 'g)
 778                   service
 779
 780     val register_new_post_auxiliary_service_for_session :
 781         server_params ->
 782           fallback:('a, 'b, [ `Internal_Service of [ `Public_Service ] ],
 783                     [< `WithSuffix | `WithoutSuffix ] as 'c, 'd, 'e)
 784             service ->
 785               post_params:('f, [ `WithoutSuffix ], 'g) params_type ->
 786                 ?error_handler:(server_params -> (string * exn) list -> page Lwt.t) ->
 787                   (server_params -> 'a -> 'f -> page Lwt.t) ->
 788                     ('a, 'f, [ `Internal_Service of [ `Local_Service ] ], 'c, 'd, 'g)
 789                       service
 790
 791   end
 792
 793 module type OCSIGENSIG = sig
 794   include OCSIGENREGSIG
 795   include OCSIGENFORMSIG
 796 end
 797
 798
 799 module MakeRegister = functor
 800   (Pages : REGCREATE) ->
 801     (struct
 802
 803       type page = Pages.page
 804
 805       let register_service_aux
 806           current_dir
 807           tables
 808           session
 809           state
 810           ~(service : ('get,'post,[`Internal_Service of 'popo],'tipo,'gn,'pn) service)
 811           ?(error_handler = fun sp l -> raise (Ocsigen_Typing_Error l))
 812           (page_generator : server_params -> 'get -> 'post -> page Lwt.t) =
 813         add_service tables current_dir session service.url
 814           Pages.headers
 815           ({prefix = service.url_prefix;
 816             state = state},
 817            (service.unique_id,
 818             (fun (suff,((ri,_,_) as h)) ->
 819               (catch (fun () ->
 820                 (force ri.ri_post_params) >>=
 821                 (fun post_params ->
 822                   (force ri.ri_files) >>=
 823                   (fun files ->
 824                     (page_generator h
 825                        (reconstruct_params
 826                           service.get_params_type
 827                           (force ri.ri_get_params)
 828                           []
 829                           suff)
 830                        (reconstruct_params
 831                           service.post_params_type
 832                           post_params
 833                           files
 834                           suff)))))
 835                  (function
 836                      Ocsigen_Typing_Error l -> error_handler h l
 837                    | e -> fail e)) >>=
 838               (fun c -> return (Pages.send ~content:c)))))
 839
 840       let register_service
 841           ~(service : ('get,'post,[`Internal_Service of 'g],'tipo,'gn,'pn) service)
 842           ?error_handler
 843           (page_gen : server_params -> 'get -> 'post -> page Lwt.t) =
 844         if global_register_allowed () then begin
 845           remove_unregistered (service.url,service.unique_id);
 846           let (globtables,_),curdir = get_current_hostdir () in
 847           register_service_aux
 848             curdir
 849             globtables
 850             false service.url_state
 851             ~service ?error_handler page_gen;
 852         end
 853         else Ocsigen_messages.warning ("URL .../"^
 854                                (string_of_url_path service.url)^
 855                                " : Public service registration outside <site></site> or after init forbidden! Please correct your module! (ignored)")
 856
 857 (* WARNING: if we create a new service without registering it,
 858    we can have a link towards a page that does not exist!!! :-(
 859    That's why I impose to register all service during init.
 860    The only other way I see to avoid this is to impose a syntax extension
 861    like "let rec" for service...
 862  *)
 863
 864       let register_service_for_session
 865           (ri,curdir,sesstab)
 866           ~(service : ('get,'post,[`Internal_Service of 'g],'tipo,'gn,'pn)
 867               service)
 868            ?error_handler
 869           page =
 870         register_service_aux ?error_handler curdir
 871           !sesstab
 872           true service.url_state ~service page
 873
 874       let register_new_service
 875           ~url
 876           ?(prefix=false)
 877           ~(get_params : ('get,[<`WithoutSuffix|`WithSuffix] as 'tipo,'gn) params_type)
 878           ?error_handler
 879           page
 880           : ('get,unit, [`Internal_Service of [`Public_Service]],'tipo,'gn,unit param_name) service =
 881         let u = new_service ~prefix ~url ~get_params () in
 882         register_service ~service:u ?error_handler page;
 883         u
 884
 885       let register_new_auxiliary_service
 886           ~(fallback : ('get, unit, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn) service)
 887           ?error_handler
 888           page
 889           : ('get, unit, [`Internal_Service of [`Local_Service]],'tipo,'gn,'pn) service =
 890         let u = (new_auxiliary_service fallback) in
 891         register_service ~service:u ?error_handler page;
 892         u
 893
 894       let register_new_auxiliary_service_for_session
 895           sp
 896           ~(fallback : ('get, unit, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn) service)
 897           ?error_handler
 898           page
 899           : ('get, unit, [`Internal_Service of [`Local_Service]],'tipo,'gn,'pn) service =
 900         let u = (new_auxiliary_service fallback) in
 901         register_service_for_session sp ~service:u ?error_handler page;
 902         u
 903
 904
 905
 906       let register_new_post_service
 907           ~(fallback : ('get, unit, [`Internal_Service of [`Public_Service]],'tipo,'gn,unit param_name) service)
 908           ~(post_params : ('post,[`WithoutSuffix],'pn) params_type)
 909           ?error_handler
 910           (page_gen : server_params -> 'get -> 'post -> 'fin)
 911           : ('get,'post, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn) service =
 912         let u = new_post_service ~fallback:fallback ~post_params:post_params in
 913         register_service ~service:u ?error_handler page_gen;
 914         u
 915
 916       let register_new_post_auxiliary_service
 917           ~(fallback : ('get, 'post1, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn1) service)
 918           ~(post_params : ('post,[`WithoutSuffix],'pn) params_type)
 919           ?error_handler
 920           page_gen
 921           : ('get, 'post, [`Internal_Service of [`Local_Service]],'tipo,'gn,'pn) service =
 922         let u = new_post_auxiliary_service ~fallback:fallback ~post_params:post_params in
 923         register_service ~service:u ?error_handler page_gen;
 924         u
 925
 926       let register_new_post_auxiliary_service_for_session
 927           sp
 928           ~(fallback : ('get, 'post1, [`Internal_Service of [`Public_Service]],'tipo,'gn,'pn1) service)
 929           ~(post_params : ('post,[`WithoutSuffix],'pn) params_type)
 930           ?error_handler
 931           page_gen
 932           : ('get, 'post, [`Internal_Service of [`Local_Service]],'tipo,'gn,'pn) service =
 933         let u = new_post_auxiliary_service ~fallback:fallback ~post_params:post_params in
 934         register_service_for_session sp ~service:u ?error_handler page_gen;
 935         u
 936
 937
 938   end : OCSIGENREGSIG with
 939      type page = Pages.page)
 940
 941
 942 module MakeForms = functor
 943   (Pages : FORMCREATE) ->
 944     (struct
 945
 946       type form_content_elt = Pages.form_content_elt
 947       type form_content_elt_list = Pages.form_content_elt_list
 948       type form_elt = Pages.form_elt
 949       type a_content_elt = Pages.a_content_elt
 950       type a_content_elt_list = Pages.a_content_elt_list
 951       type a_elt = Pages.a_elt
 952       type a_elt_list = Pages.a_elt_list
 953       type div_content_elt = Pages.div_content_elt
 954       type div_content_elt_list = Pages.div_content_elt_list
 955       type uri = Pages.uri
 956       type link_elt = Pages.link_elt
 957       type script_elt = Pages.script_elt
 958       type textarea_elt = Pages.textarea_elt
 959       type select_elt = Pages.select_elt
 960       type input_elt = Pages.input_elt
 961       type pcdata_elt = Pages.pcdata_elt
 962
 963       type a_attrib_t = Pages.a_attrib_t
 964       type form_attrib_t = Pages.form_attrib_t
 965       type input_attrib_t = Pages.input_attrib_t
 966       type textarea_attrib_t = Pages.textarea_attrib_t
 967       type select_attrib_t = Pages.select_attrib_t
 968       type link_attrib_t = Pages.link_attrib_t
 969       type script_attrib_t = Pages.script_attrib_t
 970       type input_type_t = Pages.input_type_t
 971
 972
 973 (** Functions to construct web pages: *)
 974
 975       let a ?a
 976           (service : ('get, unit, 'kind, 'tipo,'gn,'pn) service)
 977           (sp : server_params) content
 978           (getparams : 'get) =
 979         let suff,params_string = construct_params service.get_params_type getparams in
 980         let suff = (if service.url_prefix then Some [suff] else None) in
 981         let uri =
 982           (if service.external_service
 983           then
 984             (reconstruct_absolute_url_path
 985                (get_current_url sp) service.url suff)
 986           else
 987             (reconstruct_relative_url_path
 988                (get_current_url sp) service.url suff))
 989         in
 990         match service.url_state with
 991           None ->
 992             Pages.make_a ?a ~href:(add_to_string uri "?" params_string) content
 993         | Some i ->
 994             Pages.make_a ?a
 995               ~href:(add_to_string
 996                        (uri^"?"^state_param_name^"="^(string_of_int i))
 997                        "&" params_string)
 998               content
 999
1000 (* avec un formulaire caché (ça marche mais ce n'est pas du xhtml valide
1001    let stateparam = string_of_int i in
1002    let formname="hiddenform"^(string_of_int (counter ())) in
1003    let href="javascript:document."^formname^".submit ()" in
1004    << <a href=$href$>$str:name$<form name=$formname$ method="post" action=$v$ style="display:none">
1005    <input type="hidden" name=$state_param_name$
1006    value=$stateparam$/>
1007    </form></a> >>) *)
1008
1009 (*            let stateparam = string_of_int i in
1010    << <form name="hiddenform" method="post" action=$v$>
1011    <input type="hidden" name=$state_param_name$
1012    value=$stateparam$/>
1013    <a href="javascript:document.hiddenform.submit ()">$str:name$</a>
1014    </form> >>)
1015
1016    À VOIR ! IMPORTANT ! :
1017
1018    Pour les form get on peut faire pareil, du style :
1019    <input type="button"
1020    onClick="document.form1.submit();document.form2.submit()">
1021    (problème : on n'a pas accès au bouton)
1022
1023  *)
1024
1025       let make_params_names (params : ('t,'tipo,'n) params_type) : 'n =
1026         let rec aux prefix suffix = function
1027             TProd (t1, t2) -> Obj.magic (aux prefix suffix t1, aux prefix suffix t2)
1028           | TInt name -> Obj.magic (prefix^name^suffix)
1029           | TFloat name -> Obj.magic (prefix^name^suffix)
1030           | TString name -> Obj.magic (prefix^name^suffix)
1031           | TFile name -> Obj.magic (prefix^name^suffix)
1032           | TUserType (name,o,t) -> Obj.magic (prefix^name^suffix)
1033           | TUnit -> Obj.magic ("")
1034           | TSuffix -> Obj.magic ocsigen_suffix_name
1035           | TOption t -> Obj.magic (aux prefix suffix t)
1036           | TBool name -> Obj.magic (prefix^name^suffix)
1037           | TSum (t1,t2) -> Obj.magic (aux prefix suffix t1, aux prefix suffix t2)
1038           | TList (name,t1) -> Obj.magic
1039                 {it =
1040                  (fun f l endlist ->
1041                    let length = List.length l in
1042                    snd
1043                      (List.fold_right
1044                         (fun el (i,l2) ->
1045                           let i'= i-1 in
1046                           (i',(f (aux (prefix^name^".") (make_list_suffix i') t1) el)
1047                            @l2))
1048                         l
1049                         (length,endlist)))}
1050         in aux "" "" params
1051
1052       let get_form ?a
1053           (service : ('get,unit,'kind,'tipo,'gn,unit param_name) service)
1054           (sp : server_params)
1055           (f : 'gn -> Pages.form_content_elt_list) =
1056         let urlname =
1057           (if service.external_service
1058           then (reconstruct_absolute_url_path
1059                   (get_current_url sp) service.url None)
1060           else (reconstruct_relative_url_path
1061                   (get_current_url sp) service.url None)) in
1062         let state_param =
1063           (match  service.url_state with
1064             None -> None
1065           | Some i ->
1066               let i' = string_of_int i in
1067               Some (Pages.make_input ~typ:Pages.hidden
1068                       ~name:state_param_name ~value:i' ()))
1069         in
1070         let inside = f (make_params_names service.get_params_type) in
1071         let i1, i =
1072           match state_param, inside with
1073             Some s, i -> (Pages.make_hidden_field s),i
1074           | None, i -> Pages.remove_first i
1075         in Pages.make_get_form ?a ~action:urlname i1 i
1076
1077       let post_form ?a
1078           (service : ('get,'form,'kind,'tipo,'gn,'pn) service)
1079           (sp : server_params)
1080           (f : 'pn -> Pages.form_content_elt_list) (getparams : 'get) =
1081         let suff,params_string = construct_params service.get_params_type getparams in
1082         let suff = (if service.url_prefix then Some [suff] else None) in
1083         let urlname =
1084           (if service.external_service
1085           then (reconstruct_absolute_url_path
1086                   (get_current_url sp) service.url suff)
1087           else (reconstruct_relative_url_path
1088                   (get_current_url sp) service.url suff))
1089         in
1090         let state_param =
1091           (match  service.url_state with
1092             None -> None
1093           | Some i ->
1094               let i' = string_of_int i in
1095               Some (Pages.make_input ~typ:Pages.hidden
1096                       ~name:state_param_name ~value:i' ()))
1097         in
1098         let inside = f (make_params_names service.post_params_type) in
1099         let i1, i =
1100           match state_param, inside with
1101             Some s, i -> (Pages.make_hidden_field s),i
1102           | None, i -> Pages.remove_first i
1103         in Pages.make_post_form ?a
1104           ~action:(add_to_string urlname "?" params_string)
1105           i1 i
1106
1107       let make_uri
1108           (service : ('get, unit, 'kind, 'tipo,'gn,'pn) service) sp
1109           (getparams : 'get) : Pages.uri =
1110         let suff,params_string = construct_params service.get_params_type getparams in
1111         let suff = (if service.url_prefix then Some [suff] else None) in
1112         let uri =
1113           (if service.external_service
1114           then (reconstruct_absolute_url_path
1115                   (get_current_url sp) service.url suff)
1116           else (reconstruct_relative_url_path
1117                   (get_current_url sp) service.url suff))
1118         in
1119         match service.url_state with
1120           None ->
1121             Pages.uri_of_string (add_to_string uri "?" params_string)
1122         | Some i ->
1123             Pages.uri_of_string
1124               (add_to_string (uri^"?"^state_param_name^"="^(string_of_int i))
1125                  "&" params_string)
1126
1127 (* actions : *)
1128       let action_a ?a ?(reload=true) action h content =
1129         let formname="hiddenform"^(string_of_int (counter ())) in
1130         let href="javascript:document.getElementById(\""^formname^"\").submit ()" in
1131         let action_param_name = action_prefix^action_name in
1132         let action_param = (action.action_name) in
1133         let reload_name = action_prefix^action_reload in
1134         let reload_param =
1135           if reload
1136           then
1137             Pages.cons_form
1138               (Pages.make_hidden_field
1139                  (Pages.make_input ~typ:Pages.hidden
1140                     ~name:reload_name ~value:reload_name ()))
1141               Pages.empty_seq
1142           else Pages.empty_seq in
1143         let v = get_full_url h in
1144         Pages.make_post_form ~inline:true
1145           ~id:formname ~action:v
1146           (Pages.make_div ~classe:["inline"]
1147              (Pages.make_a ?a ~href:href content))
1148           (Pages.cons_form
1149              (Pages.make_hidden_field
1150                 (Pages.make_input ~typ:Pages.hidden ~name:action_param_name
1151                    ~value:action_param ()))
1152              reload_param)
1153
1154       let action_form ?a
1155           ?(reload=true) (action : ('a,'pn) action) h
1156           (f : 'pn -> Pages.form_content_elt_list) =
1157         let action_param_name = action_prefix^action_name in
1158         let action_param = (action.action_name) in
1159         let reload_name = action_prefix^action_reload in
1160         let action_line = Pages.make_input ~typ:Pages.hidden ~name:action_param_name ~value:action_param () in
1161         let v = get_full_url h in
1162         let inside = f (make_params_names action.action_params_type) in
1163         let inside_reload =
1164           if reload
1165           then
1166             Pages.cons_form
1167               (Pages.make_hidden_field
1168                  (Pages.make_input
1169                     ~typ:Pages.hidden ~name:reload_name ~value:reload_name ()))
1170               inside
1171           else inside
1172         in
1173         Pages.make_post_form ?a ~action:v
1174           (Pages.make_hidden_field action_line)
1175           inside_reload
1176
1177
1178
1179
1180       let js_script = Pages.make_js_script
1181       let css_link = Pages.make_css_link
1182
1183
1184       let gen_input ?a ?value ?(pwd = false)
1185           (string_of : 'a -> string) (name : 'a param_name) =
1186         let typ = if pwd then Pages.password else Pages.text in
1187         match value with
1188           None ->
1189             Pages.make_input ?a ~typ:typ ~name:name ()
1190         | Some v ->
1191             Pages.make_input
1192               ?a
1193               ~value:(string_of v)
1194               ~typ:typ ~name:name ()
1195
1196       let int_input ?a ?value (name : int param_name) =
1197         gen_input ?a ?value string_of_int name
1198       let float_input ?a ?value (name : float param_name) =
1199         gen_input ?a ?value string_of_float name
1200       let string_input ?a ?value (name : string param_name) =
1201         gen_input ?a ?value id name
1202       let user_type_input = gen_input ~pwd:false
1203
1204       let int_password_input ?a ?value (name : int param_name) =
1205         gen_input ~pwd:true ?a ?value string_of_int name
1206       let float_password_input ?a ?value (name : float param_name) =
1207         gen_input ~pwd:true ?a ?value string_of_float name
1208       let string_password_input ?a ?value (name : string param_name) =
1209         gen_input ~pwd:true ?a ?value id name
1210       let user_type_password_input = gen_input ~pwd:true
1211
1212       let hidden_gen_input ?a string_of (name : 'a param_name) v =
1213         let vv = string_of v in
1214         Pages.make_input ?a ~typ:Pages.hidden ~name:name ~value:vv ()
1215
1216       let hidden_int_input ?a (name : int param_name) v =
1217         hidden_gen_input ?a string_of_int name v
1218       let hidden_float_input ?a (name : float param_name) v =
1219         hidden_gen_input ?a string_of_float name v
1220       let hidden_string_input ?a (name : string param_name) v =
1221         hidden_gen_input ?a id name v
1222       let hidden_user_type_input = hidden_gen_input
1223
1224       let bool_checkbox ?a ?checked (name : bool param_name) =
1225         Pages.make_input ?a ?checked ~typ:Pages.checkbox ~name:name ()
1226
1227       let string_radio ?a ?checked (name : string option param_name) value =
1228         Pages.make_input
1229           ?a ?checked ~typ:Pages.radio ~name:name ~value:value ()
1230       let int_radio ?a ?checked (name : int option param_name) value =
1231         Pages.make_input
1232           ?a ?checked ~typ:Pages.radio ~name:name
1233           ~value:(string_of_int value) ()
1234       let float_radio ?a ?checked (name : float option param_name) value =
1235         Pages.make_input
1236           ?a ?checked ~typ:Pages.radio ~name:name
1237           ~value:(string_of_float value) ()
1238       let user_type_radio ?a ?checked string_of
1239           (name : 'a option param_name) (value : 'a) =
1240         Pages.make_input
1241           ?a ?checked ~typ:Pages.radio ~name:name ~value:(string_of value) ()
1242
1243       let textarea ?a (name : string param_name) =
1244         Pages.make_textarea ?a ~name:name
1245
1246       let select ?a ?selected fp lp (name : string param_name) =
1247         Pages.make_select ?a ~name:name ?selected fp lp
1248
1249       let submit_input ?a s =
1250         Pages.make_input ?a ~typ:Pages.submit ~value:s ()
1251
1252       let file_input ?a ?value (name : file_info param_name)  =
1253         Pages.make_input ?a ~typ:Pages.file ?value ~name:name ()
1254
1255     end : OCSIGENFORMSIG with
1256      type form_content_elt = Pages.form_content_elt
1257      and type form_content_elt_list = Pages.form_content_elt_list
1258      and type form_elt = Pages.form_elt
1259      and type a_content_elt = Pages.a_content_elt
1260      and type a_content_elt_list = Pages.a_content_elt_list
1261      and type a_elt = Pages.a_elt
1262      and type a_elt_list = Pages.a_elt_list
1263      and type div_content_elt = Pages.div_content_elt
1264      and type div_content_elt_list = Pages.div_content_elt_list
1265      and type uri = Pages.uri
1266      and type link_elt = Pages.link_elt
1267      and type script_elt = Pages.script_elt
1268      and type textarea_elt = Pages.textarea_elt
1269      and type select_elt = Pages.select_elt
1270      and type input_elt = Pages.input_elt
1271      and type pcdata_elt = Pages.pcdata_elt
1272      and type a_attrib_t = Pages.a_attrib_t
1273      and type form_attrib_t = Pages.form_attrib_t
1274      and type input_attrib_t = Pages.input_attrib_t
1275      and type textarea_attrib_t = Pages.textarea_attrib_t
1276      and type select_attrib_t = Pages.select_attrib_t
1277      and type link_attrib_t = Pages.link_attrib_t
1278      and type script_attrib_t = Pages.script_attrib_t
1279      and type input_type_t = Pages.input_type_t)
1280
1281
1282 (*****************************************************************************)
1283 (*****************************************************************************)
1284 (*****************************************************************************)
1285 (*****************************************************************************)
1286
1287
1288 module Xhtmlreg_ = struct
1289   open XHTML.M
1290   open Xhtmltypes
1291
1292   type page = xhtml elt
1293
1294   let headers = Ocsigen_senders.dyn_headers
1295   let send = Ocsigen_senders.send_xhtml_page
1296
1297 end
1298
1299 module Xhtmlforms_ = struct
1300   open XHTML.M
1301   open Xhtmltypes
1302
1303   type form_content_elt = form_content elt
1304   type form_content_elt_list = form_content elt list
1305   type uri = XHTML.M.uri
1306   type a_content_elt = a_content elt
1307   type a_content_elt_list = a_content elt list
1308   type div_content_elt = div_content elt
1309   type div_content_elt_list = div_content elt list
1310
1311   type a_elt = a elt
1312   type a_elt_list = a elt list
1313   type form_elt = form elt
1314
1315   type textarea_elt = textarea elt
1316   type select_elt = select elt
1317   type input_elt = input elt
1318
1319   type link_elt = link elt
1320   type script_elt = script elt
1321
1322   type pcdata_elt = pcdata elt
1323
1324   type a_attrib_t = Xhtmltypes.a_attrib XHTML.M.attrib list
1325   type form_attrib_t = Xhtmltypes.form_attrib XHTML.M.attrib list
1326   type input_attrib_t = Xhtmltypes.input_attrib XHTML.M.attrib list
1327   type textarea_attrib_t = Xhtmltypes.textarea_attrib XHTML.M.attrib list
1328   type select_attrib_t = Xhtmltypes.select_attrib XHTML.M.attrib list
1329   type link_attrib_t = Xhtmltypes.link_attrib XHTML.M.attrib list
1330   type script_attrib_t = Xhtmltypes.script_attrib XHTML.M.attrib list
1331
1332   type input_type_t =
1333       [`Button | `Checkbox | `File | `Hidden | `Image
1334     | `Password | `Radio | `Reset | `Submit | `Text]
1335
1336   let hidden = `Hidden
1337   let text = `Text
1338   let password = `Password
1339   let checkbox = `Checkbox
1340   let radio = `Radio
1341   let submit = `Submit
1342   let file = `File
1343
1344   let uri_of_string = XHTML.M.uri_of_string
1345
1346   let empty_seq = []
1347   let cons_form a l = a::l
1348
1349   let make_a ?(a=[]) ~href l : a_elt =
1350     XHTML.M.a ~a:((a_href (uri_of_string href))::a) l
1351
1352   let make_get_form ?(a=[]) ~action elt1 elts : form_elt =
1353     form ~a:((a_method `Get)::a)
1354       ~action:(uri_of_string action) elt1 elts
1355
1356   let make_post_form ?(a=[]) ~action ?id ?(inline = false) elt1 elts
1357       : form_elt =
1358     let aa = (match id with
1359       None -> a
1360     | Some i -> (a_id i)::a)
1361     in
1362     form ~a:((XHTML.M.a_enctype "multipart/form-data")::
1363              (* Always Multipart!!! How to test if there is a file?? *)
1364              (a_method `Post)::
1365              (if inline then (a_class ["inline"])::aa else aa))
1366       ~action:(uri_of_string action) elt1 elts
1367
1368   let make_hidden_field content =
1369     div ~a:[a_class ["nodisplay"]] [content]
1370
1371   let make_div ~classe (c : a_elt) =
1372     div ~a:[a_class classe] [(c :> div_content_elt)]
1373
1374   let make_empty_form_content () = p [pcdata ""] (**** à revoir !!!!! *)
1375
1376   let remove_first = function
1377       a::l -> a,l
1378     | [] -> (make_empty_form_content ()), []
1379
1380   let make_input ?(a=[]) ?(checked=false) ~typ ?name ?value () =
1381     let a2 = match value with
1382       None -> a
1383     | Some v -> (a_value v)::a
1384     in
1385     let a3 = match name with
1386       None -> a2
1387     | Some v -> (a_name v)::a2
1388     in
1389     let a4 = if checked then (a_checked `Checked)::a3 else a3 in
1390     input ~a:((a_input_type typ)::a4) ()
1391
1392   let make_textarea ?(a=[]) ~name:name =
1393     let a3 = (a_name name)::a in
1394     textarea ~a:a3
1395
1396   let make_select ?(a=[]) ~name:name ?(selected=None) fp lp =
1397     let build_option selec p =
1398       let lsel = if selec then [a_selected `Selected] else []
1399       in
1400         match p with
1401         | (None, s) -> option ~a:lsel (pcdata s)
1402         | (Some v, s) -> option ~a:((a_value v)::lsel) (pcdata s)
1403     in
1404       match selected with
1405       | None -> select ~a:((a_name name)::a) (build_option false fp)
1406           (List.map (build_option false) lp)
1407       | Some p -> select ~a:((a_name name)::a) (build_option true p)
1408           ((build_option false fp)::(List.map (build_option false) lp))
1409
1410   let make_css_link ?(a=[]) uri =
1411     link ~a:((a_href uri)::
1412              (a_type "text/css")::(a_rel [`Stylesheet])::a) ()
1413
1414   let make_js_script ?(a=[]) uri =
1415     script ~a:((a_src uri)::a) ~contenttype:"text/javascript" (pcdata "")
1416
1417 end
1418
1419
1420
1421 (****************************************************************************)
1422 (*****************************************************************************)
1423
1424 module Xhtmlforms = MakeForms(Xhtmlforms_)
1425 module Xhtmlreg = MakeRegister(Xhtmlreg_)
1426
1427 (* As we want -> [> a ] elt and not -> [ a ] elt, we define a new module: *)
1428 module Xhtml = struct
1429   open XHTML.M
1430   open Xhtmltypes
1431   include Xhtmlforms
1432   include Xhtmlreg
1433   let a = (a : ?a:([< Xhtmltypes.a_attrib > `Href ] XHTML.M.attrib list) ->
1434     ('get, unit, 'b, [< `WithSuffix | `WithoutSuffix ], 'c, unit param_name)
1435       service ->
1436         server_params ->
1437           Xhtmltypes.a_content XHTML.M.elt list ->
1438             'get -> Xhtmltypes.a XHTML.M.elt
1439                 :> ?a:([< Xhtmltypes.a_attrib > `Href ] XHTML.M.attrib list) ->
1440                   ('get, unit, 'b, [< `WithSuffix | `WithoutSuffix ], 'c, unit param_name)
1441                     service ->
1442                       server_params ->
1443                         Xhtmltypes.a_content XHTML.M.elt list ->
1444                           'get -> [> Xhtmltypes.a] XHTML.M.elt)
1445
1446   let css_link =
1447     (css_link : ?a:([< link_attrib > `Href `Rel `Type ] attrib list) ->
1448       uri -> link elt
1449           :> ?a:([< link_attrib > `Href `Rel `Type ] attrib list) ->
1450             uri -> [> link ] elt)
1451
1452   let js_script = (js_script
1453                      : ?a:([< script_attrib > `Src ] attrib list) ->
1454                        uri -> script elt
1455                            :> ?a:([< script_attrib > `Src ] attrib list) ->
1456                              uri -> [> script ] elt)
1457
1458   let get_form =
1459     (get_form
1460        : ?a:([< form_attrib > `Method ] attrib list) ->
1461          ('get, unit, 'c, 'd, 'getnames, unit param_name) service ->
1462            server_params -> ('getnames -> form_content elt list) -> form elt
1463                :> ?a:([< form_attrib > `Method ] attrib list) ->
1464                  ('get, unit, 'c, 'd, 'getnames, unit param_name) service ->
1465                    server_params -> ('getnames -> form_content_elt_list) -> [>form] elt)
1466
1467   let post_form =
1468     (post_form
1469        : ?a:([< form_attrib > `Class `Id `Method ] attrib list) ->
1470          ('get, 'post, 'c, [< `WithSuffix | `WithoutSuffix ], 'getnames, 'postnames) service ->
1471            server_params ->
1472              ('postnames -> form_content elt list) -> 'get -> form elt
1473                  :> ?a:([< form_attrib > `Class `Id `Method ] attrib list) ->
1474                    ('get, 'post, 'c, [< `WithSuffix | `WithoutSuffix ], 'getnames, 'postnames) service ->
1475                      server_params ->
1476                        ('postnames -> form_content_elt_list) -> 'get -> [>form] elt)
1477
1478   let int_input =
1479     (int_input
1480        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1481          ?value:int ->
1482            int param_name -> input elt
1483                :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1484                  ?value:int ->
1485                  int param_name -> [> input ] elt)
1486
1487   let float_input =
1488     (float_input
1489        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1490          ?value:float ->
1491          float param_name -> input elt
1492              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1493                ?value:float ->
1494                  float param_name -> [> input ] elt)
1495
1496   let user_type_input =
1497     (user_type_input
1498        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1499          ?value:'a ->
1500            ('a -> string) ->
1501              'a param_name -> input elt
1502                  :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1503                    ?value:'a ->
1504                      ('a -> string) ->
1505                        'a param_name -> [> input ] elt)
1506
1507   let string_input =
1508     (string_input
1509        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1510          ?value:string -> string param_name -> input elt
1511            :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1512              ?value:string -> string param_name -> [> input ] elt)
1513
1514   let int_password_input =
1515     (int_password_input
1516        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1517          ?value:int ->
1518            int param_name -> input elt
1519                :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1520                  ?value:int ->
1521                  int param_name -> [> input ] elt)
1522
1523   let float_password_input =
1524     (float_password_input
1525        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1526          ?value:float ->
1527          float param_name -> input elt
1528              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1529                ?value:float ->
1530                  float param_name -> [> input ] elt)
1531
1532   let user_type_password_input =
1533     (user_type_password_input
1534        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1535          ?value:'a ->
1536            ('a -> string) ->
1537              'a param_name -> input elt
1538                  :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1539                    ?value:'a ->
1540                      ('a -> string) ->
1541                        'a param_name -> [> input ] elt)
1542
1543   let string_password_input =
1544     (string_password_input
1545        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1546          ?value:string -> string param_name -> input elt
1547            :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1548              ?value:string -> string param_name -> [> input ] elt)
1549
1550   let hidden_int_input =
1551     (hidden_int_input
1552        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1553          int param_name -> int -> input elt
1554              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1555                int param_name -> int -> [> input ] elt)
1556   let hidden_float_input =
1557     (hidden_float_input
1558        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1559          float param_name -> float -> input elt
1560              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1561                float param_name -> float -> [> input ] elt)
1562   let hidden_string_input =
1563     (hidden_string_input
1564        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1565          string param_name -> string -> input elt
1566              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1567                string param_name -> string -> [> input ] elt)
1568   let hidden_user_type_input =
1569     (hidden_user_type_input
1570        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1571          ('a -> string) ->
1572            'a param_name -> 'a -> input elt
1573                :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1574                  ('a -> string) ->
1575                    'a param_name -> 'a -> [> input ] elt)
1576
1577
1578
1579   let bool_checkbox =
1580     (bool_checkbox
1581        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1582          ?checked:bool ->
1583            bool param_name -> input elt
1584                :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1585                  ?checked:bool ->
1586                    bool param_name -> [> input ] elt)
1587
1588   let string_radio =
1589     (string_radio
1590        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1591          ?checked:bool ->
1592             string option param_name -> string -> input elt
1593              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1594                ?checked:bool ->
1595                   string option param_name -> string -> [> input ] elt)
1596   let int_radio =
1597     (int_radio
1598        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1599          ?checked:bool ->
1600             int option param_name -> int -> input elt
1601              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1602                ?checked:bool ->
1603                   int option param_name -> int -> [> input ] elt)
1604   let float_radio =
1605     (float_radio
1606        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1607          ?checked:bool ->
1608             float option param_name -> float -> input elt
1609              :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1610                ?checked:bool ->
1611                   float option param_name -> float -> [> input ] elt)
1612   let user_type_radio =
1613     (user_type_radio
1614        : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1615          ?checked:bool ->
1616            ('a -> string) ->
1617              'a option param_name -> 'a -> input elt
1618                  :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1619                    ?checked:bool ->
1620                      ('a -> string) ->
1621                        'a option param_name -> 'a -> [> input ] elt)
1622
1623   let textarea = (textarea
1624                     : ?a:([< textarea_attrib > `Name ] attrib list ) ->
1625                       string param_name -> rows:number -> cols:number ->
1626                         [ `PCDATA ] XHTML.M.elt ->
1627                           textarea elt
1628                             :> ?a:([< textarea_attrib > `Name ] attrib list ) ->
1629                               string param_name -> rows:number -> cols:number ->
1630                                 [ `PCDATA ] XHTML.M.elt ->
1631                                   [> textarea ] elt)
1632
1633   let select = (select
1634                    : ?a:([< select_attrib > `Name ] attrib list ) ->
1635                  ?selected:((string option * string) option) ->
1636                  (string option * string) ->
1637                  ((string option * string) list) ->
1638                  string param_name ->
1639                  select elt
1640                    :> ?a:([< select_attrib > `Name ] attrib list ) ->
1641                  ?selected:((string option * string) option) ->
1642                  (string option * string) ->
1643                  ((string option * string) list) ->
1644                  string param_name ->
1645                  [> select ] elt)
1646
1647   let submit_input = (submit_input
1648                         : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1649                           string -> input elt
1650                               :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1651                                 string -> [> input ] elt)
1652
1653   let file_input = (file_input
1654                           : ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1655                           ?value:string -> string param_name -> input elt
1656                               :> ?a:([< input_attrib > `Input_Type `Name `Value ] attrib list ) ->
1657                                 ?value:string -> file_info param_name -> [> input ] elt)
1658
1659   let action_a = (action_a
1660                     : ?a:([< a_attrib > `Href ] attrib list) ->
1661                       ?reload:bool ->
1662                         ('a,'b) action ->
1663                           server_params ->
1664                             a_content elt list ->
1665                               form elt
1666                                 :> ?a:([< a_attrib > `Href ] attrib list) ->
1667                                   ?reload:bool ->
1668                                     ('a,'b) action ->
1669                                       server_params ->
1670                                         a_content_elt_list ->
1671                                           [> form ] elt)
1672
1673   let action_form = (action_form
1674                        : ?a:([< form_attrib > `Class `Id `Method ] attrib list) ->
1675                          ?reload:bool ->
1676                            ('a, 'b) action ->
1677                              server_params ->
1678                                ('b -> form_content elt list) ->
1679                                  form elt
1680                                    :> ?a:([< form_attrib > `Class `Id `Method ] attrib list) ->
1681                                      ?reload:bool ->
1682                                        ('a, 'b) action ->
1683                                          server_params ->
1684                                            ('b -> form_content_elt_list) ->
1685                                              [> form ] elt)
1686
1687 end
1688
1689 (****************************************************************************)
1690 (****************************************************************************)
1691 (****************************************************************************)
1692 (****************************************************************************)
1693
1694 module Textreg_ = struct
1695   open XHTML.M
1696   open Xhtmltypes
1697
1698   type page = string
1699
1700   let headers = Ocsigen_senders.dyn_headers
1701   let send = Ocsigen_senders.send_text_page ~contenttype:"text/html"
1702
1703 end
1704
1705 module Textforms_ = struct
1706   open XHTML.M
1707   open Xhtmltypes
1708
1709   type page = string
1710   type form_content_elt = string
1711   type form_content_elt_list = string
1712   type uri = string
1713   type a_content_elt = string
1714   type a_content_elt_list = string
1715   type div_content_elt = string
1716   type div_content_elt_list = string
1717
1718   type a_elt = string
1719   type a_elt_list = string
1720   type form_elt = string
1721
1722   type textarea_elt = string
1723   type select_elt = string
1724   type input_elt = string
1725
1726   type link_elt = string
1727   type script_elt = string
1728
1729   type pcdata_elt = string
1730
1731   type a_attrib_t = string
1732   type form_attrib_t = string
1733   type input_attrib_t = string
1734   type textarea_attrib_t = string
1735   type select_attrib_t = string
1736   type link_attrib_t = string
1737   type script_attrib_t = string
1738
1739   type input_type_t = string
1740
1741   let hidden = "hidden"
1742   let text = "text"
1743   let password = "password"
1744   let checkbox = "checkbox"
1745   let radio = "radio"
1746   let submit = "submit"
1747   let file = "file"
1748
1749   let uri_of_string x = x
1750
1751   let empty_seq = ""
1752   let cons_form a l = a^l
1753
1754   let make_a ?(a="") ~href l : a_elt =
1755     "<a href=\""^href^"\""^a^">"^(* List.fold_left (^) "" l *) l^"</a>"
1756
1757   let make_get_form ?(a="") ~action elt1 elts : form_elt =
1758     "<form method=\"get\" action=\""^(uri_of_string action)^"\""^a^">"^
1759     elt1^(*List.fold_left (^) "" elts *) elts^"</form>"
1760
1761   let make_post_form ?(a="") ~action ?id ?(inline = false) elt1 elts
1762       : form_elt =
1763     let aa = "enctype=\"multipart/form-data\" "
1764         (* Always Multipart!!! How to test if there is a file?? *)
1765       ^(match id with
1766         None -> a
1767       | Some i -> " id="^i^" "^a)
1768     in
1769     "<form method=\"post\" action=\""^(uri_of_string action)^"\""^
1770     (if inline then "style=\"display: inline\"" else "")^aa^">"^
1771     elt1^(* List.fold_left (^) "" elts*) elts^"</form>"
1772
1773   let make_hidden_field content =
1774     "<div style=\"display: none\""^content^"</div>"
1775
1776   let make_div ~classe c =
1777     "<div class=\""^(List.fold_left (fun a b -> a^" "^b) "" classe)^"\""^
1778     c^"</div>"
1779 (*    (List.fold_left (^) "" c)^"</div>" *)
1780
1781   let remove_first l = "",l
1782
1783   let make_input ?(a="") ?(checked=false) ~typ ?name ?value () =
1784     let a2 = match value with
1785       None -> a
1786     | Some v -> " value="^v^" "^a
1787     in
1788     let a3 = match name with
1789       None -> a2
1790     | Some v -> " name="^v^" "^a2
1791     in
1792     let a4 = if checked then " checked=\"checked\" "^a3 else a3 in
1793     "<input type=\""^typ^"\" "^a4^"/>"
1794
1795   let make_textarea ?(a="") ~name:name ~rows ~cols s =
1796     "<textarea name=\""^name^"\" rows=\""^(string_of_int rows)^
1797     "\" cols=\""^(string_of_int cols)^"\" "^a^">"^s^"</textarea>"
1798
1799   let make_select ?(a="") ~name:name ?(selected=None) fp lp =
1800     let build_option selec p =
1801       let lsel = if selec then " selected=\"selected\"" else ""
1802       in
1803         match p with
1804         | (None, s) -> "<option"^lsel^">"^s^"</option>"
1805         | (Some v, s) -> "<option value=\""^v^"\""^lsel^">"^s^"</option>"
1806     in
1807       match selected with
1808       | None -> ("<select name=\""^name^"\" "^a^">")^
1809           (build_option false fp)^
1810           (List.fold_left (fun s p -> (build_option false p)^s) "" lp)^
1811           "</select>"
1812       | Some p -> ("<select name=\""^name^"\" "^a^">")^
1813           (build_option true p)^
1814           ((build_option false fp)^
1815            (List.fold_left (fun s p -> (build_option false p)^s) "" lp))^
1816           "</select>"
1817
1818   let make_css_link ?(a="") uri =
1819     "<link href=\""^uri^" type=\"text/css\" rel=\"stylesheet\" "^a^"/>"
1820
1821   let make_js_script ?(a="") uri =
1822     "<script src=\""^uri^" contenttype=\"text/javascript\" "^a^"></script>"
1823
1824 end
1825
1826
1827
1828 (****************************************************************************)
1829 (****************************************************************************)
1830
1831 module Textforms = MakeForms(Textforms_)
1832 module Textreg = MakeRegister(Textreg_)
1833
1834 module Text = struct
1835   include Textforms
1836   include Textreg
1837 end
1838
1839