I'm trying to use Pose (https://github.com/tonerdo/pose) to shim out printfn so I can unit test what is passed to it. I've managed to get it working if I'm passing a TextWriterFormat that doesn't take additional arguments, but when I try to shim one that does take additional arguments I get a Mismatched instance types exception
This works:
let workingPrintfTest () =
let a = Printf.TextWriterFormat<unit>("herp")
Printf.printfn a
let workingShim =
Shim
.Replace(fun () ->
Printf.printfn(Is.A<Printf.TextWriterFormat<unit>>())
)
.With(Func<Printf.TextWriterFormat<unit>, unit>(fun s ->
Console.WriteLine("Hijacked: " + s.ToString())
))
PoseContext.Isolate ((fun () ->
Program.workingPrintfTest () // Hijacked: herp
), workingShim)
However, when I change herp to herp: %s and the TextWriterFormat becomes TextWriterFormat<string -> unit> is when I get the mismatched instance types exception.
This throws exception:
let printfTest toPrint =
let a = Printf.TextWriterFormat<string -> unit>("herp: %s")
Printf.printfn a toPrint
let shim =
Shim
.Replace(fun () ->
let a = Is.A<Printf.TextWriterFormat<string -> unit>>()
Printf.printfn a (Is.A<string>())
)
.With(Func<Printf.TextWriterFormat<string -> unit>, unit>(fun s ->
Console.WriteLine("Hijacked: " + s.ToString())
()
)
)
PoseContext.Isolate ((fun () ->
Program.printfTest "www"
), shim)
And the accompanying Exception: Pose.Exceptions.InvalidShimSignatureException: Mismatched instance types
I'm running this in .Net Core 2.2
Any help would be appreciated.
Related
I have a module in OCaml that is parameterized by another module, which represents a data structure (H = Hashtable, M = Map, L = LossyMap). I would now like to let this data structure be selected via the command line.
The way I create the main processing module is:
module HashSampler = MakeSampler(HashtableMatrix)
module MapSampler = MakeSampler(MapMatrix)
etc.
Unfortunately, the code that multiplexes between these is ugly:
match representation with
| "Hashtable" ->
let matrix = HashSampler.create () in
HashSampler.process_file matrix file
| "Map" ->
let matrix = MapSampler.create () in
MapSampler.process_file matrix file
Is there a better way of doing this that somehow prevents code duplication?
You can use first class modules. Here's some example code that shows one possibility.
module type Sampler = sig
type t
val create : unit -> t
val process_file : t -> string -> unit
end
module HashSampler : Sampler = struct
type t = unit
let create () = ()
let process_file () file = ()
end
module MapSampler : Sampler = struct
type t = unit
let create () = ()
let process_file () file = ()
end
let choose_sampler : string -> (module Sampler) = function
| "Hashtable" -> (module HashSampler)
| "Map" -> (module MapSampler)
let process representation file =
let (module M) = choose_sampler representation in
let matrix = M.create () in M.process_file matrix file
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 have been trying to gain a better understanding of the Eliom functionality for communication lately and to do so I tried to build a simple web page that allows users to send messages to each other.
The web page works fine if I log in as one user via Firefox and a second user via Chrome. But when I log in two different users in the same browser and try to send a message from one user to the other (i.e. from one tab to another tab), any message sent is displayed on all tabs, not the intended recipient's tab only.
I believe that I may have some issues with the chosen scope for erefs or where I am setting/getting the scope and erefs (toplevel vs. service definition).
I am trying to correct my mistake so that two users can be logged into two different tabs of the same browser and send messages back and forth to each other and the messages are only displayed on the correct users tabs.
Note: Some of this code is taken from the Eliom site tutorial at:
http://ocsigen.org/tuto/4.2/manual/how-to-implement-a-notification-system
My .eliom file:
(* Example website login: localhost:8080/?user_num=1 *)
{shared{
open Eliom_lib
open Eliom_content
open Html5
open Html5.F
open Eliom_registration
open Eliom_parameter
}}
module Channel_example_app =
Eliom_registration.App (
struct
let application_name = "channel_example"
end)
let main_service =
Eliom_service.App.service ~path:[] ~get_params:(string "user_num") ()
let new_message_action =
Eliom_service.Http.post_coservice'
~post_params:(string "from_user_id" ** string "to_user_id" ** string "msg") ()
(* Set the scope used by all erefs *)
let eref_scope = Eliom_common.default_process_scope
(* Create a channel eref *)
let channel_ref =
Eliom_reference.Volatile.eref_from_fun
~scope:eref_scope
(fun () ->
let (s, notify) = Lwt_stream.create () in
let c = Eliom_comet.Channel.create s in
(c, notify)
)
(* Reactive string eref *)
let react_string_ref =
Eliom_reference.Volatile.eref_from_fun
~scope:eref_scope
(fun () ->
let (client_string, send_client_string) :
(string React.E.t * (?step:React.step -> string -> unit) ) =
React.E.create ()
in
(client_string, send_client_string)
)
(* Reactive string to display the users session group *)
let react_session_group_ref =
Eliom_reference.Volatile.eref_from_fun
~scope:eref_scope
(fun () ->
let (session_group_string, send_session_group_string) :
(string React.E.t * (?step:React.step -> string -> unit) ) =
React.E.create ()
in
(session_group_string, send_session_group_string)
)
(* Reactive string to display the users session group size *)
let react_session_group_size_ref =
Eliom_reference.Volatile.eref_from_fun
~scope:eref_scope
(fun () ->
let (session_group_size_string, send_session_group_size_string) :
(string React.E.t * (?step:React.step -> string -> unit) ) =
React.E.create ()
in
(session_group_size_string, send_session_group_size_string)
)
(* Send a message from one client to another *)
let notify from_user_id to_user_id s =
(* Get the session group state for the user *)
let state =
Eliom_state.Ext.volatile_data_group_state ~scope:Eliom_common.default_group_scope to_user_id in
(* Iterate on all sessions from the group *)
Eliom_state.Ext.iter_volatile_sub_states ~state
(fun state ->
(* Iterate on all client process states in the session *)
Eliom_state.Ext.iter_volatile_sub_states ~state
(fun state ->
let (_, notify) = Eliom_reference.Volatile.Ext.get state channel_ref in
notify (Some ("Hello from " ^ from_user_id ^ "! You are user " ^ to_user_id ^ "\n\n" ^ s))
)
)
(* Action for a client to send a message *)
let () =
Eliom_registration.Action.register
~options:`NoReload
~service:new_message_action
(fun () (from_user_id, (to_user_id, msg)) ->
Lwt.return ## notify from_user_id to_user_id msg
)
(* Post form for one user to send a message to another user *)
let client_message_form =
Eliom_content.Html5.F.post_form ~service:new_message_action ~port:8080
(
fun (from_user_id, (to_user_id, msg)) ->
[p [pcdata "To:"];
string_input ~input_type:`Text ~name:to_user_id ();
p [pcdata "From:"];
string_input ~input_type:`Text ~name:from_user_id ();
p [pcdata "Send a message here:"];
string_input ~input_type:`Text ~name:msg ();
button ~button_type:`Submit [pcdata "Send Message"]
]
)
let () =
Channel_example_app.register
~service:main_service
(fun user_num () ->
(* Set the session group to which the erefs belong *)
Eliom_state.set_volatile_data_session_group
~set_max:1
~scope:Eliom_common.default_session_scope
~secure:true
user_num;
let (channel, _) = Eliom_reference.Volatile.get channel_ref in
let my_client_string, my_send_client_string = Eliom_reference.Volatile.get react_string_ref in
let my_send_client_string' =
server_function Json.t<string> (fun s -> Lwt.return ## my_send_client_string s)
in
let c_down = Eliom_react.Down.of_react my_client_string in
(* When a message is received on the channel, push it as a reactive event *)
let _ =
{unit{
Lwt.async
(fun () ->
Lwt_stream.iter (fun (s : string) -> ignore ## %my_send_client_string' s) %channel
)
}}
in
let my_session_group =
match
Eliom_state.get_volatile_data_session_group
~scope:Eliom_common.default_session_scope
~secure:true ()
with
| None -> "No session group"
| Some sg -> sg
in
let my_session_group_size =
match
Eliom_state.get_volatile_data_session_group_size
~scope:Eliom_common.default_session_scope
~secure:true ()
with
| None -> "0"
| Some gs -> string_of_int gs
in
Lwt.return
(Eliom_tools.F.html
~title:"channel_example"
~css:[["css";"channel_example.css"]]
Eliom_content.Html5.F.(body [
h2 [pcdata ("Your are logged in as user " ^ user_num)];
client_message_form ();
p [pcdata "Your message is:"];
C.node {{R.pcdata (React.S.hold "No message yet" %c_down)}};
p [pcdata ("I am a part of the session group named " ^ my_session_group)];
p [pcdata ("My session group size is " ^ my_session_group_size)]
])))
The problem came from using the notify function which loops through all tabs. I used the Hashtable / Weak Hashtable structure from Eliom Base App and it corrected all the communication issues. The key was altering the notify function as follows:
let notify ?(notforme = false) ~id ~to_user ~msg =
Lwt.async (fun () ->
I.fold
(fun (userid_o, ((_, _, send_e) as nn)) (beg : unit Lwt.t) ->
if notforme && nn == Eliom_reference.Volatile.get notif_e
then Lwt.return ()
else
lwt () = beg in
let content = if Some to_user = userid_o then Some msg else None in
match content with
| Some content -> send_e (id, content); Lwt.return ()
| None -> Lwt.return ()
)
id (Lwt.return ()))
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 ()
I have a problem where I have a global hashtable, and then I load a .cma file with Dynlink, which registers a function in the hashtable.
However, the behaviour I seem to be see is that when the module is dynamically linked, all the global bindings get re-initialised, such that my hashtable is empty.
E.g.:
Table.extensions : (string, string -> string) Hashtbl.t
Extensions.load : unit -> unit (* loads the specified .cma files *)
Extensions.register : string -> (string -> string) -> unit
(* adds entry to Table.extensions, prints name of extension registered *)
Main:
let () =
Extensions.load ();
Hashtbl.iter (fun x _ -> print_endline x) Table.extensions;
Printf.printf "%d extensions loaded\n" (Hashtbl.length Table.extensions)
My program loads one .cma file, so it should print:
Registered extension 'test'
test
1 extensions loaded
Instead I get:
Registered extension 'test'
0 extensions loaded
I've been fighting this for several hours now; no matter how I refactor my code, I get no closer to a working solution.
EDIT: Extensions.load:
Dynlink.allow_unsafe_modules true;;
let load () =
try
let exts = Sys.readdir "exts" in
Array.iter begin fun name ->
try
Dynlink.loadfile (Filename.concat "exts" name);
Printf.printf "Loaded %s\n" name;
with
| Dynlink.Error error -> print_endline (Dynlink.error_message error)
| exn -> print_endline (Printexc.to_string exn)
end exts
with _ -> ()
#ygrek, you were right, there were two instances.
The solution was to build/load just the .cmo, not a .cma.