Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Page
Library
Module
Module type
Parameter
Class
Class type
Source
rock.ml
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
open Sexplib.Std open Misc module Header = Cohttp.Header module Service = struct type ('req, 'rep) t = 'req -> 'rep Lwt.t [@@deriving sexp] let id req = return req let const resp = Fn.compose return (Fn.const resp) end module Filter = struct type ('req, 'rep, 'req_, 'rep_) t = ('req, 'rep) Service.t -> ('req_, 'rep_) Service.t [@@deriving sexp] type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t [@@deriving sexp] let id s = s let ( >>> ) f1 f2 s = s |> f1 |> f2 let apply_all filters service = List.fold_left filters ~init:service ~f:( |> ) end module Request = struct type t = {request: Cohttp.Request.t; body: Cohttp_lwt.Body.t; env: Hmap0.t} [@@deriving fields, sexp_of] let create ?(body = Cohttp_lwt.Body.empty) ?(env = Hmap0.empty) request = {request; env; body} let uri {request; _} = Cohttp.Request.uri request let meth {request; _} = Cohttp.Request.meth request let headers {request; _} = Cohttp.Request.headers request end module Response = struct type t = { code: Cohttp.Code.status_code ; headers: Header.t ; body: Cohttp_lwt.Body.t ; env: Hmap0.t } [@@deriving fields, sexp_of] let default_header = Option.value ~default:(Header.init ()) let create ?(env = Hmap0.empty) ?(body = Cohttp_lwt.Body.empty) ?headers ?(code = `OK) () = {code; env; headers= Option.value ~default:(Header.init ()) headers; body} let of_string_body ?(env = Hmap0.empty) ?headers ?(code = `OK) body = { env ; code ; headers= default_header headers ; body= Cohttp_lwt.Body.of_string body } let of_stream ?(env = Hmap0.empty) ?headers ?(code = `OK) body = { env ; code ; headers= default_header headers ; body= Cohttp_lwt.Body.of_stream body } let of_response_body (resp, body) = let code = Cohttp.Response.status resp in let headers = Cohttp.Response.headers resp in create ~code ~headers ~body () end module Handler = struct type t = (Request.t, Response.t) Service.t [@@deriving sexp_of] let default _ = return (Response.of_string_body "route failed (404)") let not_found _ = return (Response.of_string_body ~code:`Not_found "<html><body><h1>404 - Not found</h1></body></html>") end module Middleware = struct type t = {filter: (Request.t, Response.t) Filter.simple; name: string} [@@deriving fields, sexp_of] let create ~filter ~name = {filter; name} let apply {filter; _} handler = filter handler (* wrap_debug/apply_middlewares_debug are used for debugging when middlewares are stepping over each other *) (* let wrap_debug handler ({ Request.env ; request; _ } as req) = * let env = Hmap0.sexp_of_t env in * let req' = request * |> Cohttp.Request.headers * |> Cohttp.Header.to_lines in * Printf.printf "Env:\n%s\n" (Sexplib.Sexp.to_string_hum env); * Printf.printf "%s\n" (String.concat "" req'); * let resp = handler req in * resp >>| (fun ({Response.headers; _} as resp) -> * Printf.printf "%s\n" (headers |> Cohttp.Header.to_lines |> String.concat "\n"); * resp) *) (* let apply_middlewares_debug (middlewares : t list) handler = * ListLabels.fold_left middlewares ~init:handler ~f:(fun h m -> * wrap_debug (apply m h)) *) end module App = struct type t = {middlewares: Middleware.t list; handler: Handler.t} [@@deriving fields, sexp_of] let append_middleware t m = {t with middlewares= t.middlewares @ [m]} let create ?(middlewares = []) ~handler = {middlewares; handler} end