From ed4074e5e23e05df82bdf903771e31ff9b045b41 Mon Sep 17 00:00:00 2001 From: Andre Ambrosio Boechat Date: Sat, 15 Feb 2025 12:54:14 -0300 Subject: [PATCH 1/3] Capture the bug of the memory session used with Dream.scope --- test/expect/server/router.ml | 127 ++++++++++++++++++++++++++++++----- 1 file changed, 109 insertions(+), 18 deletions(-) diff --git a/test/expect/server/router.ml b/test/expect/server/router.ml index 09b3920b..40416b88 100644 --- a/test/expect/server/router.ml +++ b/test/expect/server/router.ml @@ -88,29 +88,79 @@ let%expect_test _ = Path wildcard must be just '**' Path wildcard must be just '**' |}] +(* Transfer a Dream session cookie from a response to a request. This function + helps testing Dream sessions.*) +let forward_session_cookie (response: Dream.response) (request: Dream.request) = + match Dream.header response "Set-Cookie" with + | None -> () + | Some payload -> + ignore @@ Str.search_forward + (Str.regexp {|\(dream.session=.+\)?;|}) payload 0; + let session_cookie = Str.matched_group 1 payload + in + Dream.set_header request "Cookie" session_cookie + +let%expect_test _ = + let print_headers message = + Dream.all_headers message + |> List.iter (fun (k, v) -> Printf.printf "%s %s\n" k v) + in + let resp = Dream.response "testing" + in + Dream.set_cookie + ~encrypt:false resp (Dream.request "first req") "dream.session" "abc"; + print_headers resp; + let req = Dream.request "second req" + in + forward_session_cookie resp req; + print_headers req; + match Dream.cookie ~decrypt:false req "dream.session" with + | None -> Printf.printf "Failed\n" + | Some x -> Printf.printf "%s\n" x; + [%expect {| + Set-Cookie dream.session=abc; Path=/; HttpOnly; SameSite=Lax + Cookie dream.session=abc; Path=/; HttpOnly + abc |}] - -let show ?(prefix = "/") ?(method_ = `GET) target router = +(* Simulate a request to a given target, execute the router, print info about + the response and return it. If a Dream response is also given, the simulated + request should contain the same Dream session cookie. *) +let show_response + ?(prefix = "/") ?(method_ = `GET) ?(response = None) target router = try - Dream.request ~method_ ~target "" + let request = Dream.request ~method_ ~target "" + in + (match response with + | None -> () + | Some r -> forward_session_cookie r request); + request |> Dream.test ~prefix router |> fun response -> - let body = - Dream.client_stream response - |> Obj.magic (* TODO Needs to be replaced by exposing read_until_close - as a function on abstract streams. *) - |> Dream_pure.Stream.read_until_close - |> Lwt_main.run - in - let status = Dream.status response in - Printf.printf "Response: %i %s\n" - (Dream.status_to_int status) (Dream.status_to_string status); - if body <> "" then - Printf.printf "%s\n" body - else - () + let body = + Dream.client_stream response + |> Obj.magic (* TODO Needs to be replaced by exposing read_until_close + as a function on abstract streams. *) + |> Dream_pure.Stream.read_until_close + |> Lwt_main.run + in + let status = Dream.status response in + Printf.printf "Response: %i %s\n" + (Dream.status_to_int status) (Dream.status_to_string status); + (if body <> "" then + Printf.printf "%s\n" body + else + ()); + response with Failure message -> - print_endline message + print_endline message; + raise (Failure message) + +(* Simulate a request to a given target, execute the router, print info about + the response and return it. This is a simpler version of "show_response". *) +let show ?(prefix = "/") ?(method_ = `GET) target router = + try + ignore @@ show_response ~prefix:prefix ~method_:method_ target router + with _ -> () (* Basic router tests. *) @@ -523,6 +573,47 @@ let%expect_test _ = [%expect {| Response: 404 Not Found |}] +(* We want to check if different session backends are working properly with + "Dream.scope". *) +let%expect_test _ = + let session_field = "testfield" + in + let app session_backend session_value = + Dream.router [ + Dream.scope "/" [session_backend] [ + Dream.get "/abc" + (fun req -> + let%lwt () = + Dream.set_session_field req session_field session_value + in + Dream.respond "baz"); + Dream.get "/def" + (fun req -> + Dream.respond + (match Dream.session_field req session_field with + | None -> "No value in the session" + | Some x -> x)) + ] + ] + in + let simulate_and_check app_with_session = + let resp_abc = show_response "/abc" app_with_session in + ignore @@ show_response ~response:(Some resp_abc) "/def" app_with_session + in + simulate_and_check (app Dream.cookie_sessions "100"); + [%expect {| + Response: 200 OK + baz + Response: 200 OK + 100 |}]; + simulate_and_check (app Dream.memory_sessions "999"); + [%expect {| + Response: 200 OK + baz + Response: 200 OK + 999 |}] + + (* Router sequence works. *) (* let%expect_test _ = From 77ef9fad0b16d01bbb0b4b9d75aff8030df95582 Mon Sep 17 00:00:00 2001 From: Andre Ambrosio Boechat Date: Tue, 18 Feb 2025 16:04:19 -0300 Subject: [PATCH 2/3] Make "memory_sessions" require initialization before usage The initialization mechanism should make it possible to share a state among routes in "Dream.scope". --- src/dream.mli | 9 +++++---- src/mirage/mirage.mli | 9 +++++---- src/server/session.ml | 7 ++++++- test/expect/server/router.ml | 2 +- 4 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/dream.mli b/src/dream.mli index 9a56351d..9a1bd5dd 100644 --- a/src/dream.mli +++ b/src/dream.mli @@ -78,7 +78,7 @@ and route {[ Dream.router [ - Dream.scope "/admin" [Dream.memory_sessions] [ + Dream.scope "/admin" [Dream.memory_sessions ()] [ Dream.get "/" admin_handler; Dream.get "/logout" admin_logout_handler; ]; @@ -1590,9 +1590,10 @@ val invalidate_session : request -> unit promise (** {2 Back ends} *) -val memory_sessions : ?lifetime:float -> middleware -(** Stores sessions in server memory. Passes session IDs to clients in cookies. - Session data is lost when the server process exits. *) +val memory_sessions : ?lifetime:float -> unit -> middleware +(** Stores sessions in server memory and requires initialization before + usage. Passes session IDs to clients in cookies. Session data is lost when + the server process exits. *) val cookie_sessions : ?lifetime:float -> middleware (** Stores sessions in encrypted cookies. Use {!Dream.set_secret} to be able to diff --git a/src/mirage/mirage.mli b/src/mirage/mirage.mli index 3e7e5337..2fe428b6 100644 --- a/src/mirage/mirage.mli +++ b/src/mirage/mirage.mli @@ -87,7 +87,7 @@ module Make {[ Dream.router [ - Dream.scope "/admin" [Dream.memory_sessions] [ + Dream.scope "/admin" [Dream.memory_sessions ()] [ Dream.get "/" admin_handler; Dream.get "/logout" admin_logout_handler; ]; @@ -1475,9 +1475,10 @@ module Make (** {2 Back ends} *) - val memory_sessions : ?lifetime:float -> middleware - (** Stores sessions in server memory. Passes session IDs to clients in cookies. - Session data is lost when the server process exits. *) + val memory_sessions : ?lifetime:float -> unit -> middleware + (** Stores sessions in server memory and requires initialization before + usage. Passes session IDs to clients in cookies. Session data is lost when + the server process exits. *) val cookie_sessions : ?lifetime:float -> middleware (** Stores sessions in encrypted cookies. Pass {!Dream.run} [~secret] to be able diff --git a/src/server/session.ml b/src/server/session.ml index 90bd59ef..a969fc49 100644 --- a/src/server/session.ml +++ b/src/server/session.ml @@ -342,7 +342,12 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let now () = Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ())) let memory_sessions ?(lifetime = two_weeks) = - middleware (Memory.back_end ~now lifetime) + (* "Memory.back_end" returns a record that has a state (a hash table). If we + don't provide a way to initialize it before returning the middleware, the + state won't be shared among routes in "Dream.scope". *) + let back_end = (Memory.back_end ~now lifetime) + in + fun () -> middleware back_end let cookie_sessions ?(lifetime = two_weeks) = middleware (Cookie.back_end ~now lifetime) diff --git a/test/expect/server/router.ml b/test/expect/server/router.ml index 40416b88..e1122f25 100644 --- a/test/expect/server/router.ml +++ b/test/expect/server/router.ml @@ -606,7 +606,7 @@ let%expect_test _ = baz Response: 200 OK 100 |}]; - simulate_and_check (app Dream.memory_sessions "999"); + simulate_and_check (app (Dream.memory_sessions ()) "999"); [%expect {| Response: 200 OK baz From 5f8ecf00c56ebfe48080729ecf126e6fca6a03d4 Mon Sep 17 00:00:00 2001 From: Andre Ambrosio Boechat Date: Tue, 18 Feb 2025 16:20:22 -0300 Subject: [PATCH 3/3] Update code in examples that use "Dream.memory_sessions" "Dream.memory_sessions" now requires an initialization call. --- example/b-session/README.md | 5 +++-- example/b-session/session.ml | 2 +- example/d-form/README.md | 3 +-- example/d-form/form.eml.ml | 2 +- example/g-upload/README.md | 2 +- example/g-upload/upload.eml.ml | 2 +- example/w-flash/README.md | 2 +- example/w-flash/flash.eml.ml | 2 +- example/w-multipart-dump/multipart_dump.eml.ml | 2 +- example/w-upload-stream/README.md | 2 +- example/w-upload-stream/upload_stream.eml.ml | 2 +- 11 files changed, 13 insertions(+), 13 deletions(-) diff --git a/example/b-session/README.md b/example/b-session/README.md index 82f50f36..a3a04b72 100644 --- a/example/b-session/README.md +++ b/example/b-session/README.md @@ -9,7 +9,7 @@ straightforward: let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ fun request -> match Dream.session_field request "user" with @@ -62,7 +62,8 @@ There are two other session back ends, which are persistent: - [`Dream.cookie_sessions`](https://camlworks.github.io/dream/#val-cookie_sessions) stores session data in encrypted cookies. That is, session data is stored on clients, rather than on the server. You can replace `Dream.memory_sessions` - with `Dream.cookie_sessions` and it will work right away. However, if you + with `Dream.cookie_sessions` and it will work right away (except that + `Dream.cookie_sessions` don't require a call with `unit`). However, if you want to be able to decrypt sessions set by previous runs of the server, use the [`Dream.set_secret`](https://camlworks.github.io/dream/#val-set_secret) middleware before `Dream.cookie_sessions`. If you don't, the server will be diff --git a/example/b-session/session.ml b/example/b-session/session.ml index 8a0c0458..139e9c50 100644 --- a/example/b-session/session.ml +++ b/example/b-session/session.ml @@ -1,7 +1,7 @@ let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ fun request -> match Dream.session_field request "user" with diff --git a/example/d-form/README.md b/example/d-form/README.md index 2f6d579a..b7ca917b 100644 --- a/example/d-form/README.md +++ b/example/d-form/README.md @@ -27,7 +27,7 @@ let show_form ?message request = let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.router [ Dream.get "/" @@ -114,4 +114,3 @@ the data is not sensitive, so we took a shortcut. See
[Up to the tutorial index](../#readme) - diff --git a/example/d-form/form.eml.ml b/example/d-form/form.eml.ml index 40fe08fa..93d5e3e4 100644 --- a/example/d-form/form.eml.ml +++ b/example/d-form/form.eml.ml @@ -19,7 +19,7 @@ let show_form ?message request = let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.router [ Dream.get "/" diff --git a/example/g-upload/README.md b/example/g-upload/README.md index 4bb200ed..472e1144 100644 --- a/example/g-upload/README.md +++ b/example/g-upload/README.md @@ -36,7 +36,7 @@ let report files = let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.router [ Dream.get "/" (fun request -> diff --git a/example/g-upload/upload.eml.ml b/example/g-upload/upload.eml.ml index 2471a4ac..b070fc6c 100644 --- a/example/g-upload/upload.eml.ml +++ b/example/g-upload/upload.eml.ml @@ -26,7 +26,7 @@ let report files = let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.router [ Dream.get "/" (fun request -> diff --git a/example/w-flash/README.md b/example/w-flash/README.md index 4d0a1caa..d24ec093 100644 --- a/example/w-flash/README.md +++ b/example/w-flash/README.md @@ -53,7 +53,7 @@ let () = Dream.set_log_level "dream.flash" `Debug; Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.flash @@ Dream.router [ diff --git a/example/w-flash/flash.eml.ml b/example/w-flash/flash.eml.ml index 3db146cc..6b7ab53b 100644 --- a/example/w-flash/flash.eml.ml +++ b/example/w-flash/flash.eml.ml @@ -22,7 +22,7 @@ let () = Dream.set_log_level "dream.flash" `Debug; Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.flash @@ Dream.router [ diff --git a/example/w-multipart-dump/multipart_dump.eml.ml b/example/w-multipart-dump/multipart_dump.eml.ml index 000d1e1b..e4a8ca26 100644 --- a/example/w-multipart-dump/multipart_dump.eml.ml +++ b/example/w-multipart-dump/multipart_dump.eml.ml @@ -13,7 +13,7 @@ let home request = let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.router [ Dream.get "/" (fun request -> diff --git a/example/w-upload-stream/README.md b/example/w-upload-stream/README.md index c0588ed4..5a13ef3c 100644 --- a/example/w-upload-stream/README.md +++ b/example/w-upload-stream/README.md @@ -36,7 +36,7 @@ let report files = let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.router [ Dream.get "/" (fun request -> diff --git a/example/w-upload-stream/upload_stream.eml.ml b/example/w-upload-stream/upload_stream.eml.ml index e6d086f9..b8d29ebc 100644 --- a/example/w-upload-stream/upload_stream.eml.ml +++ b/example/w-upload-stream/upload_stream.eml.ml @@ -26,7 +26,7 @@ let report files = let () = Dream.run @@ Dream.logger - @@ Dream.memory_sessions + @@ Dream.memory_sessions () @@ Dream.router [ Dream.get "/" (fun request ->