Skip to content
This repository
tag: v810
Fetching contributors…

Cannot retrieve contributors at this time

file 344 lines (293 sloc) 15.85 kb
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
Something went wrong with that request. Please try again.