src/common/eliom_mkforms.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * Module Eliom_mkforms
   4  * Copyright (C) 2007 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 Eliom_pervasives
  22
  23 open Lwt
  24 open Eliom_parameters
  25 open Eliom_services
  26 open Eliom_uri
  27
  28 module type FORMS_PARAM = "sigs/eliom_forms_param.mli"
  29
  30 module MakeForms(Pages : FORMS_PARAM) = struct
  31
  32   (** Functions to construct web pages: *)
  33
  34   let make_proto_prefix = make_proto_prefix
  35
  36   let make_string_uri = make_string_uri
  37
  38   let make_uri_components = make_uri_components
  39
  40   let make_post_uri_components = make_post_uri_components
  41
  42   let make_uri
  43       ?absolute
  44       ?absolute_path
  45       ?https ~service ?hostname ?port ?fragment
  46       ?keep_nl_params ?nl_params gp =
  47     Pages.uri_of_string (make_string_uri
  48                            ?absolute ?absolute_path
  49                            ?https ?fragment ~service
  50                            ?hostname ?port ?keep_nl_params ?nl_params gp)
  51
  52
  53   let a ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
  54       ?keep_nl_params ?nl_params ?no_appl content getparams =
  55     let href =
  56       Eliom_lazy.from_fun
  57         (fun () ->
  58           Pages.uri_of_string
  59             (make_string_uri
  60                ?absolute ?absolute_path ?https ~service ?hostname ?port ?fragment
  61                ?keep_nl_params ?nl_params getparams))
  62     in
  63     Pages.make_a ?a ~href content
  64
  65   let get_form_
  66         bind return
  67         ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
  68         ?(nl_params = Eliom_parameters.empty_nl_params_set) ?keep_nl_params
  69         f =
  70
  71     let getparamstype = get_get_params_type_ service in
  72     let issuffix, paramnames = make_params_names getparamstype in
  73
  74     let components =
  75       Eliom_lazy.from_fun
  76         (fun () ->
  77           make_uri_components_
  78             ?absolute ?absolute_path ?https ~service ?hostname ?port ?fragment
  79             ~nl_params ?keep_nl_params
  80             () )
  81     in
  82
  83     let uri =
  84       Eliom_lazy.from_fun
  85         (fun () ->
  86           let (uri, hiddenparams, fragment) = Eliom_lazy.force components in
  87           let uri =
  88             if issuffix then
  89               if uri.[String.length uri - 1] = '/'
  90               then uri^Eliom_common.eliom_nosuffix_page
  91               else String.concat "/" [uri; Eliom_common.eliom_nosuffix_page]
  92             else uri
  93           in
  94           let uri =
  95             match fragment with
  96             | None -> uri
  97             | Some f -> String.concat "#" [uri; Url.encode f]
  98           in
  99           Pages.uri_of_string uri)
 100     in
 101
 102     bind (f paramnames)
 103       (fun inside ->
 104         let inside =
 105           Eliom_lazy.from_fun
 106             (fun () ->
 107               let (uri, hiddenparams, fragment) = Eliom_lazy.force components in
 108               List.fold_left
 109                 (fun s (n,v) ->
 110                   Pages.cons_form
 111                     (Pages.make_hidden_field
 112                        (Some (Pages.make_input
 113                                 ~typ:Pages.hidden
 114                                 ~name:n ~value:v ())))
 115                     s
 116                 )
 117                 inside
 118                 hiddenparams)
 119         in
 120         return (Pages.make_get_form ?a ~action:uri inside))
 121
 122   let get_form
 123       ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
 124       ?keep_nl_params ?nl_params ?no_appl f =
 125     get_form_
 126       (fun x f -> f x) (fun x -> x)
 127       ?absolute ?absolute_path
 128       ?https ?a ~service ?keep_nl_params
 129       ?nl_params ?hostname ?port ?fragment f
 130
 131   let lwt_get_form
 132       ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
 133       ?keep_nl_params ?nl_params ?no_appl f =
 134     get_form_
 135       Lwt.bind Lwt.return
 136       ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
 137       ?nl_params ?keep_nl_params f
 138
 139   let post_form_
 140       bind return
 141       ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
 142       ?(nl_params = Eliom_parameters.empty_nl_params_set)
 143       ?(keep_nl_params : [ `All | `Persistent | `None ] option)
 144       ?keep_get_na_params
 145       f getparams =
 146
 147     let getparamstype = get_post_params_type_ service in
 148     let _, paramnames = make_params_names getparamstype in
 149
 150     let components =
 151       Eliom_lazy.from_fun
 152         (fun () ->
 153           make_post_uri_components_
 154             ?absolute ?absolute_path ?https ~service ?hostname ?port ?fragment
 155             ?keep_nl_params ~nl_params ?keep_get_na_params
 156             getparams
 157             ())
 158     in
 159
 160     bind (f paramnames)
 161       (fun inside ->
 162          let inside =
 163            Eliom_lazy.from_fun
 164              (fun () ->
 165                let (uri, getparams, fragment, hiddenparams) =
 166                  Eliom_lazy.force components in
 167                List.fold_left
 168                  (fun s (n,v) ->
 169                    Pages.cons_form
 170                      (Pages.make_hidden_field
 171                         (Some (Pages.make_input
 172                                  ~typ:Pages.hidden
 173                                  ~name:n ~value:v ())))
 174                      s
 175                  )
 176                  inside
 177                  hiddenparams) in
 178          let uri =
 179            Eliom_lazy.from_fun
 180              (fun () ->
 181                let (uri, getparams, fragment, hiddenparams) =
 182                  Eliom_lazy.force components in
 183                Pages.uri_of_string (make_string_uri_from_components (uri, getparams, fragment)))
 184          in
 185          return (Pages.make_post_form ?a ~action:uri inside))
 186
 187   let post_form
 188       ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
 189       ?keep_nl_params ?keep_get_na_params ?nl_params ?no_appl f getparams =
 190     post_form_
 191       (fun x f -> f x) (fun x -> x)
 192       ?absolute ?absolute_path ?https ?a ~service ?hostname ?port
 193       ?fragment ?keep_get_na_params
 194       ?keep_nl_params ?nl_params
 195       f getparams
 196
 197   let lwt_post_form
 198       ?absolute ?absolute_path ?https ?a ~service ?hostname ?port ?fragment
 199       ?keep_nl_params ?keep_get_na_params
 200       ?nl_params
 201       ?no_appl f getparams =
 202     post_form_ Lwt.bind Lwt.return
 203       ?absolute ?absolute_path
 204       ?https ?a ~service ?hostname ?port
 205       ?fragment ?keep_get_na_params ?keep_nl_params ?nl_params
 206       f getparams
 207
 208   let js_script = Pages.make_js_script
 209   let css_link = Pages.make_css_link
 210
 211   let gen_input ?a ~(input_type: Pages.input_type_t)
 212       ?value ?src
 213       ?name (string_of : 'a -> string) =
 214     let name = match name with
 215       | None -> None
 216       | Some n -> Some (string_of_param_name n)
 217     in
 218     (match value with
 219      | None ->
 220          Pages.make_input ?a ~typ:input_type ?name ?src ()
 221      | Some v ->
 222          Pages.make_input
 223            ?a
 224            ~value:(string_of v)
 225            ~typ:input_type
 226            ?src
 227            ?name
 228            ())
 229
 230   let int_input ?a ~input_type
 231       ?name ?value () =
 232     gen_input ?a ~input_type ?value ?name string_of_int
 233
 234   let int32_input ?a ~input_type
 235       ?name ?value () =
 236     gen_input ?a ~input_type ?value ?name Int32.to_string
 237
 238   let int64_input ?a ~input_type
 239       ?name ?value () =
 240     gen_input ?a ~input_type ?value ?name Int64.to_string
 241
 242   let float_input ?a ~input_type
 243       ?name ?value () =
 244     gen_input ?a ~input_type ?value ?name string_of_float
 245
 246   let string_input ?a ~input_type
 247       ?name ?value () =
 248     gen_input ?a ~input_type ?value ?name id
 249
 250   let user_type_input string_of ?a ~input_type
 251       ?name ?value () =
 252     gen_input ?a ~input_type ?value ?name string_of
 253
 254   let raw_input ?a ~input_type ?name ?value () =
 255     (match value with
 256      | None ->
 257          Pages.make_input ?a ~typ:input_type ?name ()
 258      | Some v ->
 259          Pages.make_input
 260            ?a
 261            ~value:v
 262            ~typ:input_type
 263            ?name
 264            ())
 265
 266   let file_input ?a ~name () =
 267     Pages.make_input ?a ~typ:Pages.file ~name:(string_of_param_name name) ()
 268       (* value attribute not supported by browsers for security reasons *)
 269
 270   let image_input ?a ~name ?src () =
 271     Pages.make_input
 272       ?a ~typ:Pages.image
 273       ~name:(string_of_param_name name) ?src ()
 274       (* The behaviour of <input type="image"> without name attribute
 275          depends on browsers *)
 276
 277   let int_image_input ?a ~name ~value ?src () =
 278     gen_input ?a ~input_type:Pages.image ~name
 279       ~value ?src string_of_int
 280
 281   let int32_image_input ?a ~name ~value ?src () =
 282     gen_input ?a ~input_type:Pages.image ~name
 283       ~value ?src Int32.to_string
 284
 285   let int64_image_input ?a ~name ~value ?src () =
 286     gen_input ?a ~input_type:Pages.image ~name
 287       ~value ?src Int64.to_string
 288
 289   let float_image_input ?a ~name ~value ?src () =
 290     gen_input ?a ~input_type:Pages.image ~name
 291       ~value ?src string_of_float
 292
 293   let string_image_input ?a ~name ~value ?src () =
 294     gen_input ?a ~input_type:Pages.image ~name
 295       ~value ?src id
 296
 297   let user_type_image_input string_of ?a ~name ~value ?src () =
 298     gen_input ?a ~input_type:Pages.image ~name
 299       ~value ?src string_of
 300
 301   let raw_image_input ?a ~(name : string) ~value ?src () =
 302     Pages.make_input
 303       ?a
 304       ~value
 305       ~typ:Pages.image
 306       ?src
 307       ~name
 308       ()
 309
 310   let bool_checkbox ?a ?checked ~name () =
 311     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 312       ~name:(string_of_param_name name) ()
 313
 314   let int_checkbox ?a ?checked ~name ~value () =
 315     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 316       ~name:(string_of_param_name name) ~value:(string_of_int value) ()
 317
 318   let int32_checkbox ?a ?checked ~name ~value () =
 319     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 320       ~name:(string_of_param_name name) ~value:(Int32.to_string value) ()
 321
 322   let int64_checkbox ?a ?checked ~name ~value () =
 323     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 324       ~name:(string_of_param_name name) ~value:(Int64.to_string value) ()
 325
 326   let float_checkbox ?a ?checked ~name ~value () =
 327     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 328       ~name:(string_of_param_name name) ~value:(string_of_float value) ()
 329
 330   let string_checkbox ?a ?checked ~name ~value () =
 331     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 332       ~name:(string_of_param_name name) ~value ()
 333
 334   let user_type_checkbox string_of ?a ?checked ~name ~value () =
 335     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 336       ~name:(string_of_param_name name) ~value:(string_of value) ()
 337
 338   let raw_checkbox ?a ?checked ~name ~value () =
 339     Pages.make_input ?a ?checked ~typ:Pages.checkbox
 340       ~name:name ~value ()
 341
 342
 343   let string_radio ?a ?checked ~name ~value () =
 344     Pages.make_input
 345       ?a ?checked ~typ:Pages.radio
 346       ~name:(string_of_param_name name) ~value ()
 347
 348   let int_radio ?a ?checked ~name ~value () =
 349     Pages.make_input
 350       ?a ?checked ~typ:Pages.radio
 351       ~name:(string_of_param_name name) ~value:(string_of_int value) ()
 352
 353   let int32_radio ?a ?checked ~name ~value () =
 354     Pages.make_input
 355       ?a ?checked ~typ:Pages.radio
 356       ~name:(string_of_param_name name) ~value:(Int32.to_string value) ()
 357
 358   let int64_radio ?a ?checked ~name ~value () =
 359     Pages.make_input
 360       ?a ?checked ~typ:Pages.radio
 361       ~name:(string_of_param_name name) ~value:(Int64.to_string value) ()
 362
 363   let float_radio ?a ?checked ~name ~value () =
 364     Pages.make_input
 365       ?a ?checked ~typ:Pages.radio
 366       ~name:(string_of_param_name name) ~value:(string_of_float value) ()
 367
 368   let user_type_radio string_of ?a ?checked ~name ~value () =
 369     Pages.make_input
 370       ?a ?checked ~typ:Pages.radio
 371       ~name:(string_of_param_name name) ~value:(string_of value) ()
 372
 373   let raw_radio ?a ?checked ~(name : string) ~value () =
 374     Pages.make_input
 375       ?a ?checked ~typ:Pages.radio
 376       ~name:name ~value:value ()
 377
 378   let string_button ?a ~name ~value c =
 379     Pages.make_button ?a ~button_type:Pages.buttonsubmit
 380       ~name:(string_of_param_name name) ~value c
 381
 382   let int_button ?a ~name ~value c =
 383     Pages.make_button ?a ~button_type:Pages.buttonsubmit
 384       ~name:(string_of_param_name name) ~value:(string_of_int value) c
 385
 386   let int32_button ?a ~name ~value c =
 387     Pages.make_button ?a ~button_type:Pages.buttonsubmit
 388       ~name:(string_of_param_name name) ~value:(Int32.to_string value) c
 389
 390   let int64_button ?a ~name ~value c =
 391     Pages.make_button ?a ~button_type:Pages.buttonsubmit
 392       ~name:(string_of_param_name name) ~value:(Int64.to_string value) c
 393
 394   let float_button ?a ~name ~value c =
 395     Pages.make_button ?a ~button_type:Pages.buttonsubmit
 396       ~name:(string_of_param_name name) ~value:(string_of_float value) c
 397
 398   let user_type_button string_of ?a ~name ~value c =
 399     Pages.make_button ?a ~button_type:Pages.buttonsubmit
 400       ~name:(string_of_param_name name) ~value:(string_of value) c
 401
 402   let raw_button ?a ~button_type ~name ~value c =
 403     Pages.make_button ?a ~button_type ~name ~value c
 404
 405   let button ?a ~button_type c =
 406     Pages.make_button ?a ~button_type c
 407
 408
 409   let textarea ?a ~name =
 410     Pages.make_textarea ?a ~name:(string_of_param_name name)
 411
 412   let raw_textarea ?a ~name =
 413     Pages.make_textarea ?a ~name
 414
 415
 416
 417   type 'a soption =
 418       Pages.option_attrib_t
 419       * 'a (* Content (or value if the following is present) *)
 420       * Pages.pcdata_elt option (* if content different from value *)
 421       * bool (* selected *)
 422
 423   type 'a select_opt =
 424     | Optgroup of
 425         Pages.optgroup_attrib_t
 426         * string (* label *)
 427         * 'a soption
 428         * 'a soption list
 429     | Option of 'a soption
 430
 431   let gen_select ?a ?(multiple=false) ~name
 432       (fl : 'a select_opt) (ol : 'a select_opt list) string_of =
 433
 434
 435     let normalize_selected l =
 436       (* We change the list of option to have exactly one selected item.
 437          We do this because the behaviour of browsers differs.
 438          We select the first one if nothing is selected.
 439          We select the first selected if several are selected.
 440          Thus all browsers will behave the same way.
 441       *)
 442       let aux1 trouve ((a, b, c, selected) as line) =
 443         if trouve
 444         then ((a, b, c, false), true)
 445         else if selected
 446         then (line, true)
 447         else (line, false)
 448       in
 449       let rec aux2 trouve = function
 450         | line::l ->
 451             let (line, trouve) = aux1 trouve line in
 452             let (l, trouve) = aux2 trouve l in
 453             (line::l, trouve)
 454         | [] -> ([], trouve)
 455       in
 456       let rec aux trouve = function
 457         | (Option line)::l ->
 458             let (line, trouve) = aux1 trouve line in
 459             let (l, trouve) = aux trouve l in
 460             ((Option line)::l, trouve)
 461         | (Optgroup (a, b, fl, ol))::l ->
 462             let (fl, trouve) = aux1 trouve fl in
 463             let (ol, trouve) = aux2 trouve ol in
 464             let (l, trouve) = aux trouve l in
 465             ((Optgroup (a, b, fl, ol))::l, trouve)
 466         | [] -> ([], trouve)
 467       in
 468       let select_first = function
 469         | Option (a, b, c, _) -> Option (a, b, c, true)
 470         | Optgroup (a, b, (c, d, e, _), ol) ->
 471             Optgroup (a, b, (c, d, e, true), ol)
 472       in
 473       let (newl, trouve) = aux false l in
 474       if trouve
 475       then ((List.hd newl), (List.tl newl))
 476       else
 477         let first = List.hd newl in
 478         (* We select the first one by default *)
 479         ((select_first first), (List.tl newl))
 480     in
 481
 482
 483     let (fl, ol) =
 484       if multiple
 485       then (fl, ol)
 486       else normalize_selected (fl::ol)
 487     in
 488     let make_opt (a, cv, co, sel) =
 489       (match co with
 490        | None -> Pages.make_option ~a ~selected:sel
 491            (Pages.make_pcdata (string_of cv))
 492        | Some c -> Pages.make_option ~a ~selected:sel
 493            ~value:(string_of cv) c)
 494     in
 495     let rec make_optg = function
 496       | Option o -> Pages.select_content_of_option (make_opt o)
 497       | Optgroup (a, label, og1, ogl) ->
 498           Pages.make_optgroup
 499             ~a ~label (make_opt og1) (Pages.map_option make_opt ogl)
 500     in
 501     let fl2,ol2 = Pages.map_optgroup make_optg fl ol in
 502     Pages.make_select ?a ~multiple ~name fl2 ol2
 503
 504   let raw_select ?a ~(name : string)
 505       (fl : string select_opt) (ol : string select_opt list) =
 506     gen_select ?a ~multiple:false ~name fl ol id
 507
 508   let int_select ?a ~name
 509       (fl : int select_opt) (ol : int select_opt list) =
 510     gen_select ?a ~multiple:false
 511       ~name:(string_of_param_name name) fl ol string_of_int
 512
 513   let int32_select ?a ~name
 514       (fl : int32 select_opt) (ol : int32 select_opt list) =
 515     gen_select ?a ~multiple:false
 516       ~name:(string_of_param_name name) fl ol Int32.to_string
 517
 518   let int64_select ?a ~name
 519       (fl : int64 select_opt) (ol : int64 select_opt list) =
 520     gen_select ?a ~multiple:false
 521       ~name:(string_of_param_name name) fl ol Int64.to_string
 522
 523   let float_select ?a ~name
 524       (fl : float select_opt) (ol : float select_opt list) =
 525     gen_select ?a ~multiple:false
 526       ~name:(string_of_param_name name) fl ol string_of_float
 527
 528   let string_select ?a ~name
 529       (fl : string select_opt) (ol : string select_opt list) =
 530     gen_select ?a ~multiple:false
 531       ~name:(string_of_param_name name) fl ol id
 532
 533   let user_type_select string_of ?a ~name (fl : 'a select_opt)
 534       (ol : 'a select_opt list) =
 535     gen_select ?a ~multiple:false
 536       ~name:(string_of_param_name name) fl ol string_of
 537
 538   let raw_multiple_select ?a ~(name : string)
 539       (fl : string select_opt) (ol : string select_opt list) =
 540     gen_select ?a ~multiple:true ~name fl ol id
 541
 542   let int_multiple_select ?a ~name
 543       (fl : int select_opt) (ol : int select_opt list) =
 544     gen_select ?a ~multiple:true
 545       ~name:(string_of_param_name name) fl ol string_of_int
 546
 547   let int32_multiple_select ?a ~name
 548       (fl : int32 select_opt) (ol : int32 select_opt list) =
 549     gen_select ?a ~multiple:true
 550       ~name:(string_of_param_name name) fl ol Int32.to_string
 551
 552   let int64_multiple_select ?a ~name
 553       (fl : int64 select_opt) (ol : int64 select_opt list) =
 554     gen_select ?a ~multiple:true
 555       ~name:(string_of_param_name name) fl ol Int64.to_string
 556
 557   let float_multiple_select ?a ~name
 558       (fl : float select_opt) (ol : float select_opt list) =
 559     gen_select ?a ~multiple:true
 560       ~name:(string_of_param_name name) fl ol string_of_float
 561
 562   let string_multiple_select ?a ~name
 563       (fl : string select_opt) (ol : string select_opt list) =
 564     gen_select ?a ~multiple:true
 565       ~name:(string_of_param_name name) fl ol id
 566
 567   let user_type_multiple_select string_of ?a
 568       ~name (fl : 'a select_opt)
 569       (ol : 'a select_opt list) =
 570     gen_select ?a ~multiple:true
 571       ~name:(string_of_param_name name) fl ol string_of
 572
 573 end