clean dirty sprut

src/db.ml

@@ -1,3 +1,6 @@
+open Drame
+open Html
+
 let path id = Filename.concat App.data_dir id
 
 let read_file file = In_channel.with_open_bin file In_channel.input_all
@@ -5,16 +8,22 @@ let read_file file = In_channel.with_open_bin file In_channel.input_all
 let write_file file s =
   Out_channel.with_open_bin file (fun oc -> Out_channel.output_string oc s)
 
-let get id =
+let get id req =
   let file = path id in
-  try Ok (read_file file) with Sys_error s -> Error s
+  try Ok (read_file file)
+  with Sys_error s ->
+    let body = Format.ksprintf txt "No pad found with id %s: %s!" id s in
+    Template.not_found body req
 
-let set id content =
+let set id content req =
   let file = path id in
-  try Ok (write_file file content) with Sys_error s -> Error s
+  try Ok (write_file file content)
+  with Sys_error s ->
+    let body = Format.ksprintf txt "Can not write pad: %s!" s in
+    Template.internal_error body req
 
 let make_pad () =
-  let id = Random.int 1000 |> string_of_int in
+  let id = Random.int 10000 |> string_of_int in
   let file = path id in
   write_file file "Ceci n’est pas un pad";
   id

src/kropotkine.ml

@@ -1,28 +1,9 @@
 open Drame
+open Html
 
-let hello =
-  let open Html in
+let home =
   let body = txt "How are you doing?" in
-  fun ~name ->
-    let title = Format.ksprintf txt "Hello %s!" name in
-    fun request ->
-      let doc = Template.html request ~title ~body in
-      let content = Content.Html doc in
-      Ok content
-
-let hello_q request =
-  let open Html in
-  let name = Request.query request "name" in
-  let name = Option.value name ~default:"World" in
-  let msg = Format.ksprintf txt "Hello %s!" name in
-  let doc = Template.html request ~title:msg ~body:msg in
-  let content = Content.Html doc in
-  Ok content
-
-let config =
-  let open Html in
-  let title = txt "Configuration" in
-  let body = Format.kasprintf txt "%a" Scfg.Pp.config App.config in
+  let title = txt "Hello World!" in
   fun request ->
     let doc = Template.html request ~title ~body in
     let content = Content.Html doc in
@@ -39,7 +20,7 @@ let style =
 
 let js file request =
   match Bundle.read ("/assets/js/" ^ file) with
-  | None -> Template.not_found request
+  | None -> Template.not_found (txt "File does not exist.") request
   | Some content ->
     let mimetype = Mimetype.Text_javascript in
     Ok (Content.Unsafe { content; mimetype })
@@ -48,14 +29,11 @@ let handler route =
   Format.printf "[request] %a@\n" Route.pp route;
   Format.pp_print_flush Format.std_formatter ();
   match route with
-  | [||] -> hello ~name:"World"
+  | [||] -> home
   | [| "assets"; "css"; "style.css" |] -> style
   | [| "assets"; "js"; file |] -> js file
-  | [| "config" |] -> config
-  | [| "hello"; name |] -> hello ~name
-  | [| "helloq" |] -> hello_q
   | [| "new" |] -> Pad.make_new
   | [| "pad"; id |] -> Pad.controller id
-  | _ -> Template.not_found
+  | _ -> Template.not_found (txt "Page does not exist.")
 
 let () = App.run ~handler

src/pad.ml

@@ -1,5 +1,6 @@
 open Drame
 open Html
+open Syntax
 
 (* TODO should redirect to new pad url *)
 let make_new request =
@@ -28,27 +29,21 @@ let page id content request =
       [ pad; input ~a:[ a_input_type `Submit; a_value "write!" ] () ]
   in
   let doc = Template.html request ~title ~body ~scripts:[ "pad_js.js" ] in
-  let content = Content.Html doc in
-  content
+  Content.Html doc
 
-let get id request =
-  match Db.get id with
-  | Error _e -> Template.not_found request
-  | Ok content -> Ok (page id content request)
-
-(* TODO better response on bad form/error *)
 let controller id request =
   let open Drame in
   match request.Request.meth with
-  | Meth.Get -> get id request
+  | Meth.Get ->
+    let+ content = Db.get id request in
+    page id content request
   | Post -> (
     match Form.form request with
-    | Error _e -> Template.not_found request
+    | Error e -> Template.bad_request (txt e) request
     | Ok data -> (
       match List.assoc_opt "pad" data with
-      | None -> Template.not_found request
-      | Some content -> (
-        match Db.set id content with
-        | Error e -> failwith e
-        | Ok () -> Ok (page id content request) ) ) )
-  | _ -> failwith "aba"
+      | None -> Template.bad_request (txt "Invalid form.") request
+      | Some content ->
+        let+ () = Db.set id content request in
+        page id content request ) )
+  | _ -> Template.bad_request (txt "Aba.") request

src/syntax.ml

@@ -0,0 +1,3 @@
+let ( let* ) = Result.bind
+
+let ( let+ ) r f = Result.map f r

src/template.ml

@@ -26,9 +26,20 @@ let html ?(scripts = []) (_request : Request.t) ~title ~body =
   let a = [ a_lang "en" ] in
   html ~a head body
 
-let not_found =
-  let title = txt "404 Not Found" in
-  let body = txt "Ooops :S" in
+let not_found body =
+  let title = txt "404 - Not Found" in
   fun request ->
     let content = html request ~title ~body in
     Error (Status.Not_found, content)
+
+let internal_error body =
+  let title = txt "Internal Server Error" in
+  fun request ->
+    let content = html request ~title ~body in
+    Error (Status.Internal_server_error, content)
+
+let bad_request body =
+  let title = txt "Bad request" in
+  fun request ->
+    let content = html request ~title ~body in
+    Error (Status.Bad_request, content)