Source file ocsigen_charset_mime.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
(* Ocsigen
 * http://www.ocsigen.org
 * ocsigen_charset_mime.ml Copyright (C) 2008
 * Boris Yakobowski
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

open Ocsigen_lib
module MapString = Map.Make (String)

type extension = string
type filename = string
type file = string

let section = Lwt_log.Section.make "ocsigen:mimetype"

type 'a assoc_item =
  | Extension of extension * 'a
  | File of filename * 'a
  | Regexp of Re.Pcre.regexp * 'a
  | Map of 'a MapString.t

type 'a assoc = {assoc_list : 'a assoc_item list; assoc_default : 'a}

let find_in_assoc file assoc =
  let filename = Filename.basename file in
  let ext =
    try String.lowercase_ascii (Filename.extension_no_directory file)
    with Not_found -> ""
  in
  let rec aux = function
    | [] -> assoc.assoc_default
    | Extension (ext', v) :: q -> if ext = ext' then v else aux q
    | File (filename', v) :: q -> if filename = filename' then v else aux q
    | Regexp (reg, v) :: q ->
        if Netstring_pcre.string_match reg file 0 <> None then v else aux q
    | Map m :: q -> ( try MapString.find ext m with Not_found -> aux q)
  in
  aux assoc.assoc_list

let default assoc = assoc.assoc_default
let set_default assoc default = {assoc with assoc_default = default}

let update_ext assoc (ext : extension) v =
  { assoc with
    assoc_list = Extension (String.lowercase_ascii ext, v) :: assoc.assoc_list
  }

let update_file assoc (file : filename) v =
  {assoc with assoc_list = File (file, v) :: assoc.assoc_list}

let update_regexp assoc r v =
  {assoc with assoc_list = Regexp (r, v) :: assoc.assoc_list}

let empty default () = {assoc_list = []; assoc_default = default}

(* Handling of charset and mime ; specific values and declarations *)

type charset = string
type mime_type = string
type charset_assoc = charset assoc
type mime_assoc = mime_type assoc

let no_charset : charset = ""
let default_mime_type : mime_type = "application/octet-stream"
let empty_charset_assoc ?(default = no_charset) = empty default
let empty_mime_assoc ?(default = default_mime_type) = empty default

(* Generic functions *)

let default_charset = default
let default_mime = default
let update_charset_ext = update_ext
let update_mime_ext = update_ext
let update_charset_file = update_file
let update_mime_file = update_file
let update_charset_regexp = update_regexp
let update_mime_regexp = update_regexp
let set_default_mime = set_default
let set_default_charset = set_default
let find_charset = find_in_assoc
let find_mime = find_in_assoc

(* Specific handling of content-type *)

let parse_mime_types ~filename : mime_type assoc =
  let rec read_and_split mimemap in_ch =
    try
      let line = input_line in_ch in
      let line_upto =
        try
          let upto = String.index line '#' in
          String.sub line 0 upto
        with Not_found -> line
      in
      let strlist =
        Netstring_pcre.split (Netstring_pcre.regexp "\\s+") line_upto
      in
      match strlist with
      | [] | [_] -> (* No extension on this line *) read_and_split mimemap in_ch
      | mime :: extensions ->
          let mimemap =
            List.fold_left
              (fun mimemap ext -> MapString.add ext mime mimemap)
              mimemap extensions
          in
          read_and_split mimemap in_ch
    with End_of_file -> mimemap
  in
  { assoc_list =
      [ Map
          (try
             let in_ch = open_in filename in
             let map =
               try read_and_split MapString.empty in_ch
               with e -> close_in in_ch; raise e
             in
             close_in in_ch; map
           with exn ->
             Lwt_log.ign_error ~section ~exn
               "unable to read the mime.types file";
             MapString.empty) ]
  ; assoc_default = default_mime_type }

let default_mime_assoc () =
  let parsed = ref None in
  match !parsed with
  | None ->
      let filename = !Ocsigen_config_static.mimefile in
      Lwt_log.ign_info_f ~section "Loading mime types in '%s'" filename;
      let map = parse_mime_types ~filename in
      parsed := Some map;
      map
  | Some map -> map