Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 345 lines (293 sloc) 15.85 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* see surfaceAstPasses.mli to have a description of what these passes do *)
19
20 module F : sig
21 (** *)
22 val chroot : string -> unit
23 val normalize_relative_path : string -> string option
24 val concat : string -> string -> string
25 val path_sep : string
53cc032 [fix] mime: update deprecated option
Raja authored
26 val mimetype : ?mime_db:string -> string -> string
fccc685 Initial open-source release
MLstate authored
27 val explicit_path : string -> string option -> string
28 val is_relative : string -> bool
29
30 val fold_dir_rec : ('a -> name:string -> path:string -> 'a) -> 'a -> string -> 'a
31 val content : string -> string
32 end = struct
33 include File
34
35 let absolize prefix path =
36 let path =
37 if is_relative path then
38 Printf.sprintf "%s/%s" prefix path
39 else path
40 in explicit_path path None
41
42 let chroot_dir = ref None
43
44 let chroot path =
45 if not(is_directory path) then
46 OManager.error "I/O error: @{<bright>%S@} -> No such directory" path
47 else (
48 let path = absolize (Unix.getcwd ()) path in
49 OManager.verbose "Setting root inclusions to %s" path;
50 chroot_dir := Some path
51 )
52
53 let checkroot path =
54 match !chroot_dir with
55 | None -> ()
56 | Some root ->
57 let path = absolize root path in
58 if BaseString.is_prefix root path then ()
59 else
60 OManager.error "Try to include a file that not in your compiler root inclusion directory."
61
62 let fold_dir_rec f a d = checkroot d; fold_dir_rec f a d
63
64 let content d = checkroot d; content d
65
66 end
67
68 module SA = SurfaceAst
69 module C = SurfaceAstCons.ExprIdentCons
70 module List = Base.List
71
72 let warning_set = WarningClass.Set.create ()
73
74 let warning =
75 let doc = "Static inclusion warnings" in
76 WarningClass.create ~doc ~name:"inclusions" ~err:false ~enable:true ()
77
78 let warning_unsafe_directory =
79 let doc = "Static inclusion: warn if the directory has a suspicious name." in
80 WarningClass.create ~parent:warning ~doc ~name:"unsafe_directory" ~err:false ~enable:true ()
81
82 let warning_many_files_1000 =
83 let doc = "Static inclusion: warn of you are including a directory that contains more than 1000 files." in
84 WarningClass.create ~parent:warning ~doc ~name:"many_files" ~err:false ~enable: true ()
85
86 let warning_many_files_10000 =
87 let doc = "Static inclusion: warn of you are including a directory that contains more than 10000 files." in
88 WarningClass.create ~parent:warning ~doc ~name:"really_many_files" ~err:false ~enable:true ()
89
90 let warning_directory_does_not_exist =
91 let doc = "Static inclusion: stop execution if a directory meant to be included cannot be read (generally because it doesn't exist)." in
8c6f400 [fix] inclusions: change directory_does_not_exist error to a warning
Raja authored
92 WarningClass.create ~parent:warning ~doc ~name:"directory_does_not_exist" ~err:false ~enable:true ()
fccc685 Initial open-source release
MLstate authored
93
94 let warning_directory_empty =
95 let doc = "Static inclusion: warn when including an empty directory." in
96 WarningClass.create ~parent:warning ~doc ~name:"directory_empty" ~err:false ~enable:true ()
97
98 let warning_file_does_not_exist =
99 let doc = "Static inclusion: stop execution if a file meant to be included cannot be read (generally because it doesn't exist)." in
100 WarningClass.create ~parent:warning ~doc ~name:"file_does_not_exist" ~err:true ~enable:true ()
101
102 let _ = WarningClass.Set.add_all warning_set [
103 warning;
104 warning_unsafe_directory;
105 warning_many_files_1000;
106 warning_many_files_10000;
107 warning_directory_does_not_exist;
108 warning_file_does_not_exist;
109 warning_directory_empty;
110 ]
111
112 let return_prefix_and_normalized_path options path =
113 let prefix, path =
114 match F.normalize_relative_path path with
115 | None -> "", path
116 | Some path -> F.concat options.OpaEnv.project_root "", Filename.concat options.OpaEnv.project_root path in
117 let path = match F.normalize_relative_path path with (*The path may still be relative, e.g. if project_root is "."*)
118 | None -> path
119 | Some x -> x in
120 prefix, path
121 let fold_on_files_from_directory error_handler f acc path =
122 try
123 F.fold_dir_rec (fun acc ~name:_ ~path ->
124 f acc path
125 ) acc path
126 with Unix.Unix_error (e, _, _) ->
127 error_handler e
128
129 let pass_static_inclusion_directory ~options lcode =
130 (* Seems stange that directory inclusions not use options then
131 file inclusions use it. *)
132 Option.iter (F.chroot) options.OpaEnv.root_inclusions;
133 let aux ((e,label) as v) =
134 let handle_inclusion make_expr_include path args =
135 (
136 let factory_helper = match args with
137 | [] -> None
138 | [l] -> Some l
139 | _ -> OManager.error "Internal error: directive @@static_content_directory/@@static_resource_directory has too many arguments"
140 in
141 (*let is_directory path = try F.is_directory path with | Unix.Unix_error _ -> false in*)
142
143 if path = "." || path = "./" || path = "/" || path = "\\" then
144 OManager.warning ~wclass:warning_unsafe_directory "You are attempting to include directory '%s'. This is suspicious." path;
145
146 let prefix, path = return_prefix_and_normalized_path options path in
147 let to_url my_path = match F.normalize_relative_path my_path with
148 Some (normalized_path:string) ->
149 Str.global_replace (Str.regexp F.path_sep) "/" normalized_path
150 | None -> F.explicit_path (Str.global_replace (Str.regexp F.path_sep) "/" my_path) None (*TODO: check this line*)
151 in
152
153 OManager.verbose "Embedding the resources of directory %s" path;
154
155 let (number, files) =
156 fold_on_files_from_directory
157 (fun e ->
158 OManager.warning ~wclass:warning_directory_does_not_exist "Error reading directory: %s\nError encountered: %s." path (Unix.error_message e);
159 (0, []))
160 (fun (number, acc) y ->
161 if number = 1000 then
162 OManager.warning ~wclass:warning_many_files_1000 "Suspicious include: you are attempting to include more than 1000 files in directory %s." path
163 else if number = 10000 then
164 OManager.warning ~wclass:warning_many_files_1000 "Suspicious include: you are attempting to include more than 10000 files in directory %s." path
165 ;
166 let reduced = Base.String.remove_prefix_if_possible prefix y in
167 OManager.verbose "Embedding file %s" reduced;
168 (number+1, (Base.String.remove_prefix_if_possible prefix y)::acc)) (0,[])
169 path
170 in
171
172 OManager.verbose "...that's a total of %d %s" number (if number = 1 then "file" else "files");
173
174 SurfaceAstCons.with_label label
175 (fun () ->
176 let id_sempty = OpaMapToIdent.val_ Opacapi.StringMap.empty in
177 let sempty = C.E.ident id_sempty in
178
179 let id_sadd = OpaMapToIdent.val_ Opacapi.StringMap.add in
180 let sadd = C.E.ident id_sadd in
181
182 let map_ident n = SurfaceAstCons.ExprIdent.ns_fresh ~label (Printf.sprintf "map_%d" n) in
183
184 let n = List.length files in
185 let id_mapn = map_ident n in
186 let mapn = C.E.ident id_mapn in
187
188 (* The following expression creates this term:
189 [map_0 = StringMap.empty
190 map_1 = StringMap.add("img.png", @static_include_resource("img.png"), map_0)
191 ...
192 map_n]
193 *)
194 let rec construct_expr n id_map_n let_in_n names =
195 match names with
196 | [] -> None
197 | filename::[] ->
198 let expr_filename = C.E.string(to_url filename) in
199 let expr_include = make_expr_include factory_helper filename in
200 let application = C.E.applys sadd [expr_filename; expr_include; sempty] in
201 let map_n = C.E.letin id_map_n application let_in_n in
202 Some map_n
203 | filename::y ->
204 let expr_filename = C.E.string(to_url filename) in
205 let expr_include = make_expr_include factory_helper filename in
206 let id_map_n_moins_un = map_ident (n-1) in
207 let map_n_moins_un = C.E.ident id_map_n_moins_un in
208 let application = C.E.applys sadd [expr_filename;expr_include;map_n_moins_un] in
209 let map_n = C.E.letin id_map_n application let_in_n in
210 construct_expr (n-1) id_map_n_moins_un map_n y
211 in
212
213 let final_exp =
214 match construct_expr n id_mapn mapn files with
215 | Some e -> e
216 | None ->
217 OManager.warning ~wclass:warning_directory_empty "Directory %s is empty." path;
218 sempty
219 in
220 final_exp
221 ) (* end with_label *)
222 ) (* end else *)
223 in
224 match e with
225 | SA.Directive (`static_content_directory (path, eval), args, _) ->
226 handle_inclusion (fun factory_helper filename -> C.D.static_content ?factory_helper eval filename) path args
227 | SA.Directive (`static_resource_directory path, args, _) ->
228 handle_inclusion (fun factory_helper filename -> C.D.static_resource ?factory_helper filename) path args
229 | _ -> v in
230 (* any 'map' function will do *)
231 OpaWalk.Code.map_down aux lcode
232
233
234 let copy_label v = {v with QmlLoc.notes = SurfaceAstCons.Fresh.id ()}
235
236 let pass_static_inclusions ~options lcode: (Ident.t, 'a) SurfaceAst.code =
237 let aux acc ((e,label) as v) =
238 let lab() = copy_label label in
239 let get_content s =
240 let handle_error message =
241 OManager.warning ~wclass:warning_file_does_not_exist "Could not open file %s. Error encountered: %s. I'll replace that file by some debugging code." s message;
242 Printf.sprintf "This should have been the contents of file '%s'. However, this file could not be opened because of a compile-time error. This compile-time error was ignored because the compiler was launched with some warnings/errors deactivated.\n Detail of the error:\n %s." s message
243 in
244 try F.content s
245 with
246 Unix.Unix_error(e, _, _) ->
247 let message = Unix.error_message e in
248 handle_error message
249 | Failure message ->
250 handle_error message
251 in
252 match e with
253 | SA.Directive ((`static_content (path, eval)), maybe_factory, _) ->
254 OManager.verbose "I wish to embed content %S" path;
255 let factory_expr = match maybe_factory with
256 | [] -> (C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.identity))
257 | [e] -> e
258 | _ -> OManager.error "Internal error: directive @@static_*_content has too many arguments"
259 in
260 let full_path = if F.is_relative path then Filename.concat options.OpaEnv.project_root path else path in
261 OManager.verbose "Embedding file @{<bright>%S@} as @{<bright>%S@}" full_path path;
262
263 let getter_ident = SurfaceAstCons.ExprIdent.ns_fresh ~label:(lab()) "static_file_content" in
264 let getter_expr = C.E.applys ~label:(lab())
265 (C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.Resource_private.content_of_include))
266 [C.E.string ~label:(lab()) path;
267 C.E.record ~label:(lab()) ["misc", C.E.void ~label:(lab()) ()];
268 C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.identity);
269 C.E.string ~label:(lab()) (get_content full_path);
270 C.E.false_ ~label:(lab()) ();
271 if options.OpaEnv.compile_release then C.E.true_ ~label:(lab()) () else C.E.false_ ~label:(lab()) ();
272 factory_expr
273 ] in
274 let getter_code = C.C.newval ~label:(lab()) getter_ident getter_expr in
275
276 (*If [eval] is required, insert a call to <<$f$()>>*)
277 let getter_call = if eval then C.E.applys ~label:(lab()) (C.E.ident ~label:(lab()) getter_ident) [] else C.E.ident ~label:(lab()) getter_ident
278 in
279 (getter_code::acc, getter_call)
280
281 | SA.Directive ((`static_resource path), maybe_factory, _) ->
282 (* Oops, duplication *)
283 let relative_position = PathTransform.of_string options.OpaEnv.project_root in
284 let full_path = PathTransform.string_to_mysys ~relative_position path in
285
286 let mimetype =
53cc032 [fix] mime: update deprecated option
Raja authored
287 try F.mimetype ?mime_db:options.OpaEnv.mime_database full_path
fccc685 Initial open-source release
MLstate authored
288 with (File_mimetype.Open s) ->
289 (OManager.warning ~wclass:warning_file_does_not_exist
290 "Could not open file %s. Error encountered: %s. I'll replace that file by some debugging code." full_path s;
291 "text/plain") in
292
293 OManager.unquiet "Embedding file @{<bright>%S@} as resource @{<bright>%S@} with mimetype @{<bright>%S@}" full_path path mimetype;
294
295 let factory_expr = match maybe_factory with
296 | [] -> C.E.applys ~label:(lab())
297 (C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.Resource_private.raw_resource_factory))
298 [C.E.string ~label:(lab()) mimetype]
299 | [e] -> e
300 | _ -> OManager.error "Internal error: directive @@static_include_resource has too many arguments"
301 in
302
303 let getter_ident = SurfaceAstCons.ExprIdent.ns_fresh ~label:(lab()) "static_include_resource" in
304 let getter_expr = C.E.applys ~label:(lab())
305 (C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.Resource_private.make_resource_include))
306 [C.E.string ~label:(lab()) path;
307 C.E.record ~label:(lab()) ["misc", C.E.void ~label:(lab()) ()];
308 C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.identity);
309 C.E.string ~label:(lab()) (get_content full_path);
310 C.E.false_ ~label:(lab()) ();
311 if options.OpaEnv.compile_release then C.E.true_ ~label:(lab()) () else C.E.false_ ~label:(lab()) ();
312 C.E.record ~label:(lab()) ["permanent", C.E.void ~label:(lab()) ()];
313 factory_expr] in
314 let getter_code = C.C.newval ~label:(lab()) getter_ident getter_expr in
315
316 (*Insert a call to <<$f$()>>*)
317 (*let getter_call = C.E.applys ~label:(lab()) (C.E.ident ~label:(lab()) getter_ident) []
318 in*)
319 (getter_code::acc, C.E.ident ~label:(lab()) getter_ident)
320
321 | _ -> (acc, v) in
322
323 let (adds, v) = OpaWalk.Code.foldmap aux [] lcode in
324 adds @ v
325
326
327 let pass_analyse_static_include_deps ~options code =
328 let update_map_with_path map path =
329 let full_path = if F.is_relative path then Filename.concat options.OpaEnv.project_root path else path in
330 let last_modification_time = try Some (Unix.stat full_path).Unix.st_mtime with Unix.Unix_error _ -> None in
331 StringMap.add full_path last_modification_time map in
332 OpaWalk.Code.fold
333 (fun acc e ->
334 match e with
335 | (SA.Directive (((`static_resource path | `static_content (path, _)) : [< SurfaceAst.all_directives ]), _, _), _) ->
336 update_map_with_path acc path
337 | (SA.Directive ((`static_resource_directory path | `static_content_directory (path, _)), _, _), _) ->
338 let _prefix, path = return_prefix_and_normalized_path options path in
339 fold_on_files_from_directory
340 (fun _e -> acc)
341 (fun acc path -> update_map_with_path acc path)
342 acc path
343 | _ -> acc
344 ) StringMap.empty code
Something went wrong with that request. Please try again.