kestrel/lib/Varvara/File.ml

type file_state =
  | Idle
  | File_read of in_channel
  | File_write of out_channel
  | Dir_read of Unix.dir_handle * string (* dir_handle, filepath *)
  | Dir_write

type file_device = {
  mutable filepath : string option;
  mutable state : file_state;
}

let create_file_device () = { filepath = None; state = Idle }
let file_devices = [| create_file_device (); create_file_device () |]
let file_lengths = [| 0; 0 |]

(* Read null-terminated string from RAM *)
let read_cstring ram addr =
  let buf = Buffer.create 256 in
  let rec loop pos =
    if pos >= Bytes.length ram then Buffer.contents buf
    else
      let c = Bytes.get ram pos in
      if c = '\x00' then Buffer.contents buf
      else (
        Buffer.add_char buf c;
        loop (pos + 1))
  in
  loop addr

let file_reset dev =
  (match dev.state with
  | File_read ic -> close_in_noerr ic
  | File_write oc -> close_out_noerr oc
  | Dir_read (dh, _) -> Unix.closedir dh
  | Idle | Dir_write -> ());
  dev.state <- Idle

let file_init ram id addr =
  let dev = file_devices.(id) in
  file_reset dev;
  dev.filepath <- Some (read_cstring ram addr);
  0

let file_not_ready id =
  match file_devices.(id).filepath with
  | None ->
      Format.eprintf "File %d is uninitialized@." id;
      true
  | Some _ -> false

let format_size size len =
  let hex_digits = "0123456789abcdef" in
  let buf = Bytes.create len in
  for i = 0 to len - 1 do
    let shift = 4 * (len - 1 - i) in
    let nibble = (size lsr shift) land 0xf in
    Bytes.set buf i hex_digits.[nibble]
  done;
  Bytes.to_string buf

let format_stat ?(capsize = false) filepath len =
  try
    let st = Unix.stat filepath in
    let is_dir = st.Unix.st_kind = Unix.S_DIR in
    if is_dir then String.make len '-'
    else if capsize && st.Unix.st_size >= 0x10000 then String.make len '?'
    else format_size st.Unix.st_size len
  with Unix.Unix_error _ -> String.make len '!'

let format_dir_entry filepath basename =
  let full_path = Filename.concat filepath basename in
  let stat_str = format_stat ~capsize:true full_path 4 in
  try
    let st = Unix.stat full_path in
    let is_dir = st.Unix.st_kind = Unix.S_DIR in
    Printf.sprintf "%s %s%s\n" stat_str basename (if is_dir then "/" else "")
  with Unix.Unix_error _ -> Printf.sprintf "%s %s\n" stat_str basename

let read_directory filepath maxlen =
  let dh = Unix.opendir filepath in
  let buf = Buffer.create 1024 in
  let rec read_entries () =
    try
      let entry = Unix.readdir dh in
      if entry <> "." && entry <> ".." then
        Buffer.add_string buf (format_dir_entry filepath entry);
      if Buffer.length buf < maxlen then read_entries ()
    with End_of_file -> ()
  in
  read_entries ();
  Unix.closedir dh;
  let result = Buffer.contents buf in
  if String.length result > maxlen then String.sub result 0 maxlen else result

let create_directories path =
  let rec mkdir_parents p =
    if p <> "" && p <> "." && p <> "/" then
      if not (Sys.file_exists p) then (
        mkdir_parents (Filename.dirname p);
        try Unix.mkdir p 0o755 with Unix.Unix_error _ -> ())
  in
  mkdir_parents (Filename.dirname path)

let is_dir_path path =
  String.length path > 0 && path.[String.length path - 1] = '/'

let file_read ram id addr len =
  if file_not_ready id then 0
  else
    let dev = file_devices.(id) in
    match dev.filepath with
    | None -> 0
    | Some filepath -> (
        (match dev.state with
        | Idle ->
            if Sys.is_directory filepath then
              dev.state <- Dir_read (Unix.opendir filepath, filepath)
            else dev.state <- File_read (open_in_bin filepath)
        | _ -> ());
        match dev.state with
        | File_read ic -> (
            try
              let bytes_read = input ic ram addr len in
              bytes_read
            with
            | End_of_file -> 0
            | Sys_error _ -> 0)
        | Dir_read (dh, fp) -> (
            try
              let contents = read_directory fp len in
              let bytes_to_copy = min len (String.length contents) in
              Bytes.blit_string contents 0 ram addr bytes_to_copy;
              Unix.closedir dh;
              dev.state <- Idle;
              bytes_to_copy
            with Unix.Unix_error _ -> 0)
        | _ -> 0)

let file_write ram id addr len append_flag =
  if file_not_ready id then 0
  else
    let dev = file_devices.(id) in
    match dev.filepath with
    | None -> 0
    | Some filepath -> (
        (match dev.state with
        | Idle ->
            if is_dir_path filepath then (
              create_directories filepath;
              dev.state <- Dir_write)
            else (
              create_directories filepath;
              let mode =
                if append_flag land 0x01 <> 0 then
                  [ Open_wronly; Open_binary; Open_append; Open_creat ]
                else [ Open_wronly; Open_binary; Open_creat; Open_trunc ]
              in
              try
                let oc = open_out_gen mode 0o644 filepath in
                dev.state <- File_write oc
              with Sys_error _ -> ())
        | _ -> ());
        match dev.state with
        | File_write oc -> (
            try
              output oc ram addr len;
              flush oc;
              len
            with Sys_error _ -> 0)
        | Dir_write ->
            if Sys.file_exists filepath && Sys.is_directory filepath then 1
            else 0
        | _ -> 0)

let file_stat ram id addr len =
  if file_not_ready id then 0
  else
    let dev = file_devices.(id) in
    match dev.filepath with
    | None -> 0
    | Some filepath ->
        let stat_str = format_stat filepath len in
        let bytes_to_copy = min len (String.length stat_str) in
        Bytes.blit_string stat_str 0 ram addr bytes_to_copy;
        bytes_to_copy

let file_delete id =
  if file_not_ready id then -1
  else
    let dev = file_devices.(id) in
    match dev.filepath with
    | None -> -1
    | Some filepath -> (
        try
          Unix.unlink filepath;
          0
        with Unix.Unix_error _ -> -1)

let file_success dev port value = Bytes.set_uint16_be dev port value