commit 4ad8279a13e5ef52372a9449c2b7a3eaa542cd48
parent 1445636cfcda30715c304ad5bb17e19d61f99e9b
Author: Andrew Laack <andrew@laack.co>
Date: Wed, 2 Sep 2026 11:35:11 -0500
Refactoring to test server, improved course parameter handling, improved status code messaging.
Diffstat:
6 files changed, 137 insertions(+), 49 deletions(-)
diff --git a/learning/bin/dune b/learning/bin/dune
@@ -1,4 +1,4 @@
(executable
(public_name learning)
(name main)
- (libraries dream jingoo learning))
+ (libraries learning))
diff --git a/learning/bin/main.ml b/learning/bin/main.ml
@@ -1,51 +1,7 @@
open Learning
-(* TODO: Make this a whitelist based on the page / course lists *)
-(* TODO: Favicon *)
-
-let is_safe_path name =
- String.length name > 0
- && name <> "."
- && name <> ".."
- && String.for_all (fun c ->
- (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
- || (c >= '0' && c <= '9') || c = '-' || c = '_' || c = '.') name
-
-(* TODO: Ensure server responds correctly to invalid requests. *)
-(*
- Examples: Non-existent course
- Examples: Non-existent page
- Examples: Non-existent asset
- Examples: Unknown path
-*)
-
-let my_error_template _error debug_info suggested_response =
- let status = Dream.status suggested_response in
- let code = Dream.status_to_int status
- and reason = Dream.status_to_string status in
- Dream.set_header suggested_response "Content-Type" Dream.text_html;
- Dream.set_body suggested_response ("<h1>" ^ (string_of_int code) ^ " - " ^ reason ^ "</h1>");
- Lwt.return suggested_response
-
-
-let () =
- Dream.run ~error_handler:(Dream.error_template my_error_template)
+let () =
+ Dream.run ~error_handler:(Server.handler)
@@ Dream.logger
- @@ Dream.router [
- Dream.get "/course/:course_name/" (fun request -> Dream.html (Render.render_sidebar @@ Render.render_course_home
- (if is_safe_path (Dream.param request "course_name") then Dream.param request "course_name" else "")));
-
- Dream.get "/course/:course_name/page/:page_name" (fun request -> Dream.html @@ Render.render_sidebar @@ Render.render_page
- (if is_safe_path (Dream.param request "course_name") then Dream.param request "course_name" else "")
-
- (if is_safe_path (Dream.param request "page_name") then (Dream.param request "page_name") else ""));
-
- Dream.get "/static/**" (Dream.static "./static");
- Dream.get "/" (fun _ -> Dream.html (Render.render_sidebar @@ Render.render_course_list));
- Dream.get "/robots.txt" (Dream.from_filesystem "./static" "robots.txt");
+ @@ Dream.router Server.routes
- Dream.get "/course/:course_name/page/assets/**" (fun request -> Dream.static
- (Shared.course_dir ^
- (if is_safe_path (Dream.param request "course_name") then Dream.param request "course_name" else "")
- ^ "/assets") request);
- ]
diff --git a/learning/lib/dune b/learning/lib/dune
@@ -1,3 +1,3 @@
(library
(name learning)
- (libraries jingoo))
+ (libraries jingoo dream))
diff --git a/learning/lib/server.ml b/learning/lib/server.ml
@@ -0,0 +1,93 @@
+(* TODO: Make this a whitelist based on the page / course lists *)
+(* TODO: Favicon *)
+
+let is_file filename =
+ if Sys.file_exists filename then
+ true
+ else
+ false
+
+let is_directory path =
+ if Sys.file_exists path then
+ (if Sys.is_directory path then
+ true
+ else
+ false)
+ else
+ false
+
+let is_safe_path name =
+ String.length name > 0
+ && name <> "."
+ && name <> ".."
+ && String.for_all (fun c ->
+ (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
+ || (c >= '0' && c <= '9') || c = '-' || c = '_' || c = '.') name
+
+(* TODO: Ensure server responds correctly to invalid requests. *)
+(*
+ Examples: Non-existent course
+ Examples: Non-existent page
+ Examples: Non-existent asset
+ Examples: Unknown path
+*)
+
+let my_error_template _error debug_info suggested_response =
+ let status = Dream.status suggested_response in
+ let code = Dream.status_to_int status
+ and reason = Dream.status_to_string status in
+ Dream.set_header suggested_response "Content-Type" Dream.text_html;
+ Dream.set_body suggested_response ("<h1>" ^ (string_of_int code) ^ " - " ^ reason ^ "</h1>");
+ Lwt.return suggested_response
+
+let get_course_name request =
+ Dream.param request "course_name"
+
+
+(* TODO: When should trailing slash be in a url? *)
+(* TODO: If sticking with course_name/ then course_name ^ "/" redirect *)
+
+let is_valid_course name =
+ let pth = Shared.course_dir ^ name in
+ (is_safe_path name && is_directory pth)
+
+let routes = [
+ Dream.get "/course/:course_name/" (fun request ->
+ let name = get_course_name request in
+ if is_valid_course name then
+ Dream.html (
+ Render.render_sidebar @@ Render.render_course_home (name)
+ )
+ else
+ Dream.empty `Not_Found
+ );
+
+ Dream.get "/course/:course_name/page/:page_name" (fun request ->
+ let name = get_course_name request in
+ if is_valid_course name then
+ Dream.html @@ Render.render_sidebar @@ Render.render_page name (if is_safe_path (Dream.param request "page_name") then (Dream.param request "page_name") else "")
+
+ else
+ Dream.empty `Not_Found
+ );
+
+
+
+ Dream.get "/static/**" (Dream.static "./static");
+ Dream.get "/" (fun _ -> Dream.html (Render.render_sidebar @@ Render.render_course_list));
+ Dream.get "/robots.txt" (Dream.from_filesystem "./static" "robots.txt");
+
+ Dream.get "/course/:course_name/page/assets/**" (fun request ->
+
+ let name = get_course_name request in
+ if is_valid_course name then
+ Dream.static
+ (Shared.course_dir ^ name
+ ^ "/assets") request
+ else
+ Dream.empty `Not_Found
+ );
+
+]
+
+let handler = Dream.error_template my_error_template
diff --git a/learning/test/test_learning.ml b/learning/test/test_learning.ml
@@ -1,2 +1,3 @@
let () = Test_line_parsing.test_line_parsing ()
let () = Test_rendering.test_rendering ()
+let () = Test_server.test_server ()
diff --git a/learning/test/test_server.ml b/learning/test/test_server.ml
@@ -0,0 +1,38 @@
+open Learning
+
+(*main.ml server definition:
+
+let () =
+ Dream.run ~error_handler:(Server.handler)
+ @@ Dream.logger
+ @@ Dream.router Server.routes
+
+*)
+
+let test_server =
+ Dream.test
+ @@ Dream.router Server.routes
+
+
+let root_response = test_server (Dream.request ~target:"/" "")
+let course_0_response = test_server (Dream.request ~target:"/course/course_0/" "")
+let course_1_response = test_server (Dream.request ~target:"/course/course_1/" "")
+let course_dne_response = test_server (Dream.request ~target:"/course/this_course_doesnt_exist/" "")
+
+
+
+let test_server () =
+ assert (not (Server.is_safe_path "../"));
+ assert (not (Server.is_safe_path ".."));
+ assert (not (Server.is_safe_path "smt/../../../"));
+ assert (not (Server.is_safe_path "smt/../"));
+ assert (Server.is_safe_path "smt.sl");
+ assert (Server.is_safe_path "smt");
+ assert (Server.is_safe_path "0_course_1.sl");
+ assert (Server.is_safe_path "1_course_1.sl");
+
+ (* Requests to test dream server handling routes. *)
+ assert (Dream.status_to_int (Dream.status root_response) = 200);
+ assert (Dream.status_to_int (Dream.status course_0_response) = 200);
+ assert (Dream.status_to_int (Dream.status course_1_response) = 200);
+ assert (Dream.status_to_int (Dream.status course_dne_response) = 404);
