mpg123.ml

module Constants = struct
  open C.Types

  let api_version = mpg123_api_version
  let ok = mpg123_ok
  let done_ = mpg123_done
  let flag_id3 = mpg123_id3
  let flag_new_id3 = mpg123_new_id3
  let flag_icy = mpg123_icy
  let flag_new_icy = mpg123_new_icy
  let enc_signed16 = mpg123_enc_signed16
  let enc_float32 = mpg123_enc_float32
end

type error_code = int
type flags = int
type enc = int

include Constants

type id3_v1 =
  { tag : string;
    title : string;
    artist : string;
    album : string;
    year : string;
    comment : string;
    genre : char
  }

type id3_v2_text =
  { lang : string;
    id : string;
    description : string;
    text : string
  }

type id3_v2_picture =
  { type_ : char;
    description : string;
    mime_type : string;
    size : int;
    data : string
  }

type id3_v2 =
  { version : char;
    title : string;
    artist : string;
    album : string;
    year : string;
    genre : string;
    comment : string;
    comment_list : id3_v2_text list;
    text : id3_v2_text list;
    extra : id3_v2_text list;
    picture : id3_v2_picture list
  }

type output_format =
  { rate : int;
    channels : int;
    encoding : int
  }

(*
   let memcpy ~dest ~src n =
   let cast p = from_voidp (array n uchar) p in
   cast dest <-@ !@(cast src)
*)

(*
   let char_array_as_string a =
   	let len = Ctypes.CArray.length a in
   	let b = Buffer.create len in
   	try
   		for i = 0 to len -1 do
   			let c = Ctypes.CArray.get a i in
   			if c = '\x00'
   			then raise Exit
   			else Buffer.add_char b c
   		done;
   		Buffer.contents b
   	with Exit ->
   		Buffer.contents b
*)
let char_array_as_string a = Ctypes.(string_from_ptr (CArray.start a) ~length:(CArray.length a))

