Something went wrong. Try again.
ocaml
Something went wrong. Try again.
11 kB · 310 lines
OCaml
at pp-ast
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311(* * SPDX-FileCopyrightText: 2024 The Forester Project Contributors * SPDX-FileCopyrightText: 2026 The Forester Project Contributors * * SPDX-License-Identifier: GPL-3.0-or-later *)
open Forester_coreopen Forester_compileropen Forester_frontendopen Forest.Syntax
open struct module T = Types module EP = Eio.Path module P = Pure_html module H = Pure_html.HTML module Hx = Pure_html.Hx type env = Html_client.envend
type 'a request = {route: 'a; request: Http.Request.t; body: Cohttp_eio.Body.t}type response = Cohttp_eio.Server.(response IO.t)
let serve ~env ~route ~port handler = let@ sw = Eio.Switch.run ~name:"forester.server" in let net = Eio.Stdenv.net env in let stream = `Tcp (Eio.Net.Ipaddr.V4.any, port) in let socket = Eio.Net.listen net ~sw ~backlog:128 ~reuse_addr:true stream in let callback _ request body = handler {route; request; body} in let server = Cohttp_eio.Server.make ~callback () in Cohttp_eio.Server.run socket server ~on_error:(fun exn -> Eio.traceln "Server: %a" Eio.Exn.pp exn)
let respond_string = Cohttp_eio.Server.respond_string
let respond_html ~status body = let body = Pure_html.to_string body in let headers = Http.Header.of_list [("Content-Type", "text/html")] in respond_string ~headers ~status ~body ()
let respond_json ?(status = `OK) ~body = let body = Yojson.Safe.to_string body in let headers = Http.Header.of_list [("Content-Type", "application/json")] in respond_string ~headers ~status ~body ()
let theme_dir ~env ~(config : Config.t) = match config.theme with | Some dir -> Some EP.(env#fs / dir) | None -> begin match Theme_site.Sites.themes with | base_dir :: _ -> Some EP.(env#fs / base_dir / "default") | [] -> Logs.warn ~src:Log.Src.server (fun m -> m "Could not find a theme directory, your installation might be \ broken."); None end
let mimetype_of_extension = function | ".png" -> "image/png" | ".jpg" | ".jpeg" -> "image/jpeg" | ".gif" -> "image/gif" | ".svg" -> "image/svg+xml" | ".webp" -> "image/webp" | ".ico" -> "image/x-icon" | ".pdf" -> "application/pdf" | ".css" -> "text/css" | ".js" -> "application/javascript" | ".ttf" -> "font/ttf" | ".woff" -> "font/woff" | ".woff2" -> "font/woff2" | _ -> "application/octet-stream"
let mimetype : Router.static -> string = fun route -> match route with | `Font fontname -> mimetype_of_extension (Filename.extension fontname) | `File name -> mimetype_of_extension (Filename.extension name)
(* Routes that don't depend on a forest*)let static_handler ~env ~config : Router.static -> Cohttp_eio.Server.response = fun route -> match theme_dir ~env ~config with | None -> respond_string ~status:`Not_found ~body:"" () | Some theme_dir -> let headers = Http.Header.of_list [("Content-Type", mimetype route)] in let body = match route with | `Font fontname -> let font_dir = EP.(native_exn (theme_dir / "fonts")) in EP.(load (env#fs / font_dir / fontname)) | `File name -> EP.(load (theme_dir / name)) in respond_string ~headers ~status:`OK ~body ()
let asset_mimetype (asset : T.asset) = mimetype_of_extension (Filename.extension (URI.stripped_path_string asset.uri))
let respond_asset (asset : T.asset) = let headers = Http.Header.of_list [("Content-Type", asset_mimetype asset)] in respond_string ~headers ~status:`OK ~body:asset.content ()
(* It is important that the render functions used here don't utilise the cache, since I have not implemented cache invalidation*)let tree_handler ~(forest : Forest.t) ~request_headers ~href = let htmx = Option.is_some @@ Http.Header.get request_headers "Hx-Request" in let boosted_swap = Http.Header.get request_headers "Hx-Target" = Some "main-wrapper" in let history_restore = Http.Header.get request_headers "Hx-History-Restore-Request" = Some "true" in let env = Html_client.{(default_env ~forest) with mode = Preview} in Link_checker.check_and_report_document ~forest href; let content = if Headers.parse_link_preview request_headers then let preview_render = Html_client.render_content ~env:{env with mode = Publish} in let@ {mainmatter = T.Content mainmatter; frontmatter; _} = Option.bind @@ Forest.get_article ~forest href in let title = T.html_elt "strong" @@ Forest.get_expanded_title frontmatter forest in Some (H.null (preview_render (T.Content (title :: mainmatter)))) else begin match Forest.get_article ~forest href with | None -> if htmx then None else let ctx = Router.page_context ~forest ~mode:Preview ~dev:true in let is_home = URI.equal (Config.home_uri forest.config) href in let tree_href = Some (URI.to_string href) in let tree_version = Some (Forest.effective_tree_version ~forest href) in Some (Templates.page ~ctx ~is_home ~tree_href ~tree_version [H.p [H.class_ "message"] [P.txt "This tree failed to compile."]]) | Some (T.{mainmatter; _} as article) -> begin let env = {env with scope = Some href} in let article = Html_client.render_article ~env article in let toc = Html_client.render_toc ~env mainmatter in let content = [article; H.nav [H.id "toc"] toc] in let ctx = Router.page_context ~forest ~mode:Preview ~dev:true in let is_home = URI.equal (Config.home_uri forest.config) href in let full_page () = let tree_href = Some (URI.to_string href) in let tree_version = Some (Forest.effective_tree_version ~forest href) in Some (Templates.page ~ctx ~is_home ~tree_href ~tree_version content) in if history_restore then full_page () else if htmx && boosted_swap then Some (H.null (Templates.main_wrapper_children ~is_home ~ctx content)) else if htmx then Some (H.null content) else full_page () end end in let status = match content with None -> `Not_found | Some _ -> `OK in match content with | None -> respond_string ~status ~body:"" () | Some body -> respond_html ~status body
let respond_tree ~(forest : Forest.t) ~request_headers scope name = let href = Router.Scope.to_href ~forest scope name in match Forest.get_resource ~forest href with | Some (T.Asset asset) -> respond_asset asset | _ -> tree_handler ~forest ~request_headers ~href
let not_found = respond_string ~status:`Not_found ~body:"" ()
let query_handler ~(env : env) ~request_headers = let query = Headers.parse_query request_headers in let run_query ~forest q = let result = Driver.update (Query q) forest in match result with Query_results vertex_set -> Some vertex_set | _ -> None in match query with | None -> respond_string ~status:`Bad_request ~body:"bad query" () | Some query -> begin let delete_section_headers = (* NOTE: When computing the backmatter, we will sometimes run queries return the empty set. In this case, we want to hide the entire backmatter section, heading included.*) Http.Header.of_list [ ("Hx-Retarget", "closest section.backmatter-section"); ("Hx-Swap", "delete"); ] in match run_query ~forest:env.forest query with | None -> respond_string ~status:`Internal_server_error ~body: "Internal error: Running query returned something unexpected. This \ is a bug. Something is wrong with Driver.update" () | Some vs when Vertex_set.cardinal vs = 0 -> respond_string ~headers:delete_section_headers ~status:`OK ~body:"" () | Some vertex_set -> let to_section = T.article_to_section ~flags: { T.default_section_flags with expanded = false; numbered = false; included_in_toc = false; metadata_shown = true; } in List.iter (fun vertex -> Option.iter (Link_checker.check_and_report_document ~forest:env.forest) (Vertex.uri_of_vertex vertex)) (Vertex_set.elements vertex_set); let body = H.div [] @@ List.map (to_section >>> Html_client.render_section ~env) (Forester.get_sorted_articles ~forest:env.forest vertex_set) in respond_html ~status:`OK body end
(* Allows the user to enter a config file name and loads the forest *)let respond_config ~forest request_headers request_body = let _, form = Form.parse request_headers (Eio.Flow.read_all request_body) in let env = Forest.env forest in match Form.get_field "config_name" form with | None -> let body = H.div [Hx.target "config-input"] [] in respond_html ~status:`Bad_request body | Some filename -> let body, status = (* This expects an absolute path, we should handle the case when the user enters ~/forest/forest.toml *) match Config_parser.parse_forest_config_file ~env filename with | Error errs -> let errors = List.map Error.render_config_error errs in let errors = List.map (Format.asprintf "%a@." Grace_ansi_renderer.( pp_diagnostic ?config:None ?code_to_string:None) >>> P.txt "%s") errors in (H.div [] errors, `OK) | Ok config -> let config = Forester.with_docs_foreign config in let home = match forest.@{Config.home_uri config} with | Some (Article article) -> article | _ -> assert false in Link_checker.check_and_report_all ~forest; let body = Html_client.render_article ~env:Html_client.{(default_env ~forest) with mode = Preview} home in (body, `OK) in respond_html ~status body
let respond_index ~(forest : Forest.t) ~request_headers = tree_handler ~forest ~request_headers ~href:(Config.home_uri forest.config)
let respond_version ~forest resource = let version = match Uri.get_query_param resource "uri" with | Some uri_str -> begin match URI.of_string_exn uri_str with | uri -> Forest.effective_tree_version ~forest uri | exception _ -> 0 end | _ -> 0 in respond_string ~status:`OK ~body:(string_of_int version) ()
let respond_diagnostics ~forest resource = let diagnostics = match Uri.get_query_param resource "uri" with | None -> [] | Some uri_str -> begin match URI.of_string_exn uri_str with | exception _ -> [] | uri -> Link_checker.check_and_report_transitive ~forest uri; let lsp_uri = Lsp.Uri.of_path (URI.to_string uri) in let config = forest.config in let@ error = List.map @~ Forest.transitive_errors ~forest uri in let diagnostic = Error.render ~config error in Error.render_lsp_diagnostic lsp_uri diagnostic end in let body = `List (List.map Lsp.Types.Diagnostic.yojson_of_t diagnostics) in respond_json ~status:`OK ~bodylet respond_search ~(forest : Forest.t) resource = let body = `List [] in respond_json ~status:`OK ~body