This following piece of code works when the database is already created, but fails if the database is not created. The more concerning issue for me is that my code is not catching the error thrown by the code when the database has not been created. I am new to Ocaml error handling, so I am wondering why this does not work. Here is the error I receive:
Fatal error: exception Postgresql.Error(_)
and here is the code I have:
open Postgresql;;
let main () = (
let c = new connection ~host:"localhost" ~port:"5432" ~dbname:"stocks" ~user:"postgres"
~password:"postgres" () in
let status () = (
try match c#status with
| Ok -> print_string ("STATUS CONNECTED\n");
| Bad -> print_string "BAD";
with Error(s) ->( print_string (string_of_error(s)))) in
status();
c#finish
);;
main();;
It is very likely that exception is raised in let c = .... statement because it is not located inside try....with block. Code example below is not ideal but more OCaml-way than you have.
open Postgresql
let with_connection f =
try
let c = new connection ~host:"localhost" ~port:"5432" ~dbname:"stocks" ~user:"postgres"
~password:"postgres" () in
f c;
c#finish
with _ -> print_endline "ERROR"
let main () =
with_connection (fun c ->
try match c#status with
| Ok -> print_string ("STATUS CONNECTED\n");
| Bad -> print_string "BAD";
with Error(s) ->( print_string (string_of_error(s))))
)
let () = main ()
Related
e.g.
let expect_raises f exc =
try f ()
with
| exc -> "Expected error raised"
| e -> "Unexpected error raised"
in
expect_raises (fun () -> raise Not_found) Not_found (* "Expected" *)
expect_raises (fun () -> raise Invalid_argument "bad") Not_found (* "Unexpected" *)
But this doesn't work because I can't pattern match on the exc arg, it just becomes the pattern variable.
Is there some way to do this?
Pattern matching in OCaml works essentially against constants (or more generally trees of constants with wildcard slots). So there's no way to use pattern matching to do what you want. This is the same for exceptions as it would be if you (for example) wanted to pass an integer value.
Similarly to integers, you can compare exception values for equality. So you can write your function like this:
let expect_raises f exc =
try f ()
with e ->
if e = exc then "Expected error raise"
else "Unexpected error raised"
Here are the test cases:
# expect_raises (fun () -> raise Not_found) Not_found;;
- : string = "Expected error raise"
# expect_raises (fun () -> raise (Invalid_argument "bad")) Not_found;;
- : string = "Unexpected error raised"
However, this seems like a fragile test because the equality comparison depends on the exact contents of the exception constructor. The compiler warns (reasonably so IMHO) against doing this:
# match (try failwith "abc" with e -> e) with
| Failure "abc" -> 20
| _ -> 30;;
Warning 52 [fragile-literal-pattern]: Code should not
depend on the actual values of this constructor's
arguments. They are only for information and may change
in future versions. (See manual section 11.5)
FWIW my solution at the moment looks like:
let expect_raises f exc_f pp =
let result_opt =
try exc_f f
with e -> Some (Error e)
in
match result_opt with
| Some (Ok a) ->
fail ## Format.asprintf "Unexpected result: %a" pp a
| Some (Error e) ->
fail ## Printf.sprintf "Unexpected error: %s" (Printexc.to_string e)
| None -> pass (* the correct result *)
let test_fun () ->
let exc_f f = try Some (Ok (f ())) with Not_found -> None in
expect_raises (fun () -> funtotest 123) exc_f pp
let test_other_fun () ->
let exc_f f = try Some (Ok (f ())) with Invalid_argument _ -> None in
expect_raises (fun () -> otherfuntotest "abc") exc_f pp
Having to define the exf_f is a bit cumbersome - I would love to be able to factor out the common part leaving just the exception type. But at least this works and allows to match by constructor alone and not by value.
I guess it would be possible to make a ppx rewriter to replace manual definition of exc_f func with something like:
expect_raises (fun () -> otherfuntotest "abc") [%excf Invalid_argument] pp
I am trying to understand the following behaviour of OCaml Format module and semantic tags.
My code:
let prepare_ppf ppf =
let original_stag_functions = Format.pp_get_formatter_stag_functions ppf () in
let original_mark_tags_state = Format.pp_get_mark_tags ppf () in
Format.pp_set_mark_tags ppf true;
Format.pp_set_print_tags ppf false;
Format.pp_set_formatter_stag_functions ppf {
mark_open_stag = (fun stag ->
print_endline "MARK-OPEN";
match stag with
| Format.String_tag s -> Printf.sprintf "<open:%s>" s
| _ -> "<UNKNOWN>"
);
mark_close_stag = (fun stag ->
print_endline "MARK-CLOSE";
match stag with
| Format.String_tag s -> Printf.sprintf "</close:%s>" s
| _ -> "</UNKNOWN>"
);
print_open_stag = (fun _ -> print_endline "PRINT-OPEN"; ());
print_close_stag = (fun _ -> print_endline "PRINT-CLOSE"; ());
};
print_endline "PREPARED";
if Format.pp_get_mark_tags ppf () then print_endline "MARK:true";
(fun ppf ->
print_endline "RESET";
Format.pp_set_mark_tags ppf original_mark_tags_state;
Format.pp_set_formatter_stag_functions ppf original_stag_functions;)
let fprintf ppf fmt =
let reset = prepare_ppf ppf in
Format.kfprintf reset ppf fmt
let printf fmt = fprintf Format.std_formatter fmt
If I paste that into: utop version 2.8.0 (using OCaml version 4.12.0)
When I run it:
utop # printf "#{<bold>%s#}" "hello";;
PREPARED
MARK:true
RESET
<bold>hello</bold>- : unit = ()
Why are the mark_open_stag and close functions not called?
If I change line 5 to Format.pp_set_print_tags ppf true; then I see the print_open_stag and close function are called.
This is an interaction between buffering and utop handling of the stdout formatter.
The buffering issue can be seen with
printf "#{<bold>%s#}" "A very very very very very very very very very very very very very very very very very long hello world";;
which prints the half-correct
PREPARED
MARK:true
MARK-OPEN
<open:bold>A very very very very very very very very very very very very very very very very very long hello worldRESET
</bold>
Going on step further, flushing the stdout at the end with
printf "#{<bold>%s#}#." "hello";;
yields the correct output
PREPARED
MARK:true
MARK-OPEN
<open:bold>helloMARK-CLOSE
</close:bold>
RESET
The issue is thus that
printf "#{<bold>%s#}" "hello"
buffers completely all its input.
And it is utop taking the hand on the stdout formatter which triggers the printing by trying to print
- : unit = ()
This yields then
<bold>hello</bold>- : unit = ()
because at the time of the printing utop has reset the formatter configuration to its own default.
I have simple HTTP server in Ocaml with Cohttp and Lwt. When I run wrk the application crashes around 50% of the time as soon as wrk finishes. I imagine the crash is triggered by the unexpected tear-down of the connection.
I see the following error on the console:
Fatal error: exception Unix.Unix_error(Unix.ECONNRESET, "read", "")
Raised by primitive operation at file "src/unix/lwt_bytes.ml", line 130, characters 42-84
Called from file "src/unix/lwt_unix.ml", line 489, characters 13-24
Is there anyway to prevent this?
My full source-code is:
(* server_test.ml *)
open Unix
open Lwt
open Cohttp
open Cohttp_lwt_unix
open Yojson
open Yojson.Basic.Util
open Core.Std
type create = {
username: string;
email: string;
password: string;
} [##deriving yojson]
let insert coll doc =
let _id = Core.Std.Uuid.to_string (Uuid.create ()) in
let uri = Uri.make ~scheme:"http" ~host:"127.0.0.1" ~port:5984 ~path:(coll ^ "/" ^ _id) () in
Cohttp_lwt_unix.Client.put ~body:(Cohttp_lwt_body.of_string (Yojson.Safe.to_string doc)) uri
>|= fun (r, _) -> Code.code_of_status ## Response.status r
let callback _conn req body =
body |> Cohttp_lwt_body.to_string
>>= (fun body ->
let mc = Yojson.Safe.from_string body |> create_of_yojson in
match mc with
| Ok c ->
insert "users" (create_to_yojson c)
>>= fun status -> print_endline ## string_of_int status;
Server.respond_string ~status:(`Code status) ~body:(string_of_int status) ()
| _ -> Server.respond_string ~status:`OK ~body: "Not OK" ())
let timeit _conn req body =
let start = Unix.gettimeofday () in
callback _conn req body
>>=
fun result ->
let finish = Unix.gettimeofday () in
Lwt_io.printlf "Execution time took %fms" ((finish -. start) *. 1000.0)
>|= fun _ -> result
let server =
Server.create ~mode:(`TCP (`Port 8000)) (Server.make timeit ())
let () = ignore (Lwt_main.run server)
Thanks!
The error you're seeing is from an unhanded exception raised when the client disconnects unexpectedly. The relevant exception is handed to Lwt's async exception hook (http://ocsigen.org/lwt/2.6.0/api/Lwt#VALasync_exception_hook) which, by Lwt's default, prints a backtrace and exits the program with an exit code of 2.
There is an ongoing discussion about this on the cohttp github issue tracker: https://github.com/mirage/ocaml-cohttp/issues/511
In short, if you define a custom exception handler for Lwt's async/"background" threads then you can capture and ignore/log/handle the client errors. Add something like the following before you start your cohttp server:
Lwt.async_exception_hook := (function
| Unix.Unix_error (error, func, arg) ->
Logs.warn (fun m ->
m "Client connection error %s: %s(%S)"
(Unix.error_message error) func arg
)
| exn -> Logs.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn)
);
Taken from https://github.com/mirage/ocaml-cohttp/issues/511#issuecomment-258510531 and using the logs library to log the event: http://erratique.ch/software/logs
I'm trying to write a function that tries to evaluate a function, but stops after a specific timeout.
I tried to use Deferred.any, which returns a deferred that is fulfilled when one of the underlying deferred is fulfilled.
type 'a output = OK of 'a | Exn of exn
let fun_test msg f eq (inp,ans) =
let outp = wait_for (Deferred.any
[ return (try OK (f inp) with e -> Exn e)
; (after (Core.Std.sec 0.0) >>| (fun () -> Exn TIMEOUT))])
in {msg = msg;inp = inp;outp = outp;ans = ans;pass = eq outp ans}
I was not sure how to extract a value from the deferred monad, so I wrote a function 'wait_for' which just spins until the underlying value is determined.
let rec wait_for x =
match Deferred.peek x with
| None -> wait_for x
| Some done -> done;;
This did not work. After reading through the Async chapter of Real World OCaml, I realized I needed to start the scheduler. However I'm not sure where I would call Schedule.go in my code. I do not see where the type go : ?raise_unhandled_exn:bool -> unit -> Core.Std.never_returns would fit into code where you actually want your asynchronous code to return. The documentation for go says "Async programs do not exit until shutdown is called."
I was beginning to doubt I had taken the entirely wrong approach to the problem until I found a very similar solution to that same problem on this Cornell website
let timeout (thunk:unit -> 'a Deferred.t) (n:float) : ('a option) Deferred.t
= Deferred.any
[ after (sec n) >>| (fun () -> None) ;
thunk () >>= (fun x -> Some x) ]
Anyway, I'm not quite sure my use of wait_for is correct. Is there a canonical way to extract a value from the deferred monad? Also how do I start the scheduler?
Update:
I tried writing a timeout function using only Core.Std.Thread and Core.Std.Mutex.
let rec wait_for lck ptr =
Core.Std.Thread.delay 0.25;
Core.Std.Mutex.lock lck;
(match !ptr with
| None -> Core.Std.Mutex.unlock lck; wait_for lck ptr
| Some x -> Core.Std.Mutex.unlock lck; x);;
let timeout t f =
let lck = Core.Std.Mutex.create () in
let ptr = ref None in
let _ = Core.Std.Thread.create
(fun () -> Core.Std.Thread.delay t;
Core.Std.Mutex.lock lck;
(match !ptr with
| None -> ptr := Some (Exn TIMEOUT)
| Some _ -> ());
Core.Std.Mutex.unlock lck;) () in
let _ = Core.Std.Thread.create
(fun () -> let x = f () in
Core.Std.Mutex.lock lck;
(match !ptr with
| None -> ptr := Some x
| Some _ -> ());
Core.Std.Mutex.unlock lck;) () in
wait_for lck ptr
I think this is pretty close to working. It works on computations like let rec loop x = print_string ".\n"; loop x, but it does not work on computations like let rec loop x = loop x. I believe the problem right now is that if the computation f () loops infinitely, then its thread is never preempted, so none of other threads can notice the timeout has expired. If the thread does IO like printing a string, then the thread does get preempted. Also I don't know how to kill a thread, I couldn't find such a function in the documentation for Core.Std.Thread
The solution I came up with is
let kill pid sign =
try Unix.kill pid sign with
| Unix.Unix_error (e,f,p) -> debug_print ((Unix.error_message e)^"|"^f^"|"^p)
| e -> raise e;;
let timeout f arg time default =
let pipe_r,pipe_w = Unix.pipe () in
(match Unix.fork () with
| 0 -> let x = Some (f arg) in
let oc = Unix.out_channel_of_descr pipe_w in
Marshal.to_channel oc x [];
close_out oc;
exit 0
| pid0 ->
(match Unix.fork () with
| 0 -> Unix.sleep time;
kill pid0 Sys.sigkill;
let oc = Unix.out_channel_of_descr pipe_w in
Marshal.to_channel oc default [];
close_out oc;
exit 0
| pid1 -> let ic = Unix.in_channel_of_descr pipe_r in
let result = (Marshal.from_channel ic : 'b option) in
result ));;
I think I might be creating two zombie processes with this though. But it is the only solution that works on let rec loop x = loop x when compiled using ocamlopt (The solution using Unix.alarm given here works when compiled with ocamlc but not when compiled with ocamlopt).
The following code...
type 'a osResult =
Success of 'a
| Error of string
let errorCatcher f =
try
let result = f () in
Success result
with Unix.Unix_error (code, fun_name, arg) ->
Error(String.concat ":" [(Unix.error_message code); fun_name; arg])
let my_getcwd () =
errorCatcher (fun () -> Unix.getcwd ())
let _ =
print_endline "The Start";
let result = my_getcwd () |> function
| Success folder -> Printf.sprintf "getcwd:\n\t%s\n" folder
| Error errMessage -> Printf.sprintf "getcwd (error):\n\t%s\n" errMessage
in
print_string result ;
print_endline "The End."
;;
...compiles fine:
$ corebuild -tag debug test1.native
...and runs fine:
$ ./test1.native
The Start
getcwd:
/home/ttsiod/work/byePythonHelloOCaml
The End.
But if I change the main body to this:
let _ =
print_endline "The Start";
my_getcwd () |> function
| Success folder -> Printf.printf "getcwd:\n\t%s\n" folder
| Error errMessage -> Printf.printf "getcwd (error):\n\t%s\n" errMessage
;
print_endline "The End."
;;
... then apparently the last print statement ("The End") gets lost or something...
$ ./test2.native
The Start
getcwd:
/home/ttsiod/work/byePythonHelloOCaml
Initially, I thought this is a case of stdout buffering not being flushed.
But the docs of print_endline clearly claim that it flushes stdout, so I am at a loss - and adding "flush" didn't help, either:
let _ =
print_endline "The Start";
my_getcwd () |> function
| Success folder -> Printf.printf "getcwd:\n\t%s\n" folder
| Error errMessage -> Printf.printf "getcwd (error):\n\t%s\n" errMessage
;
print_endline "The End." ;
flush stdout
;;
Help?
The print_endline is treated as part of the Error case. From the indentation, this is clearly not what you meant, but unfortunately the OCaml compiler doesn't warn about this.
You can use begin and end (or just parentheses) to make it work:
let () =
print_endline "The Start";
my_getcwd () |> begin function
| Success folder -> Printf.printf "getcwd:\n\t%s\n" folder
| Error errMessage -> Printf.printf "getcwd (error):\n\t%s\n" errMessage
end;
print_endline "The End." ;
flush stdout
Alternatively, without using ;,
let () =
let () = print_endline "The Start" in
let () = match my_getcwd () with
| Success folder -> Printf.printf "getcwd:\n\t%s\n" folder
| Error errMessage -> Printf.printf "getcwd (error):\n\t%s\n" errMessage
in
let () = print_endline "The End." in
flush stdout