Source file file.ml

(* Js_of_ocaml library
 * http://www.ocsigen.org/js_of_ocaml/
 * Copyright (C) 2011 Pierre Chambart
 * 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 Js
open Dom
open! Import

class type blob =
  object
    method size : int readonly_prop

    method _type : js_string t readonly_prop

    method slice : int -> int -> blob t meth

    method slice_withContentType : int -> int -> js_string t -> blob t meth
  end

let blob_constr = Unsafe.global##._Blob

type 'a make_blob =
  ?contentType:string -> ?endings:[ `Transparent | `Native ] -> 'a -> blob t

let rec filter_map f = function
  | [] -> []
  | v :: q -> (
      match f v with
      | None -> filter_map f q
      | Some v' -> v' :: filter_map f q)

let make_blob_options contentType endings =
  let options =
    filter_map
      (fun (name, v) ->
        match v with
        | None -> None
        | Some v -> Some (name, Unsafe.inject (string v)))
      [ "type", contentType
      ; ( "endings"
        , match endings with
          | None -> None
          | Some `Transparent -> Some "transparent"
          | Some `Native -> Some "native" )
      ]
  in
  match options with
  | [] -> undefined
  | l -> Unsafe.obj (Array.of_list l)

let blob_raw ?contentType ?endings a =
  let options = make_blob_options contentType endings in
  new%js blob_constr (array a) options

let blob_from_string ?contentType ?endings s =
  blob_raw ?contentType ?endings [| string s |]

let blob_from_any ?contentType ?endings l =
  let l =
    List.map
      (function
        | `arrayBuffer a -> Unsafe.inject a
        | `arrayBufferView a -> Unsafe.inject a
        | `string s -> Unsafe.inject (string s)
        | `js_string s -> Unsafe.inject s
        | `blob b -> Unsafe.inject b)
      l
  in
  blob_raw ?contentType ?endings (Array.of_list l)

class type file =
  object
    inherit blob

    method name : js_string t readonly_prop

    method lastModifiedDate : js_string t readonly_prop
  end

(* in firefox 3.0-3.5 file.name is not available, we use the nonstandard fileName instead *)
class type file_name_only =
  object
    method name : js_string t optdef readonly_prop

    method fileName : js_string t optdef readonly_prop
  end

let filename file =
  let file : file_name_only t = Js.Unsafe.coerce file in
  match Optdef.to_option file##.name with
  | None -> (
      match Optdef.to_option file##.fileName with
      | None -> failwith "can't retrieve file name: not implemented"
      | Some name -> name)
  | Some name -> name

type file_any = < > t

let doc_constr = Unsafe.global##._Document

module CoerceTo = struct
  external json : file_any -> 'a Opt.t = "%identity"

  let document (e : file_any) =
    if instanceof e doc_constr
    then Js.some (Unsafe.coerce e : element document t)
    else Js.null

  let blob (e : file_any) =
    if instanceof e blob_constr then Js.some (Unsafe.coerce e : #blob t) else Js.null

  let string (e : file_any) =
    if typeof e == string "string"
    then Js.some (Unsafe.coerce e : js_string t)
    else Js.null

  let arrayBuffer (e : file_any) =
    if instanceof e Typed_array.arrayBuffer
    then Js.some (Unsafe.coerce e : Typed_array.arrayBuffer t)
    else Js.null
end

class type fileList =
  object
    inherit [file] Dom.nodeList
  end

class type fileError =
  object
    method code : int readonly_prop
  end

class type ['a] progressEvent =
  object
    inherit ['a] event

    method lengthComputable : bool t readonly_prop

    method loaded : int readonly_prop

    method total : int readonly_prop
  end

class type progressEventTarget =
  object ('self)
    method onloadstart : ('self t, 'self progressEvent t) event_listener writeonly_prop

    method onprogress : ('self t, 'self progressEvent t) event_listener writeonly_prop

    method onload : ('self t, 'self progressEvent t) event_listener writeonly_prop

    method onabort : ('self t, 'self progressEvent t) event_listener writeonly_prop

    method onerror : ('self t, 'self progressEvent t) event_listener writeonly_prop

    method onloadend : ('self t, 'self progressEvent t) event_listener writeonly_prop
  end

type readyState =
  | EMPTY
  | LOADING
  | DONE

class type fileReader =
  object ('self)
    method readAsArrayBuffer : #blob t -> unit meth

    method readAsBinaryString : #blob t -> unit meth

    method readAsText : #blob t -> unit meth

    method readAsText_withEncoding : #blob t -> js_string t -> unit meth

    method readAsDataURL : #blob t -> unit meth

    method abort : unit meth

    method readyState : readyState readonly_prop

    method result : file_any readonly_prop

    method error : fileError t readonly_prop

    inherit progressEventTarget
  end

module ReaderEvent = struct
  type typ = fileReader progressEvent t Dom.Event.typ

  let loadstart = Event.make "loadstart"

  let progress = Event.make "progress"

  let abort = Event.make "abort"

  let error = Event.make "error"

  let load = Event.make "load"

  let loadend = Event.make "loadend"
end

let fileReader : fileReader t constr = Js.Unsafe.global##._FileReader

let addEventListener = Dom.addEventListener