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
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_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