-
Notifications
You must be signed in to change notification settings - Fork 125
/
surfaceAstStaticInclude.ml
344 lines (293 loc) · 15.5 KB
/
surfaceAstStaticInclude.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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA 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 Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* see surfaceAstPasses.mli to have a description of what these passes do *)
module F : sig
(** *)
val chroot : string -> unit
val normalize_relative_path : string -> string option
val concat : string -> string -> string
val path_sep : string
val mimetype : ?mime_db:string -> string -> string
val explicit_path : string -> string option -> string
val is_relative : string -> bool
val fold_dir_rec : ('a -> name:string -> path:string -> 'a) -> 'a -> string -> 'a
val content : string -> string
end = struct
include File
let absolize prefix path =
let path =
if is_relative path then
Printf.sprintf "%s/%s" prefix path
else path
in explicit_path path None
let chroot_dir = ref None
let chroot path =
if not(is_directory path) then
OManager.error "I/O error: @{<bright>%S@} -> No such directory" path
else (
let path = absolize (Unix.getcwd ()) path in
OManager.verbose "Setting root inclusions to %s" path;
chroot_dir := Some path
)
let checkroot path =
match !chroot_dir with
| None -> ()
| Some root ->
let path = absolize root path in
if BaseString.is_prefix root path then ()
else
OManager.error "Try to include a file that not in your compiler root inclusion directory."
let fold_dir_rec f a d = checkroot d; fold_dir_rec f a d
let content d = checkroot d; content d
end
module SA = SurfaceAst
module C = SurfaceAstCons.ExprIdentCons
module List = Base.List
let warning_set = WarningClass.Set.create ()
let warning =
let doc = "Static inclusion warnings" in
WarningClass.create ~doc ~name:"inclusions" ~err:false ~enable:true ()
let warning_unsafe_directory =
let doc = "Static inclusion: warn if the directory has a suspicious name." in
WarningClass.create ~parent:warning ~doc ~name:"unsafe_directory" ~err:false ~enable:true ()
let warning_many_files_1000 =
let doc = "Static inclusion: warn of you are including a directory that contains more than 1000 files." in
WarningClass.create ~parent:warning ~doc ~name:"many_files" ~err:false ~enable: true ()
let warning_many_files_10000 =
let doc = "Static inclusion: warn of you are including a directory that contains more than 10000 files." in
WarningClass.create ~parent:warning ~doc ~name:"really_many_files" ~err:false ~enable:true ()
let warning_directory_does_not_exist =
let doc = "Static inclusion: stop execution if a directory meant to be included cannot be read (generally because it doesn't exist)." in
WarningClass.create ~parent:warning ~doc ~name:"directory_does_not_exist" ~err:false ~enable:true ()
let warning_directory_empty =
let doc = "Static inclusion: warn when including an empty directory." in
WarningClass.create ~parent:warning ~doc ~name:"directory_empty" ~err:false ~enable:true ()
let warning_file_does_not_exist =
let doc = "Static inclusion: stop execution if a file meant to be included cannot be read (generally because it doesn't exist)." in
WarningClass.create ~parent:warning ~doc ~name:"file_does_not_exist" ~err:true ~enable:true ()
let _ = WarningClass.Set.add_all warning_set [
warning;
warning_unsafe_directory;
warning_many_files_1000;
warning_many_files_10000;
warning_directory_does_not_exist;
warning_file_does_not_exist;
warning_directory_empty;
]
let return_prefix_and_normalized_path options path =
let prefix, path =
match F.normalize_relative_path path with
| None -> "", path
| Some path -> F.concat options.OpaEnv.project_root "", Filename.concat options.OpaEnv.project_root path in
let path = match F.normalize_relative_path path with (*The path may still be relative, e.g. if project_root is "."*)
| None -> path
| Some x -> x in
prefix, path
let fold_on_files_from_directory error_handler f acc path =
try
F.fold_dir_rec (fun acc ~name:_ ~path ->
f acc path
) acc path
with Unix.Unix_error (e, _, _) ->
error_handler e
let pass_static_inclusion_directory ~options lcode =
(* Seems stange that directory inclusions not use options then
file inclusions use it. *)
Option.iter (F.chroot) options.OpaEnv.root_inclusions;
let aux ((e,label) as v) =
let handle_inclusion make_expr_include path args =
(
let factory_helper = match args with
| [] -> None
| [l] -> Some l
| _ -> OManager.error "Internal error: directive @@static_content_directory/@@static_resource_directory has too many arguments"
in
(*let is_directory path = try F.is_directory path with | Unix.Unix_error _ -> false in*)
if path = "." || path = "./" || path = "/" || path = "\\" then
OManager.warning ~wclass:warning_unsafe_directory "You are attempting to include directory '%s'. This is suspicious." path;
let prefix, path = return_prefix_and_normalized_path options path in
let to_url my_path = match F.normalize_relative_path my_path with
Some (normalized_path:string) ->
Str.global_replace (Str.regexp F.path_sep) "/" normalized_path
| None -> F.explicit_path (Str.global_replace (Str.regexp F.path_sep) "/" my_path) None (*TODO: check this line*)
in
OManager.verbose "Embedding the resources of directory %s" path;
let (number, files) =
fold_on_files_from_directory
(fun e ->
OManager.warning ~wclass:warning_directory_does_not_exist "Error reading directory: %s\nError encountered: %s." path (Unix.error_message e);
(0, []))
(fun (number, acc) y ->
if number = 1000 then
OManager.warning ~wclass:warning_many_files_1000 "Suspicious include: you are attempting to include more than 1000 files in directory %s." path
else if number = 10000 then
OManager.warning ~wclass:warning_many_files_1000 "Suspicious include: you are attempting to include more than 10000 files in directory %s." path
;
let reduced = Base.String.remove_prefix_if_possible prefix y in
OManager.verbose "Embedding file %s" reduced;
(number+1, (Base.String.remove_prefix_if_possible prefix y)::acc)) (0,[])
path
in
OManager.verbose "...that's a total of %d %s" number (if number = 1 then "file" else "files");
SurfaceAstCons.with_label label
(fun () ->
let id_sempty = OpaMapToIdent.val_ Opacapi.StringMap.empty in
let sempty = C.E.ident id_sempty in
let id_sadd = OpaMapToIdent.val_ Opacapi.StringMap.add in
let sadd = C.E.ident id_sadd in
let map_ident n = SurfaceAstCons.ExprIdent.ns_fresh ~label (Printf.sprintf "map_%d" n) in
let n = List.length files in
let id_mapn = map_ident n in
let mapn = C.E.ident id_mapn in
(* The following expression creates this term:
[map_0 = StringMap.empty
map_1 = StringMap.add("img.png", @static_include_resource("img.png"), map_0)
...
map_n]
*)
let rec construct_expr n id_map_n let_in_n names =
match names with
| [] -> None
| filename::[] ->
let expr_filename = C.E.string(to_url filename) in
let expr_include = make_expr_include factory_helper filename in
let application = C.E.applys sadd [expr_filename; expr_include; sempty] in
let map_n = C.E.letin id_map_n application let_in_n in
Some map_n
| filename::y ->
let expr_filename = C.E.string(to_url filename) in
let expr_include = make_expr_include factory_helper filename in
let id_map_n_moins_un = map_ident (n-1) in
let map_n_moins_un = C.E.ident id_map_n_moins_un in
let application = C.E.applys sadd [expr_filename;expr_include;map_n_moins_un] in
let map_n = C.E.letin id_map_n application let_in_n in
construct_expr (n-1) id_map_n_moins_un map_n y
in
let final_exp =
match construct_expr n id_mapn mapn files with
| Some e -> e
| None ->
OManager.warning ~wclass:warning_directory_empty "Directory %s is empty." path;
sempty
in
final_exp
) (* end with_label *)
) (* end else *)
in
match e with
| SA.Directive (`static_content_directory (path, eval), args, _) ->
handle_inclusion (fun factory_helper filename -> C.D.static_content ?factory_helper eval filename) path args
| SA.Directive (`static_resource_directory path, args, _) ->
handle_inclusion (fun factory_helper filename -> C.D.static_resource ?factory_helper filename) path args
| _ -> v in
(* any 'map' function will do *)
OpaWalk.Code.map_down aux lcode
let copy_label v = {v with QmlLoc.notes = SurfaceAstCons.Fresh.id ()}
let pass_static_inclusions ~options lcode: (Ident.t, 'a) SurfaceAst.code =
let aux acc ((e,label) as v) =
let lab() = copy_label label in
let get_content s =
let handle_error message =
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;
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
in
try F.content s
with
Unix.Unix_error(e, _, _) ->
let message = Unix.error_message e in
handle_error message
| Failure message ->
handle_error message
in
match e with
| SA.Directive ((`static_content (path, eval)), maybe_factory, _) ->
OManager.verbose "I wish to embed content %S" path;
let factory_expr = match maybe_factory with
| [] -> (C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.identity))
| [e] -> e
| _ -> OManager.error "Internal error: directive @@static_*_content has too many arguments"
in
let full_path = if F.is_relative path then Filename.concat options.OpaEnv.project_root path else path in
OManager.verbose "Embedding file @{<bright>%S@} as @{<bright>%S@}" full_path path;
let getter_ident = SurfaceAstCons.ExprIdent.ns_fresh ~label:(lab()) "static_file_content" in
let getter_expr = C.E.applys ~label:(lab())
(C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.Resource_private.content_of_include))
[C.E.string ~label:(lab()) path;
C.E.record ~label:(lab()) ["misc", C.E.void ~label:(lab()) ()];
C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.identity);
C.E.string ~label:(lab()) (get_content full_path);
C.E.false_ ~label:(lab()) ();
if options.OpaEnv.compile_release then C.E.true_ ~label:(lab()) () else C.E.false_ ~label:(lab()) ();
factory_expr
] in
let getter_code = C.C.newval ~label:(lab()) getter_ident getter_expr in
(*If [eval] is required, insert a call to <<$f$()>>*)
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
in
(getter_code::acc, getter_call)
| SA.Directive ((`static_resource path), maybe_factory, _) ->
(* Oops, duplication *)
let relative_position = PathTransform.of_string options.OpaEnv.project_root in
let full_path = PathTransform.string_to_mysys ~relative_position path in
let mimetype =
try F.mimetype ?mime_db:options.OpaEnv.mime_database full_path
with (File_mimetype.Open s) ->
(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." full_path s;
"text/plain") in
OManager.unquiet "Embedding file @{<bright>%S@} as resource @{<bright>%S@} with mimetype @{<bright>%S@}" full_path path mimetype;
let factory_expr = match maybe_factory with
| [] -> C.E.applys ~label:(lab())
(C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.Resource_private.raw_resource_factory))
[C.E.string ~label:(lab()) mimetype]
| [e] -> e
| _ -> OManager.error "Internal error: directive @@static_include_resource has too many arguments"
in
let getter_ident = SurfaceAstCons.ExprIdent.ns_fresh ~label:(lab()) "static_include_resource" in
let getter_expr = C.E.applys ~label:(lab())
(C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.Resource_private.make_resource_include))
[C.E.string ~label:(lab()) path;
C.E.record ~label:(lab()) ["misc", C.E.void ~label:(lab()) ()];
C.E.ident ~label:(lab()) (OpaMapToIdent.val_ Opacapi.identity);
C.E.string ~label:(lab()) (get_content full_path);
C.E.false_ ~label:(lab()) ();
if options.OpaEnv.compile_release then C.E.true_ ~label:(lab()) () else C.E.false_ ~label:(lab()) ();
C.E.record ~label:(lab()) ["permanent", C.E.void ~label:(lab()) ()];
factory_expr] in
let getter_code = C.C.newval ~label:(lab()) getter_ident getter_expr in
(*Insert a call to <<$f$()>>*)
(*let getter_call = C.E.applys ~label:(lab()) (C.E.ident ~label:(lab()) getter_ident) []
in*)
(getter_code::acc, C.E.ident ~label:(lab()) getter_ident)
| _ -> (acc, v) in
let (adds, v) = OpaWalk.Code.foldmap aux [] lcode in
adds @ v
let pass_analyse_static_include_deps ~options code =
let update_map_with_path map path =
let full_path = if F.is_relative path then Filename.concat options.OpaEnv.project_root path else path in
let last_modification_time = try Some (Unix.stat full_path).Unix.st_mtime with Unix.Unix_error _ -> None in
StringMap.add full_path last_modification_time map in
OpaWalk.Code.fold
(fun acc e ->
match e with
| (SA.Directive (((`static_resource path | `static_content (path, _)) : [< SurfaceAst.all_directives ]), _, _), _) ->
update_map_with_path acc path
| (SA.Directive ((`static_resource_directory path | `static_content_directory (path, _)), _, _), _) ->
let _prefix, path = return_prefix_and_normalized_path options path in
fold_on_files_from_directory
(fun _e -> acc)
(fun acc path -> update_map_with_path acc path)
acc path
| _ -> acc
) StringMap.empty code