From 6e07594aace8bc2c6f99219b4022a68291201aad Mon Sep 17 00:00:00 2001 From: Marius Peter Date: Sun, 15 Jun 2025 16:30:36 +0200 Subject: Refactor Git_presenters to Resolvers. What this module really does is resolve Git types to values usable by ogit views. --- lib/git_presenters.ml | 138 -------------------------------------------------- lib/handlers.ml | 77 ++++++++++++++-------------- lib/resolvers.ml | 135 ++++++++++++++++++++++++++++++++++++++++++++++++ lib/views.ml | 81 ++++++++++++++--------------- 4 files changed, 213 insertions(+), 218 deletions(-) delete mode 100644 lib/git_presenters.ml create mode 100644 lib/resolvers.ml diff --git a/lib/git_presenters.ml b/lib/git_presenters.ml deleted file mode 100644 index 963f1bd..0000000 --- a/lib/git_presenters.ml +++ /dev/null @@ -1,138 +0,0 @@ -(* -*- mode: tuareg; -*- *) - -module Store = Git_unix.Store -open Lwt_result.Syntax -open Lwt_result.Infix -open Config - -let full_path path = Filename.concat config.git_project_root path - -let store repo = - let path = Fpath.v @@ full_path repo in - Store.v ~dotgit:path path - -let repo_description repo = - let description_path = Filename.concat (full_path repo) "description" in - In_channel.with_open_text description_path In_channel.input_all - -type user = Git.User.t - -(* let all_authors store = *) -(* let* store = store repo in *) - -type commit = { - hash : string; - short_hash : string; - parents : string list; - author : user; - message : string option; -} - -let to_commit store hash = - Store.read store hash >>= function - | Git.Value.Commit c -> - let hash = Store.Hash.to_hex hash in - Lwt_result.return - { - hash; - short_hash = String.sub hash 0 8; - parents = Store.Value.Commit.parents c |> List.map Store.Hash.to_hex; - author = Store.Value.Commit.author c; - message = Store.Value.Commit.message c; - } - | _ -> Lwt_result.fail (`Msg "value is not a commit") - -let commit_of_id repo id = - let* store = store repo in - let hash = Store.Hash.of_hex id in - to_commit store hash - -let recent_commits repo n = - let* store = store repo in - let* head = Store.Ref.resolve store Git.Reference.head in - let rec walk acc hash count = - if count = 0 then Lwt_result.return (List.rev acc) - else - let* commit = to_commit store hash in - match commit.parents with - | parent :: _ -> - walk (commit :: acc) (Store.Hash.of_hex parent) (count - 1) - | [] -> Lwt_result.return (List.rev (commit :: acc)) - in - walk [] head n - -type branch = { hash : string; name : string } - -let all_branches repo = - let* store = store repo in - let open Lwt.Syntax in - let* refs = Store.Ref.list store in - let branches = - List.map - (fun (reference, hash) -> - let name = Git.Reference.to_string reference in - let hash = Store.Hash.to_hex hash in - { name; hash }) - refs - in - Lwt_result.return branches - -type tree_entry = { - hash : string; - short_hash : string; - name : string; - perm : int; -} - -type tree = { hash : string; short_hash : string; entries : tree_entry list } -type blob = { content : string } - -let to_entry (entry : Store.Value.Tree.entry) = - let perm = - match entry.perm with - | `Commit -> 0o160000 - | `Dir -> 0o040000 - | `Everybody -> 0o100664 - | `Exec -> 0o100755 - | `Link -> 0o120000 - | `Normal -> 0o100644 - in - let hash = Store.Hash.to_hex entry.node in - let short_hash = String.sub hash 0 8 in - { hash; short_hash; name = entry.name; perm } - -let to_tree store hash = - Store.read store hash >>= function - | Git.Value.Tree tree -> - let hash = Store.Hash.to_hex hash in - let short_hash = String.sub hash 0 8 in - let entries = Store.Value.Tree.to_list tree |> List.map to_entry in - Lwt_result.return { hash; short_hash; entries } - | _ -> Lwt_result.fail (`Msg "value is not a tree") - -let to_blob store hash = - Store.read store hash >>= function - | Git.Value.Blob blob -> - let content = Store.Value.Blob.to_string blob in - Lwt_result.return { content } - | _ -> Lwt_result.fail (`Msg "value is not a blob") - -let head_tree repo = - let* store = store repo in - let* hash = - Store.Ref.resolve store Git.Reference.head >>= Store.read store >>= function - | Git.Value.Commit commit -> - Store.Value.Commit.tree commit |> Lwt_result.return - | _ -> `Msg "no head tree id" |> Lwt_result.fail - in - to_tree store hash - -let tree_of_id repo id = - let* store = store repo in - let hash = Store.Hash.of_hex id in - to_tree store hash - -let blob_of_id repo id = - let* store = store repo in - let hash = Store.Hash.of_hex id in - to_blob store hash diff --git a/lib/handlers.ml b/lib/handlers.ml index ff4c4a5..871931c 100644 --- a/lib/handlers.ml +++ b/lib/handlers.ml @@ -3,62 +3,63 @@ let root _req = Views.root () module Repo = struct - open Git_presenters - let ( let* ) m f = let open Lwt.Infix in m >>= function | Ok x -> f x | Error e -> - let msg = Format.asprintf "%a" Store.pp_error e in - Views.error_page msg |> Dream_html.respond - - let repo req = Dream.param req "repo" - let id_of_req req = Dream.param req "id" + let msg = Format.asprintf "%a" Resolvers.Store.pp_error e in + Views.error_page msg let summary req = - let* branches = all_branches (repo req) in - let* commits = recent_commits (repo req) 10 in + let repo = Dream.param req "repo" in + let* branches = Resolvers.all_branches repo in + let* commits = Resolvers.recent_commits repo 10 in let authors = [ "John Pork"; "Sebastian Jellybean" ] in - Views.Repo.summary (repo req) branches commits authors + Views.Repo.summary repo branches commits authors let log req = - let* commits = recent_commits (repo req) 100 in - Views.Repo.log (repo req) commits + let repo = Dream.param req "repo" in + let* commits = Resolvers.recent_commits repo 100 in + Views.Repo.log repo commits let files_at_head req = - let* tree = head_tree (repo req) in - Views.Repo.files (repo req) tree + let repo = Dream.param req "repo" in + let* tree = Resolvers.head_tree repo in + Views.Repo.files repo tree let file_id req = - let id = id_of_req req in - let* blob = blob_of_id (repo req) id in - Views.Repo.file (repo req) blob + let repo = Dream.param req "repo" in + let id = Dream.param req "repo" in + let* blob = Resolvers.blob_of_id repo id in + Views.Repo.file repo blob let refs req = - let* branches = all_branches (repo req) in - Views.Repo.refs (repo req) branches + let repo = Dream.param req "repo" in + let* branches = Resolvers.all_branches repo in + Views.Repo.refs repo branches let commit req = - let id = id_of_req req in - let* commit = commit_of_id (repo req) id in - Views.Repo.commit (repo req) commit + let repo = Dream.param req "repo" in + let id = Dream.param req "id" in + let* commit = Resolvers.commit_of_id repo id in + Views.Repo.commit repo commit end let all_handlers = - Dream. - [ - get "/" root; - scope "/:repo" [] - Repo. - [ - get "/" summary; - get "/summary/" summary; - get "/log/" log; - get "/files/" files_at_head; - get "/files/:id" file_id; - get "/refs/" refs; - get "/commit/:id" commit; - ]; - get "/static/**" (static "./lib/static"); - ] + let open Dream in + [ + get "/" root; + scope "/:repo" [] + Repo. + [ + get "/" summary; + get "/summary/" summary; + get "/log/" log; + get "/files/" files_at_head; + get "/files/:id" file_id; + get "/refs/" refs; + get "/commit/:id" commit; + ]; + get "/static/**" (static "./lib/static"); + ] diff --git a/lib/resolvers.ml b/lib/resolvers.ml new file mode 100644 index 0000000..af8fd8b --- /dev/null +++ b/lib/resolvers.ml @@ -0,0 +1,135 @@ +(* -*- mode: tuareg; -*- *) + +module Store = Git_unix.Store +open Lwt_result.Syntax +open Lwt_result.Infix +open Config + +let full_path path = Filename.concat config.git_project_root path + +let store repo = + let path = Fpath.v @@ full_path repo in + Store.v ~dotgit:path path + +let repo_description repo = + let description_path = Filename.concat (full_path repo) "description" in + In_channel.with_open_text description_path In_channel.input_all + +type user = Git.User.t + +type commit = { + hash : string; + short_hash : string; + parents : string list; + author : user; + message : string option; +} + +let to_commit store hash = + Store.read store hash >>= function + | Git.Value.Commit c -> + let hash = Store.Hash.to_hex hash in + Lwt_result.return + { + hash; + short_hash = String.sub hash 0 8; + parents = Store.Value.Commit.parents c |> List.map Store.Hash.to_hex; + author = Store.Value.Commit.author c; + message = Store.Value.Commit.message c; + } + | _ -> Lwt_result.fail (`Msg "value is not a commit") + +let commit_of_id repo id = + let* store = store repo in + let hash = Store.Hash.of_hex id in + to_commit store hash + +let recent_commits repo n = + let* store = store repo in + let* head = Store.Ref.resolve store Git.Reference.head in + let rec walk acc hash count = + if count = 0 then Lwt_result.return (List.rev acc) + else + let* commit = to_commit store hash in + match commit.parents with + | parent :: _ -> + walk (commit :: acc) (Store.Hash.of_hex parent) (count - 1) + | [] -> Lwt_result.return (List.rev (commit :: acc)) + in + walk [] head n + +type branch = { hash : string; name : string } + +let all_branches repo = + let* store = store repo in + let open Lwt.Syntax in + let* refs = Store.Ref.list store in + let branches = + List.map + (fun (reference, hash) -> + let name = Git.Reference.to_string reference in + let hash = Store.Hash.to_hex hash in + { name; hash }) + refs + in + Lwt_result.return branches + +type tree_entry = { + hash : string; + short_hash : string; + name : string; + perm : int; +} + +type tree = { hash : string; short_hash : string; entries : tree_entry list } +type blob = { content : string } + +let to_entry (entry : Store.Value.Tree.entry) = + let perm = + match entry.perm with + | `Commit -> 0o160000 + | `Dir -> 0o040000 + | `Everybody -> 0o100664 + | `Exec -> 0o100755 + | `Link -> 0o120000 + | `Normal -> 0o100644 + in + let hash = Store.Hash.to_hex entry.node in + let short_hash = String.sub hash 0 8 in + { hash; short_hash; name = entry.name; perm } + +let to_tree store hash = + Store.read store hash >>= function + | Git.Value.Tree tree -> + let hash = Store.Hash.to_hex hash in + let short_hash = String.sub hash 0 8 in + let entries = Store.Value.Tree.to_list tree |> List.map to_entry in + Lwt_result.return { hash; short_hash; entries } + | _ -> Lwt_result.fail (`Msg "value is not a tree") + +let to_blob store hash = + Store.read store hash >>= function + | Git.Value.Blob blob -> + let content = Store.Value.Blob.to_string blob in + Lwt_result.return { content } + | _ -> Lwt_result.fail (`Msg "value is not a blob") + +let head_tree repo = + let* store = store repo in + let* hash = + Store.Ref.resolve store Git.Reference.head >>= Store.read store >>= function + | Git.Value.Commit commit -> + Store.Value.Commit.tree commit |> Lwt_result.return + | _ -> `Msg "no head tree id" |> Lwt_result.fail + in + to_tree store hash + +let tree_of_id repo id = + let* store = store repo in + let hash = Store.Hash.of_hex id in + to_tree store hash + +let blob_of_id repo id = + let* store = store repo in + let hash = Store.Hash.of_hex id in + to_blob store hash diff --git a/lib/views.ml b/lib/views.ml index e65a249..fc211c5 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -11,8 +11,6 @@ type body_data = { } module Components = struct - open Dream_html - module Topnav = struct type t = None | Summary | Log | Files | Refs @@ -36,23 +34,21 @@ module Components = struct end module Page = struct - open Dream_html - open HTML - - let header title subtitle = - let subtitle = - if String.starts_with ~prefix:"Unnamed repository" subtitle then "" - else subtitle + let page_header header1 header2 = + let header2 = + if String.starts_with ~prefix:"Unnamed repository" header2 then "" + else header2 in - null [ h1 [] [ txt "%s" title ]; h2 [] [ txt "%s" subtitle ] ] + HTML.(null [ h1 [] [ txt "%s" header1 ]; h2 [] [ txt "%s" header2 ] ]) - let footer () = + let page_footer () = let today = Unix.localtime (Unix.time ()) in let year = string_of_int (today.Unix.tm_year + 1900) in let footer_text = Printf.sprintf "Copyright %s %s" year config.user in - footer [] [ txt "%s" footer_text ] + HTML.footer [] [ txt "%s" footer_text ] let render ?(page_title = "Ogit") body_data = + let open HTML in html [] [ head [] @@ -64,10 +60,10 @@ module Page = struct ]; body [] [ - header body_data.title body_data.subtitle; + page_header body_data.title body_data.subtitle; body_data.topnav; div [ id "main" ] body_data.content; - footer (); + page_footer (); ]; ] end @@ -76,7 +72,7 @@ let root () = let all_repositories = let repos = Sys.readdir config.git_project_root - |> Array.to_list (* |> List.sort String.compare *) + |> Array.to_list |> List.sort String.compare in let li_of_repo repo = HTML.li [] [ Routes.link_to (Routes.Repo repo) (txt "%s" repo) ] @@ -94,7 +90,7 @@ let root () = respond @@ Page.render body_data module Repo = struct - open Git_presenters + open Resolvers let page_title repo = Printf.sprintf "%s — %s" repo (repo_description repo) let li_of_author author = HTML.(li [] [ txt "%s" author ]) @@ -242,29 +238,30 @@ module Repo = struct end let error_page message = - HTML.( - html [] - [ - head [] - [ - title [] "Fatal error"; - link [ rel "stylesheet"; href "/static/styles.css" ]; - link - [ rel "icon"; type_ "image/x-icon"; href "/static/git_icon.svg" ]; - ]; - body [] - [ - h1 [] [ txt "Fatal Error" ]; - div - [ id "main" ] - [ - p [] [ b [] [ txt "%s" message ] ]; - p [] - [ - txt - "Your best course of action is to press the 'back' \ - button in your browser."; - ]; - ]; - ]; - ]) + let open HTML in + respond + @@ html [] + [ + head [] + [ + title [] "Fatal error"; + link [ rel "stylesheet"; href "/static/styles.css" ]; + link + [ rel "icon"; type_ "image/x-icon"; href "/static/git_icon.svg" ]; + ]; + body [] + [ + h1 [] [ txt "Fatal Error" ]; + div + [ id "main" ] + [ + p [] [ b [] [ txt "%s" message ] ]; + p [] + [ + txt + "Your best course of action is to press the 'back' \ + button in your browser."; + ]; + ]; + ]; + ] -- cgit v1.2.3