module Functions = struct
  open Ctypes
  open C.Functions

  type handle = C.Types.Handle.t ptr

  let ok_unit_or_err err = if err = ok then Ok () else Error (err : error_code)
  let init () = ok_unit_or_err (mpg123_init ())
  let exit = mpg123_exit

  let new_ ?decoder () =
    let errp = allocate int 0 in
    let h = mpg123_new decoder errp in
    let err = !@errp in
    if err = ok then Ok (h : handle) else Error (err : error_code)

  let delete mh = mpg123_delete mh
  let plain_strerror = mpg123_plain_strerror
  let strerror = mpg123_strerror
  let errcode = mpg123_errcode

  let rec copy_char_pp acc cpp =
    match !@cpp with
    | Some s -> copy_char_pp (s :: acc) (cpp +@ 1)
    | None -> acc

  let decoders () =
    let cpp = mpg123_decoders () in
    copy_char_pp [] cpp

  let supported_decoders () =
    let cpp = mpg123_supported_decoders () in
    copy_char_pp [] cpp

  let decoder mh ~decoder_name = ok_unit_or_err (mpg123_decoder mh decoder_name)
  let current_decoder = mpg123_current_decoder
  let open_ mh ~path = ok_unit_or_err (mpg123_open mh path)

  let open_fixed mh ~path ~channels ~encoding =
    ok_unit_or_err (mpg123_open_fixed mh path channels encoding)

  let close mh = ok_unit_or_err (mpg123_close mh)

  let read_ba mh ~buf ~len_in_bytes =
    let bytes_read = allocate int 0 in
    let buf_ptr = to_voidp (bigarray_start array1 buf) in
    let retval = mpg123_read mh buf_ptr len_in_bytes bytes_read in
    if retval = ok
    then Ok !@bytes_read
    else if retval = done_
    then if !@bytes_read = 0 then Error (retval : error_code) else Ok !@bytes_read
    else Error (retval : error_code)

  let scan mh = ok_unit_or_err (mpg123_scan mh)

  let length mh =
    let result = mpg123_length mh in
    if result >= 0 then Ok result else Error (result : error_code)

  let meta_check mh : flags = mpg123_meta_check mh
  let meta_free = mpg123_meta_free

  let id3 mh =
    let null_v1 = from_voidp C.Types.Id3v1.t null in
    let id3v1 = allocate (ptr C.Types.Id3v1.t) null_v1 in
    let null_v2 = from_voidp C.Types.Id3v2.t null in
    let id3v2 = allocate (ptr C.Types.Id3v2.t) null_v2 in
    let err = mpg123_id3 mh id3v1 id3v2 in
    if ok <> err
    then Error err
    else (
      let v1 =
        if is_null id3v1
        then None
        else (
          let v1 = !@id3v1 in
          if is_null v1
          then None
          else (
            let v1 = !@(v1 +@ 0) in
            let module ID = C.Types.Id3v1 in
            let cass = char_array_as_string in
            Some
              { tag = cass @@ getf v1 ID.tag;
                title = cass @@ getf v1 ID.title;
                artist = cass @@ getf v1 ID.artist;
                album = cass @@ getf v1 ID.album;
                year = cass @@ getf v1 ID.year;
                comment = cass @@ getf v1 ID.comment;
                genre = getf v1 ID.genre
              }))
      in
      let v2 =
        if is_null id3v2
        then None
        else (
          let v2 = !@id3v2 in
          if is_null v2
          then None
          else (
            let v2 = !@(v2 +@ 0) in
            let module ID = C.Types.Id3v2 in
            let module MS = C.Types.Mpg123_string in
            let module MT = C.Types.Mpg123_text in
            let module MP = C.Types.Mpg123_picture in
            let read_string ms =
              let len = getf ms MS.fill in
              if len < 1
              then ""
              else (
                let a = CArray.from_ptr (getf ms MS.p) (len - 1) in
                char_array_as_string a)
            in
            let get_mpg123_string x =
              let ms = getf v2 x in
              if is_null ms then "" else read_string !@ms
            in
            let get_mpg123_texts num x =
              let len = getf v2 num in
              let ms = getf v2 x in
              if is_null ms
              then []
              else if len = 0
              then []
              else (
                let ms = CArray.from_ptr ms len in
                let cass = char_array_as_string in
                let rec f i acc =
                  if i = len
                  then List.rev acc
                  else (
                    let mt = CArray.get ms i in
                    let acc =
                      { lang = cass @@ getf mt MT.lang;
                        id = cass @@ getf mt MT.id;
                        description = read_string (getf mt MT.description);
                        text = read_string (getf mt MT.text)
                      }
                      :: acc
                    in
                    f (succ i) acc)
                in
                f 0 [])
            in
            let get_mpg123_pictures num x =
              let len = getf v2 num in
              let ms = getf v2 x in
              if is_null ms
              then []
              else if len = 0
              then []
              else (
                let ms = CArray.from_ptr ms len in
                let cass = char_array_as_string in
                let rec f i acc =
                  if i = len
                  then List.rev acc
                  else (
                    let mp = CArray.get ms i in
                    let size = getf mp MP.size in
                    let data = CArray.from_ptr (getf mp MP.data) (size - 1) in
                    let acc =
                      { type_ = getf mp MP.type_;
                        description = read_string (getf mp MP.description);
                        mime_type = read_string (getf mp MP.mime_type);
                        size = getf mp MP.size;
                        data = cass data
                      }
                      :: acc
                    in
                    f (succ i) acc)
                in
                f 0 [])
            in
            let get = get_mpg123_string in
            let get_texts = get_mpg123_texts in
            let get_pics = get_mpg123_pictures in
            Some
              { version = getf v2 ID.version;
                title = get ID.title;
                artist = get ID.artist;
                album = get ID.album;
                year = get ID.year;
                genre = get ID.genre;
                comment = get ID.comment;
                comment_list = get_texts ID.comments ID.comment_list;
                text = get_texts ID.texts ID.text;
                extra = get_texts ID.extras ID.extra;
                picture = get_pics ID.pictures ID.picture
              }))
      in
      Ok (v1, v2))

  let getformat mh =
    let rate = allocate int 0 in
    let channels = allocate int 0 in
    let encoding = allocate int 0 in
    let retval = mpg123_getformat mh rate channels encoding in
    if retval = ok
    then Ok { rate = !@rate; channels = !@channels; encoding = !@encoding }
    else Error (retval : error_code)

  let format_none mh = ok_unit_or_err (mpg123_format_none mh)

  let format_ mh ~rate ~channels ~encodings =
    ok_unit_or_err (mpg123_format mh rate channels encodings)
end

include Functions

let%test_module "mpg123" =
  (module struct
    let%test "no-op" = true

    let lib_init () =
      match init () with
      | Ok _ -> ()
      | Error e -> failwith (Printf.sprintf "failed to init library: %d" e)

    let lib_exit = exit

    let%test "init-then-exit" =
      lib_init ();
      lib_exit ();
      true

    let%test "new-then-delete" =
      lib_init ();
      let mh =
        match new_ () with
        | Error e -> failwith (Printf.sprintf "new failed: %d" e)
        | Ok mh -> mh
      in
      delete mh;
      lib_exit ();
      true

    let%test "has-decoders" =
      lib_init ();
      let res = List.length (decoders ()) > 0 in
      lib_exit ();
      res

    let%test "has-supported-decoders" =
      lib_init ();
      let res = List.length (supported_decoders ()) > 0 in
      lib_exit ();
      res
  end)