test.ml

open Oslo3

exception Fdleak

module U = struct
  let with_leak_checker (f : unit -> unit) () =
    let fetch () =
      let l = List.init 512 (fun _ -> Unix.(socket PF_UNIX SOCK_STREAM 0)) in
      List.iter Unix.close l;
      l
    in
    let l1 = fetch () in
    match f () with
    | exception exn -> raise exn
    | () ->
      (* Linux is buggy. In multithreaded programs not always the
         file-descriptor is released immediatelly if it has/have been
         used in another thread. This causes the list to be
         re-ordered, with sometimes one file descriptor showing up
         only later (but it shows up so it's not a leak). So we just
         fetch again. *)
        if (l1 <> fetch ()) && (l1 <> fetch ()) then
          raise Fdleak

  let forever () =
    while true do
      Task.yield ()
    done
end

module T = struct

  let retv () =
    let v = Scheduler.run (fun () -> 1) in
    assert (v = 1)

  let basic_fail () =
    Alcotest.check_raises "failwith" (Failure "oh noes") @@ fun () ->
    Scheduler.run @@ fun () ->
    failwith "oh noes"

  let not_my_child () =
    Alcotest.check_raises "Not_child" Task.Not_child @@ fun () ->
    Scheduler.run @@ fun () ->
    let t2 = Task.async U.forever in
    let t3 = Task.async (fun () -> Task.await t2) in
    Task.await t3

  let already_awaited () =
    Alcotest.check_raises "Already_waited" Task.Already_awaited @@ fun () ->
    Scheduler.run @@ fun () ->
    let t2 = Task.async (fun () -> ()) in
    Task.await t2; Task.await t2

  let unawaited () =
    Alcotest.check_raises "Still_has_children" Task.Still_has_children @@ fun () ->
    Scheduler.run (fun () -> ignore (Task.async (fun () -> ())))

  let orphan () =
    Alcotest.check_raises "Still_has_children" Task.Still_has_children @@ fun () ->
    Scheduler.run @@ fun () ->
    let ta =
      Task.async (fun () ->
          let _orphan = Task.async (fun () -> ()) in ())
    in
    Task.await ta

  let remote_orphan () =
    Alcotest.check_raises "Still_has_children" Task.Still_has_children @@ fun () ->
    Scheduler.run @@ fun () ->
    let ta =
      Task.async_p 2 (fun () ->
          let _orphan = Task.async_p 3 (fun () -> ()) in ())
    in
    Task.await ta

  let remote_fail () =
    Alcotest.check_raises "failwith" (Failure "oh noes") @@ fun () ->
    Scheduler.run @@ fun () ->
    Task.async_p 2 (fun () -> failwith "oh noes") |> Task.await

  let basic_cancel () = Scheduler.run @@ fun () ->
    let t2 = Task.async U.forever in
    Task.cancel t2;
    Alcotest.check_raises "cancelled" Task.Cancelled @@ fun () ->
    Task.await t2

  let deeper_cancel () = Scheduler.run @@ fun () ->
    let t2 = Task.async (fun () -> Task.async U.forever |> Task.await) in
    Task.cancel t2;
    Alcotest.check_raises "cancelled" Task.Cancelled @@ fun () ->
    Task.await t2

  let () =
    let open Alcotest in
    let wlc = U.with_leak_checker in
    run "Oslo" [
      "unit",           [ test_case "" `Quick (wlc retv) ];
      "basic fail",     [ test_case "" `Quick (wlc basic_fail) ];
      "not my child",   [ test_case "" `Quick (wlc not_my_child) ];
      "already awaited",[ test_case "" `Quick (wlc already_awaited) ];
      "unawaited",      [ test_case "" `Quick (wlc unawaited) ];
      "orphan",         [ test_case "" `Quick (wlc orphan) ];
      "remote orphan",  [ test_case "" `Quick (wlc remote_orphan) ];
      "remote fail",    [ test_case "" `Quick (wlc remote_fail) ];
      "basic cancel",   [ test_case "" `Quick (wlc basic_cancel) ];
      "deeper cancel",  [ test_case "" `Quick (wlc deeper_cancel) ];
      (* "",    [ test_case "" `Quick t_ ]; *)
      (* "",    [ test_case "" `Quick t_ ]; *)
      (* "",    [ test_case "" `Quick t_ ]; *)
      (* "",    [ test_case "" `Quick t_ ]; *)
    ]

end