| 1 | (* Routes and actions, independent of the HTTP server: a request in, a |
| 2 | response out. bin/main.ml adapts this to cohttp-eio, and the tests call |
| 3 | it directly. *) |
| 4 | |
| 5 | type request = { |
| 6 | meth : string; |
| 7 | path : string; |
| 8 | query : (string * string) list; |
| 9 | header : string -> string option; (** by lower-case name *) |
| 10 | body : string; |
| 11 | } |
| 12 | |
| 13 | type response = { status : int; headers : (string * string) list; body : string } |
| 14 | |
| 15 | type t = { |
| 16 | store : Store.t; |
| 17 | origin : string; (** this app's own origin, e.g. https://todo-ocaml.bfj.oncarlos.com *) |
| 18 | version : string; |
| 19 | } |
| 20 | |
| 21 | (* `make bump` edits this constant so the next build must recompile this file. *) |
| 22 | let build_marker = "todomvc" |
| 23 | |
| 24 | let create ~store ~origin ~version = { store; origin; version } |
| 25 | |
| 26 | let cookie_name = "todomvc_list" |
| 27 | |
| 28 | (* Kept for 400 days, the longest a browser will keep a cookie. *) |
| 29 | let cookie_max_age = 400 * 24 * 60 * 60 |
| 30 | |
| 31 | (* The inline script that marks the page as having JavaScript, and its hash |
| 32 | for the Content-Security-Policy. *) |
| 33 | let csp = |
| 34 | "default-src 'self'; script-src 'self' 'sha256-qOhFsq0QMV2REqNwk5hGH5bZE9SkX6gt6yeyKdYPv+U='; \ |
| 35 | img-src 'self' data:; frame-ancestors 'none'; base-uri 'none'; form-action 'self'" |
| 36 | |
| 37 | let respond ?(headers = []) status body = { status; headers; body } |
| 38 | let text ?(headers = []) status body = |
| 39 | respond status body ~headers:(("content-type", "text/plain; charset=utf-8") :: headers) |
| 40 | |
| 41 | let html ?(headers = []) status body = |
| 42 | respond status body |
| 43 | ~headers: |
| 44 | ([ ("content-type", "text/html; charset=utf-8"); |
| 45 | ("cache-control", "private, no-cache"); |
| 46 | ("content-security-policy", csp); |
| 47 | ("x-content-type-options", "nosniff"); |
| 48 | ("referrer-policy", "same-origin") ] |
| 49 | @ headers) |
| 50 | |
| 51 | let is_token s = |
| 52 | String.length s = 32 && String.for_all (function '0' .. '9' | 'a' .. 'f' -> true | _ -> false) s |
| 53 | |
| 54 | (* The caller's list id. An unknown or garbled cookie gets a fresh list, |
| 55 | and the response sets the cookie for it. *) |
| 56 | let visitor t req = |
| 57 | let known = |
| 58 | Option.bind (req.header "cookie") (fun h -> Form.cookie h cookie_name) |
| 59 | |> Option.map String.trim |
| 60 | |> Option.to_list |
| 61 | |> List.find_opt (fun id -> is_token id && Store.list_exists t.store id) |
| 62 | in |
| 63 | match known with |
| 64 | | Some id -> (id, []) |
| 65 | | None -> |
| 66 | let id = Rand.token () in |
| 67 | Store.create_list t.store id; |
| 68 | let secure = String.starts_with ~prefix:"https:" t.origin in |
| 69 | ( id, |
| 70 | [ ( "set-cookie", |
| 71 | Printf.sprintf "%s=%s; Max-Age=%d; Path=/; HttpOnly; SameSite=Lax%s" cookie_name id |
| 72 | cookie_max_age (if secure then "; Secure" else "") ) ] ) |
| 73 | |
| 74 | let static name = |
| 75 | let asset body ctype = |
| 76 | respond 200 body |
| 77 | ~headers:[ ("content-type", ctype); ("cache-control", "public, max-age=86400"); |
| 78 | ("x-content-type-options", "nosniff") ] |
| 79 | in |
| 80 | match name with |
| 81 | | "base.css" -> Some (asset Assets.base_css "text/css; charset=utf-8") |
| 82 | | "index.css" -> Some (asset Assets.index_css "text/css; charset=utf-8") |
| 83 | | "app.css" -> Some (asset Assets.app_css "text/css; charset=utf-8") |
| 84 | | "app.js" -> Some (asset Assets.app_js "text/javascript; charset=utf-8") |
| 85 | | _ -> None |
| 86 | |
| 87 | (* GET /, /active and /completed. *) |
| 88 | let page t req filter = |
| 89 | let list, cookie = visitor t req in |
| 90 | let editing = Option.bind (List.assoc_opt "edit" req.query) int_of_string_opt in |
| 91 | html 200 ~headers:cookie (View.page ~version:t.version ~filter ?editing (Store.todos t.store ~list)) |
| 92 | |
| 93 | type action = |
| 94 | | Add |
| 95 | | Toggle_all |
| 96 | | Clear_completed |
| 97 | | Toggle of int |
| 98 | | Edit of int |
| 99 | | Destroy of int |
| 100 | |
| 101 | let action_of_path path = |
| 102 | let id s = |
| 103 | if s <> "" && String.for_all (function '0' .. '9' -> true | _ -> false) s then int_of_string_opt s |
| 104 | else None |
| 105 | in |
| 106 | match String.split_on_char '/' path with |
| 107 | | [ ""; "todos" ] -> Some Add |
| 108 | | [ ""; "todos"; "toggle-all" ] -> Some Toggle_all |
| 109 | | [ ""; "todos"; "clear-completed" ] -> Some Clear_completed |
| 110 | | [ ""; "todos"; n; verb ] -> ( |
| 111 | match (id n, verb) with |
| 112 | | Some n, "toggle" -> Some (Toggle n) |
| 113 | | Some n, "edit" -> Some (Edit n) |
| 114 | | Some n, "destroy" -> Some (Destroy n) |
| 115 | | _ -> None) |
| 116 | | _ -> None |
| 117 | |
| 118 | let perform store ~list fields = function |
| 119 | | Add -> |
| 120 | let title = Form.trim (Option.value ~default:"" (List.assoc_opt "title" fields)) in |
| 121 | if title <> "" then Store.add store ~list title; |
| 122 | true |
| 123 | | Toggle_all -> Store.toggle_all store ~list; true |
| 124 | | Clear_completed -> Store.clear_completed store ~list; true |
| 125 | | Toggle id -> Store.toggle store ~list id |
| 126 | | Destroy id -> Store.delete store ~list id |
| 127 | | Edit id -> ( |
| 128 | match Form.trim (Option.value ~default:"" (List.assoc_opt "title" fields)) with |
| 129 | | "" -> Store.delete store ~list id |
| 130 | | title -> Store.rename store ~list id title) |
| 131 | |
| 132 | (* Every action is a form POST answering 303 back to the filter. With |
| 133 | X-Fragment: todoapp (sent by app.js) it answers section.todoapp instead. *) |
| 134 | let post t req action = |
| 135 | match req.header "origin" with |
| 136 | | Some o when o <> t.origin -> text 403 "Cross-origin request refused\n" |
| 137 | | _ when not (String.is_valid_utf_8 req.body) -> text 400 "Bad form body\n" |
| 138 | | _ -> |
| 139 | let fields = Form.parse req.body in |
| 140 | if not (List.for_all (fun (_, v) -> String.is_valid_utf_8 v) fields) then text 400 "Bad form body\n" |
| 141 | else |
| 142 | let list, cookie = visitor t req in |
| 143 | let filter = View.filter_of_string (Option.value ~default:"" (List.assoc_opt "filter" fields)) in |
| 144 | if not (perform t.store ~list fields action) then text 404 ~headers:cookie "No such todo\n" |
| 145 | else if req.header "x-fragment" = Some "todoapp" then |
| 146 | html 200 ~headers:cookie (View.fragment ~filter (Store.todos t.store ~list)) |
| 147 | else respond 303 "" ~headers:(("location", View.filter_path filter) :: cookie) |
| 148 | |
| 149 | let handle t req = |
| 150 | let filter = function |
| 151 | | "/" -> Some View.All |
| 152 | | "/active" -> Some View.Active |
| 153 | | "/completed" -> Some View.Completed |
| 154 | | _ -> None |
| 155 | in |
| 156 | match (req.meth, req.path) with |
| 157 | | ("GET" | "HEAD"), "/healthz" -> text 200 "ok\n" |
| 158 | | ("GET" | "HEAD"), "/api/version" -> text 200 t.version |
| 159 | | ("GET" | "HEAD"), p when String.starts_with ~prefix:"/static/" p -> ( |
| 160 | match static (String.sub p 8 (String.length p - 8)) with |
| 161 | | Some r -> r |
| 162 | | None -> text 404 "Not found\n") |
| 163 | | ("GET" | "HEAD"), p when filter p <> None -> page t req (Option.get (filter p)) |
| 164 | | "POST", p when action_of_path p <> None -> post t req (Option.get (action_of_path p)) |
| 165 | | _, p when filter p <> None || action_of_path p <> None -> |
| 166 | text 405 "Method not allowed\n" ~headers:[ ("allow", if filter p <> None then "GET, HEAD" else "POST") ] |
| 167 | | _ -> text 404 "Not found\n" |
| 168 | |
amadan