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 state = {
  mutable filepath : string option;
  mutable state : file_state;
  mutable length : int;
}

module type ADDR = sig
  val start : int
end

module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct
  type nonrec state = state

  let state = { filepath = None; state = Idle; length = 0 }
  let can_handle port = port >= Addr.start && port <= Addr.start + 0x0f

  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 addr =
    file_reset state;
    state.filepath <- Some (read_cstring ram addr);
    0

  let file_not_ready () = state.filepath |> Option.is_none

  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 addr len =
    if file_not_ready () then 0
    else
      match state.filepath with
      | None -> 0
      | Some filepath -> (
          (match state.state with
          | Idle ->
              if Sys.is_directory filepath then
                state.state <- Dir_read (Unix.opendir filepath, filepath)
              else state.state <- File_read (open_in_bin filepath)
          | _ -> ());
          match state.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;
                state.state <- Idle;
                bytes_to_copy
              with Unix.Unix_error _ -> 0)
          | _ -> 0)

  let file_write ram addr len append_flag =
    if file_not_ready () then 0
    else
      match state.filepath with
      | None -> 0
      | Some filepath -> (
          (match state.state with
          | Idle ->
              if is_dir_path filepath then (
                create_directories filepath;
                state.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
                  state.state <- File_write oc
                with Sys_error _ -> ())
          | _ -> ());
          match state.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 addr len =
    if file_not_ready () then 0
    else
      match state.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 () =
    if file_not_ready () then -1
    else
      match state.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
  let dei _ _ = None
  let dei2 _ _ = None

  let deo mach port value =
    let open Uxn in
    let ram = Machine.ram mach in
    let dev = Machine.dev mach in
    let with_success result = file_success dev (Addr.start + 0x02) result in
    match port - Addr.start with
    | 0x0a -> state.length <- value
    | 0x04 -> file_stat (Machine.ram mach) value state.length |> with_success
    | 0x06 -> file_delete () |> with_success
    | 0x08 -> file_init (Machine.ram mach) value |> with_success
    | 0x0c -> file_read (Machine.ram mach) value state.length |> with_success
    | 0x0e ->
        let append = Bytes.get_uint8 dev (Addr.start + 0x07) in
        file_write ram value state.length append |> with_success
    | _ -> ()
end