http/ocsigen_senders.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * sender_helpers.ml Copyright (C) 2005 Denis Berthod
   4  * Laboratoire PPS - CNRS Université Paris Diderot
   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 (** This module provides predefined "senders" for usual types of pages to be
  21   sent by the server: xhtml, files, ... *)
  22
  23 open Ocsigen_http_frame
  24 open Ocsigen_http_com
  25 open Lwt
  26 open Ocsigen_stream
  27 open XHTML.M
  28
  29
  30 (*****************************************************************************)
  31 (** this module instantiate the HTTP_CONTENT signature for an Xhtml content*)
  32
  33 module Old_Xhtml_content =
  34   struct
  35     type t = [ `Html ] XHTML.M.elt
  36
  37     type options = unit
  38
  39     let get_etag_aux x =
  40       Some (Digest.to_hex (Digest.string x))
  41
  42     let get_etag c =
  43       let x = Xhtmlpretty.xhtml_print c in
  44       get_etag_aux x
  45
  46     let result_of_content ?(options = ()) c =
  47       let x = Xhtmlpretty.xhtml_print c in
  48       let md5 = get_etag_aux x in
  49       let default_result = default_result () in
  50       Lwt.return
  51         {default_result with
  52          res_content_length = Some (Int64.of_int (String.length x));
  53          res_content_type = Some "text/html";
  54          res_etag = md5;
  55          res_headers= Http_headers.dyn_headers;
  56          res_stream =
  57             (Ocsigen_stream.make
  58                (fun () -> Ocsigen_stream.cont x
  59                   (fun () -> Ocsigen_stream.empty None)),
  60              None)
  61        }
  62
  63   end
  64
  65 module Xhtml_content_(Xhtmlprinter : sig
  66                         val xhtml_stream :
  67                           ?version:[< `HTML_v03_02 | `HTML_v04_01
  68                           | `XHTML_01_00 | `XHTML_01_01 | `Doctype of string
  69                               > `XHTML_01_01 ] ->
  70                           ?width:int ->
  71                           ?encode:(string -> string) ->
  72                           ?html_compat:bool ->
  73                           [ `Html ] XHTML.M.elt -> string Ocsigen_stream.t
  74                       end) =
  75   struct
  76     type t = [ `Html ] XHTML.M.elt
  77
  78     type options = [ `HTML_v03_02 | `HTML_v04_01 | `XHTML_01_00 | `XHTML_01_01 | `Doctype of string ]
  79
  80     let get_etag_aux x = None
  81
  82     let get_etag c = None
  83
  84     let result_of_content ?(options = `XHTML_01_01) c =
  85       let x = Xhtmlprinter.xhtml_stream ~version:options c in
  86       let default_result = default_result () in
  87       Lwt.return
  88         {default_result with
  89          res_content_length = None;
  90          res_content_type = Some "text/html";
  91          res_etag = get_etag c;
  92          res_headers= Http_headers.dyn_headers;
  93          res_stream = (x, None)
  94        }
  95
  96   end
  97
  98 module Xhtml_content = Xhtml_content_(Xhtmlpretty_streams)
  99 module Xhtmlcompact_content = Xhtml_content_(Xhtmlcompact_streams)
 100
 101 (*****************************************************************************)
 102 module Text_content =
 103   struct
 104     type t = string (* content *) * string (* content-type *)
 105
 106     type options = unit
 107
 108     let get_etag (x, _) =
 109       Some (Digest.to_hex (Digest.string x))
 110
 111     let result_of_content ?(options = ()) ((c, ct) as content) =
 112       let md5 = get_etag content in
 113       let default_result = default_result () in
 114       Lwt.return
 115         {default_result with
 116          res_content_length = Some (Int64.of_int (String.length c));
 117          res_etag = md5;
 118          res_content_type = Some ct;
 119          res_headers= Http_headers.dyn_headers;
 120          res_stream =
 121             (Ocsigen_stream.make
 122                (fun () ->
 123                   Ocsigen_stream.cont c (fun () -> Ocsigen_stream.empty None)),
 124              None)
 125
 126             }
 127
 128   end
 129
 130 (*****************************************************************************)
 131 module Stream_content =
 132   (* Used to send data from a stream *)
 133   struct
 134     type t = string Ocsigen_stream.t
 135
 136     type options = unit
 137
 138     let get_etag c = None
 139
 140     let result_of_content ?(options = ()) c =
 141       let default_result = default_result () in
 142       Lwt.return
 143         {default_result with
 144          res_content_length = None;
 145          res_headers= Http_headers.dyn_headers;
 146          res_stream = (c, None)}
 147
 148   end
 149
 150 (*****************************************************************************)
 151 module Streamlist_content =
 152   (* Used to send data from streams *)
 153   struct
 154     type t = (unit -> string Ocsigen_stream.t Lwt.t) list
 155           * string (* content-type *)
 156
 157     type options = unit
 158
 159     let get_etag c = None
 160
 161     let result_of_content ?(options = ()) (c, ct) =
 162       let finalizer = ref (fun () -> Lwt.return ()) in
 163       let finalize () =
 164         let f = !finalizer in
 165         finalizer := (fun () -> Lwt.return ());
 166         f ()
 167       in
 168       let rec next stream l =
 169         Lwt.try_bind (fun () -> Ocsigen_stream.next stream)
 170           (fun s ->
 171              match s with
 172                Ocsigen_stream.Finished None ->
 173                  finalize () >>= fun () ->
 174                  next_stream l
 175              | Ocsigen_stream.Finished (Some stream) ->
 176                  next stream l
 177              | Ocsigen_stream.Cont (v, stream) ->
 178                  Ocsigen_stream.cont v (fun () -> next stream l))
 179           (function Interrupted e | e ->
 180 (*XXX string_of_exn should know how to print "Interrupted _" exceptions*)
 181              exnhandler e l)
 182       and next_stream l =
 183         match l with
 184           [] -> Ocsigen_stream.empty None
 185         | f :: l ->
 186             Lwt.try_bind f
 187               (fun stream ->
 188                  finalizer := (fun () -> Ocsigen_stream.finalize stream);
 189                  next (Ocsigen_stream.get stream) l)
 190               (fun e -> exnhandler e l)
 191       and exnhandler e l =
 192         Ocsigen_messages.warning
 193           ("Error while reading stream list: " ^ Ocsigen_lib.string_of_exn e);
 194         finalize () >>= fun () ->
 195         next_stream l
 196       in
 197       let default_result = default_result () in
 198       Lwt.return
 199         {default_result with
 200          res_content_length = None;
 201          res_etag = get_etag c;
 202          res_stream =
 203             (Ocsigen_stream.make ~finalize (fun () -> next_stream c), None);
 204          res_headers= Http_headers.dyn_headers;
 205          res_content_type = Some ct}
 206
 207   end
 208
 209
 210 (*****************************************************************************)
 211 module Empty_content =
 212   struct
 213     type t = unit
 214
 215     type options = unit
 216
 217     let get_etag c = None
 218
 219     let result_of_content ?(options = ()) c = Lwt.return (empty_result ())
 220
 221   end
 222
 223 (*****************************************************************************)
 224 (* Files *)
 225
 226 (** this module instanciate the HTTP_CONTENT signature for files *)
 227 module File_content =
 228   struct
 229     type t =
 230         string (* nom du fichier *) *
 231         Ocsigen_charset_mime.charset_assoc *
 232         Ocsigen_charset_mime.mime_assoc
 233
 234     type options = unit
 235
 236     let read_file ?buffer_size fd =
 237       let buffer_size = match buffer_size with
 238       | None -> Ocsigen_config.get_filebuffersize ()
 239       | Some s -> s
 240       in
 241       Ocsigen_messages.debug2 "start reading file (file opened)";
 242       let buf = String.create buffer_size in
 243       let rec read_aux () =
 244           Lwt_unix.read fd buf 0 buffer_size >>= fun read ->
 245           if read = 0 then
 246             Ocsigen_stream.empty None
 247           else begin
 248             if read = buffer_size
 249             then Ocsigen_stream.cont buf read_aux
 250             else Ocsigen_stream.cont (String.sub buf 0 read) read_aux
 251           end
 252       in read_aux
 253
 254     let get_etag_aux st =
 255       Some (Printf.sprintf "%Lx-%x-%f" st.Unix.LargeFile.st_size
 256               st.Unix.LargeFile.st_ino st.Unix.LargeFile.st_mtime)
 257
 258     let get_etag (f, _, _) =
 259       let st = Unix.LargeFile.stat f in
 260       get_etag_aux st
 261
 262     let skip fd stream k =
 263       try
 264         ignore
 265           (Unix.LargeFile.lseek (Lwt_unix.unix_file_descr fd) k Unix.SEEK_CUR);
 266         Ocsigen_stream.next (Ocsigen_stream.get stream)
 267       with e -> Lwt.fail e
 268
 269     let result_of_content ?options (c, charset_assoc, mime_assoc) =
 270       (* open the file *)
 271       catch
 272         (fun () ->
 273         let fdu = Unix.openfile c [Unix.O_RDONLY;Unix.O_NONBLOCK] 0o666 in
 274         let fd = Lwt_unix.of_unix_file_descr fdu in
 275         catch
 276           (fun () ->
 277           let st = Unix.LargeFile.fstat fdu in
 278           let etag = get_etag_aux st in
 279           let stream = read_file fd in
 280           let default_result = default_result () in
 281           Lwt.return
 282             {default_result with
 283                res_content_length = Some st.Unix.LargeFile.st_size;
 284                res_content_type =
 285                 Some (Ocsigen_charset_mime.find_mime c mime_assoc);
 286                res_charset =
 287                 Some (Ocsigen_charset_mime.find_charset c charset_assoc);
 288                res_lastmodified = Some st.Unix.LargeFile.st_mtime;
 289                res_etag = etag;
 290                res_stream =
 291                 (Ocsigen_stream.make
 292                    ~finalize:
 293                    (fun () ->
 294                       Ocsigen_messages.debug2 "closing file";
 295                       Lwt_unix.close fd)
 296                    stream,
 297                  Some (skip fd))
 298             })
 299           (fun e -> Lwt_unix.close fd >>= (fun () -> fail e)))
 300         (fun e -> Ocsigen_messages.debug2 (Printexc.to_string e); fail e)
 301
 302   end
 303
 304 (*****************************************************************************)
 305 (* directory listing - by Gabriel Kerneis *)
 306
 307 (** this module instanciate the HTTP_CONTENT signature for directories *)
 308 module Directory_content =
 309   struct
 310     type t = string (* dir name *) * string list (* corresponding URL path *)
 311
 312     type options = unit
 313
 314     let get_etag_aux st =
 315       Some (Printf.sprintf "%Lx-%x-%f" st.Unix.LargeFile.st_size
 316               st.Unix.LargeFile.st_ino st.Unix.LargeFile.st_mtime)
 317
 318     let get_etag (f, _) =
 319       let st = Unix.LargeFile.stat f in
 320       get_etag_aux st
 321
 322     let date fl =
 323       let t = Unix.gmtime fl in
 324       Printf.sprintf
 325         "%02d-%02d-%04d %02d:%02d:%02d"
 326         t.Unix.tm_mday
 327         (t.Unix.tm_mon + 1)
 328         (1900 + t.Unix.tm_year)
 329         t.Unix.tm_hour
 330         t.Unix.tm_min
 331         t.Unix.tm_sec
 332
 333
 334     let image_found fich =
 335       if fich="README" || fich="README.Debian"
 336       then "/ocsigenstuff/readme.png"
 337       else
 338         let reg=Netstring_pcre.regexp "([^//.]*)(.*)"
 339         in match Netstring_pcre.global_replace reg "$2" fich with
 340         | ".jpeg" | ".jpg" | ".gif" | ".tif"
 341         | ".png" -> "/ocsigenstuff/image.png"
 342         | ".ps" -> "/ocsigenstuff/postscript.png"
 343         | ".pdf" -> "/ocsigenstuff/pdf.png"
 344         | ".html" | ".htm"
 345         | ".php" -> "/ocsigenstuff/html.png"
 346         | ".mp3"
 347         | ".wma" -> "/ocsigenstuff/sound.png"
 348         | ".c" -> "/ocsigenstuff/source_c.png"
 349         | ".java" -> "/ocsigenstuff/source_java.png"
 350         | ".pl" -> "/ocsigenstuff/source_pl.png"
 351         | ".py" -> "/ocsigenstuff/source_py.png"
 352         | ".iso" | ".mds" | ".mdf" | ".cue" | ".nrg"
 353         | ".cdd" -> "/ocsigenstuff/cdimage.png"
 354         | ".deb" -> "/ocsigenstuff/deb.png"
 355         | ".dvi" -> "/ocsigenstuff/dvi.png"
 356         | ".rpm" -> "/ocsigenstuff/rpm.png"
 357         | ".tar" | ".rar" -> "/ocsigenstuff/tar.png"
 358         | ".gz" | ".tar.gz" | ".tgz" | ".zip"
 359         | ".jar"  -> "/ocsigenstuff/tgz.png"
 360         | ".tex" -> "/ocsigenstuff/tex.png"
 361         | ".avi" | ".mov" -> "/ocsigenstuff/video.png"
 362         | ".txt" -> "/ocsigenstuff/txt.png"
 363         | _ -> "/ocsigenstuff/unknown.png"
 364
 365
 366     (* An html row for a file in the directory listing *)
 367     let file_row name icon stat = Printf.sprintf "
 368 <tr>
 369   <td class=\"img\"><img src=\"%s\" alt=\"\" /></td>
 370   <td><a href=\"%s\">%s</a></td>
 371   <td>%Ld</td>
 372   <td>%s</td>
 373 </tr>"
 374       icon (Netencoding.Url.encode ~plus:false name) name
 375       stat.Unix.LargeFile.st_size (date stat.Unix.LargeFile.st_mtime)
 376
 377
 378     let directory filename =
 379       let dir = Unix.opendir filename in
 380       let rec aux d =
 381         try
 382           let f = Unix.readdir dir in
 383           try
 384             let stat = Unix.LargeFile.stat (filename^f) in
 385             if stat.Unix.LargeFile.st_kind = Unix.S_DIR && f <> "." && f <> ".."
 386             then
 387               (`Dir, f,
 388                file_row f "/ocsigenstuff/folder_open.png" stat) :: aux d
 389             else
 390               if stat.Unix.LargeFile.st_kind = Unix.S_REG &&
 391                 f.[(String.length f) - 1] <> '~'
 392               then
 393                 (`Reg, f, file_row f (image_found f) stat) :: aux d
 394               else aux d
 395           with _ (* Unix.stat can fail for a lot of reasons *) -> aux d
 396         with
 397           End_of_file -> Unix.closedir d;[]
 398
 399       in
 400       let trie li =
 401         List.sort (fun (a1, b1, _) (a2, b2, _) -> match a1, a2 with
 402         | `Dir, `Dir ->
 403             if b1<b2
 404             then 0
 405             else 1
 406         | `Dir, _ -> 0
 407         | _, `Dir -> 1
 408         | _, _->
 409             if b1<b2
 410             then 0
 411             else 1) li
 412
 413       in let rec aux2 = function
 414         | [] -> ""
 415         | (_, _, i)::l -> i^(aux2 l)
 416       in aux2 (trie (aux dir))
 417
 418
 419
 420     let result_of_content ?(options = ()) (filename, path) =
 421       let stat = Unix.LargeFile.stat filename in
 422       let rec back = function
 423         | [] | [""] -> assert false
 424         | [_] | [_ ; ""] -> []
 425         | i::j -> i :: (back j)
 426       in
 427       let parent =
 428         if path = [] || path = [""] then
 429           None
 430         else
 431           Some ("/"^Ocsigen_lib.string_of_url_path ~encode:true (back path))
 432       in
 433       let before =
 434         let st = (Ocsigen_lib.string_of_url_path ~encode:true path) in
 435         "<html>\n\
 436          <head><meta http-equiv=\"Content-Type\" content=\"text/html;\" />\n\
 437          <link rel=\"stylesheet\" type=\"text/css\" href=\"/ocsigenstuff/style.css\" media=\"screen\" />\n\
 438          <title>Listing Directory: "^st^"</title>\n</head>\n\
 439          <body><h1>"^st^"</h1>\n\
 440          <table summary=\"Contenu du dossier "^st^"\">\n\
 441          <tr id=\"headers\"><th></th><th>Name</th><th>Size</th>\
 442          <th>Last modified</th></tr>\n"
 443
 444       and back = match parent with
 445         | None -> ""
 446         | Some parent ->
 447          "<tr>\n\
 448           <td class=\"img\"><img src=\"/ocsigenstuff/back.png\" alt=\"\" /></td>\n\
 449          <td><a href=\""^parent^"\">Parent Directory</a></td>\n\
 450          <td>"^(Int64.to_string stat.Unix.LargeFile.st_size)^"</td>\n\
 451          <td>"^(date stat.Unix.LargeFile.st_mtime)^"</td>\n\
 452          </tr>\n"
 453
 454       and after=
 455         "</table>\
 456          <p id=\"footer\">Ocsigen Webserver</p>\
 457          </body></html>"
 458       in
 459       let c = before^back^(directory filename)^after in
 460       let etag = get_etag_aux stat in
 461       Text_content.result_of_content (c, "text/html") >>= fun r ->
 462       Lwt.return
 463         {r with
 464          res_lastmodified = Some stat.Unix.LargeFile.st_mtime;
 465          res_etag = etag;
 466          res_charset= Some "utf-8"
 467        }
 468
 469
 470   end
 471
 472
 473
 474 (*****************************************************************************)
 475 module Error_content =
 476 (** sends an error page that fit the error number *)
 477   struct
 478     type t = int option * exn option * Ocsigen_http_frame.cookieset
 479
 480     type options = unit
 481
 482     let get_etag c = None
 483
 484     let error_page s msg c =
 485       XHTML.M.html
 486         (XHTML.M.head (XHTML.M.title (XHTML.M.pcdata s)) [])
 487         (XHTML.M.body
 488            (XHTML.M.h1 [XHTML.M.pcdata msg]::
 489             p [pcdata s]::
 490             c)
 491         )
 492
 493     let result_of_content ?(options = ()) (code, exn, cookies_to_set) =
 494       let code = match code with
 495       | None -> 500
 496       | Some c -> c
 497       in
 498       let (error_code, error_msg, headers) =
 499         match exn with
 500         | Some (Http_error.Http_exception (errcode, msgs, h) as e) ->
 501             let msg = Http_error.string_of_http_exception e in
 502             let headers = match h with
 503               | Some h -> h
 504               | None -> Http_headers.dyn_headers
 505             in (errcode, msg, headers)
 506         | _ ->
 507             let error_mes = Http_error.expl_of_code code in
 508             (code, error_mes, Http_headers.empty)
 509       in
 510       let headers =
 511         (* puts dynamic headers *)
 512         let (<<) h (n, v) = Http_headers.replace n v h in
 513         headers
 514         << (Http_headers.cache_control, "no-cache")
 515         << (Http_headers.expires, "0")
 516       in
 517       let str_code = string_of_int error_code in
 518       let err_page =
 519         match exn with
 520         | Some exn when Ocsigen_config.get_debugmode () ->
 521             error_page
 522               ("Error "^str_code)
 523               error_msg
 524               [XHTML.M.p
 525                  [XHTML.M.pcdata (Ocsigen_lib.string_of_exn exn);
 526                   XHTML.M.br ();
 527                   XHTML.M.em
 528                     [XHTML.M.pcdata "(Ocsigen running in debug mode)"]
 529                 ]]
 530         | _ ->
 531           error_page
 532               ("Error "^str_code)
 533               error_msg
 534               []
 535       in
 536       Xhtml_content.result_of_content err_page >>= fun r ->
 537       Lwt.return
 538           {r with
 539            res_cookies = cookies_to_set;
 540            res_code = error_code;
 541            res_charset = Some "utf-8";
 542            res_headers = headers;
 543          }
 544
 545
 546   end
 547
 548
 549 let send_error
 550     ?code
 551     ?exn
 552     slot
 553     ~clientproto
 554     ?mode
 555     ?proto
 556     ?(cookies = Ocsigen_http_frame.Cookies.empty)
 557     ~head
 558     ~sender
 559     ()
 560     =
 561   Error_content.result_of_content (code, exn, cookies) >>= fun r ->
 562   send
 563     slot
 564     ~clientproto
 565     ?mode
 566     ?proto
 567     ~head
 568     ~sender
 569     r