ocaml http/1, http/2 and websocket client and server library
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

feat: add LAS (Link Aggregator Service) tutorial application

- Complete tutorial app showcasing HCS features
- Content negotiation (JSON/HTML from same endpoints)
- Session-based authentication with CSRF protection
- Real-time updates via WebSocket pub/sub
- SQLite3 database with direct bindings
- Pure-html templates with form handling
- Rate limiting and compression plugs

Fixed type compatibility:
- Updated handlers to use Server.request/response (not H1_server types)
- Fixed pure-html method_ attribute to use polymorphic variants
- Implemented form URL encoding parser
- All components now work with Endpoint API

Files: bin/las/{las,routes,handlers,auth,db,models,views,realtime}.ml + README + dune

+1876
+822
bin/las/README.md
··· 1 + # Building a Link Aggregator Service with HCS 2 + 3 + This tutorial walks through building a Reddit/Hacker News-style link aggregator using the HCS HTTP library. We'll showcase HCS's key features: 4 + 5 + - **Content Negotiation**: Same endpoints return JSON or HTML based on Accept header 6 + - **Session Management**: Cookie-based sessions with fiber-local storage 7 + - **CSRF Protection**: Double-submit cookie pattern for form security 8 + - **Rate Limiting**: Protect against abuse 9 + - **WebSocket Pub/Sub**: Real-time vote updates 10 + - **Compression**: Automatic gzip/zstd compression 11 + - **Router**: Type-safe path parameters 12 + - **Endpoint**: Pluggable middleware composition 13 + 14 + ## Architecture 15 + 16 + ``` 17 + bin/las/ 18 + ├── las.ml # Main entry point 19 + ├── routes.ml # Route definitions 20 + ├── handlers.ml # Request handlers 21 + ├── views.ml # HTML templates 22 + ├── models.ml # Data types 23 + ├── db.ml # Database (Caqti + SQLite) 24 + ├── auth.ml # Authentication logic 25 + ├── realtime.ml # WebSocket/Pubsub for live updates 26 + └── dune 27 + ``` 28 + 29 + ## Prerequisites 30 + 31 + Add to your `dune` file: 32 + ```lisp 33 + (executable 34 + (name las) 35 + (public_name las) 36 + (libraries hcs caqti caqti-driver-sqlite3 caqti-eio yojson)) 37 + ``` 38 + 39 + ## Part 1: Project Setup 40 + 41 + ### 1.1 Main Entry Point 42 + 43 + ```ocaml 44 + (* las.ml *) 45 + open Hcs 46 + 47 + let () = 48 + Eio_main.run @@ fun env -> 49 + let clock = Eio.Stdenv.clock env in 50 + let store = Plug.Session.Memory_store.create () in 51 + 52 + (* Build the plug pipeline *) 53 + let endpoint = 54 + Endpoint.create 55 + { Endpoint.default_config with 56 + port = 8080; 57 + secret_key_base = Sys.getenv_opt "SECRET_KEY" |> Option.value ~default:"dev-secret-32-chars-minimum!!!"; 58 + } 59 + |> Endpoint.plug (Plug.Logger.create ~clock (fun _ _ -> ())) 60 + |> Endpoint.plug (Plug.Compress.create ()) 61 + |> Endpoint.plug (Plug.Session.create ~store ()) 62 + |> Endpoint.plug (Plug.Csrf.create ()) 63 + |> Endpoint.plug (Plug.Rate_limit.create 64 + ~clock 65 + ~key:(fun req -> 66 + (* Rate limit by session or IP *) 67 + match Plug.Session.get "user_id" with 68 + | Some uid -> uid 69 + | None -> List.assoc_opt "x-forwarded-for" req.headers 70 + |> Option.value ~default:"anonymous") 71 + ~requests:100 72 + ~per:60.0) 73 + |> Endpoint.router Routes.router 74 + |> Endpoint.websocket Realtime.ws_handler 75 + in 76 + 77 + Endpoint.start endpoint ~env 78 + ``` 79 + 80 + ### 1.2 Data Models 81 + 82 + ```ocaml 83 + (* models.ml *) 84 + 85 + type user = { 86 + id: int; 87 + username: string; 88 + password_hash: string; 89 + created_at: float; 90 + } 91 + 92 + type link = { 93 + id: int; 94 + url: string; 95 + title: string; 96 + submitted_by: int; (* user.id *) 97 + score: int; 98 + comment_count: int; 99 + created_at: float; 100 + } 101 + 102 + type vote = { 103 + user_id: int; 104 + link_id: int; 105 + direction: [ `Up | `Down ]; 106 + } 107 + 108 + type comment = { 109 + id: int; 110 + link_id: int; 111 + user_id: int; 112 + parent_id: int option; (* None = top-level *) 113 + body: string; 114 + created_at: float; 115 + } 116 + 117 + (* JSON serialization *) 118 + let link_to_json link = 119 + Printf.sprintf 120 + {|{"id":%d,"url":"%s","title":"%s","score":%d,"comment_count":%d,"created_at":%.0f}|} 121 + link.id 122 + (String.escaped link.url) 123 + (String.escaped link.title) 124 + link.score 125 + link.comment_count 126 + link.created_at 127 + 128 + let links_to_json links = 129 + "[" ^ String.concat "," (List.map link_to_json links) ^ "]" 130 + ``` 131 + 132 + ## Part 2: Database Layer 133 + 134 + ### 2.1 Schema 135 + 136 + ```sql 137 + -- schema.sql 138 + CREATE TABLE IF NOT EXISTS users ( 139 + id INTEGER PRIMARY KEY AUTOINCREMENT, 140 + username TEXT UNIQUE NOT NULL, 141 + password_hash TEXT NOT NULL, 142 + created_at REAL NOT NULL DEFAULT (unixepoch()) 143 + ); 144 + 145 + CREATE TABLE IF NOT EXISTS links ( 146 + id INTEGER PRIMARY KEY AUTOINCREMENT, 147 + url TEXT NOT NULL, 148 + title TEXT NOT NULL, 149 + submitted_by INTEGER NOT NULL REFERENCES users(id), 150 + score INTEGER NOT NULL DEFAULT 0, 151 + comment_count INTEGER NOT NULL DEFAULT 0, 152 + created_at REAL NOT NULL DEFAULT (unixepoch()) 153 + ); 154 + 155 + CREATE TABLE IF NOT EXISTS votes ( 156 + user_id INTEGER NOT NULL REFERENCES users(id), 157 + link_id INTEGER NOT NULL REFERENCES links(id), 158 + direction INTEGER NOT NULL, -- 1 = up, -1 = down 159 + PRIMARY KEY (user_id, link_id) 160 + ); 161 + 162 + CREATE TABLE IF NOT EXISTS comments ( 163 + id INTEGER PRIMARY KEY AUTOINCREMENT, 164 + link_id INTEGER NOT NULL REFERENCES links(id), 165 + user_id INTEGER NOT NULL REFERENCES users(id), 166 + parent_id INTEGER REFERENCES comments(id), 167 + body TEXT NOT NULL, 168 + created_at REAL NOT NULL DEFAULT (unixepoch()) 169 + ); 170 + 171 + CREATE INDEX IF NOT EXISTS idx_links_score ON links(score DESC); 172 + CREATE INDEX IF NOT EXISTS idx_links_created ON links(created_at DESC); 173 + CREATE INDEX IF NOT EXISTS idx_comments_link ON comments(link_id); 174 + ``` 175 + 176 + ### 2.2 Caqti Integration 177 + 178 + ```ocaml 179 + (* db.ml *) 180 + open Caqti_request.Infix 181 + open Caqti_type.Std 182 + 183 + (* Connection pool *) 184 + let pool_ref : (Caqti_eio.connection, Caqti_error.t) Caqti_eio.Pool.t option ref = ref None 185 + 186 + let init ~sw ~stdenv db_path = 187 + let uri = Uri.of_string ("sqlite3://" ^ db_path) in 188 + match Caqti_eio_unix.connect_pool ~sw ~stdenv uri with 189 + | Ok pool -> pool_ref := Some pool; Ok () 190 + | Error e -> Error (Caqti_error.show e) 191 + 192 + let use f = 193 + match !pool_ref with 194 + | None -> Error "Database not initialized" 195 + | Some pool -> 196 + match Caqti_eio.Pool.use f pool with 197 + | Ok x -> Ok x 198 + | Error e -> Error (Caqti_error.show e) 199 + 200 + (* Queries *) 201 + module Q = struct 202 + let list_links_by_score = 203 + (int ->* tup4 int string string int) 204 + "SELECT id, url, title, score FROM links ORDER BY score DESC LIMIT ?" 205 + 206 + let list_links_by_new = 207 + (int ->* tup4 int string string int) 208 + "SELECT id, url, title, score FROM links ORDER BY created_at DESC LIMIT ?" 209 + 210 + let get_link = 211 + (int ->? tup4 int string string int) 212 + "SELECT id, url, title, score FROM links WHERE id = ?" 213 + 214 + let insert_link = 215 + (tup3 string string int ->. unit) 216 + "INSERT INTO links (url, title, submitted_by) VALUES (?, ?, ?)" 217 + 218 + let vote = 219 + (tup3 int int int ->. unit) 220 + "INSERT OR REPLACE INTO votes (user_id, link_id, direction) VALUES (?, ?, ?)" 221 + 222 + let update_score = 223 + (int ->. unit) 224 + {|UPDATE links SET score = ( 225 + SELECT COALESCE(SUM(direction), 0) FROM votes WHERE link_id = links.id 226 + ) WHERE id = ?|} 227 + 228 + let get_user_vote = 229 + (tup2 int int ->? int) 230 + "SELECT direction FROM votes WHERE user_id = ? AND link_id = ?" 231 + 232 + let get_user_by_username = 233 + (string ->? tup3 int string string) 234 + "SELECT id, username, password_hash FROM users WHERE username = ?" 235 + 236 + let insert_user = 237 + (tup2 string string ->. unit) 238 + "INSERT INTO users (username, password_hash) VALUES (?, ?)" 239 + end 240 + 241 + (* Public API *) 242 + let list_links ?(sort=`Score) ?(limit=50) () = 243 + let query = match sort with 244 + | `Score -> Q.list_links_by_score 245 + | `New -> Q.list_links_by_new 246 + in 247 + use (fun (module Db : Caqti_eio.CONNECTION) -> 248 + Db.collect_list query limit) 249 + 250 + let get_link id = 251 + use (fun (module Db : Caqti_eio.CONNECTION) -> 252 + Db.find_opt Q.get_link id) 253 + 254 + let submit_link ~url ~title ~user_id = 255 + use (fun (module Db : Caqti_eio.CONNECTION) -> 256 + Db.exec Q.insert_link (url, title, user_id)) 257 + 258 + let vote ~user_id ~link_id ~direction = 259 + let dir = match direction with `Up -> 1 | `Down -> -1 in 260 + use (fun (module Db : Caqti_eio.CONNECTION) -> 261 + let* () = Db.exec Q.vote (user_id, link_id, dir) in 262 + Db.exec Q.update_score link_id) 263 + 264 + let get_user_vote ~user_id ~link_id = 265 + use (fun (module Db : Caqti_eio.CONNECTION) -> 266 + Db.find_opt Q.get_user_vote (user_id, link_id)) 267 + ``` 268 + 269 + ## Part 3: Content Negotiation 270 + 271 + HCS's `Plug.Negotiate` allows the same endpoint to return different formats based on the `Accept` header. This is perfect for building APIs that serve both browsers and API clients. 272 + 273 + ### 3.1 Setting Up Negotiation 274 + 275 + ```ocaml 276 + (* routes.ml *) 277 + open Hcs 278 + 279 + (* Content negotiation plug - applied per-route or globally *) 280 + let negotiate_json_html = 281 + Plug.Negotiate.create ~formats:[Json; Html] () 282 + 283 + let router = Router.compile [ 284 + (* Index: GET / *) 285 + Router.Route.get "/" (fun _params req -> 286 + (* Negotiate plug sets format on request *) 287 + let req = Plug.Core.apply negotiate_json_html (fun r -> r) req in 288 + Handlers.index req); 289 + 290 + (* Show link: GET /links/:id *) 291 + Router.Route.get "/links/:id" (fun params req -> 292 + let req = Plug.Core.apply negotiate_json_html (fun r -> r) req in 293 + Handlers.show_link params req); 294 + 295 + (* Submit form: GET /submit (HTML only) *) 296 + Router.Route.get "/submit" (fun _params req -> 297 + Handlers.submit_form req); 298 + 299 + (* Submit link: POST /links *) 300 + Router.Route.post "/links" (fun _params req -> 301 + Handlers.create_link req); 302 + 303 + (* Vote: POST /links/:id/vote *) 304 + Router.Route.post "/links/:id/vote" (fun params req -> 305 + Handlers.vote params req); 306 + ] 307 + ``` 308 + 309 + ### 3.2 Responding with Negotiated Content 310 + 311 + ```ocaml 312 + (* handlers.ml *) 313 + open Hcs 314 + 315 + let index req = 316 + match Db.list_links ~sort:`Score () with 317 + | Error e -> Server.respond ~status:`Internal_server_error e 318 + | Ok links -> 319 + (* Use Plug.Negotiate.respond to automatically select format *) 320 + Plug.Negotiate.respond req 321 + ~json:(fun () -> Models.links_to_json links) 322 + ~html:(fun () -> Views.index_page links) 323 + () 324 + 325 + let show_link params req = 326 + let link_id = Router.param_int_or "id" ~default:0 params in 327 + match Db.get_link link_id with 328 + | Error e -> Server.respond ~status:`Internal_server_error e 329 + | Ok None -> Server.respond ~status:`Not_found "Link not found" 330 + | Ok (Some link) -> 331 + Plug.Negotiate.respond req 332 + ~json:(fun () -> Models.link_to_json link) 333 + ~html:(fun () -> Views.link_page link) 334 + () 335 + ``` 336 + 337 + ### 3.3 How It Works 338 + 339 + When a request comes in: 340 + 341 + 1. **Browser** sends `Accept: text/html,application/xhtml+xml,...` 342 + - HCS selects `Html` format 343 + - Handler returns rendered HTML page 344 + 345 + 2. **API client** sends `Accept: application/json` 346 + - HCS selects `Json` format 347 + - Handler returns JSON response 348 + 349 + 3. **curl** (no Accept header) gets `*/*` 350 + - HCS defaults to first available format (Json in our case) 351 + 352 + ```bash 353 + # Browser-like request 354 + curl -H "Accept: text/html" http://localhost:8080/ 355 + # Returns HTML page 356 + 357 + # API request 358 + curl -H "Accept: application/json" http://localhost:8080/ 359 + # Returns JSON array 360 + 361 + # Default (no Accept header) 362 + curl http://localhost:8080/ 363 + # Returns JSON (first in formats list) 364 + ``` 365 + 366 + ## Part 4: Session and Authentication 367 + 368 + ### 4.1 Session-Based Auth 369 + 370 + HCS sessions use fiber-local storage, so you can access session data from anywhere in the request handling fiber without passing the request around. 371 + 372 + ```ocaml 373 + (* auth.ml *) 374 + open Hcs 375 + 376 + let hash_password password = 377 + (* In production, use Argon2 or bcrypt *) 378 + Digestif.SHA256.(digest_string password |> to_hex) 379 + 380 + let verify_password password hash = 381 + String.equal (hash_password password) hash 382 + 383 + let current_user () = 384 + match Plug.Session.get "user_id" with 385 + | None -> None 386 + | Some uid_str -> 387 + match int_of_string_opt uid_str with 388 + | None -> None 389 + | Some uid -> Db.get_user uid |> Result.to_option |> Option.join 390 + 391 + let require_auth handler req = 392 + match current_user () with 393 + | None -> 394 + (* Redirect to login for HTML, 401 for JSON *) 395 + (match Plug.Negotiate.get_format req with 396 + | Some Html -> 397 + Server.respond ~status:`Found 398 + ~headers:[("Location", "/login")] "" 399 + | _ -> 400 + Server.respond ~status:`Unauthorized 401 + {|{"error":"authentication_required"}|}) 402 + | Some _user -> handler req 403 + 404 + let login ~username ~password = 405 + match Db.get_user_by_username username with 406 + | Error _ -> Error "Database error" 407 + | Ok None -> Error "Invalid credentials" 408 + | Ok (Some (id, _, hash)) -> 409 + if verify_password password hash then begin 410 + Plug.Session.put "user_id" (string_of_int id); 411 + Ok id 412 + end else 413 + Error "Invalid credentials" 414 + 415 + let logout () = 416 + Plug.Session.clear () 417 + ``` 418 + 419 + ### 4.2 Login Handler with CSRF 420 + 421 + ```ocaml 422 + (* handlers.ml continued *) 423 + 424 + let login_form _req = 425 + (* CSRF token is automatically set by Csrf plug on GET requests *) 426 + Server.respond_html (Views.login_page ()) 427 + 428 + let login_submit req = 429 + (* Parse form body *) 430 + let params = parse_form_body req.body in 431 + let username = List.assoc_opt "username" params |> Option.value ~default:"" in 432 + let password = List.assoc_opt "password" params |> Option.value ~default:"" in 433 + 434 + match Auth.login ~username ~password with 435 + | Ok _user_id -> 436 + Server.respond ~status:`Found 437 + ~headers:[("Location", "/")] "" 438 + | Error msg -> 439 + Server.respond_html ~status:`Unauthorized 440 + (Views.login_page ~error:msg ()) 441 + 442 + let logout_submit _req = 443 + Auth.logout (); 444 + Server.respond ~status:`Found 445 + ~headers:[("Location", "/")] "" 446 + ``` 447 + 448 + ### 4.3 CSRF Token in Forms 449 + 450 + ```ocaml 451 + (* views.ml *) 452 + 453 + let csrf_field () = 454 + (* Get token from cookie - Csrf plug sets it on safe methods *) 455 + match Plug.Session.get "_csrf" with 456 + | Some token -> 457 + Printf.sprintf {|<input type="hidden" name="_csrf" value="%s">|} token 458 + | None -> "" 459 + 460 + let login_page ?error () = 461 + Printf.sprintf {| 462 + <!DOCTYPE html> 463 + <html> 464 + <head><title>Login - Link Aggregator</title></head> 465 + <body> 466 + <h1>Login</h1> 467 + %s 468 + <form method="POST" action="/login"> 469 + %s 470 + <label>Username: <input type="text" name="username"></label><br> 471 + <label>Password: <input type="password" name="password"></label><br> 472 + <button type="submit">Login</button> 473 + </form> 474 + </body> 475 + </html>|} 476 + (match error with Some e -> Printf.sprintf {|<p style="color:red">%s</p>|} e | None -> "") 477 + (csrf_field ()) 478 + ``` 479 + 480 + ## Part 5: Real-Time Updates with WebSocket 481 + 482 + ### 5.1 Pub/Sub for Vote Updates 483 + 484 + ```ocaml 485 + (* realtime.ml *) 486 + open Hcs 487 + 488 + (* Global pubsub instance *) 489 + let pubsub = Pubsub.create () 490 + 491 + (* Broadcast vote update to all subscribers *) 492 + let broadcast_vote ~link_id ~new_score = 493 + let topic = Printf.sprintf "link:%d" link_id in 494 + let msg = Printf.sprintf {|{"type":"vote","link_id":%d,"score":%d}|} link_id new_score in 495 + Pubsub.broadcast pubsub topic msg 496 + 497 + (* WebSocket handler *) 498 + let ws_handler ws = 499 + (* Read subscription requests from client *) 500 + let rec loop () = 501 + match Websocket.recv_message ws with 502 + | Error Websocket.Connection_closed -> () 503 + | Error _ -> () 504 + | Ok (_, msg) -> 505 + (* Parse subscription request: {"subscribe":"link:123"} *) 506 + (try 507 + let json = Yojson.Safe.from_string msg in 508 + match Yojson.Safe.Util.(member "subscribe" json |> to_string_option) with 509 + | Some topic -> 510 + (* Subscribe and forward messages to WebSocket *) 511 + let _sub = Pubsub.subscribe pubsub topic (fun msg -> 512 + ignore (Websocket.send_text ws msg)) 513 + in 514 + () 515 + | None -> () 516 + with _ -> ()); 517 + loop () 518 + in 519 + loop () 520 + ``` 521 + 522 + ### 5.2 Vote Handler with Broadcast 523 + 524 + ```ocaml 525 + (* handlers.ml continued *) 526 + 527 + let vote params req = 528 + match Auth.current_user () with 529 + | None -> Server.respond ~status:`Unauthorized {|{"error":"login_required"}|} 530 + | Some user -> 531 + let link_id = Router.param_int_or "id" ~default:0 params in 532 + let direction = 533 + if String.sub req.body 0 2 = "up" then `Up else `Down 534 + in 535 + match Db.vote ~user_id:user.id ~link_id ~direction with 536 + | Error e -> Server.respond ~status:`Internal_server_error e 537 + | Ok () -> 538 + (* Get new score and broadcast *) 539 + (match Db.get_link link_id with 540 + | Ok (Some link) -> Realtime.broadcast_vote ~link_id ~new_score:link.score 541 + | _ -> ()); 542 + Server.respond_json {|{"ok":true}|} 543 + ``` 544 + 545 + ### 5.3 Client-Side WebSocket 546 + 547 + ```javascript 548 + // In your HTML template 549 + const ws = new WebSocket('ws://' + location.host + '/ws'); 550 + 551 + ws.onopen = () => { 552 + // Subscribe to updates for links on the page 553 + document.querySelectorAll('[data-link-id]').forEach(el => { 554 + ws.send(JSON.stringify({ subscribe: 'link:' + el.dataset.linkId })); 555 + }); 556 + }; 557 + 558 + ws.onmessage = (event) => { 559 + const data = JSON.parse(event.data); 560 + if (data.type === 'vote') { 561 + // Update score display 562 + const el = document.querySelector(`[data-link-id="${data.link_id}"] .score`); 563 + if (el) el.textContent = data.score; 564 + } 565 + }; 566 + ``` 567 + 568 + ## Part 6: Rate Limiting 569 + 570 + ### 6.1 Global Rate Limit 571 + 572 + Applied in the main plug pipeline (see Part 1): 573 + 574 + ```ocaml 575 + Plug.Rate_limit.create 576 + ~clock 577 + ~key:(fun req -> 578 + match Plug.Session.get "user_id" with 579 + | Some uid -> "user:" ^ uid 580 + | None -> 581 + List.assoc_opt "x-forwarded-for" req.headers 582 + |> Option.value ~default:"anon") 583 + ~requests:100 (* 100 requests *) 584 + ~per:60.0 (* per 60 seconds *) 585 + ``` 586 + 587 + ### 6.2 Stricter Limits for Specific Actions 588 + 589 + ```ocaml 590 + (* routes.ml *) 591 + 592 + (* Stricter rate limit for submissions *) 593 + let submit_rate_limit clock = 594 + Plug.Rate_limit.create 595 + ~clock 596 + ~key:(fun _req -> 597 + Plug.Session.get "user_id" |> Option.value ~default:"anon") 598 + ~requests:10 (* 10 submissions *) 599 + ~per:3600.0 (* per hour *) 600 + 601 + let router clock = Router.compile [ 602 + (* ... other routes ... *) 603 + 604 + Router.Route.post "/links" (fun _params req -> 605 + (* Apply stricter rate limit, then handler *) 606 + let handler = Auth.require_auth Handlers.create_link in 607 + Plug.Core.apply (submit_rate_limit clock) handler req); 608 + ] 609 + ``` 610 + 611 + ### 6.3 Rate Limit Headers 612 + 613 + When rate limited, HCS returns: 614 + - `429 Too Many Requests` status 615 + - `X-RateLimit-Limit`: Max requests allowed 616 + - `X-RateLimit-Remaining`: Requests remaining 617 + - `X-RateLimit-Reset`: Unix timestamp when window resets 618 + - `Retry-After`: Seconds until can retry 619 + 620 + ## Part 7: HTML Views 621 + 622 + ### 7.1 Base Layout 623 + 624 + ```ocaml 625 + (* views.ml *) 626 + 627 + let layout ~title content = 628 + Printf.sprintf {| 629 + <!DOCTYPE html> 630 + <html> 631 + <head> 632 + <meta charset="utf-8"> 633 + <meta name="viewport" content="width=device-width, initial-scale=1"> 634 + <title>%s - Link Aggregator</title> 635 + <style> 636 + body { font-family: system-ui, sans-serif; max-width: 800px; margin: 0 auto; padding: 1rem; } 637 + .link { margin: 1rem 0; padding: 0.5rem; border: 1px solid #ddd; border-radius: 4px; } 638 + .link-title { font-size: 1.1rem; font-weight: bold; } 639 + .link-meta { color: #666; font-size: 0.9rem; } 640 + .score { font-weight: bold; color: #f60; } 641 + .vote-btn { cursor: pointer; padding: 0.25rem 0.5rem; } 642 + nav { margin-bottom: 1rem; padding-bottom: 0.5rem; border-bottom: 1px solid #ddd; } 643 + nav a { margin-right: 1rem; } 644 + </style> 645 + </head> 646 + <body> 647 + <nav> 648 + <a href="/">Home</a> 649 + <a href="/?sort=new">New</a> 650 + <a href="/submit">Submit</a> 651 + %s 652 + </nav> 653 + %s 654 + <script> 655 + // WebSocket for live updates 656 + const ws = new WebSocket('ws://' + location.host + '/ws'); 657 + ws.onopen = () => { 658 + document.querySelectorAll('[data-link-id]').forEach(el => { 659 + ws.send(JSON.stringify({ subscribe: 'link:' + el.dataset.linkId })); 660 + }); 661 + }; 662 + ws.onmessage = (e) => { 663 + const d = JSON.parse(e.data); 664 + if (d.type === 'vote') { 665 + const el = document.querySelector('[data-link-id="' + d.link_id + '"] .score'); 666 + if (el) el.textContent = d.score; 667 + } 668 + }; 669 + </script> 670 + </body> 671 + </html>|} 672 + title 673 + (match Plug.Session.get "user_id" with 674 + | Some _ -> {|<a href="/logout">Logout</a>|} 675 + | None -> {|<a href="/login">Login</a> <a href="/register">Register</a>|}) 676 + content 677 + ``` 678 + 679 + ### 7.2 Link List 680 + 681 + ```ocaml 682 + let link_item link = 683 + Printf.sprintf {| 684 + <div class="link" data-link-id="%d"> 685 + <div class="link-title"> 686 + <a href="%s" target="_blank">%s</a> 687 + </div> 688 + <div class="link-meta"> 689 + <span class="score">%d points</span> | 690 + <a href="/links/%d">%d comments</a> 691 + %s 692 + </div> 693 + </div>|} 694 + link.id 695 + link.url 696 + link.title 697 + link.score 698 + link.id 699 + link.comment_count 700 + (if Plug.Session.get "user_id" |> Option.is_some then 701 + Printf.sprintf {| 702 + | <button class="vote-btn" onclick="vote(%d, 'up')">+</button> 703 + <button class="vote-btn" onclick="vote(%d, 'down')">-</button>|} 704 + link.id link.id 705 + else "") 706 + 707 + let index_page links = 708 + let content = 709 + if links = [] then "<p>No links yet. <a href=\"/submit\">Submit one!</a></p>" 710 + else String.concat "\n" (List.map link_item links) 711 + in 712 + layout ~title:"Home" content 713 + ``` 714 + 715 + ## Part 8: Complete Route Map 716 + 717 + ```ocaml 718 + (* routes.ml - complete version *) 719 + open Hcs 720 + 721 + let negotiate = Plug.Negotiate.create ~formats:[Json; Html] () 722 + 723 + let router clock = 724 + let submit_limiter = Plug.Rate_limit.create ~clock 725 + ~key:(fun _ -> Plug.Session.get "user_id" |> Option.value ~default:"anon") 726 + ~requests:10 ~per:3600.0 727 + in 728 + 729 + Router.compile [ 730 + (* Public - negotiated *) 731 + Router.Route.get "/" (Handlers.index ~negotiate); 732 + Router.Route.get "/links/:id" (Handlers.show_link ~negotiate); 733 + Router.Route.get "/new" (Handlers.index_new ~negotiate); 734 + 735 + (* Auth - HTML only *) 736 + Router.Route.get "/login" Handlers.login_form; 737 + Router.Route.post "/login" Handlers.login_submit; 738 + Router.Route.get "/register" Handlers.register_form; 739 + Router.Route.post "/register" Handlers.register_submit; 740 + Router.Route.post "/logout" Handlers.logout_submit; 741 + 742 + (* Protected - require auth *) 743 + Router.Route.get "/submit" (Auth.require_auth Handlers.submit_form); 744 + Router.Route.post "/links" (fun params req -> 745 + Plug.Core.apply submit_limiter 746 + (Auth.require_auth (Handlers.create_link params)) req); 747 + 748 + (* Voting - JSON only, require auth *) 749 + Router.Route.post "/links/:id/vote" (Auth.require_auth Handlers.vote); 750 + 751 + (* Comments *) 752 + Router.Route.get "/links/:id/comments" (Handlers.comments ~negotiate); 753 + Router.Route.post "/links/:id/comments" (Auth.require_auth Handlers.create_comment); 754 + ] 755 + ``` 756 + 757 + ## Part 9: Running the Application 758 + 759 + ### 9.1 Development 760 + 761 + ```bash 762 + # Set environment 763 + export SECRET_KEY="your-secret-key-at-least-32-chars" 764 + export DATABASE_PATH="las.db" 765 + 766 + # Build and run 767 + dune build 768 + dune exec -- las 769 + 770 + # Server starts on http://localhost:8080 771 + ``` 772 + 773 + ### 9.2 Testing Content Negotiation 774 + 775 + ```bash 776 + # Get HTML (browser simulation) 777 + curl -H "Accept: text/html" http://localhost:8080/ 778 + 779 + # Get JSON (API) 780 + curl -H "Accept: application/json" http://localhost:8080/ 781 + 782 + # Submit a link (requires session cookie) 783 + curl -X POST http://localhost:8080/links \ 784 + -H "Content-Type: application/x-www-form-urlencoded" \ 785 + -H "X-CSRF-Token: $TOKEN" \ 786 + -b "session=$COOKIE" \ 787 + -d "url=https://example.com&title=Example" 788 + 789 + # Vote 790 + curl -X POST http://localhost:8080/links/1/vote \ 791 + -H "Content-Type: application/json" \ 792 + -b "session=$COOKIE" \ 793 + -d '{"direction":"up"}' 794 + ``` 795 + 796 + ### 9.3 WebSocket Testing 797 + 798 + ```bash 799 + # Using websocat 800 + websocat ws://localhost:8080/ws 801 + > {"subscribe":"link:1"} 802 + # Now you'll receive vote updates for link 1 803 + ``` 804 + 805 + ## Summary 806 + 807 + This tutorial demonstrated HCS's key features: 808 + 809 + | Feature | HCS Module | Usage | 810 + |---------|------------|-------| 811 + | Content Negotiation | `Plug.Negotiate` | Same endpoint, JSON or HTML based on Accept | 812 + | Sessions | `Plug.Session` | Fiber-local storage, memory or cookie backend | 813 + | CSRF Protection | `Plug.Csrf` | Double-submit cookie, automatic on forms | 814 + | Rate Limiting | `Plug.Rate_limit` | Token bucket, per-key limits | 815 + | Compression | `Plug.Compress` | Auto gzip/zstd based on Accept-Encoding | 816 + | Logging | `Plug.Logger` | Request/response logging | 817 + | Routing | `Router` | Radix trie, path params, type-safe | 818 + | WebSocket | `Websocket` | Full RFC 6455, upgrade from HTTP | 819 + | Pub/Sub | `Pubsub` | Topic-based messaging | 820 + | Endpoint | `Endpoint` | Plug composition, server bootstrap | 821 + 822 + The combination of content negotiation with session management, CSRF protection, and real-time updates creates a modern web application architecture that serves both traditional browsers and API clients from the same codebase.
+42
bin/las/auth.ml
··· 1 + let hash_password password = Digestif.SHA256.(digest_string password |> to_hex) 2 + let verify_password password hash = String.equal (hash_password password) hash 3 + 4 + let current_user_id () = 5 + Hcs.Plug.Session.get "user_id" |> Option.map int_of_string 6 + 7 + let current_user () = 8 + match current_user_id () with 9 + | None -> None 10 + | Some uid -> ( 11 + match Db.get_user uid with Ok user -> user | Error _ -> None) 12 + 13 + let login ~username ~password = 14 + match Db.get_user_by_username username with 15 + | Error _ -> Error "Database error" 16 + | Ok None -> Error "Invalid credentials" 17 + | Ok (Some user) -> 18 + if verify_password password user.password_hash then ( 19 + Hcs.Plug.Session.put "user_id" (string_of_int user.id); 20 + Ok user.id) 21 + else Error "Invalid credentials" 22 + 23 + let register ~username ~password = 24 + if String.length username < 3 then 25 + Error "Username must be at least 3 characters" 26 + else if String.length password < 6 then 27 + Error "Password must be at least 6 characters" 28 + else 29 + let password_hash = hash_password password in 30 + match Db.create_user ~username ~password_hash with 31 + | Ok user_id -> 32 + Hcs.Plug.Session.put "user_id" (string_of_int user_id); 33 + Ok user_id 34 + | Error _ -> Error "Username already taken" 35 + 36 + let logout () = Hcs.Plug.Session.clear () 37 + 38 + let require_auth handler (req : Hcs.Server.request) = 39 + match current_user_id () with 40 + | None -> 41 + Hcs.Server.respond ~status:`Found ~headers:[ ("Location", "/login") ] "" 42 + | Some _ -> handler req
+314
bin/las/db.ml
··· 1 + let db_ref : Sqlite3.db option ref = ref None 2 + 3 + let schema = 4 + {| 5 + CREATE TABLE IF NOT EXISTS users ( 6 + id INTEGER PRIMARY KEY AUTOINCREMENT, 7 + username TEXT UNIQUE NOT NULL, 8 + password_hash TEXT NOT NULL, 9 + created_at REAL NOT NULL DEFAULT (unixepoch()) 10 + ); 11 + CREATE TABLE IF NOT EXISTS links ( 12 + id INTEGER PRIMARY KEY AUTOINCREMENT, 13 + url TEXT NOT NULL, 14 + title TEXT NOT NULL, 15 + submitted_by INTEGER NOT NULL REFERENCES users(id), 16 + score INTEGER NOT NULL DEFAULT 0, 17 + comment_count INTEGER NOT NULL DEFAULT 0, 18 + created_at REAL NOT NULL DEFAULT (unixepoch()) 19 + ); 20 + CREATE TABLE IF NOT EXISTS votes ( 21 + user_id INTEGER NOT NULL REFERENCES users(id), 22 + link_id INTEGER NOT NULL REFERENCES links(id), 23 + direction INTEGER NOT NULL, 24 + PRIMARY KEY (user_id, link_id) 25 + ); 26 + CREATE TABLE IF NOT EXISTS comments ( 27 + id INTEGER PRIMARY KEY AUTOINCREMENT, 28 + link_id INTEGER NOT NULL REFERENCES links(id), 29 + user_id INTEGER NOT NULL REFERENCES users(id), 30 + parent_id INTEGER REFERENCES comments(id), 31 + body TEXT NOT NULL, 32 + created_at REAL NOT NULL DEFAULT (unixepoch()) 33 + ); 34 + CREATE INDEX IF NOT EXISTS idx_links_score ON links(score DESC); 35 + CREATE INDEX IF NOT EXISTS idx_links_created ON links(created_at DESC); 36 + CREATE INDEX IF NOT EXISTS idx_comments_link ON comments(link_id); 37 + |} 38 + 39 + let init db_path = 40 + let db = Sqlite3.db_open db_path in 41 + db_ref := Some db; 42 + let statements = 43 + String.split_on_char ';' schema 44 + |> List.map String.trim 45 + |> List.filter (fun s -> String.length s > 0) 46 + in 47 + let rec exec_all = function 48 + | [] -> Ok () 49 + | stmt :: rest -> ( 50 + match Sqlite3.exec db stmt with 51 + | Sqlite3.Rc.OK -> exec_all rest 52 + | rc -> Error (Sqlite3.Rc.to_string rc)) 53 + in 54 + exec_all statements 55 + 56 + let close () = 57 + match !db_ref with 58 + | Some db -> 59 + ignore (Sqlite3.db_close db); 60 + db_ref := None 61 + | None -> () 62 + 63 + let use f = 64 + match !db_ref with 65 + | None -> Error "Database not initialized" 66 + | Some db -> f db 67 + 68 + let get_int data idx = 69 + match data.(idx) with 70 + | Sqlite3.Data.INT i -> Int64.to_int i 71 + | Sqlite3.Data.TEXT s -> int_of_string s 72 + | _ -> 0 73 + 74 + let get_string data idx = 75 + match data.(idx) with Sqlite3.Data.TEXT s -> s | _ -> "" 76 + 77 + let get_float data idx = 78 + match data.(idx) with 79 + | Sqlite3.Data.FLOAT f -> f 80 + | Sqlite3.Data.INT i -> Int64.to_float i 81 + | _ -> 0.0 82 + 83 + let get_int_opt data idx = 84 + match data.(idx) with 85 + | Sqlite3.Data.INT i -> Some (Int64.to_int i) 86 + | Sqlite3.Data.NULL -> None 87 + | _ -> None 88 + 89 + let row_to_link data = 90 + Models. 91 + { 92 + id = get_int data 0; 93 + url = get_string data 1; 94 + title = get_string data 2; 95 + submitted_by = get_int data 3; 96 + score = get_int data 4; 97 + comment_count = get_int data 5; 98 + created_at = get_float data 6; 99 + } 100 + 101 + let row_to_user data = 102 + Models. 103 + { 104 + id = get_int data 0; 105 + username = get_string data 1; 106 + password_hash = get_string data 2; 107 + created_at = get_float data 3; 108 + } 109 + 110 + let row_to_comment data = 111 + Models. 112 + { 113 + id = get_int data 0; 114 + link_id = get_int data 1; 115 + user_id = get_int data 2; 116 + parent_id = get_int_opt data 3; 117 + body = get_string data 4; 118 + created_at = get_float data 5; 119 + } 120 + 121 + let collect_rows stmt convert = 122 + let rec loop acc = 123 + match Sqlite3.step stmt with 124 + | Sqlite3.Rc.ROW -> 125 + let data = Sqlite3.row_data stmt in 126 + loop (convert data :: acc) 127 + | Sqlite3.Rc.DONE -> List.rev acc 128 + | rc -> failwith (Sqlite3.Rc.to_string rc) 129 + in 130 + loop [] 131 + 132 + let find_one stmt convert = 133 + match Sqlite3.step stmt with 134 + | Sqlite3.Rc.ROW -> 135 + let data = Sqlite3.row_data stmt in 136 + Some (convert data) 137 + | Sqlite3.Rc.DONE -> None 138 + | rc -> failwith (Sqlite3.Rc.to_string rc) 139 + 140 + type sort = Score | New 141 + 142 + let list_links ?(sort = Score) ?(limit = 50) () = 143 + use (fun db -> 144 + let sql = 145 + match sort with 146 + | Score -> 147 + "SELECT id, url, title, submitted_by, score, comment_count, \ 148 + created_at FROM links ORDER BY score DESC LIMIT ?" 149 + | New -> 150 + "SELECT id, url, title, submitted_by, score, comment_count, \ 151 + created_at FROM links ORDER BY created_at DESC LIMIT ?" 152 + in 153 + let stmt = Sqlite3.prepare db sql in 154 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.INT (Int64.of_int limit))); 155 + let result = collect_rows stmt row_to_link in 156 + ignore (Sqlite3.finalize stmt); 157 + Ok result) 158 + 159 + let get_link id = 160 + use (fun db -> 161 + let sql = 162 + "SELECT id, url, title, submitted_by, score, comment_count, created_at \ 163 + FROM links WHERE id = ?" 164 + in 165 + let stmt = Sqlite3.prepare db sql in 166 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.INT (Int64.of_int id))); 167 + let result = find_one stmt row_to_link in 168 + ignore (Sqlite3.finalize stmt); 169 + Ok result) 170 + 171 + let submit_link ~url ~title ~user_id = 172 + use (fun db -> 173 + let sql = 174 + "INSERT INTO links (url, title, submitted_by) VALUES (?, ?, ?)" 175 + in 176 + let stmt = Sqlite3.prepare db sql in 177 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT url)); 178 + ignore (Sqlite3.bind stmt 2 (Sqlite3.Data.TEXT title)); 179 + ignore (Sqlite3.bind stmt 3 (Sqlite3.Data.INT (Int64.of_int user_id))); 180 + match Sqlite3.step stmt with 181 + | Sqlite3.Rc.DONE -> 182 + ignore (Sqlite3.finalize stmt); 183 + Ok (Int64.to_int (Sqlite3.last_insert_rowid db)) 184 + | rc -> 185 + ignore (Sqlite3.finalize stmt); 186 + Error (Sqlite3.Rc.to_string rc)) 187 + 188 + let vote ~user_id ~link_id ~direction = 189 + let dir = Models.direction_to_int direction in 190 + use (fun db -> 191 + let sql = 192 + "INSERT OR REPLACE INTO votes (user_id, link_id, direction) VALUES (?, \ 193 + ?, ?)" 194 + in 195 + let stmt = Sqlite3.prepare db sql in 196 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.INT (Int64.of_int user_id))); 197 + ignore (Sqlite3.bind stmt 2 (Sqlite3.Data.INT (Int64.of_int link_id))); 198 + ignore (Sqlite3.bind stmt 3 (Sqlite3.Data.INT (Int64.of_int dir))); 199 + (match Sqlite3.step stmt with 200 + | Sqlite3.Rc.DONE -> () 201 + | rc -> failwith (Sqlite3.Rc.to_string rc)); 202 + ignore (Sqlite3.finalize stmt); 203 + 204 + let sql2 = 205 + "UPDATE links SET score = (SELECT COALESCE(SUM(direction), 0) FROM \ 206 + votes WHERE link_id = links.id) WHERE id = ?" 207 + in 208 + let stmt2 = Sqlite3.prepare db sql2 in 209 + ignore (Sqlite3.bind stmt2 1 (Sqlite3.Data.INT (Int64.of_int link_id))); 210 + (match Sqlite3.step stmt2 with 211 + | Sqlite3.Rc.DONE -> () 212 + | rc -> failwith (Sqlite3.Rc.to_string rc)); 213 + ignore (Sqlite3.finalize stmt2); 214 + Ok ()) 215 + 216 + let get_user_vote ~user_id ~link_id = 217 + use (fun db -> 218 + let sql = 219 + "SELECT direction FROM votes WHERE user_id = ? AND link_id = ?" 220 + in 221 + let stmt = Sqlite3.prepare db sql in 222 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.INT (Int64.of_int user_id))); 223 + ignore (Sqlite3.bind stmt 2 (Sqlite3.Data.INT (Int64.of_int link_id))); 224 + let result = 225 + match Sqlite3.step stmt with 226 + | Sqlite3.Rc.ROW -> ( 227 + let data = Sqlite3.row_data stmt in 228 + match data.(0) with 229 + | Sqlite3.Data.INT i -> Models.direction_of_int (Int64.to_int i) 230 + | _ -> None) 231 + | _ -> None 232 + in 233 + ignore (Sqlite3.finalize stmt); 234 + Ok result) 235 + 236 + let get_user id = 237 + use (fun db -> 238 + let sql = 239 + "SELECT id, username, password_hash, created_at FROM users WHERE id = ?" 240 + in 241 + let stmt = Sqlite3.prepare db sql in 242 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.INT (Int64.of_int id))); 243 + let result = find_one stmt row_to_user in 244 + ignore (Sqlite3.finalize stmt); 245 + Ok result) 246 + 247 + let get_user_by_username username = 248 + use (fun db -> 249 + let sql = 250 + "SELECT id, username, password_hash, created_at FROM users WHERE \ 251 + username = ?" 252 + in 253 + let stmt = Sqlite3.prepare db sql in 254 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT username)); 255 + let result = find_one stmt row_to_user in 256 + ignore (Sqlite3.finalize stmt); 257 + Ok result) 258 + 259 + let create_user ~username ~password_hash = 260 + use (fun db -> 261 + let sql = "INSERT INTO users (username, password_hash) VALUES (?, ?)" in 262 + let stmt = Sqlite3.prepare db sql in 263 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT username)); 264 + ignore (Sqlite3.bind stmt 2 (Sqlite3.Data.TEXT password_hash)); 265 + match Sqlite3.step stmt with 266 + | Sqlite3.Rc.DONE -> 267 + ignore (Sqlite3.finalize stmt); 268 + Ok (Int64.to_int (Sqlite3.last_insert_rowid db)) 269 + | rc -> 270 + ignore (Sqlite3.finalize stmt); 271 + Error (Sqlite3.Rc.to_string rc)) 272 + 273 + let list_comments link_id = 274 + use (fun db -> 275 + let sql = 276 + "SELECT id, link_id, user_id, parent_id, body, created_at FROM \ 277 + comments WHERE link_id = ? ORDER BY created_at ASC" 278 + in 279 + let stmt = Sqlite3.prepare db sql in 280 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.INT (Int64.of_int link_id))); 281 + let result = collect_rows stmt row_to_comment in 282 + ignore (Sqlite3.finalize stmt); 283 + Ok result) 284 + 285 + let create_comment ~link_id ~user_id ~parent_id ~body = 286 + use (fun db -> 287 + let sql = 288 + "INSERT INTO comments (link_id, user_id, parent_id, body) VALUES (?, \ 289 + ?, ?, ?)" 290 + in 291 + let stmt = Sqlite3.prepare db sql in 292 + ignore (Sqlite3.bind stmt 1 (Sqlite3.Data.INT (Int64.of_int link_id))); 293 + ignore (Sqlite3.bind stmt 2 (Sqlite3.Data.INT (Int64.of_int user_id))); 294 + (match parent_id with 295 + | Some pid -> 296 + ignore (Sqlite3.bind stmt 3 (Sqlite3.Data.INT (Int64.of_int pid))) 297 + | None -> ignore (Sqlite3.bind stmt 3 Sqlite3.Data.NULL)); 298 + ignore (Sqlite3.bind stmt 4 (Sqlite3.Data.TEXT body)); 299 + (match Sqlite3.step stmt with 300 + | Sqlite3.Rc.DONE -> () 301 + | rc -> failwith (Sqlite3.Rc.to_string rc)); 302 + let id = Int64.to_int (Sqlite3.last_insert_rowid db) in 303 + ignore (Sqlite3.finalize stmt); 304 + 305 + let sql2 = 306 + "UPDATE links SET comment_count = comment_count + 1 WHERE id = ?" 307 + in 308 + let stmt2 = Sqlite3.prepare db sql2 in 309 + ignore (Sqlite3.bind stmt2 1 (Sqlite3.Data.INT (Int64.of_int link_id))); 310 + (match Sqlite3.step stmt2 with 311 + | Sqlite3.Rc.DONE -> () 312 + | rc -> failwith (Sqlite3.Rc.to_string rc)); 313 + ignore (Sqlite3.finalize stmt2); 314 + Ok id)
+9
bin/las/dune
··· 1 + (executable 2 + (name las) 3 + (public_name las) 4 + (libraries 5 + hcs 6 + sqlite3 7 + pure-html 8 + digestif 9 + eio_main))
+203
bin/las/handlers.ml
··· 1 + open Hcs 2 + 3 + let accepts_json (req : Server.request) = 4 + match 5 + List.find_opt 6 + (fun (n, _) -> String.lowercase_ascii n = "accept") 7 + req.headers 8 + with 9 + | None -> false 10 + | Some (_, v) -> String.contains v 'j' && String.contains v 's' 11 + 12 + let parse_form_urlencoded (body : string) : (string * string) list = 13 + let decode_plus s = String.map (fun c -> if c = '+' then ' ' else c) s in 14 + let uri_decode s = 15 + let buf = Buffer.create (String.length s) in 16 + let rec loop i = 17 + if i >= String.length s then () 18 + else 19 + match s.[i] with 20 + | '%' when i + 2 < String.length s -> ( 21 + match int_of_string_opt ("0x" ^ String.sub s (i + 1) 2) with 22 + | Some code -> 23 + Buffer.add_char buf (Char.chr code); 24 + loop (i + 3) 25 + | None -> 26 + Buffer.add_char buf s.[i]; 27 + loop (i + 1)) 28 + | c -> 29 + Buffer.add_char buf c; 30 + loop (i + 1) 31 + in 32 + loop 0; 33 + Buffer.contents buf 34 + in 35 + let decode s = uri_decode (decode_plus s) in 36 + body |> String.split_on_char '&' 37 + |> List.filter (fun kv -> kv <> "") 38 + |> List.map (fun kv -> 39 + match String.split_on_char '=' kv with 40 + | [ k; v ] -> (decode k, decode v) 41 + | [ k ] -> (decode k, "") 42 + | k :: rest -> (decode k, decode (String.concat "=" rest)) 43 + | [] -> ("", "")) 44 + 45 + let form_value key form = List.assoc_opt key form |> Option.value ~default:"" 46 + 47 + let index _params (req : Server.request) : Server.response = 48 + match Db.list_links ~sort:Db.Score () with 49 + | Error e -> Server.respond ~status:`Internal_server_error e 50 + | Ok links -> 51 + if accepts_json req then 52 + Server.respond 53 + ~headers:[ ("Content-Type", "application/json") ] 54 + (Models.links_to_json links) 55 + else 56 + Server.respond 57 + ~headers:[ ("Content-Type", "text/html") ] 58 + (Views.index_page links) 59 + 60 + let index_new _params (req : Server.request) : Server.response = 61 + match Db.list_links ~sort:Db.New () with 62 + | Error e -> Server.respond ~status:`Internal_server_error e 63 + | Ok links -> 64 + if accepts_json req then 65 + Server.respond 66 + ~headers:[ ("Content-Type", "application/json") ] 67 + (Models.links_to_json links) 68 + else 69 + Server.respond 70 + ~headers:[ ("Content-Type", "text/html") ] 71 + (Views.index_page links) 72 + 73 + let show_link params (req : Server.request) : Server.response = 74 + let link_id = Router.param_int_or "id" ~default:0 params in 75 + match Db.get_link link_id with 76 + | Error e -> Server.respond ~status:`Internal_server_error e 77 + | Ok None -> Server.respond ~status:`Not_found "Not Found" 78 + | Ok (Some link) -> ( 79 + match Db.list_comments link_id with 80 + | Error e -> Server.respond ~status:`Internal_server_error e 81 + | Ok comments -> 82 + if accepts_json req then 83 + Server.respond 84 + ~headers:[ ("Content-Type", "application/json") ] 85 + (Models.link_to_json link) 86 + else 87 + Server.respond 88 + ~headers:[ ("Content-Type", "text/html") ] 89 + (Views.link_page link comments)) 90 + 91 + let login_form _params (_req : Server.request) : Server.response = 92 + Server.respond 93 + ~headers:[ ("Content-Type", "text/html") ] 94 + (Views.login_page ()) 95 + 96 + let login_submit _params (req : Server.request) : Server.response = 97 + let form = parse_form_urlencoded req.body in 98 + let username = form_value "username" form in 99 + let password = form_value "password" form in 100 + match Auth.login ~username ~password with 101 + | Ok _ -> Server.respond ~status:`Found ~headers:[ ("Location", "/") ] "" 102 + | Error msg -> 103 + Server.respond ~status:`Unauthorized 104 + ~headers:[ ("Content-Type", "text/html") ] 105 + (Views.login_page ~error:msg ()) 106 + 107 + let register_form _params (_req : Server.request) : Server.response = 108 + Server.respond 109 + ~headers:[ ("Content-Type", "text/html") ] 110 + (Views.register_page ()) 111 + 112 + let register_submit _params (req : Server.request) : Server.response = 113 + let form = parse_form_urlencoded req.body in 114 + let username = form_value "username" form in 115 + let password = form_value "password" form in 116 + match Auth.register ~username ~password with 117 + | Ok _ -> Server.respond ~status:`Found ~headers:[ ("Location", "/") ] "" 118 + | Error msg -> 119 + Server.respond ~status:`Bad_request 120 + ~headers:[ ("Content-Type", "text/html") ] 121 + (Views.register_page ~error:msg ()) 122 + 123 + let logout_submit _params (_req : Server.request) : Server.response = 124 + Auth.logout (); 125 + Server.respond ~status:`Found ~headers:[ ("Location", "/") ] "" 126 + 127 + let submit_form _params (_req : Server.request) : Server.response = 128 + Server.respond 129 + ~headers:[ ("Content-Type", "text/html") ] 130 + (Views.submit_page ()) 131 + 132 + let create_link _params (req : Server.request) : Server.response = 133 + match Auth.current_user_id () with 134 + | None -> Server.respond ~status:`Unauthorized "Unauthorized" 135 + | Some user_id -> ( 136 + let form = parse_form_urlencoded req.body in 137 + let url = form_value "url" form in 138 + let title = form_value "title" form in 139 + if String.length url = 0 || String.length title = 0 then 140 + Server.respond ~status:`Bad_request 141 + ~headers:[ ("Content-Type", "text/html") ] 142 + (Views.submit_page ~error:"URL and title are required" ()) 143 + else 144 + match Db.submit_link ~url ~title ~user_id with 145 + | Ok link_id -> 146 + if accepts_json req then 147 + Server.respond 148 + ~headers:[ ("Content-Type", "application/json") ] 149 + (Printf.sprintf {|{"id":%d}|} link_id) 150 + else 151 + Server.respond ~status:`Found 152 + ~headers:[ ("Location", Printf.sprintf "/links/%d" link_id) ] 153 + "" 154 + | Error e -> Server.respond ~status:`Internal_server_error e) 155 + 156 + let vote params (req : Server.request) : Server.response = 157 + match Auth.current_user_id () with 158 + | None -> 159 + Server.respond ~status:`Unauthorized 160 + ~headers:[ ("Content-Type", "application/json") ] 161 + {|{"error":"login_required"}|} 162 + | Some user_id -> ( 163 + let link_id = Router.param_int_or "id" ~default:0 params in 164 + let form = parse_form_urlencoded req.body in 165 + let dir_str = form_value "direction" form in 166 + let direction = 167 + match Models.direction_of_string dir_str with 168 + | Some d -> d 169 + | None -> Models.Up 170 + in 171 + match Db.vote ~user_id ~link_id ~direction with 172 + | Error e -> Server.respond ~status:`Internal_server_error e 173 + | Ok () -> ( 174 + match Db.get_link link_id with 175 + | Ok (Some link) -> 176 + Realtime.broadcast_vote ~link_id ~new_score:link.score; 177 + Server.respond 178 + ~headers:[ ("Content-Type", "application/json") ] 179 + {|{"ok":true}|} 180 + | _ -> 181 + Server.respond 182 + ~headers:[ ("Content-Type", "application/json") ] 183 + {|{"ok":true}|})) 184 + 185 + let create_comment params (req : Server.request) : Server.response = 186 + match Auth.current_user_id () with 187 + | None -> Server.respond ~status:`Unauthorized "Unauthorized" 188 + | Some user_id -> ( 189 + let link_id = Router.param_int_or "id" ~default:0 params in 190 + let form = parse_form_urlencoded req.body in 191 + let body = form_value "body" form in 192 + let parent_id = 193 + Option.bind (List.assoc_opt "parent_id" form) int_of_string_opt 194 + in 195 + if String.length body = 0 then 196 + Server.respond ~status:`Bad_request "Comment body is required" 197 + else 198 + match Db.create_comment ~link_id ~user_id ~parent_id ~body with 199 + | Ok _ -> 200 + Server.respond ~status:`Found 201 + ~headers:[ ("Location", Printf.sprintf "/links/%d" link_id) ] 202 + "" 203 + | Error e -> Server.respond ~status:`Internal_server_error e)
+44
bin/las/las.ml
··· 1 + let () = 2 + Eio_main.run @@ fun env -> 3 + let clock = Eio.Stdenv.clock env in 4 + let db_path = 5 + Sys.getenv_opt "DATABASE_PATH" |> Option.value ~default:"las.db" 6 + in 7 + (match Db.init db_path with 8 + | Ok () -> () 9 + | Error e -> failwith ("Database init failed: " ^ e)); 10 + let store = Hcs.Plug.Session.Memory_store.create () in 11 + let logger _level _event = () in 12 + let rate_key (req : Hcs.Server.request) = 13 + match 14 + List.find_opt 15 + (fun (n, _) -> String.lowercase_ascii n = "x-forwarded-for") 16 + req.Hcs.Server.headers 17 + with 18 + | Some (_, ip) -> "ip:" ^ ip 19 + | None -> "anon" 20 + in 21 + let endpoint = 22 + let e = 23 + Hcs.Endpoint.create 24 + { 25 + Hcs.Endpoint.default_config with 26 + port = 8080; 27 + secret_key_base = 28 + Sys.getenv_opt "SECRET_KEY" 29 + |> Option.value ~default:"dev-secret-32-chars-minimum!!!"; 30 + } 31 + in 32 + let e = Hcs.Endpoint.plug e (Hcs.Plug.Logger.create ~clock logger) in 33 + let e = Hcs.Endpoint.plug e (Hcs.Plug.Compress.create ()) in 34 + let e = Hcs.Endpoint.plug e (Hcs.Plug.Session.create ~store ()) in 35 + let e = Hcs.Endpoint.plug e (Hcs.Plug.Csrf.create ()) in 36 + let e = 37 + Hcs.Endpoint.plug e 38 + (Hcs.Plug.Rate_limit.create ~clock ~key:rate_key ~requests:100 ~per:60.0) 39 + in 40 + let e = Hcs.Endpoint.router e Routes.router in 41 + let e = Hcs.Endpoint.websocket e Realtime.ws_handler in 42 + e 43 + in 44 + Hcs.Endpoint.start endpoint ~env
+120
bin/las/models.ml
··· 1 + type user = { 2 + id : int; 3 + username : string; 4 + password_hash : string; 5 + created_at : float; 6 + } 7 + 8 + type link = { 9 + id : int; 10 + url : string; 11 + title : string; 12 + submitted_by : int; 13 + score : int; 14 + comment_count : int; 15 + created_at : float; 16 + } 17 + 18 + type vote_direction = Up | Down 19 + type vote = { user_id : int; link_id : int; direction : vote_direction } 20 + 21 + type comment = { 22 + id : int; 23 + link_id : int; 24 + user_id : int; 25 + parent_id : int option; 26 + body : string; 27 + created_at : float; 28 + } 29 + 30 + let escape_json_string s = 31 + let buf = Buffer.create (String.length s) in 32 + String.iter 33 + (fun c -> 34 + match c with 35 + | '"' -> Buffer.add_string buf "\\\"" 36 + | '\\' -> Buffer.add_string buf "\\\\" 37 + | '\n' -> Buffer.add_string buf "\\n" 38 + | '\r' -> Buffer.add_string buf "\\r" 39 + | '\t' -> Buffer.add_string buf "\\t" 40 + | c when Char.code c < 32 -> 41 + Buffer.add_string buf (Printf.sprintf "\\u%04x" (Char.code c)) 42 + | c -> Buffer.add_char buf c) 43 + s; 44 + Buffer.contents buf 45 + 46 + let user_to_json (u : user) = 47 + Printf.sprintf {|{"id":%d,"username":"%s","created_at":%.0f}|} u.id 48 + (escape_json_string u.username) 49 + u.created_at 50 + 51 + let link_to_json (l : link) = 52 + Printf.sprintf 53 + {|{"id":%d,"url":"%s","title":"%s","submitted_by":%d,"score":%d,"comment_count":%d,"created_at":%.0f}|} 54 + l.id (escape_json_string l.url) 55 + (escape_json_string l.title) 56 + l.submitted_by l.score l.comment_count l.created_at 57 + 58 + let links_to_json links = 59 + "[" ^ String.concat "," (List.map link_to_json links) ^ "]" 60 + 61 + let comment_to_json (c : comment) = 62 + let parent = 63 + match c.parent_id with Some id -> string_of_int id | None -> "null" 64 + in 65 + Printf.sprintf 66 + {|{"id":%d,"link_id":%d,"user_id":%d,"parent_id":%s,"body":"%s","created_at":%.0f}|} 67 + c.id c.link_id c.user_id parent 68 + (escape_json_string c.body) 69 + c.created_at 70 + 71 + let comments_to_json comments = 72 + "[" ^ String.concat "," (List.map comment_to_json comments) ^ "]" 73 + 74 + let vote_to_json (v : vote) = 75 + let dir = match v.direction with Up -> "up" | Down -> "down" in 76 + Printf.sprintf {|{"user_id":%d,"link_id":%d,"direction":"%s"}|} v.user_id 77 + v.link_id dir 78 + 79 + let url_decode s = 80 + let len = String.length s in 81 + let buf = Buffer.create len in 82 + let rec loop i = 83 + if i >= len then Buffer.contents buf 84 + else if s.[i] = '+' then ( 85 + Buffer.add_char buf ' '; 86 + loop (i + 1)) 87 + else if s.[i] = '%' && i + 2 < len then ( 88 + let hex = String.sub s (i + 1) 2 in 89 + (try 90 + let code = int_of_string ("0x" ^ hex) in 91 + Buffer.add_char buf (Char.chr code) 92 + with _ -> Buffer.add_char buf '%'); 93 + loop (i + 3)) 94 + else ( 95 + Buffer.add_char buf s.[i]; 96 + loop (i + 1)) 97 + in 98 + loop 0 99 + 100 + let parse_form_body body = 101 + if body = "" then [] 102 + else 103 + String.split_on_char '&' body 104 + |> List.filter_map (fun pair -> 105 + match String.index_opt pair '=' with 106 + | Some i -> 107 + let key = String.sub pair 0 i |> url_decode in 108 + let value = 109 + String.sub pair (i + 1) (String.length pair - i - 1) |> url_decode 110 + in 111 + Some (key, value) 112 + | None -> None) 113 + 114 + let direction_of_string = function 115 + | "up" -> Some Up 116 + | "down" -> Some Down 117 + | _ -> None 118 + 119 + let direction_to_int = function Up -> 1 | Down -> -1 120 + let direction_of_int = function 1 -> Some Up | -1 -> Some Down | _ -> None
+34
bin/las/realtime.ml
··· 1 + let pubsub = Hcs.Pubsub.create () 2 + 3 + let broadcast_vote ~link_id ~new_score = 4 + let topic = Printf.sprintf "link:%d" link_id in 5 + let msg = 6 + Printf.sprintf {|{"type":"vote","link_id":%d,"score":%d}|} link_id new_score 7 + in 8 + Hcs.Pubsub.broadcast pubsub topic msg 9 + 10 + let ws_handler ws = 11 + let rec loop () = 12 + match Hcs.Websocket.recv_message ws with 13 + | Error Hcs.Websocket.Connection_closed -> () 14 + | Error _ -> () 15 + | Ok (_, msg) -> ( 16 + match String.index_opt msg ':' with 17 + | Some i when i > 12 -> 18 + let prefix = String.sub msg 0 12 in 19 + if prefix = "{\"subscribe\"" then 20 + let rest = String.sub msg (i + 1) (String.length msg - i - 1) in 21 + let topic = 22 + String.trim rest |> String.split_on_char '"' 23 + |> List.filter (fun s -> s <> "" && s <> "}" && s <> ":") 24 + |> List.hd 25 + in 26 + let _sub = 27 + Hcs.Pubsub.subscribe pubsub topic (fun msg -> 28 + ignore (Hcs.Websocket.send_text ws msg)) 29 + in 30 + loop () 31 + else loop () 32 + | _ -> loop ()) 33 + in 34 + loop ()
+21
bin/las/routes.ml
··· 1 + open Hcs 2 + 3 + let router = 4 + Router.compile 5 + [ 6 + Router.Route.get "/" Handlers.index; 7 + Router.Route.get "/new" Handlers.index_new; 8 + Router.Route.get "/links/:id" Handlers.show_link; 9 + Router.Route.get "/login" Handlers.login_form; 10 + Router.Route.post "/login" Handlers.login_submit; 11 + Router.Route.get "/register" Handlers.register_form; 12 + Router.Route.post "/register" Handlers.register_submit; 13 + Router.Route.post "/logout" Handlers.logout_submit; 14 + Router.Route.get "/submit" (fun params req -> 15 + Auth.require_auth (Handlers.submit_form params) req); 16 + Router.Route.post "/links" (fun params req -> 17 + Auth.require_auth (Handlers.create_link params) req); 18 + Router.Route.post "/links/:id/vote" Handlers.vote; 19 + Router.Route.post "/links/:id/comments" (fun params req -> 20 + Auth.require_auth (Handlers.create_comment params) req); 21 + ]
+267
bin/las/views.ml
··· 1 + open Pure_html 2 + open HTML 3 + 4 + let styles = 5 + style [] 6 + {| 7 + body { font-family: system-ui, sans-serif; max-width: 800px; margin: 0 auto; padding: 1rem; background: #fafafa; } 8 + .link { margin: 1rem 0; padding: 1rem; border: 1px solid #ddd; border-radius: 4px; background: white; } 9 + .link-title { font-size: 1.1rem; font-weight: bold; } 10 + .link-title a { color: #333; text-decoration: none; } 11 + .link-title a:hover { color: #f60; } 12 + .link-meta { color: #666; font-size: 0.9rem; margin-top: 0.5rem; } 13 + .score { font-weight: bold; color: #f60; } 14 + .vote-btn { cursor: pointer; padding: 0.25rem 0.5rem; border: 1px solid #ddd; background: white; border-radius: 3px; } 15 + .vote-btn:hover { background: #f0f0f0; } 16 + nav { margin-bottom: 1rem; padding: 1rem; border-bottom: 2px solid #f60; background: white; } 17 + nav a { margin-right: 1rem; color: #333; text-decoration: none; } 18 + nav a:hover { color: #f60; } 19 + h1 { color: #f60; } 20 + form { max-width: 400px; } 21 + input[type="text"], input[type="password"], input[type="url"], textarea { 22 + width: 100%%; padding: 0.5rem; margin: 0.25rem 0 1rem 0; border: 1px solid #ddd; border-radius: 4px; box-sizing: border-box; 23 + } 24 + button { background: #f60; color: white; border: none; padding: 0.75rem 1.5rem; border-radius: 4px; cursor: pointer; } 25 + button:hover { background: #e55; } 26 + .error { color: #c00; background: #fee; padding: 0.5rem; border-radius: 4px; margin-bottom: 1rem; } 27 + .comment { margin: 0.5rem 0; padding: 0.5rem; border-left: 2px solid #ddd; } 28 + .comment-meta { font-size: 0.8rem; color: #666; } 29 + |} 30 + 31 + let websocket_script = 32 + script [] 33 + {| 34 + const ws = new WebSocket('ws://' + location.host + '/'); 35 + ws.onopen = () => { 36 + document.querySelectorAll('[data-link-id]').forEach(el => { 37 + ws.send(JSON.stringify({ subscribe: 'link:' + el.dataset.linkId })); 38 + }); 39 + }; 40 + ws.onmessage = (e) => { 41 + const d = JSON.parse(e.data); 42 + if (d.type === 'vote') { 43 + const el = document.querySelector('[data-link-id="' + d.link_id + '"] .score'); 44 + if (el) el.textContent = d.score + ' points'; 45 + } 46 + }; 47 + function vote(linkId, dir) { 48 + fetch('/links/' + linkId + '/vote', { 49 + method: 'POST', 50 + headers: {'Content-Type': 'application/x-www-form-urlencoded'}, 51 + body: 'direction=' + dir 52 + }); 53 + } 54 + |} 55 + 56 + let csrf_field () = 57 + match Hcs.Plug.Session.get "_csrf" with 58 + | Some token -> input [ type_ "hidden"; name "_csrf"; value "%s" token ] 59 + | None -> null [] 60 + 61 + let nav_links () = 62 + match Hcs.Plug.Session.get "user_id" with 63 + | Some _ -> a [ href "/logout" ] [ txt "Logout" ] 64 + | None -> 65 + null 66 + [ 67 + a [ href "/login" ] [ txt "Login" ]; 68 + a [ href "/register" ] [ txt "Register" ]; 69 + ] 70 + 71 + let layout ~page_title page_content = 72 + html [] 73 + [ 74 + head [] 75 + [ 76 + meta [ charset "utf-8" ]; 77 + meta 78 + [ name "viewport"; content "width=device-width, initial-scale=1" ]; 79 + title [] "%s - Link Aggregator" page_title; 80 + styles; 81 + ]; 82 + body [] 83 + [ 84 + nav [] 85 + [ 86 + strong [] [ a [ href "/" ] [ txt "LAS" ] ]; 87 + a [ href "/" ] [ txt "Top" ]; 88 + a [ href "/new" ] [ txt "New" ]; 89 + a [ href "/submit" ] [ txt "Submit" ]; 90 + nav_links (); 91 + ]; 92 + page_content; 93 + websocket_script; 94 + ]; 95 + ] 96 + |> to_string 97 + 98 + let vote_buttons link_id = 99 + if Option.is_some (Hcs.Plug.Session.get "user_id") then 100 + null 101 + [ 102 + button 103 + [ 104 + class_ "vote-btn"; 105 + Hx.post "/links/%d/vote" link_id; 106 + Hx.vals {|{"direction":"up"}|}; 107 + ] 108 + [ txt "+" ]; 109 + button 110 + [ 111 + class_ "vote-btn"; 112 + Hx.post "/links/%d/vote" link_id; 113 + Hx.vals {|{"direction":"down"}|}; 114 + ] 115 + [ txt "-" ]; 116 + ] 117 + else null [] 118 + 119 + let link_item (link : Models.link) = 120 + div 121 + [ class_ "link"; string_attr "data-link-id" "%d" link.id ] 122 + [ 123 + div 124 + [ class_ "link-title" ] 125 + [ a [ href "%s" link.url; target "_blank" ] [ txt "%s" link.title ] ]; 126 + div 127 + [ class_ "link-meta" ] 128 + [ 129 + span [ class_ "score" ] [ txt "%d points" link.score ]; 130 + txt " | "; 131 + a 132 + [ href "/links/%d" link.id ] 133 + [ txt "%d comments" link.comment_count ]; 134 + vote_buttons link.id; 135 + ]; 136 + ] 137 + 138 + let index_page links = 139 + let content = 140 + if links = [] then 141 + p [] [ txt "No links yet. "; a [ href "/submit" ] [ txt "Submit one!" ] ] 142 + else div [] (List.map link_item links) 143 + in 144 + layout ~page_title:"Home" content 145 + 146 + let link_page (link : Models.link) comments = 147 + let comments_html = 148 + if comments = [] then p [] [ txt "No comments yet." ] 149 + else 150 + div [] 151 + (List.map 152 + (fun (c : Models.comment) -> 153 + div 154 + [ class_ "comment" ] 155 + [ 156 + div [ class_ "comment-meta" ] [ txt "by user #%d" c.user_id ]; 157 + div [] [ txt "%s" c.body ]; 158 + ]) 159 + comments) 160 + in 161 + let comment_form = 162 + if Option.is_some (Hcs.Plug.Session.get "user_id") then 163 + form 164 + [ method_ `POST; action "/links/%d/comments" link.id ] 165 + [ 166 + csrf_field (); 167 + textarea [ name "body"; placeholder "Add a comment..."; rows 3 ] ""; 168 + button [ type_ "submit" ] [ txt "Comment" ]; 169 + ] 170 + else p [] [ a [ href "/login" ] [ txt "Login" ]; txt " to comment." ] 171 + in 172 + let content = 173 + div [] 174 + [ 175 + div 176 + [ class_ "link"; string_attr "data-link-id" "%d" link.id ] 177 + [ 178 + div 179 + [ class_ "link-title" ] 180 + [ 181 + a 182 + [ href "%s" link.url; target "_blank" ] 183 + [ txt "%s" link.title ]; 184 + ]; 185 + div 186 + [ class_ "link-meta" ] 187 + [ span [ class_ "score" ] [ txt "%d points" link.score ] ]; 188 + ]; 189 + h2 [] [ txt "Comments" ]; 190 + comments_html; 191 + comment_form; 192 + ] 193 + in 194 + layout ~page_title:link.title content 195 + 196 + let error_box = function 197 + | Some e -> div [ class_ "error" ] [ txt "%s" e ] 198 + | None -> null [] 199 + 200 + let login_page ?error () = 201 + let content = 202 + div [] 203 + [ 204 + h1 [] [ txt "Login" ]; 205 + error_box error; 206 + form 207 + [ method_ `POST; action "/login" ] 208 + [ 209 + csrf_field (); 210 + label [] [ txt "Username" ]; 211 + input [ type_ "text"; name "username"; required ]; 212 + label [] [ txt "Password" ]; 213 + input [ type_ "password"; name "password"; required ]; 214 + button [ type_ "submit" ] [ txt "Login" ]; 215 + ]; 216 + p [] 217 + [ 218 + txt "Don't have an account? "; 219 + a [ href "/register" ] [ txt "Register" ]; 220 + ]; 221 + ] 222 + in 223 + layout ~page_title:"Login" content 224 + 225 + let register_page ?error () = 226 + let content = 227 + div [] 228 + [ 229 + h1 [] [ txt "Register" ]; 230 + error_box error; 231 + form 232 + [ method_ `POST; action "/register" ] 233 + [ 234 + csrf_field (); 235 + label [] [ txt "Username" ]; 236 + input [ type_ "text"; name "username"; required ]; 237 + label [] [ txt "Password" ]; 238 + input [ type_ "password"; name "password"; required ]; 239 + button [ type_ "submit" ] [ txt "Register" ]; 240 + ]; 241 + p [] 242 + [ 243 + txt "Already have an account? "; a [ href "/login" ] [ txt "Login" ]; 244 + ]; 245 + ] 246 + in 247 + layout ~page_title:"Register" content 248 + 249 + let submit_page ?error () = 250 + let content = 251 + div [] 252 + [ 253 + h1 [] [ txt "Submit Link" ]; 254 + error_box error; 255 + form 256 + [ method_ `POST; action "/links" ] 257 + [ 258 + csrf_field (); 259 + label [] [ txt "Title" ]; 260 + input [ type_ "text"; name "title"; required ]; 261 + label [] [ txt "URL" ]; 262 + input [ type_ "url"; name "url"; required ]; 263 + button [ type_ "submit" ] [ txt "Submit" ]; 264 + ]; 265 + ] 266 + in 267 + layout ~page_title:"Submit" content