Commits

Dmitry Grebeniuk  committed 9c6fb48

Parvel.create_server_st for servers with state

  • Participants
  • Parent commits de68112

Comments (0)

Files changed (3)

     ;
 
     type server_context 'i 'o =
-      < me : server 'i 'o
+      < (*
+        me : server 'i 'o
       ; my_group : server_group 'i 'o
+      ; *)
 
-      ; return : 'o -> server_result 'o
+        return : 'o -> server_result 'o
       ; error : call_resp_error -> server_result 'o
       >
     ;
  =
         let ctx_for_serv : server_context 'i 'o =
           object
+            (*
             method me = ctx_for_proc#me;
             method my_group = ctx_for_proc#my_group;
+            *)
             method return r = Return r;
             method error e = Error e;
           end
       ]
     ;
 
+
+    (* servers with state *)
+
+    value (create_server_st :
+      server_group 'i 'o ->
+      server_dispatcher ('i * 's) ('o * 's) ->
+      's ->
+      IO.m (server 'i 'o)
+    )
+    group in_disp state =
+      let out_disp : server_dispatcher 'i 'o =
+        fun _out_ctx ->
+          let in_ctx = ((
+            object
+              method return x = Return x;
+              method error x = Error x;
+            end
+          ) : server_context ('i * 's) ('o * 's)) in
+          let in_disp_ctx = in_disp in_ctx in
+          let state = ref state in
+          fun msg ->
+            let old_state = state.val in
+            in_disp_ctx (msg, old_state) >>= fun (res, new_state) ->
+            ( if old_state != new_state
+              then state.val := new_state
+              else ()
+            ; IO.return res
+            )
+      in
+        create_server group out_disp
+    ;
+
+
   end
 ;
     ;
 
     type server_context 'i 'o =
-      < me : server 'i 'o
+      < (* commented out, since it complicates the implementation
+           (of create_server_st, for example)
+           without the real need of me/my_group for now.
+        me : server 'i 'o
       ; my_group : server_group 'i 'o
+      ; *)
 
-      ; return : 'o -> server_result 'o
+        return : 'o -> server_result 'o
       ; error : call_resp_error -> server_result 'o
       >
     ;
     value switch_keys : switch 'k 'i 'o -> IO.m (list 'k)
     ;
 
+
+    (* servers with state.
+       passing state in and out of server function,
+       but this implies no parallel requests processing can be made.
+       (todo: maybe add logic for handling
+          ([= `Readonly | `Exclusive ] * 'i) requests to allow
+          parallel execution of `Readonly requests?)
+     *)
+
+    value create_server_st :
+      server_group 'i 'o ->
+      server_dispatcher ('i * 's) ('o * 's) ->
+      's ->
+      IO.m (server 'i 'o)
+    ;
+
   end
 ;
   IO.return ()
 ;
 
+value func_something_state _ctx (n, state) =
+  let state_string =
+    sprintf "(previous waits: %s)" &
+    String.concat ", " &
+    List.map (sprintf "%.2f") &
+    state
+  in
+  IO.printf "do_something: %.2f\n%!" n >>= fun () ->
+  Lwt_unix.sleep n >>= fun () ->
+  IO.printf "do_something: %.2f done (%s)\n%!" n state_string >>= fun () ->
+  IO.return ((), [n :: state])
+;
+
+
 
 value io_main () =
   P.create_server_group () >>= fun servg ->
 (*
   P.create_process servg (loop do_something) >>= fun serv ->
 *)
+  P.create_server_st servg func_something_state [] >>= fun serv ->
+  P.call_io serv 0.5 >>= fun () ->
+  P.call_io serv 1.5 >>= fun () ->
+  P.call_io serv 2.5 >>= fun () ->
+  IO.printf "io_main: awake\n" >>= fun () ->
+  IO.printf "done\n%!"
+;
+
+
+value _io_main_stateless () =
+  P.create_server_group () >>= fun servg ->
+(*
+  P.create_process servg (loop do_something) >>= fun serv ->
+*)
   P.create_server servg func_something >>= fun serv ->
   P.call_io serv 0.5 >>= fun () ->
   P.call_io serv 1.5 >>= fun () ->