tests/eliom_testsuite2.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * Module eliomexamples.ml
   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
  22 (* Other examples for Eliom, and various tests *)
  23
  24 open Lwt
  25 open Eliom_parameters
  26 open Ocsigen_cookies
  27 open HTML5.M
  28
  29 (*****************************************************************************)
  30 (* Test for raw_post_data *)
  31
  32 let raw_post_example =
  33   Eliom_output.Html5.register_service
  34     ~path:["rawpost"]
  35     ~get_params:unit
  36     (fun () () ->
  37       Lwt.return
  38         (html
  39            (head (title (pcdata "raw post data")) [])
  40            (body [p [pcdata "It is possible to send POST data to this URL, using any content-type other than form data or multipart. Try it with telnet. Cut and paste in a terminal:"];
  41                   pre [pcdata "telnet localhost 8080
  42 POST /rawpost HTTP/1.0
  43 Content-type: plop/plop
  44 Content-length: 124"];
  45                  ]))
  46     )
  47
  48 let raw_post_service =
  49   Eliom_output.Html5.register_post_service
  50     ~fallback:raw_post_example
  51     ~post_params:raw_post_data
  52     (fun () (ct, stream) ->
  53       let ct = match ct with
  54         | None -> "<none>"
  55         | Some ((content_type1, content_type2), _) ->
  56           content_type1^"/"^content_type2
  57       in
  58       (match stream with
  59         | None -> Lwt.return ""
  60         | Some stream ->
  61           Ocsigen_stream.string_of_stream 1000 (Ocsigen_stream.get stream))
  62       >>= fun s ->
  63       Lwt.return
  64         (html
  65            (head (title (pcdata "raw post data")) [])
  66            (body [p [pcdata "I received POST data, with content-type = ";
  67                      pcdata ct;
  68                      pcdata ", and the first 1000 bytes of the content are:"];
  69                   p [pcdata s]])
  70         )
  71     )
  72
  73
  74 (*****************************************************************************)
  75
  76 (************************************************************)
  77 (****************** Connection of users *********************)
  78 (************************************************************)
  79 (*zap* *)
  80 let scope_name = Eliom_common.create_scope_name "connect_example_state"
  81 let session = `Session scope_name
  82 (* *zap*)
  83 (* -------------------------------------------------------- *)
  84 (* We create one main service and two (POST) actions        *)
  85 (* (for connection and disconnection)                       *)
  86
  87 let connect_example =
  88   Eliom_services.service
  89     ~path:["connect_example"]
  90     ~get_params:unit
  91     ()
  92
  93 let connect_action =
  94   Eliom_services.post_coservice'
  95     ~name:"connection"
  96     ~post_params:(string "login")
  97     ()
  98
  99 (* disconnect action and box:                               *)
 100
 101 let disconnect_action =
 102   Eliom_output.Action.register_post_coservice'
 103     ~name:"disconnection"
 104     ~post_params:Eliom_parameters.unit
 105     (fun () () ->
 106       Eliom_state.discard ~scope:session ())
 107
 108 let disconnect_box s =
 109   Eliom_output.Html5.post_form disconnect_action
 110     (fun _ -> [p [Eliom_output.Html5.string_input
 111                     ~input_type:`Submit ~value:s ()]]) ()
 112
 113 (* The following eref is true if the connection has action failed: *)
 114 let bad_user = Eliom_references.eref ~scope:Eliom_common.request false
 115
 116 (* The following eref is the name of the user, when connected *)
 117 let user = Eliom_references.eref ~scope:session None
 118
 119 (* -------------------------------------------------------- *)
 120 (* new login box:                                           *)
 121
 122 let login_box session_expired bad_u action =
 123   Eliom_output.Html5.post_form action
 124     (fun loginname ->
 125       let l =
 126         [pcdata "login: ";
 127          Eliom_output.Html5.string_input ~input_type:`Text ~name:loginname ()]
 128       in
 129       [p (if bad_u
 130         then (pcdata "Wrong user")::(br ())::l
 131         else
 132           if session_expired
 133           then (pcdata "Session expired")::(br ())::l
 134           else l)
 135       ])
 136     ()
 137
 138 (* -------------------------------------------------------- *)
 139 (* Handler for the "connect_example" service (main page):   *)
 140
 141 let connect_example_handler () () =
 142   (* The following function tests whether the session has expired: *)
 143   let status = Eliom_state.volatile_data_state_status (*zap* *) ~scope:session (* *zap*) ()
 144   in
 145   Eliom_references.get bad_user >>= fun bad_u ->
 146   Eliom_references.get user >>= fun u ->
 147   Lwt.return
 148     (html
 149        (head (title (pcdata "")) [])
 150        (body
 151           (match u, status with
 152             | Some name, _ ->
 153               [p [pcdata ("Hello "^name); br ()];
 154                disconnect_box "Close session"]
 155             | None, Eliom_state.Expired_state ->
 156               [login_box true bad_u connect_action;
 157                p [em [pcdata "The only user is 'toto'."]]]
 158             | _ ->
 159               [login_box false bad_u connect_action;
 160                p [em [pcdata "The only user is 'toto'."]]]
 161           )))
 162
 163 (* -------------------------------------------------------- *)
 164 (* Handler for connect_action (user logs in):               *)
 165
 166 let connect_action_handler () login =
 167   lwt () = Eliom_state.discard ~scope:session () in
 168   if login = "toto" (* Check user and password :-) *)
 169   then Eliom_references.set user (Some login)
 170   else Eliom_references.set bad_user true
 171
 172
 173 (* -------------------------------------------------------- *)
 174 (* Registration of main services:                           *)
 175
 176 let () =
 177   Eliom_output.Html5.register ~service:connect_example connect_example_handler;
 178   Eliom_output.Action.register ~service:connect_action connect_action_handler
 179
 180
 181 (*****************************************************************************)
 182
 183 (************************************************************)
 184 (********* Connection of users with session groups **********)
 185 (************************************************************)
 186 (*zap* *)
 187 let scope_name = Eliom_common.create_scope_name "session_group_example_state"
 188 let session = `Session scope_name
 189 (* *zap*)
 190 (* -------------------------------------------------------- *)
 191 (* We create one main service and two (POST) actions        *)
 192 (* (for connection and disconnection)                       *)
 193
 194 let connect_example =
 195   Eliom_services.service
 196     ~path:["sessgrp"]
 197     ~get_params:unit
 198     ()
 199
 200 let connect_action =
 201   Eliom_services.post_coservice'
 202     ~name:"connection2"
 203     ~post_params:(string "login")
 204     ()
 205
 206 (* disconnect action and box:                               *)
 207
 208 let disconnect_action =
 209   Eliom_output.Action.register_post_coservice'
 210     ~name:"disconnection2"
 211     ~post_params:Eliom_parameters.unit
 212     (fun () () ->
 213       Eliom_state.discard ~scope:session ())
 214
 215 let disconnect_box s =
 216   Eliom_output.Html5.post_form disconnect_action
 217     (fun _ -> [p [Eliom_output.Html5.string_input
 218                     ~input_type:`Submit ~value:s ()]]) ()
 219
 220 (* The following eref is true if the connection has action failed: *)
 221 let bad_user = Eliom_references.eref ~scope:Eliom_common.request false
 222
 223 (* -------------------------------------------------------- *)
 224 (* new login box:                                           *)
 225
 226 let login_box session_expired bad_u action =
 227   Eliom_output.Html5.post_form action
 228     (fun loginname ->
 229       let l =
 230         [pcdata "login: ";
 231          Eliom_output.Html5.string_input ~input_type:`Text ~name:loginname ()]
 232       in
 233       [p (if bad_u
 234         then (pcdata "Wrong user")::(br ())::l
 235         else
 236           if session_expired
 237           then (pcdata "Session expired")::(br ())::l
 238           else l)
 239      ])
 240     ()
 241
 242 (* -------------------------------------------------------- *)
 243 (* Handler for the "connect_example" service (main page):   *)
 244
 245 let connect_example_handler () () =
 246   (* The following function tests whether the session has expired: *)
 247   let status = Eliom_state.volatile_data_state_status (*zap* *) ~scope:session (* *zap*) ()
 248   in
 249   let group =
 250     Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) ()
 251   in
 252   Eliom_references.get bad_user >>= fun bad_u ->
 253   Lwt.return
 254     (html
 255        (head (title (pcdata "")) [])
 256        (body
 257           (match group, status with
 258           | Some name, _ ->
 259               [p [pcdata ("Hello "^name); br ()];
 260               disconnect_box "Close session"]
 261           | None, Eliom_state.Expired_state ->
 262               [login_box true bad_u connect_action;
 263                p [em [pcdata "The only user is 'toto'."]]]
 264           | _ ->
 265               [login_box false bad_u connect_action;
 266                p [em [pcdata "The only user is 'toto'."]]]
 267           )))
 268
 269 (* -------------------------------------------------------- *)
 270 (* Handler for connect_action (user logs in):               *)
 271
 272 let connect_action_handler () login =
 273   lwt () = Eliom_state.discard ~scope:session () in
 274   if login = "toto" (* Check user and password :-) *)
 275   then begin
 276     Eliom_state.set_volatile_data_session_group ~set_max:4 (*zap* *) ~scope:session (* *zap*) login;
 277     Eliom_output.Redirection.send Eliom_services.void_hidden_coservice'
 278   end
 279   else
 280     Eliom_references.set bad_user true >>= fun () ->
 281     Eliom_output.Action.send ()
 282
 283
 284 (* -------------------------------------------------------- *)
 285 (* Registration of main services:                           *)
 286
 287 let () =
 288   Eliom_output.Html5.register ~service:connect_example connect_example_handler;
 289   Eliom_output.Any.register ~service:connect_action connect_action_handler
 290
 291
 292
 293 (*****************************************************************************)
 294
 295 let myeref = Eliom_references.eref ~scope:`Global ~persistent:"perscount" 0
 296
 297 let count3 =
 298   let next =
 299     let mutex = Lwt_mutex.create () in
 300     (fun () ->
 301       Lwt_mutex.lock mutex >>= fun () ->
 302       Eliom_references.get myeref >>= fun oldc ->
 303       let newc = oldc + 1 in
 304       Eliom_references.set myeref newc >>= fun () ->
 305       Lwt_mutex.unlock mutex;
 306       Lwt.return newc)
 307   in
 308   Eliom_output.Html5.register_service
 309     ~path:["count3"]
 310     ~get_params:unit
 311     (fun () () ->
 312       next () >>=
 313       (fun n ->
 314         Lwt.return
 315          (HTML5.M.html
 316           (HTML5.M.head (HTML5.M.title (HTML5.M.pcdata "counter")) [])
 317           (HTML5.M.body [HTML5.M.p [HTML5.M.pcdata (string_of_int n)]]))))
 318
 319
 320 (*****************************************************************************)
 321
 322 open Eliom_testsuite1
 323 open XHTML.M
 324 open Eliom_output.Xhtml
 325 open Eliom_output
 326 open Eliom_services
 327 open Eliom_state
 328
 329 (* Lists of lists *)
 330
 331 let lilists = service [ "lilists" ] unit ()
 332
 333 let lilists2 = service
 334   ["lilists2"] (list "l" (string "title" ** (list "il" (int "i")))) ()
 335
 336 let create_form f =
 337   let l =
 338     f.it (fun (sn, l2) v init ->
 339             (tr (td [pcdata ("Write a string: ")])
 340                ((td [string_input ~input_type:`Text ~name:sn ()])::
 341                    (td [pcdata ("Write integers: ")])::
 342
 343                    (l2.it (fun iname v init ->
 344                      (td [int_input ~input_type:`Text ~name:iname ()])::init)
 345                       ["A"; "B"]
 346                       []))
 347
 348             )::init)
 349       ["one";"two";"three"]
 350       []
 351   in
 352   [table (List.hd l) (List.tl l);
 353    p [string_input ~input_type:`Submit ~value:"Click" ()]]
 354
 355 let () = register lilists
 356   (fun () () ->
 357      let f = Eliom_output.Xhtml.get_form lilists2 create_form in
 358      return
 359        (html
 360          (head (title (pcdata "")) [])
 361          (body [f])))
 362
 363 let () = register lilists2
 364   (fun ll () ->
 365      return
 366        (html
 367          (head (title (pcdata "")) [])
 368          (body
 369             (List.map (fun (s, il) -> p (pcdata s::
 370                                            List.map (fun i -> pcdata (string_of_int i)) il)) ll))))
 371
 372
 373 (* sums in parameters types *)
 374
 375 let sumserv = register_service
 376     ~path:["sum"]
 377     ~get_params:(sum (int "i") (sum (int "ii") (string "s")))
 378     (fun g () ->
 379        return
 380          (html
 381             (head (title (pcdata "")) [])
 382             (body [p [pcdata "You sent: ";
 383                       strong [pcdata
 384                                 (match g with
 385                                    | Inj1 i
 386                                    | Inj2 (Inj1 i) -> string_of_int i
 387                                    | Inj2 (Inj2 s) -> s) ]]])))
 388
 389 let create_form =
 390   (fun (name1, (name2, name3)) ->
 391     [p [
 392        Eliom_output.Xhtml.int_input
 393          ~name:name1 ~input_type:`Submit ~value:48 ();
 394        Eliom_output.Xhtml.int_input
 395          ~name:name2 ~input_type:`Submit ~value:55 ();
 396        Eliom_output.Xhtml.string_input
 397          ~name:name3 ~input_type:`Submit ~value:"plop" ();
 398      ]])
 399
 400 let sumform = register_service ["sumform"] unit
 401   (fun () () ->
 402      let f = Eliom_output.Xhtml.get_form sumserv create_form in
 403      return
 404        (html
 405          (head (title (pcdata "")) [])
 406          (body [f])))
 407
 408
 409 let sumform2 = service ~path:["sumform2"] ~get_params:unit ()
 410
 411 let sumserv = register_post_service
 412     ~fallback:sumform2
 413     ~post_params:(sum (int "i") (sum (int "ii") (string "s")))
 414     (fun () post ->
 415        return
 416          (html
 417             (head (title (pcdata "")) [])
 418             (body [p [pcdata "You sent: ";
 419                       strong [pcdata
 420                                 (match post with
 421                                    | Inj1 i
 422                                    | Inj2 (Inj1 i) -> string_of_int i
 423                                    | Inj2 (Inj2 s) -> s) ]]])))
 424
 425 let () = register sumform2
 426   (fun () () ->
 427      let f = Eliom_output.Xhtml.post_form sumserv create_form () in
 428      return
 429        (html
 430          (head (title (pcdata "")) [])
 431          (body [f])))
 432
 433
 434 (******)
 435 (* unregistering services *)
 436 let unregister_example =
 437   Eliom_output.Xhtml.register_service
 438     ~path:["unregister"]
 439     ~get_params:Eliom_parameters.unit
 440     (fun () () ->
 441        let s1 = Eliom_output.Xhtml.register_service
 442          ~path:["unregister1"]
 443          ~get_params:Eliom_parameters.unit
 444          (fun () () -> failwith "s1")
 445        in
 446        let s2 = Eliom_output.Xhtml.register_coservice
 447          ~fallback:s1
 448          ~get_params:Eliom_parameters.unit
 449          (fun () () -> failwith "s2")
 450        in
 451        let s3 = Eliom_output.Xhtml.register_coservice'
 452          ~get_params:Eliom_parameters.unit
 453          (fun () () -> failwith "s3")
 454        in
 455        Eliom_output.Xhtml.register ~scope:Eliom_common.session
 456          ~service:s1
 457          (fun () () -> failwith "s4");
 458        Eliom_services.unregister s1;
 459        Eliom_services.unregister s2;
 460        Eliom_services.unregister s3;
 461        Eliom_services.unregister ~scope:Eliom_common.session s1;
 462        Lwt.return
 463          (html
 464             (head (title (pcdata "Unregistering services")) [])
 465             (body [p [pcdata
 466                         "These services have been registered and unregistered"];
 467                    p [a s1 [pcdata "regular service"] ();
 468                       pcdata ", ";
 469                       a s2 [pcdata "coservice"] ();
 470                       pcdata ", ";
 471                       a s3 [pcdata "non attached coservice"] ();
 472                       pcdata ", ";
 473                       a s1 [pcdata "session service"] ();
 474                      ]]))
 475     )
 476
 477
 478 (******)
 479 (* CSRF GET *)
 480
 481 let csrfsafe_get_example =
 482   Eliom_services.service
 483     ~path:["csrfget"]
 484     ~get_params:Eliom_parameters.unit
 485     ()
 486
 487 let csrfsafe_example_get =
 488   Eliom_services.coservice
 489     ~csrf_safe:true
 490     ~timeout:10.
 491     ~fallback:csrfsafe_get_example
 492     ~get_params:Eliom_parameters.unit
 493     ()
 494
 495 let _ =
 496   let page () () =
 497     let l3 = Eliom_output.Xhtml.get_form csrfsafe_example_get
 498         (fun _ -> [p [Eliom_output.Xhtml.string_input
 499                         ~input_type:`Submit
 500                         ~value:"Click" ()]])
 501     in
 502     return
 503       (html
 504        (head (title (pcdata "CSRF safe service example")) [])
 505        (body [p [pcdata "A new coservice will be created each time this form is displayed"];
 506               l3]))
 507   in
 508   Eliom_output.Xhtml.register csrfsafe_get_example page;
 509   Eliom_output.Xhtml.register csrfsafe_example_get
 510     (fun () () ->
 511        Lwt.return
 512          (html
 513             (head (title (pcdata "CSRF safe service")) [])
 514             (body [p [pcdata "This is a GET CSRF safe service"]])))
 515
 516 (******)
 517 (* CSRF POST on CSRF GET coservice *)
 518
 519 let csrfsafe_postget_example =
 520   Eliom_services.service
 521     ~path:["csrfpostget"]
 522     ~get_params:Eliom_parameters.unit
 523     ()
 524
 525 let csrfsafe_example_post =
 526   Eliom_services.post_coservice
 527     ~csrf_safe:true
 528     ~timeout:10.
 529     ~fallback:csrfsafe_example_get (* !!! *)
 530     ~post_params:Eliom_parameters.unit
 531     ()
 532
 533 let _ =
 534   let page () () =
 535     let l3 = Eliom_output.Xhtml.post_form csrfsafe_example_post
 536         (fun _ -> [p [Eliom_output.Xhtml.string_input
 537                         ~input_type:`Submit
 538                         ~value:"Click" ()]]) ()
 539     in
 540     return
 541       (html
 542        (head (title (pcdata "CSRF safe service example")) [])
 543        (body [p [pcdata "A new coservice will be created each time this form is displayed"];
 544               l3]))
 545   in
 546   Eliom_output.Xhtml.register csrfsafe_postget_example page;
 547   Eliom_output.Xhtml.register csrfsafe_example_post
 548     (fun () () ->
 549        Lwt.return
 550          (html
 551             (head (title (pcdata "CSRF safe service")) [])
 552             (body [p [pcdata "This is a POST CSRF safe service, combined with a GET CSRF safe service"]])))
 553
 554
 555 (******)
 556 (* CSRF for_session *)
 557
 558 let csrfsafe_session_example =
 559   Eliom_services.service
 560     ~path:["csrfsession"]
 561     ~get_params:Eliom_parameters.unit
 562     ()
 563
 564 let myscope = (`Session (Eliom_common.create_scope_name "plop"))
 565
 566 let csrfsafe_example_session =
 567   Eliom_services.post_coservice'
 568     ~csrf_safe:true
 569     ~csrf_scope:myscope
 570     ~csrf_secure:true
 571     ~timeout:10.
 572     ~post_params:Eliom_parameters.unit
 573     ()
 574
 575 let _ =
 576   let page () () =
 577     Eliom_output.Xhtml.register ~scope:myscope
 578       ~secure_session:true
 579       ~service:csrfsafe_example_session
 580       (fun () () ->
 581          Lwt.return
 582            (html
 583               (head (title (pcdata "CSRF safe service")) [])
 584               (body [p [pcdata "This is a POST CSRF safe service"]])));
 585     let l3 = Eliom_output.Xhtml.post_form csrfsafe_example_session
 586         (fun _ -> [p [Eliom_output.Xhtml.string_input
 587                         ~input_type:`Submit
 588                         ~value:"Click" ()]])
 589         ()
 590     in
 591     return
 592       (html
 593        (head (title (pcdata "CSRF safe service example")) [])
 594        (body [p [pcdata "A new coservice will be created each time this form is displayed"];
 595               l3]))
 596   in
 597   Eliom_output.Xhtml.register csrfsafe_session_example page
 598
 599
 600
 601 (******)
 602 (* optional suffix parameters *)
 603
 604 let optsuf =
 605   register_service
 606     ~path:["optsuf"]
 607     ~get_params:(suffix(opt(string "q" ** (opt (int "i")))))
 608     (fun o () ->
 609        Lwt.return
 610          (html
 611             (head (title (pcdata "")) [])
 612             (body [p [pcdata (match o with
 613                                  | None -> "<none>"
 614                                  | Some (s, o) ->
 615                                      s^(match o with
 616                                           | None -> "<none>"
 617                                           | Some i -> string_of_int i));
 618                      ]])))
 619
 620 let optsuf2 =
 621   register_service
 622     ~path:["optsuf2"]
 623     ~get_params:(suffix(opt(string "q") ** (opt (int "i"))))
 624     (fun (s, i) () ->
 625        Lwt.return
 626          (html
 627             (head (title (pcdata "")) [])
 628             (body [p [pcdata (match s with
 629                                  | None -> "<none>"
 630                                  | Some s -> s);
 631                       pcdata (match i with
 632                                 | None -> "<none>"
 633                                 | Some i -> string_of_int i)];
 634                      ])))
 635
 636 (*******)
 637 let my_nl_params =
 638   Eliom_parameters.make_non_localized_parameters
 639     ~prefix:"tutoeliom"
 640     ~name:"mynlp"
 641     (Eliom_parameters.int "a" ** Eliom_parameters.string "s")
 642
 643 let void_with_nlp =
 644   Eliom_services.add_non_localized_get_parameters
 645     my_nl_params Eliom_services.void_hidden_coservice'
 646
 647 let nlparams2 = service
 648     ~path:["voidnl"]
 649     ~get_params:(suffix_prod (int "year" ** int "month") (int "w" ))
 650     ()
 651
 652 let nlparams2_with_nlp =
 653   Eliom_services.add_non_localized_get_parameters
 654     my_nl_params nlparams2
 655
 656 let () = register
 657   nlparams2
 658   (fun ((aa, bb), w) () ->
 659      Lwt.return
 660        (html
 661           (head (title (pcdata "")) [])
 662           (body [p [
 663                    a void_with_nlp
 664                      [pcdata "void coservice with non loc param"] ((), (11, "aa"));
 665                    a nlparams2_with_nlp
 666                      [pcdata "myself with non loc param"] (((4, 5), 777), (12, "ab"))];
 667                  p [pcdata "I have my suffix, ";
 668                     pcdata ("with values year = "^string_of_int aa^
 669                               " and month = "^string_of_int bb^
 670                               ". w = "^string_of_int w^".")];
 671                  (match Eliom_parameters.get_non_localized_get_parameters
 672                     my_nl_params
 673                   with
 674                     | None ->
 675                         p [pcdata "I do not have my non localized parameters"]
 676                     | Some (a, s) ->
 677                         p [pcdata "I have my non localized parameters, ";
 678                            pcdata ("with values a = "^string_of_int a^
 679                                      " and s = "^s^".")]
 680                  )]))
 681     )
 682
 683
 684
 685
 686 (*******)
 687 (* doing requests *)
 688 (* Warning: compute_result may return an deflated result! *)
 689 (* Check! (see for example Eliom_output.Action) *)
 690 let extreq =
 691   register_service
 692     ~path:["extreq"]
 693     ~get_params:unit
 694     (fun () () ->
 695        Ocsigen_http_client.get "ocsigen.org" "/ocsimoreadmin/static/ocsiwikistyle.css" () >>= fun frame ->
 696        (match frame.Ocsigen_http_frame.frame_content with
 697          | None -> Lwt.return ""
 698          | Some stream -> Ocsigen_stream.string_of_stream (Ocsigen_config.get_maxrequestbodysizeinmemory ()) (Ocsigen_stream.get stream)) >>= fun s ->
 699        (* Here use an XML parser,
 700           or send the stream directly using an appropriate Eliom_mkreg module *)
 701        return
 702          (html
 703             (head (title (pcdata "")) [])
 704             (body [p [pcdata s]])))
 705
 706 let servreq =
 707   register_service
 708     ~path:["servreq"]
 709     ~get_params:unit
 710     (fun () () ->
 711        let ri = Eliom_request_info.get_ri () in
 712        let ri = Ocsigen_extensions.ri_of_url "tuto/" ri in
 713        Ocsigen_extensions.compute_result ri >>= fun result ->
 714        let stream = fst result.Ocsigen_http_frame.res_stream in
 715        Ocsigen_stream.string_of_stream (Ocsigen_config.get_maxrequestbodysizeinmemory ()) (Ocsigen_stream.get stream) >>= fun s ->
 716        (* Here use an XML parser,
 717           or send the stream directly using an appropriate Eliom_mkreg module *)
 718        return
 719          (html
 720             (head (title (pcdata "")) [])
 721             (body [p [pcdata s]])))
 722
 723 let servreqloop =
 724   register_service
 725     ~path:["servreqloop"]
 726     ~get_params:unit
 727     (fun () () ->
 728        let ri = Eliom_request_info.get_ri () in
 729        Ocsigen_extensions.compute_result ri >>= fun result ->
 730        let stream = fst result.Ocsigen_http_frame.res_stream in
 731        Ocsigen_stream.string_of_stream (Ocsigen_config.get_maxrequestbodysizeinmemory ()) (Ocsigen_stream.get stream) >>= fun s ->
 732        (* Here use an XML parser,
 733           or send the stream directly using an appropriate Eliom_mkreg module *)
 734        return
 735          (html
 736             (head (title (pcdata "")) [])
 737             (body [p [pcdata s]])))
 738
 739
 740
 741
 742
 743 (* Customizing HTTP headers *)
 744 let headers =
 745   register_service
 746     ~code:666
 747     ~charset:"plopcharset"
 748 (*    ~content_type:"custom/contenttype" *)
 749     ~headers:(Http_headers.add
 750                 (Http_headers.name "XCustom-header")
 751                 "This is an example"
 752                 Http_headers.empty)
 753     ~path:["httpheaders"]
 754     ~get_params:unit
 755     (fun () () ->
 756       Eliom_state.set_cookie
 757         ~path:[] ~name:"Customcookie" ~value:"Value" ~secure:true ();
 758       Eliom_state.set_cookie
 759         ~path:[] ~name:"Customcookie2" ~value:"Value2" ();
 760       Lwt.return
 761         (html
 762            (head (title (pcdata "")) [])
 763            (body [h1 [pcdata "Look at my HTTP headers"]])))
 764
 765
 766 (* form towards a suffix service with constants *)
 767 let create_form (n1, (_, n2)) =
 768     <:xhtmllist< <p>
 769       $string_input ~input_type:`Text ~name:n1 ()$
 770       $string_input ~input_type:`Text ~name:n2 ()$
 771       $string_input ~input_type:`Submit ~value:"Click" ()$</p> >>
 772
 773 let constform = register_service ["constform"] unit
 774   (fun () () ->
 775      let f = get_form Eliom_testsuite1.constfix create_form in
 776      return
 777         (html
 778           (head (title (pcdata "")) [])
 779           (body [h1 [pcdata "Hallo"];
 780                  f ])))
 781
 782
 783 (* Suffix and other service at same URL *)
 784 let su2 =
 785   register_service
 786     ~path:["fuffix";""]
 787     ~get_params:(suffix (all_suffix_string "s"))
 788     (fun s () ->
 789       return
 790         (html
 791           (head (title (pcdata "")) [])
 792           (body [h1
 793                    [pcdata s];
 794                  p [pcdata "Try page fuffix/a/b"]])))
 795
 796 let su =
 797   register_service
 798     ~path:["fuffix";"a";"b"]
 799     ~get_params:unit
 800     (fun () () ->
 801       return
 802         (html
 803           (head (title (pcdata "")) [])
 804           (body [h1 [pcdata "Try another suffix"]])))
 805
 806 let su3 =
 807   register_service
 808     ~path:["fuffix";""]
 809     ~get_params:unit
 810     (fun () () ->
 811       return
 812         (html
 813           (head (title (pcdata "")) [])
 814           (body [h1 [pcdata "Try another suffix"]])))
 815
 816 let su4 =
 817   register_service
 818     ~path:["fuffix";""]
 819     ~get_params:(suffix (string "s" ** suffix_const "CONST" ** string "ss"))
 820     ~priority:1
 821     (fun (s, ((), ss)) () ->
 822       return
 823         (html
 824           (head (title (pcdata "")) [])
 825           (body [h1
 826                    [pcdata s];
 827                  p [pcdata "I am a suffix service with a constant part, registered after the generic suffix service, but I have a priority, so that you can see me!"]])))
 828
 829 let create_suffixform_su2 s =
 830     <:xhtmllist< <p>Write a string:
 831       $string_input ~input_type:`Text ~name:s ()$ <br/>
 832       $string_input ~input_type:`Submit ~value:"Click" ()$</p> >>
 833
 834 let suffixform_su2 = register_service ["suffixform_su2"] unit
 835   (fun () () ->
 836      let f = get_form su2 create_suffixform_su2 in
 837      return
 838        (html
 839           (head (title (pcdata "")) [])
 840           (body [h1 [pcdata "Hallo"];
 841                  f ])))
 842
 843 (* optional parameters *)
 844 let optparam =
 845   register_service
 846     ~path:["opt"]
 847     ~get_params:(Eliom_parameters.opt (Eliom_parameters.string "a" **
 848                                          Eliom_parameters.string "b"))
 849     (fun o () ->
 850       Lwt.return
 851         (html
 852            (head (title (pcdata "")) [])
 853            (body [h1 [pcdata "Hallo!"];
 854                   match o with
 855                     | None -> p [pcdata "no parameters"]
 856                     | Some (a, b) -> p [pcdata a;
 857                                         pcdata ", ";
 858                                         pcdata b]
 859                  ]))
 860
 861     )
 862
 863 let optform =
 864   register_service
 865     ~path:["optform"]
 866     ~get_params:unit
 867     (fun () () ->
 868 (* testing lwt_get_form *)
 869        Eliom_output.Xhtml.lwt_get_form
 870          ~service:optparam
 871          (fun (an, bn) ->
 872             Lwt.return
 873               [p [
 874                  string_input ~input_type:`Text ~name:an ();
 875                  string_input ~input_type:`Text ~name:bn ();
 876                  Eliom_output.Xhtml.string_input
 877                    ~input_type:`Submit
 878                    ~value:"Click" ()]])
 879       >>= fun form ->
 880       let form =
 881         (form : XHTML_types.form XHTML.M.elt :> [> XHTML_types.form ] XHTML.M.elt)
 882       in
 883       return
 884         (html
 885            (head (title (pcdata "")) [])
 886            (body [h1 [pcdata "Hallo!"];
 887                   form
 888                  ]))
 889
 890  )
 891
 892
 893 (* Preapplied service with suffix parameters *)
 894
 895 let presu_service =
 896   register_service
 897     ~path: ["preappliedsuffix2"]
 898     ~get_params: (suffix (int "i"))
 899     (fun i () ->
 900       Lwt.return
 901         (html
 902            (head (title (pcdata "")) [])
 903            (body [p [ pcdata ("You sent: " ^ (string_of_int i))]])))
 904
 905
 906 let creator_handler () () =
 907   let create_form () =
 908     [fieldset [string_input ~input_type:`Submit ~value:"Click" ()]] in
 909   let myservice = preapply presu_service 10 in
 910   let myform = get_form myservice create_form in
 911   Lwt.return
 912     (html
 913        (head (title (pcdata "")) [])
 914        (body   [
 915         p [pcdata "Form with preapplied parameter:"];
 916         myform;
 917         p [a myservice [pcdata "Link with preapplied parameter"] ()]
 918       ]))
 919
 920 let preappliedsuffix =
 921   register_service
 922     ~path: ["preappliedsuffix"]
 923     ~get_params: unit
 924     creator_handler
 925
 926
 927 (* URL with ? or / in data or paths *)
 928
 929 let url_encoding =
 930   register_service
 931     ~path:["urlencoding&à/=é?ablah"]
 932     ~get_params:(suffix_prod (all_suffix "s//\\à") any)
 933     (fun (suf, l) () ->
 934       let ll =
 935         List.map
 936           (fun (a,s) -> <:xhtml< <strong>($str:a$, $str:s$) </strong> >>) l
 937       in
 938       let sl =
 939         List.map
 940           (fun s -> <:xhtml< <strong>$str:s$ </strong> >>) suf
 941       in
 942       return
 943         (html
 944            (head (title (pcdata "")) [])
 945            (body [h1 [pcdata "Hallo"];
 946                   p sl;
 947                   p ll
 948                 ])))
 949
 950
 951 (* menu with preapplied services *)
 952
 953 let preappl = preapply coucou_params (3,(4,"cinq"))
 954 let preappl2 = preapply uasuffix (1999,01)
 955
 956 let mymenu current =
 957   Eliom_tools.Xhtml.menu ~classe:["menuprincipal"]
 958     (coucou, <:xhtmllist< coucou >>)
 959     [
 960      (preappl, <:xhtmllist< params >>);
 961      (preappl2, <:xhtmllist< params and suffix >>);
 962    ] ~service:current ()
 963
 964 let preappmenu =
 965   register_service
 966     ~path:["menu"]
 967     ~get_params:unit
 968     (fun () () ->
 969       return
 970         (html
 971           (head (title (pcdata "")) [])
 972           (body [h1 [pcdata "Hallo"];
 973                  mymenu coucou ])))
 974
 975
 976
 977
 978 (* GET Non-attached coservice *)
 979 let nonatt = coservice' ~get_params:(string "e") ()
 980
 981 (* GET coservice with preapplied fallback *)
 982 (* + Non-attached coservice on a pre-applied coservice *)
 983 (* + Non-attached coservice on a non-attached coservice *)
 984 let f s =
 985   (html
 986      (head (title (pcdata "")) [])
 987      (body [h1 [pcdata s];
 988             p [a nonatt [pcdata "clic"] "nonon"];
 989             get_form nonatt
 990               (fun string_name ->
 991                 [p [pcdata "Non attached coservice: ";
 992                     string_input ~input_type:`Text ~name:string_name ();
 993                     string_input ~input_type:`Submit ~value:"Click" ()]])
 994           ]))
 995
 996 let getco = register_coservice
 997     ~fallback:preappl
 998     ~get_params:(int "i" ** string "s")
 999     (fun (i,s) () -> return (f s))
1000
1001 let _ = register nonatt (fun s () -> return (f s))
1002
1003 let getcoex =
1004   register_service
1005     ~path:["getco"]
1006     ~get_params:unit
1007     (fun () () ->
1008       return
1009         (html
1010           (head (title (pcdata "")) [])
1011           (body [p [a getco [pcdata "clic"] (22,"eee") ];
1012                  get_form getco
1013                    (fun (number_name,string_name) ->
1014                      [p [pcdata "Write an int: ";
1015                          int_input ~input_type:`Text ~name:number_name ();
1016                          pcdata "Write a string: ";
1017                          string_input ~input_type:`Text ~name:string_name ();
1018                          string_input  ~input_type:`Submit ~value:"Click" ()]])
1019                ])))
1020
1021
1022 (* POST service with preapplied fallback are not possible: *)
1023 (*
1024 let my_service_with_post_params =
1025   register_post_service
1026     ~fallback:preappl
1027     ~post_params:(string "value")
1028     (fun () value ->  return
1029       (html
1030          (head (title (pcdata "")) [])
1031          (body [h1 [pcdata value]])))
1032 *)
1033
1034 (* GET coservice with coservice fallback: not possible *)
1035 (*
1036 let preappl3 = preapply getco (777,"ooo")
1037
1038 let getco2 =
1039   register_coservice
1040     ~fallback:preappl3
1041     ~get_params:(int "i2" ** string "s2")
1042     (fun (i,s) () ->
1043       return
1044         (html
1045           (head (title (pcdata "")) [])
1046           (body [h1 [pcdata s]])))
1047
1048 *)
1049
1050
1051 (* POST service with coservice fallback *)
1052 let my_service_with_post_params =
1053   register_post_service
1054     ~fallback:getco
1055     ~post_params:(string "value")
1056     (fun (i,s) value ->  return
1057       (html
1058          (head (title (pcdata "")) [])
1059          (body [h1 [pcdata (s^" "^value)]])))
1060
1061 let postcoex = register_service ["postco"] unit
1062   (fun () () ->
1063      let f =
1064        (post_form my_service_with_post_params
1065           (fun chaine ->
1066             [p [pcdata "Write a string: ";
1067                 string_input ~input_type:`Text ~name:chaine ()]])
1068           (222,"ooo")) in
1069      return
1070        (html
1071          (head (title (pcdata "form")) [])
1072          (body [f])))
1073
1074
1075 (* action on GET attached coservice *)
1076 let v = ref 0
1077
1078 let getact =
1079   service
1080     ~path:["getact"]
1081     ~get_params:(int "p")
1082     ()
1083
1084 let act = Action.register_coservice
1085     ~fallback:(preapply getact 22)
1086     ~get_params:(int "bip")
1087     (fun g p -> v := g; return ())
1088
1089 (* action on GET non-attached coservice on GET coservice page *)
1090 let naact = Action.register_coservice'
1091     ~get_params:(int "bop")
1092     (fun g p -> v := g; return ())
1093
1094 let naunit = Unit.register_coservice'
1095     ~get_params:(int "bap")
1096     (fun g p -> v := g; return ())
1097
1098 let _ =
1099   register
1100     getact
1101     (fun aa () ->
1102       return
1103         (html
1104            (head (title (pcdata "getact")) [])
1105            (body [h1 [pcdata ("v = "^(string_of_int !v))];
1106                   p [pcdata ("p = "^(string_of_int aa))];
1107                   p [a getact [pcdata "link to myself"] 0;
1108                      br ();
1109                      a act [pcdata "an attached action to change v"]
1110                        (Random.int 100);
1111                      br ();
1112                      a naact [pcdata "a non attached action to change v"]
1113                        (100 + Random.int 100);
1114                      pcdata " (Actually if called after the previous one, v won't change. More precisely, it will change and turn back to the former value because the attached coservice is reloaded after action)";
1115                      br ();
1116                      a naunit [pcdata "a non attached \"Unit\" page to change v"]
1117                        (200 + Random.int 100);
1118                      pcdata " (Reload after clicking here)"
1119                    ]])))
1120
1121
1122
1123
1124 (* Many cookies *)
1125 let cookiename = "c"
1126
1127 let cookies2 = service ["c";""] (suffix (all_suffix_string "s")) ()
1128
1129 let _ = Eliom_output.Xhtml.register cookies2
1130     (fun s () ->
1131       let now = Unix.time () in
1132       Eliom_state.set_cookie
1133         ~path:[] ~exp:(now +. 10.) ~name:(cookiename^"6")
1134         ~value:(string_of_int (Random.int 100)) ~secure:true ();
1135       Eliom_state.set_cookie
1136         ~path:[] ~exp:(now +. 10.) ~name:(cookiename^"7")
1137         ~value:(string_of_int (Random.int 100)) ~secure:true ();
1138       Eliom_state.set_cookie
1139         ~path:["c";"plop"] ~name:(cookiename^"8")
1140         ~value:(string_of_int (Random.int 100)) ();
1141       Eliom_state.set_cookie
1142         ~path:["c";"plop"] ~name:(cookiename^"9")
1143         ~value:(string_of_int (Random.int 100)) ();
1144       Eliom_state.set_cookie
1145         ~path:["c";"plop"] ~name:(cookiename^"10")
1146         ~value:(string_of_int (Random.int 100)) ~secure:true ();
1147       Eliom_state.set_cookie
1148         ~path:["c";"plop"] ~name:(cookiename^"11")
1149         ~value:(string_of_int (Random.int 100)) ~secure:true ();
1150       Eliom_state.set_cookie
1151         ~path:["c";"plop"] ~name:(cookiename^"12")
1152         ~value:(string_of_int (Random.int 100)) ~secure:true ();
1153       if CookiesTable.mem (cookiename^"1") (Eliom_request_info.get_cookies ())
1154       then
1155         (Eliom_state.unset_cookie ~name:(cookiename^"1") ();
1156          Eliom_state.unset_cookie ~name:(cookiename^"2") ())
1157       else begin
1158         Eliom_state.set_cookie
1159           ~name:(cookiename^"1") ~value:(string_of_int (Random.int 100))
1160           ~secure:true ();
1161         Eliom_state.set_cookie
1162           ~name:(cookiename^"2") ~value:(string_of_int (Random.int 100)) ();
1163         Eliom_state.set_cookie
1164           ~name:(cookiename^"3") ~value:(string_of_int (Random.int 100)) ()
1165       end;
1166
1167       Lwt.return
1168         (html
1169            (head (title (pcdata "")) [])
1170            (body [p
1171                      (CookiesTable.fold
1172                         (fun n v l ->
1173                           (pcdata (n^"="^v))::
1174                             (br ())::l
1175                         )
1176                         (Eliom_request_info.get_cookies ())
1177                         [a cookies2 [pcdata "send other cookies"] ""; br ();
1178                          a cookies2 [pcdata "send other cookies and see the url /c/plop"] "plop"]
1179                      )]))
1180     )
1181
1182
1183
1184
1185 (* Send file *)
1186 let sendfileex =
1187   register_service
1188     ~path:["files";""]
1189     ~get_params:unit
1190     (fun () () ->
1191       return
1192         (html
1193           (head (title (pcdata "")) [])
1194           (body [h1 [pcdata "With a suffix, that page will send a file"]])))
1195
1196 let sendfile2 =
1197   Files.register_service
1198     ~path:["files";""]
1199     ~get_params:(suffix (all_suffix "filename"))
1200     (fun s () ->
1201       return ("/var/www/ocsigen/"^(Url.string_of_url_path ~encode:false s)))
1202
1203 let sendfileexception =
1204   register_service
1205     ~path:["files";"exception"]
1206     ~get_params:unit
1207     (fun () () ->
1208       return
1209         (html
1210           (head (title (pcdata "")) [])
1211           (body [h1 [pcdata "With another suffix, that page will send a file"]])))
1212
1213
1214 (* Complex suffixes *)
1215 let suffix2 =
1216   service
1217     ~path:["suffix2";""]
1218     ~get_params:(suffix (string "suff1" ** int "ii" ** all_suffix "ee"))
1219     ()
1220
1221 let _ =
1222   register suffix2
1223     (fun (suf1, (ii, ee)) () ->
1224       return
1225         (html
1226            (head (title (pcdata "")) [])
1227            (body
1228               [p [pcdata "The suffix of the url is ";
1229                   strong [pcdata (suf1^", "^(string_of_int ii)^", "^
1230                                   (Url.string_of_url_path ~encode:false ee))]];
1231               p [a suffix2 [pcdata "link to myself"] ("a", (2, []))]])))
1232
1233 let suffix3 =
1234   register_service
1235     ~path:["suffix3";""]
1236     ~get_params:(suffix_prod
1237                    (string "suff1" ** int "ii" **
1238                       all_suffix_user int_of_string string_of_int "ee")
1239                    (string "a" ** int "b"))
1240     (fun ((suf1, (ii, ee)), (a, b)) () ->
1241       return
1242         (html
1243            (head (title (pcdata "")) [])
1244            (body
1245               [p [pcdata "The parameters in the url are ";
1246                   strong [pcdata (suf1^", "^(string_of_int ii)^", "^
1247                                   (string_of_int ee)^", "^
1248                                   a^", "^(string_of_int b))]]])))
1249
1250 let create_suffixform2 (suf1, (ii, ee)) =
1251     <:xhtmllist< <p>Write a string:
1252       $string_input ~input_type:`Text ~name:suf1 ()$ <br/>
1253       Write an int: $int_input ~input_type:`Text ~name:ii ()$ <br/>
1254       Write a string: $user_type_input
1255       (Url.string_of_url_path ~encode:false)
1256       ~input_type:`Text ~name:ee ()$ <br/>
1257       $string_input ~input_type:`Submit ~value:"Click" ()$</p> >>
1258
1259 let suffixform2 = register_service ["suffixform2"] unit
1260   (fun () () ->
1261      let f = get_form suffix2 create_suffixform2 in
1262      return
1263        (html
1264           (head (title (pcdata "")) [])
1265           (body [h1 [pcdata "Hallo"];
1266                  f ])))
1267
1268 let create_suffixform3 ((suf1, (ii, ee)), (a, b)) =
1269     <:xhtmllist< <p>Write a string:
1270       $string_input ~input_type:`Text ~name:suf1 ()$ <br/>
1271       Write an int: $int_input ~input_type:`Text ~name:ii ()$ <br/>
1272       Write an int: $int_input ~input_type:`Text ~name:ee ()$ <br/>
1273       Write a string: $string_input ~input_type:`Text ~name:a ()$ <br/>
1274       Write an int: $int_input ~input_type:`Text ~name:b ()$ <br/>
1275       $string_input ~input_type:`Submit ~value:"Click" ()$</p> >>
1276
1277 let suffixform3 = register_service ["suffixform3"] unit
1278   (fun () () ->
1279      let f = get_form suffix3 create_suffixform3 in
1280      return
1281         (html
1282           (head (title (pcdata "")) [])
1283           (body [h1 [pcdata "Hallo"];
1284                  f ])))
1285
1286 let suffix5 =
1287   register_service
1288     ~path:["suffix5"]
1289     ~get_params:(suffix (all_suffix "s"))
1290     (fun s () ->
1291       return
1292         (html
1293            (head (title (pcdata "")) [])
1294            (body
1295               [p [pcdata "This is a page with suffix ";
1296                   strong [pcdata (Url.string_of_url_path
1297                                     ~encode:false s)]]])))
1298
1299 let nosuffix =
1300   register_service
1301     ~path:["suffix5";"notasuffix"]
1302     ~get_params:unit
1303     (fun () () ->
1304       return
1305         (html
1306            (head (title (pcdata "")) [])
1307            (body
1308               [p [pcdata "This is a page without suffix. Replace ";
1309                   code [pcdata "notasuffix"];
1310                   pcdata " in the URL by something else."
1311                 ]])))
1312
1313
1314
1315 (* Send file with regexp *)
1316 let sendfileregexp =
1317   register_service
1318     ~path:["files2";""]
1319     ~get_params:unit
1320     (fun () () ->
1321       return
1322         (html
1323           (head (title (pcdata "")) [])
1324           (body [h1 [pcdata "With a suffix, that page will send a file"]])))
1325
1326 let r = Netstring_pcre.regexp "~([^/]*)(.*)"
1327
1328 let sendfile2 =
1329   Files.register_service
1330     ~path:["files2";""]
1331 (*    ~get_params:(regexp r "/home/$1/public_html$2" "filename") *)
1332     ~get_params:(suffix ~redirect_if_not_suffix:false
1333                    (all_suffix_regexp r "$u($1)/public_html$2"
1334                       ~to_string:(fun s -> s) "filename"))
1335     (fun s () -> return s)
1336
1337 (* Here I am using redirect_if_not_suffix:false because
1338    otherwise I would need to write a more sophisticated to_string function *)
1339
1340 (*
1341 let sendfile2 =
1342   Files.register_service
1343     ~path:["files2";""]
1344     ~get_params:(suffix
1345                    (all_suffix_regexp r "/home/$1/public_html$2" "filename"))
1346 (*    ~get_params:(suffix (all_suffix_regexp r "$$u($1)$2" "filename")) *)
1347     (fun s () -> return s)
1348 *)
1349
1350 let create_suffixform4 n =
1351     <:xhtmllist< <p>Write the name of the file:
1352       $string_input ~input_type:`Text ~name:n ()$
1353       $string_input ~input_type:`Submit ~value:"Click" ()$</p> >>
1354
1355 let suffixform4 = register_service ["suffixform4"] unit
1356   (fun () () ->
1357      let f = get_form sendfile2 create_suffixform4 in
1358      return
1359         (html
1360           (head (title (pcdata "")) [])
1361           (body [h1 [pcdata "Hallo"];
1362                  f ])))
1363
1364
1365 (* Advanced use of any *)
1366 let any2 = register_service
1367     ~path:["any2"]
1368     ~get_params:(int "i" ** any)
1369   (fun (i,l) () ->
1370     let ll =
1371       List.map
1372         (fun (a,s) -> <:xhtml< <strong>($str:a$, $str:s$)</strong> >>) l
1373     in
1374     return
1375   <:xhtml< <html>
1376        <head><title></title></head>
1377        <body>
1378        <p>
1379          You sent:
1380          <span>$list:ll$</span>
1381          <br/>
1382          i = $str:(string_of_int i)$
1383        </p>
1384        </body>
1385      </html> >>)
1386
1387 (* the following will not work because s is taken in any. (not checked) *)
1388 let any3 = register_service
1389     ~path:["any3"]
1390     ~get_params:(int "i" ** any ** string "s")
1391   (fun (i,(l,s)) () ->
1392     let ll =
1393       List.map
1394         (fun (a,s) -> <:xhtml< <strong>($str:a$, $str:s$)</strong> >>) l
1395     in
1396     return
1397   <:xhtml< <html>
1398        <head><title></title></head>
1399        <body>
1400        <p>
1401          You sent:
1402          <span>$list:ll$</span>
1403          <br/>
1404          i = $str:(string_of_int i)$
1405          <br/>
1406          s = $str:s$
1407        </p>
1408        </body>
1409      </html> >>)
1410
1411
1412 (* any cannot be in suffix: (not checked) *)
1413 let any4 = register_service
1414     ~path:["any4"]
1415     ~get_params:(suffix any)
1416   (fun l () ->
1417     let ll =
1418       List.map
1419         (fun (a,s) -> <:xhtml< <strong>($str:a$, $str:s$)</strong> >>) l
1420     in
1421     return
1422   <:xhtml< <html>
1423        <head><title></title></head>
1424        <body>
1425        <p>
1426          You sent:
1427          <span>$list:ll$</span>
1428        </p>
1429        </body>
1430      </html> >>)
1431
1432
1433 let any5 = register_service
1434     ~path:["any5"]
1435     ~get_params:(suffix_prod (string "s") any)
1436   (fun (s, l) () ->
1437     let ll =
1438       List.map
1439         (fun (a,s) -> <:xhtml< <strong>($str:a$, $str:s$)</strong> >>) l
1440     in
1441     return
1442   <:xhtml< <html>
1443        <head><title></title></head>
1444        <body>
1445        <p>
1446          You sent <strong>$str:s$</strong> and :
1447          <span>$list:ll$</span>
1448        </p>
1449        </body>
1450      </html> >>)
1451
1452 (* list in suffix *)
1453 let sufli = service
1454     ~path:["sufli"]
1455     ~get_params:(suffix (list "l" (string "s" ** int "i")))
1456     ()
1457
1458 let _ = register sufli
1459   (fun l () ->
1460     let ll =
1461       List.map
1462         (fun (s, i) -> <:xhtml< <strong> $str:(s^string_of_int i)$ </strong> >>) l
1463     in
1464     return
1465   <:xhtml< <html>
1466        <head><title></title></head>
1467        <body>
1468        <p>
1469          You sent:
1470          <span>$list:ll$</span>
1471        </p>
1472        <p>
1473          $a sufli [pcdata "myself"] [("a", 2)]$,
1474          $a sufli [pcdata "myself (empty list)"] []$
1475        </p>
1476        </body>
1477      </html> >>)
1478
1479 let create_sufliform f =
1480   let l =
1481     f.it (fun (sn, iname) v init ->
1482             (tr (td [pcdata ("Write a string: ")])
1483                [td [string_input ~input_type:`Text ~name:sn ()];
1484                 td [pcdata ("Write an integer: ")];
1485                 td [int_input ~input_type:`Text ~name:iname ()];
1486                ])::init)
1487       ["one";"two";"three"]
1488       []
1489   in
1490   [table (List.hd l) (List.tl l);
1491    p [string_input ~input_type:`Submit ~value:"Click" ()]]
1492
1493 let sufliform = register_service ["sufliform"] unit
1494   (fun () () ->
1495      let f = get_form sufli create_sufliform in
1496      return
1497        (html
1498           (head (title (pcdata "")) [])
1499           (body [h1 [pcdata "Hallo"];
1500                  f ])))
1501
1502 (*
1503 (* mmmh ... disabled dynamically for now *)
1504 let sufli2 = service
1505     ~path:["sufli2"]
1506     ~get_params:(suffix ((list "l" (int "i")) ** int "j"))
1507     ()
1508
1509 let _ = register sufli2
1510   (fun (l, j) () ->
1511     let ll =
1512       List.map (fun i -> <:xhtml< <strong> $str:(string_of_int i)$ </strong> >>) l
1513     in
1514     return
1515   <:xhtml< <html>
1516        <head><title></title></head>
1517        <body>
1518        <p>
1519          You sent:
1520          <span>$list:ll$</span>,
1521          and
1522          j=$str:string_of_int j$.
1523        </p>
1524        <p>
1525          $a sufli2 [pcdata "myself"] ([1; 2], 3)$,
1526          $a sufli2 [pcdata "myself (empty list)"] ([], 1)$
1527        </p>
1528        </body>
1529      </html> >>)
1530 *)
1531
1532 let sufliopt = service
1533     ~path:["sufliopt"]
1534     ~get_params:(suffix (list "l" (opt (string "s"))))
1535     ()
1536
1537 let _ = register sufliopt
1538   (fun l () ->
1539     let ll =
1540       List.map
1541         (function None -> pcdata "<none>"
1542            | Some s -> <:xhtml< <strong> $str:s$ </strong> >>) l
1543     in
1544     return
1545   <:xhtml< <html>
1546        <head><title></title></head>
1547        <body>
1548        <p>
1549          You sent:
1550          <span>$list:ll$</span>
1551        </p>
1552        <p>
1553          $a sufliopt [pcdata "myself"] [Some "a"; None; Some "po"; None; None; Some "k"; None]$,
1554          $a sufliopt [pcdata "myself (empty list)"] []$
1555          $a sufliopt [pcdata "myself (list [None; None])"] [None; None]$
1556          $a sufliopt [pcdata "myself (list [None])"] [None]$
1557        </p>
1558        </body>
1559      </html> >>)
1560
1561
1562 let sufliopt2 = service
1563     ~path:["sufliopt2"]
1564     ~get_params:(suffix (list "l" (opt (string "s" ** string "ss"))))
1565     ()
1566
1567 let _ = register sufliopt2
1568   (fun l () ->
1569     let ll =
1570       List.map
1571         (function None -> pcdata "<none>"
1572            | Some (s, ss) -> <:xhtml< <strong> ($str:s$, $str:ss$) </strong> >>) l
1573     in
1574     return
1575   <:xhtml< <html>
1576        <head><title></title></head>
1577        <body>
1578        <p>
1579          You sent:
1580          <span>$list:ll$</span>
1581        </p>
1582        <p>
1583          $a sufliopt2 [pcdata "myself"] [Some ("a", "jj"); None; Some ("po", "jjj"); None; None; Some ("k", "pp"); None]$,
1584          $a sufliopt2 [pcdata "myself (empty list)"] []$
1585          $a sufliopt2 [pcdata "myself (list [None; None])"] [None; None]$
1586          $a sufliopt2 [pcdata "myself (list [None])"] [None]$
1587        </p>
1588        </body>
1589      </html> >>)
1590
1591
1592 (* set in suffix *)
1593 let sufset = register_service
1594     ~path:["sufset"]
1595     ~get_params:(suffix (Eliom_parameters.set string "s"))
1596   (fun l () ->
1597     let ll =
1598       List.map
1599         (fun s -> <:xhtml< <strong>$str:s$</strong> >>) l
1600     in
1601     return
1602   <:xhtml< <html>
1603        <head><title></title></head>
1604        <body>
1605        <p>
1606          You sent:
1607          <span>$list:ll$</span>
1608        </p>
1609        </body>
1610      </html> >>)
1611
1612
1613
1614 (* form to any2 *)
1615 let any2form = register_service
1616     ~path:["any2form"]
1617     ~get_params:unit
1618     (fun () () ->
1619       return
1620         (html
1621            (head (title (pcdata "")) [])
1622            (body [h1 [pcdata "Any Form"];
1623                   get_form any2
1624                     (fun (iname,grr) ->
1625                       [p [pcdata "Form to any2: ";
1626                           int_input ~input_type:`Text ~name:iname ();
1627                           raw_input ~input_type:`Text ~name:"plop" ();
1628                           raw_input ~input_type:`Text ~name:"plip" ();
1629                           raw_input ~input_type:`Text ~name:"plap" ();
1630                           string_input ~input_type:`Submit ~value:"Click" ()]])
1631                 ])))
1632
1633
1634 (* bool list *)
1635
1636 let boollist = register_service
1637     ~path:["boollist"]
1638     ~get_params:(list "a" (bool "b"))
1639   (fun l () ->
1640     let ll =
1641       List.map (fun b ->
1642         (strong [pcdata (if b then "true" else "false")])) l in
1643     return
1644       (html
1645          (head (title (pcdata "")) [])
1646          (body
1647             [p ((pcdata "You sent: ")::ll)]
1648          )))
1649
1650 let create_listform f =
1651   (* Here, f.it is an iterator like List.map,
1652      but it must be applied to a function taking 2 arguments
1653      (and not 1 as in map), the first one being the name of the parameter.
1654      The last parameter of f.it is the code that must be appended at the
1655      end of the list created
1656    *)
1657   let l =
1658     f.it (fun boolname v init ->
1659             (tr (td [pcdata ("Write the value for "^v^": ")])
1660                [td [bool_checkbox ~name:boolname ()]])::init)
1661       ["one";"two";"three"]
1662       []
1663   in
1664   [table (List.hd l) (List.tl l);
1665    p [raw_input ~input_type:`Submit ~value:"Click" ()]]
1666
1667 let boollistform = register_service ["boolform"] unit
1668   (fun () () ->
1669      let f = get_form boollist create_listform in return
1670         (html
1671           (head (title (pcdata "")) [])
1672           (body [f])))
1673
1674
1675 (********)
1676
1677 let coucoucou =
1678   register_service
1679     ~path:["coucoucou"]
1680     ~get_params:unit
1681     (fun () () ->
1682       return
1683         (html
1684            (head (title (pcdata "")) [])
1685            (body [h1 [pcdata "Hallo!"]])))
1686
1687 (* any with POST *)
1688 let any = register_post_service
1689     ~fallback:coucoucou
1690     ~post_params:any
1691   (fun () l ->
1692     let ll =
1693       List.map
1694         (fun (a,s) -> <:xhtml< <strong>($str:a$, $str:s$)</strong> >>) l
1695     in
1696     return
1697   <:xhtml< <html>
1698        <head><title></title></head>
1699        <body>
1700        <p>
1701          You sent:
1702          $list:ll$
1703        </p>
1704        </body>
1705      </html> >>)
1706
1707 (* form to any *)
1708 let anypostform = register_service
1709     ~path:["anypostform"]
1710     ~get_params:unit
1711     (fun () () ->
1712       return
1713         (html
1714            (head (title (pcdata "")) [])
1715            (body [h1 [pcdata "Any Form"];
1716                   post_form any
1717                     (fun () ->
1718                       [p [pcdata "Empty form to any: ";
1719                           string_input ~input_type:`Submit ~value:"Click" ()]])
1720                     ()
1721                 ])))
1722
1723 (**********)
1724 (* upload *)
1725
1726 (* ce qui suit ne doit pas fonctionner. Mais il faudrait l'interdire *)
1727 let get_param_service =
1728   register_service
1729    ~path:["uploadget"]
1730    ~get_params:(string "name" ** file "file")
1731     (fun (name,file) () ->
1732          let to_display =
1733            let newname = "/tmp/fichier" in
1734            (try
1735              Unix.unlink newname;
1736            with _ -> ());
1737            Unix.link (Eliom_request_info.get_tmp_filename file) newname;
1738            let fd_in = open_in newname in
1739            try
1740              let line = input_line fd_in in close_in fd_in; line (*end*)
1741            with End_of_file -> close_in fd_in; "vide"
1742          in
1743          return
1744             (html
1745                 (head (title (pcdata name)) [])
1746                 (body [h1 [pcdata to_display]])))
1747
1748
1749 let uploadgetform = register_service ["uploadget"] unit
1750   (fun () () ->
1751     let f =
1752 (* ARG        (post_form ~a:[(XHTML.M.a_enctype "multipart/form-data")] fichier2 *)
1753      (get_form ~a:[(XHTML.M.a_enctype "multipart/form-data")] ~service:get_param_service
1754      (*post_form my_service_with_post_params        *)
1755         (fun (str, file) ->
1756           [p [pcdata "Write a string: ";
1757               string_input ~input_type:`Text ~name:str ();
1758               br ();
1759               file_input ~name:file ()]])) in  return
1760          (html
1761            (head (title (pcdata "form")) [])
1762            (body [f])))
1763
1764
1765 (*******)
1766 (* Actions that raises an exception *)
1767 let exn_act = Action.register_coservice'
1768     ~get_params:unit
1769     (fun g p -> fail Not_found)
1770
1771 let exn_act_main =
1772   register_service
1773     ~path:["exnact"]
1774     ~get_params:unit
1775     (fun () () ->
1776       return
1777         (html
1778            (head (title (pcdata "exnact")) [])
1779            (body [h1 [pcdata "Hello"];
1780                   p [a exn_act [pcdata "Do the action"] ()
1781                    ]])))
1782
1783
1784 let action_example2_scope =
1785   `Session (Eliom_common.create_scope_name "action_example2")
1786
1787 (* close sessions from outside *)
1788 let close_from_outside =
1789   register_service
1790     ~path:["close_from_outside"]
1791     ~get_params:unit
1792     (fun () () ->
1793       lwt () = discard_all ~scope:persistent_session_scope () in
1794       lwt () = discard_all ~scope:action_example2_scope () in
1795       return
1796         (html
1797            (head (title (pcdata "")) [])
1798            (body [h1 [pcdata "all sessions called \"persistent_sessions\" and \"action_example2\" closed"];
1799                   p [a persist_session_example [pcdata "try"] ()]])))
1800
1801
1802
1803 (* setting timeouts *)
1804 let set_timeout =
1805 register_service
1806     ~path:["set_timeout"]
1807     ~get_params:(int "t" ** (bool "recompute" ** bool "overrideconfig"))
1808     (fun (t, (recompute, override_configfile)) () ->
1809       set_global_persistent_data_state_timeout
1810         ~override_configfile
1811         ~scope:persistent_session_scope
1812         ~recompute_expdates:recompute (Some (float_of_int t));
1813       set_global_volatile_state_timeout
1814         ~override_configfile
1815         ~scope:action_example2_scope
1816         ~recompute_expdates:recompute (Some (float_of_int t));
1817       return
1818         (html
1819            (head (title (pcdata "")) [])
1820            (body [h1 [pcdata "Setting timeout"];
1821                   p [
1822                   if recompute
1823                   then pcdata ("The timeout for sessions called \"persistent_sessions\" and \"action_example2\" has been set to "^(string_of_int t)^" seconds (all expiration dates updated).")
1824                   else pcdata ("From now, the timeout for sessions called \"persistent_sessions\" and \"action_example2\" will be "^(string_of_int t)^" seconds (expiration dates not updated)."); br ();
1825                   a persist_session_example [pcdata "Try"] ()]])))
1826
1827
1828 let create_form =
1829   (fun (number_name, (bool1name, bool2name)) ->
1830     [p [pcdata "New timeout: ";
1831         Eliom_output.Xhtml.int_input ~input_type:`Text ~name:number_name ();
1832         br ();
1833         pcdata "Check the box if you want to recompute all timeouts: ";
1834         Eliom_output.Xhtml.bool_checkbox ~name:bool1name ();
1835         br ();
1836         pcdata "Check the box if you want to override configuration file: ";
1837         Eliom_output.Xhtml.bool_checkbox ~name:bool2name ();
1838         Eliom_output.Xhtml.string_input ~input_type:`Submit ~value:"Submit" ()]])
1839
1840 let set_timeout_form =
1841   register_service
1842     ["set_timeout"]
1843     unit
1844     (fun () () ->
1845       let f = Eliom_output.Xhtml.get_form set_timeout create_form in
1846       return
1847         (html
1848            (head (title (pcdata "")) [])
1849            (body [f])))
1850
1851
1852
1853 (******************************************************************)
1854
1855 let sraise =
1856   register_service
1857     ~path:["raise"]
1858     ~get_params:unit
1859     (fun () () -> failwith "Bad use of exceptions")
1860
1861 let sfail =
1862   register_service
1863     ~path:["fail"]
1864     ~get_params:unit
1865     (fun () () -> Lwt.fail (Failure "Service raising an exception"))
1866
1867
1868 (*****************************************************************************)
1869
1870 (* 2011/08/02 Vincent - Volatile group data
1871    removing group data or not when no session in the group?*)
1872 (*zap* *)
1873 open HTML5.M
1874 open Eliom_output.Html5
1875
1876 (*zap* *)
1877 let scope_name = Eliom_common.create_scope_name "session_group_data_example_state"
1878 let session = `Session scope_name
1879 let group = `Session_group scope_name
1880 (* *zap*)
1881 (* -------------------------------------------------------- *)
1882 (* We create one main service and two (POST) actions        *)
1883 (* (for connection and disconnection)                       *)
1884
1885 let connect_example_gd =
1886   Eliom_services.service
1887     ~path:["sessgrpdata"]
1888     ~get_params:unit
1889     ()
1890
1891 let connect_action =
1892   Eliom_services.post_coservice'
1893     ~name:"connectiongd"
1894     ~post_params:(string "login")
1895     ()
1896
1897 (* disconnect action and box:                               *)
1898
1899 let disconnect_action =
1900   Eliom_output.Action.register_post_coservice'
1901     ~name:"disconnectiongd"
1902     ~post_params:Eliom_parameters.unit
1903     (fun () () -> Eliom_state.discard ~scope:session ())
1904
1905 let disconnect_box s =
1906   Eliom_output.Html5.post_form disconnect_action
1907     (fun _ -> [p [Eliom_output.Html5.string_input
1908                     ~input_type:`Submit ~value:s ()]]) ()
1909
1910 (* The following eref is true if the connection has action failed: *)
1911 let bad_user = Eliom_references.eref ~scope:Eliom_common.request false
1912
1913 let my_group_data = Eliom_references.eref ~scope:group None
1914
1915 let change_gd =
1916   Eliom_output.Action.register_post_coservice'
1917     ~name:"changegd"
1918     ~post_params:Eliom_parameters.unit
1919     (fun () () -> Eliom_references.set my_group_data (Some (1000 + Random.int 1000)))
1920
1921 (* -------------------------------------------------------- *)
1922 (* new login box:                                           *)
1923
1924 let login_box session_expired bad_u action =
1925   Eliom_output.Html5.post_form action
1926     (fun loginname ->
1927       let l =
1928         [pcdata "login: ";
1929          Eliom_output.Html5.string_input ~input_type:`Text ~name:loginname ()]
1930       in
1931       [p (if bad_u
1932         then (pcdata "Wrong user")::(br ())::l
1933         else
1934           if session_expired
1935           then (pcdata "Session expired")::(br ())::l
1936           else l)
1937      ])
1938     ()
1939
1940 (* -------------------------------------------------------- *)
1941 (* Handler for the "connect_example" service (main page):   *)
1942
1943 let connect_example_handler () () =
1944   (* The following function tests whether the session has expired: *)
1945   let status = Eliom_state.volatile_data_state_status (*zap* *) ~scope:session (* *zap*) ()
1946   in
1947   let group =
1948     Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) ()
1949   in
1950   Eliom_references.get bad_user >>= fun bad_u ->
1951   Eliom_references.get my_group_data >>= fun my_group_data ->
1952   Lwt.return
1953     (html
1954        (head (title (pcdata "")) [])
1955        (body
1956           (match group, status with
1957           | Some name, _ ->
1958               [p [pcdata ("Hello "^name); br ();
1959                   (match my_group_data with
1960                     | None -> pcdata "You have no group data."
1961                     | Some i -> pcdata ("Your group data is "^string_of_int i^"."))];
1962                Eliom_output.Html5.post_form change_gd
1963                  (fun () -> [p [Eliom_output.Html5.string_input
1964                                    ~input_type:`Submit
1965                                    ~value:"Change group data" ()]]) ();
1966                p [pcdata "Check that several sessions have the same group data."];
1967                p [pcdata "Volatile group data are currently discarded when all group disappear. This is weird and not coherent with persistent group data. But I don't really see a correct use of volatile group data. Is there any? And there is a risk of memory leak if we keep them. Besides, volatile sessions are (hopefully) going to disappear soon."];
1968                disconnect_box "Close session"]
1969           | None, Eliom_state.Expired_state ->
1970               [login_box true bad_u connect_action;
1971                p [em [pcdata "The only user is 'toto'."]]]
1972           | _ ->
1973               [login_box false bad_u connect_action;
1974                p [em [pcdata "The only user is 'toto'."]]]
1975           )))
1976
1977 (* -------------------------------------------------------- *)
1978 (* Handler for connect_action (user logs in):               *)
1979
1980 let connect_action_handler () login =
1981   lwt () = Eliom_state.discard ~scope:session () in
1982   if login = "toto" (* Check user and password :-) *)
1983   then begin
1984     Eliom_state.set_volatile_data_session_group ~set_max:4 (*zap* *) ~scope:session (* *zap*) login;
1985     Eliom_references.get my_group_data >>= fun mgd ->
1986     (if mgd = None
1987      then Eliom_references.set my_group_data (Some (Random.int 1000))
1988      else Lwt.return ()) >>= fun () ->
1989     Eliom_output.Redirection.send Eliom_services.void_hidden_coservice'
1990   end
1991   else
1992     Eliom_references.set bad_user true >>= fun () ->
1993     Eliom_output.Action.send ()
1994
1995
1996 (* -------------------------------------------------------- *)
1997 (* Registration of main services:                           *)
1998
1999 let () =
2000   Eliom_output.Html5.register ~service:connect_example_gd connect_example_handler;
2001   Eliom_output.Any.register ~service:connect_action connect_action_handler
2002
2003
2004 (*****************************************************************************)
2005
2006 (* 2011/08/02 Vincent - Persistent group data
2007    removing group data or not when no session in the group? *)
2008 (*zap* *)
2009 open HTML5.M
2010
2011 (*zap* *)
2012 let scope_name = Eliom_common.create_scope_name "pers_session_group_data_example_state"
2013 let session = `Session scope_name
2014 let group = `Session_group scope_name
2015 (* *zap*)
2016 (* -------------------------------------------------------- *)
2017 (* We create one main service and two (POST) actions        *)
2018 (* (for connection and disconnection)                       *)
2019
2020 let connect_example_pgd =
2021   Eliom_services.service
2022     ~path:["psessgrpdata"]
2023     ~get_params:unit
2024     ()
2025
2026 let connect_action =
2027   Eliom_services.post_coservice'
2028     ~name:"connectionpgd"
2029     ~post_params:(string "login")
2030     ()
2031
2032 (* disconnect action and box:                               *)
2033
2034 let disconnect_action =
2035   Eliom_output.Action.register_post_coservice'
2036     ~name:"disconnectionpgd"
2037     ~post_params:Eliom_parameters.unit
2038     (fun () () -> Eliom_state.discard ~scope:session ())
2039
2040 let disconnect_box s =
2041   Eliom_output.Html5.post_form disconnect_action
2042     (fun _ -> [p [Eliom_output.Html5.string_input
2043                     ~input_type:`Submit ~value:s ()]]) ()
2044
2045 (* The following eref is true if the connection has action failed: *)
2046 let bad_user = Eliom_references.eref ~scope:Eliom_common.request false
2047
2048 let my_group_data = Eliom_references.eref ~persistent:"pgd" ~scope:group None
2049
2050 let change_gd =
2051   Eliom_output.Action.register_post_coservice'
2052     ~name:"changepgd"
2053     ~post_params:Eliom_parameters.unit
2054     (fun () () -> Eliom_references.set my_group_data (Some (1000 + Random.int 1000)))
2055
2056
2057 (* -------------------------------------------------------- *)
2058 (* new login box:                                           *)
2059
2060 let login_box session_expired bad_u action =
2061   Eliom_output.Html5.post_form action
2062     (fun loginname ->
2063       let l =
2064         [pcdata "login: ";
2065          Eliom_output.Html5.string_input ~input_type:`Text ~name:loginname ()]
2066       in
2067       [p (if bad_u
2068         then (pcdata "Wrong user")::(br ())::l
2069         else
2070           if session_expired
2071           then (pcdata "Session expired")::(br ())::l
2072           else l)
2073      ])
2074     ()
2075
2076 (* -------------------------------------------------------- *)
2077 (* Handler for the "connect_example" service (main page):   *)
2078
2079 let connect_example_handler () () =
2080   (* The following function tests whether the session has expired: *)
2081   let status = Eliom_state.volatile_data_state_status (*zap* *) ~scope:session (* *zap*) ()
2082   in
2083   let group =
2084     Eliom_state.get_volatile_data_session_group (*zap* *) ~scope:session (* *zap*) ()
2085   in
2086   Eliom_references.get bad_user >>= fun bad_u ->
2087   Eliom_references.get my_group_data >>= fun my_group_data ->
2088   Lwt.return
2089     (html
2090        (head (title (pcdata "")) [])
2091        (body
2092           (match group, status with
2093           | Some name, _ ->
2094               [p [pcdata ("Hello "^name); br ();
2095                   (match my_group_data with
2096                     | None -> pcdata "You have no group data."
2097                     | Some i -> pcdata ("Your group data is "^string_of_int i^"."));
2098                  ];
2099                Eliom_output.Html5.post_form change_gd
2100                  (fun () -> [p [Eliom_output.Html5.string_input
2101                                    ~input_type:`Submit
2102                                    ~value:"Change group data" ()]]) ();
2103                p [pcdata "Check that several sessions have the same group data."];
2104                p [pcdata "Check that persistent group data do not disappear when all sessions from the group are closed."];
2105                p [pcdata "Persistent group data are used as a basic database, for example to store user information (email, etc)."];
2106               disconnect_box "Close session"]
2107           | None, Eliom_state.Expired_state ->
2108               [login_box true bad_u connect_action;
2109                p [em [pcdata "The only user is 'toto'."]]]
2110           | _ ->
2111               [login_box false bad_u connect_action;
2112                p [em [pcdata "The only user is 'toto'."]]]
2113           )))
2114
2115 (* -------------------------------------------------------- *)
2116 (* Handler for connect_action (user logs in):               *)
2117
2118 let connect_action_handler () login =
2119   lwt () = Eliom_state.discard ~scope:session () in
2120   if login = "toto" (* Check user and password :-) *)
2121   then begin
2122     Eliom_state.set_volatile_data_session_group ~set_max:4 (*zap* *) ~scope:session (* *zap*) login;
2123     Eliom_references.get my_group_data >>= fun mgd ->
2124     (if mgd = None
2125      then Eliom_references.set my_group_data (Some (Random.int 1000))
2126      else Lwt.return ()) >>= fun () ->
2127     Eliom_output.Redirection.send Eliom_services.void_hidden_coservice'
2128   end
2129   else
2130     Eliom_references.set bad_user true >>= fun () ->
2131     Eliom_output.Action.send ()
2132
2133
2134 (* -------------------------------------------------------- *)
2135 (* Registration of main services:                           *)
2136
2137 let () =
2138   Eliom_output.Html5.register ~service:connect_example_pgd connect_example_handler;
2139   Eliom_output.Any.register ~service:connect_action connect_action_handler
2140
2141
2142 (*****************************************************************************)
2143 (* Actions with `NoReload option *)
2144 let noreload_ref = ref 0
2145
2146 let noreload_action =
2147   Eliom_output.Action.register_coservice'
2148     ~options:`NoReload
2149     ~get_params:unit
2150     (fun () () -> noreload_ref := !noreload_ref + 1; Lwt.return ())
2151
2152 let noreload =
2153   register_service
2154     ~path:["noreload"]
2155     ~get_params:unit
2156     (fun () () ->
2157       return
2158         (html
2159          (head (title (pcdata "counter")) [])
2160          (body [p [pcdata (string_of_int (!noreload_ref)); br ();
2161                    Eliom_output.Html5.a ~service:noreload_action
2162                      [pcdata "Click to increment the counter."] ();
2163                    br ();
2164                    pcdata "You should not see the result if you do not reload the page."
2165                   ]])))
2166