Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: v1154
Fetching contributors…

Cannot retrieve contributors at this time

345 lines (293 sloc) 15.85 kb
(*
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
Jump to Line
Something went wrong with that request. Please try again.