Implement Tree and Blob views.

Getting real close to something good now!

4 files changed, 101 insertions, 57 deletions

diff --git a/lib/git_presenters.ml b/lib/git_presenters.ml
index f0a0317..215e9c5 100644
--- a/lib/git_presenters.ml
+++ b/lib/git_presenters.ml
@@ -3,6 +3,7 @@
 module Store = Git_unix.Store
 open Lwt_result.Syntax
 open Config
+open Lwt_result.Infix
 
 let full_path path = Filename.concat config.git_project_root path
 
@@ -69,8 +70,10 @@ let all_branches repo =
   let* refs = Store.Ref.list store in
   let branches =
     List.map
-      (fun (ref, hash) ->
-        { name = Git.Reference.to_string ref; hash = Store.Hash.to_hex hash })
+      (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
@@ -83,37 +86,45 @@ type tree_entry = {
 }
 
 type tree = { hash : string; short_hash : string; entries : tree_entry list }
-
-let to_entry _ =
-  {
-    hash = "foo";
-    short_hash = String.sub "foobar" 0 8;
-    name = "foobarbino";
-    perm = 122;
-  }
+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 present_tree tree = Store.Value.Tree.to_list tree |> List.map to_entry
 
 let to_tree store hash =
-  let* v = Store.read store hash in
-  match v with
+  Store.read store hash >>= function
   | Git.Value.Tree tree ->
       let hash = Store.Hash.to_hex hash in
-      Lwt_result.return
-        { hash; short_hash = String.sub hash 0 8; entries = present_tree tree }
-  | _ ->
-      Dream.log "Value is not a tree";
-      Lwt_result.fail (`Msg "value is not a tree")
+      let short_hash = String.sub hash 0 8 in
+      let entries = present_tree tree 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 tree")
 
 let head_tree_id store =
-  let* commit_hash = Store.Ref.resolve store Git.Reference.head in
-  let* v = Store.read store commit_hash in
-  match v with
+  Store.Ref.resolve store Git.Reference.head >>= Store.read store >>= function
   | Git.Value.Commit commit ->
       Store.Value.Commit.tree commit |> Lwt_result.return
-  | _ ->
-      Dream.log "no head tree id";
-      Lwt_result.fail (`Msg "")
+  | _ -> `Msg "no head tree id" |> Lwt_result.fail
 
 let head_tree repo =
   let* store = store repo in
@@ -124,3 +135,8 @@ let tree_of_id repo id =
   let* store = store repo in
   let* hash = Lwt_result.return (Store.Hash.of_hex id) in
   to_tree store hash
+
+let blob_of_id repo id =
+  let* store = store repo in
+  let* hash = Lwt_result.return (Store.Hash.of_hex id) in
+  to_blob store hash
diff --git a/lib/handlers.ml b/lib/handlers.ml
index 17f3ac0..21d3ea8 100644
--- a/lib/handlers.ml
+++ b/lib/handlers.ml
@@ -31,16 +31,19 @@ module Repo = struct
     Views.Repo.log (repo req) commits |> Dream_html.respond
 
   let tree_head req =
-    Dream.log "Tree head";
     let* tree = head_tree (repo req) in
     Views.Repo.tree (repo req) tree |> Dream_html.respond
 
   let tree_id req =
-    Dream.log "Tree id";
     let id = id_of_req req in
     let* tree = tree_of_id (repo req) id in
     Views.Repo.tree (repo req) tree |> Dream_html.respond
 
+  let blob_id req =
+    let id = id_of_req req in
+    let* blob = blob_of_id (repo req) id in
+    Views.Repo.blob (repo req) blob |> Dream_html.respond
+
   let commit req =
     let id = id_of_req req in
     let* commit = commit_of_id (repo req) id in
@@ -59,6 +62,7 @@ let all_handlers =
             get "/log/" log;
             get "/tree/" tree_head;
             get "/tree/:id" tree_id;
+            get "/blob/:id" blob_id;
             get "/commit/:id" commit;
           ];
       get "/static/**" (static "./lib/static");
diff --git a/lib/routes.ml b/lib/routes.ml
index c136152..84c2851 100644
--- a/lib/routes.ml
+++ b/lib/routes.ml
@@ -1,29 +1,29 @@
 (* -*- mode: tuareg; -*- *)
 
-open Dream_html
-open HTML
-
 type t =
   | Root
   | Repo of string
   | Tag of string * string
   | Commit of string * string
-  | Tree of string * string * string
-  | Blob of string * string * string
+  | Tree of string * string
+  | Blob of string * string
 
 let%path root_path = "/"
 let%path repo_path = "/%s/"
 let%path tag_path = "/%s/refs/%s"
 let%path commit_path = "/%s/commit/%s"
-let%path tree_path = "/%s/tree/%s/%s"
-let%path blob_path = "/%s/blob/%s/%s"
-
-let path_attr = function
-  | Root -> path_attr href root_path
-  | Repo repo -> path_attr href repo_path repo
-  | Tag (repo, branch) -> path_attr href tag_path repo branch
-  | Commit (repo, commit) -> path_attr href commit_path repo commit
-  | Tree (repo, commit, path) -> path_attr href tree_path repo commit path
-  | Blob (repo, commit, path) -> path_attr href blob_path repo commit path
+let%path tree_path = "/%s/tree/%s"
+let%path blob_path = "/%s/blob/%s"
 
-let link_to route content = a [ path_attr route ] [ content ]
+let link_to route contents =
+  let open Dream_html in
+  let open HTML in
+  let path = function
+    | Root -> path_attr href root_path
+    | Repo repo -> path_attr href repo_path repo
+    | Tag (repo, branch) -> path_attr href tag_path repo branch
+    | Commit (repo, commit) -> path_attr href commit_path repo commit
+    | Tree (repo, hash) -> path_attr href tree_path repo hash
+    | Blob (repo, hash) -> path_attr href blob_path repo hash
+  in
+  a [ path route ] [ contents ]
diff --git a/lib/views.ml b/lib/views.ml
index b6cf617..e1056b7 100644
--- a/lib/views.ml
+++ b/lib/views.ml
@@ -1,7 +1,6 @@
 (* -*- mode: tuareg; -*- *)
 
 open Dream_html
-open Git_presenters
 open Config
 
 type body_data = {
@@ -16,9 +15,7 @@ module Components = struct
 
   let topnav repo =
     let open HTML in
-    let () = Dream.log "%s" ("current path is: " ^ repo) in
     let li_of_a (path, text) =
-      let () = Dream.log "%s" ("and path is: " ^ path) in
       let is_active = String.ends_with ~suffix:path repo in
       let attrs = if is_active then [ id "active" ] else [] in
       let url = Printf.sprintf "/%s/%s" repo path in
@@ -98,7 +95,10 @@ let root () =
   Page.render body_data
 
 module Repo = struct
+  open Git_presenters
+
   let page_title repo = Printf.sprintf "%s — %s" repo (repo_description repo)
+  let li_of_author author = HTML.(li [] [ txt "%s" author ])
 
   let li_of_branch repo (branch : branch) =
     HTML.(
@@ -120,17 +120,24 @@ module Repo = struct
                  ]);
           ]
 
+  let li_of_entry repo entry =
+    let display_name =
+      if entry.perm = 0o040000 then entry.name ^ "/" else entry.name
+    in
+    let route =
+      if entry.perm = 0o040000 then Routes.Tree (repo, entry.hash)
+      else Routes.Blob (repo, entry.hash)
+    in
+    HTML.(li [] [ Routes.link_to route @@ txt "%s" display_name ])
+
   let summary repo branches commits authors =
-    let li_of_branch = li_of_branch repo in
-    let li_of_commit = li_of_commit repo in
-    let li_of_author author = HTML.(li [] [ txt "%s" author ]) in
     let content =
       HTML.
         [
           h3 [] [ txt "Branches" ];
-          ul [] (List.map li_of_branch branches);
+          ul [] (List.map (li_of_branch repo) branches);
           h3 [] [ txt "Recent commits" ];
-          ul [] (List.map li_of_commit commits);
+          ul [] (List.map (li_of_commit repo) commits);
           h3 [] [ txt "Authors" ];
           ul [] (List.map li_of_author authors);
         ]
@@ -144,9 +151,12 @@ module Repo = struct
       }
 
   let refs repo branches =
-    let li_of_branch = li_of_branch repo in
     let content =
-      HTML.[ h3 [] [ txt "Branches" ]; ul [] (List.map li_of_branch branches) ]
+      HTML.
+        [
+          h3 [] [ txt "Branches" ];
+          ul [] (List.map (li_of_branch repo) branches);
+        ]
     in
     Page.render ~page_title:(page_title repo)
       {
@@ -157,10 +167,12 @@ module Repo = struct
       }
 
   let log repo commits =
-    let li_of_commit = li_of_commit repo in
     let content =
       HTML.
-        [ h3 [] [ txt "All commits" ]; ul [] (List.map li_of_commit commits) ]
+        [
+          h3 [] [ txt "All commits" ];
+          ul [] (List.map (li_of_commit repo) commits);
+        ]
     in
     Page.render ~page_title:(page_title repo)
       {
@@ -171,13 +183,12 @@ module Repo = struct
       }
 
   let tree repo tree =
-    let title = Printf.sprintf "%s : %s" repo tree.short_hash in
-    let li_of_entry entry = HTML.(li [] [ txt "%s" entry.name ]) in
+    let title = Printf.sprintf "%s" repo in
     let content =
       HTML.
         [
           h3 [] [ txt "Tree %s" tree.short_hash ];
-          ul [] (List.map li_of_entry tree.entries);
+          ul [] (List.map (li_of_entry repo) tree.entries);
         ]
     in
     Page.render ~page_title:(page_title repo)
@@ -188,6 +199,19 @@ module Repo = struct
         content;
       }
 
+  let blob repo blob =
+    let title = Printf.sprintf "%s" repo in
+    let content =
+      HTML.[ h3 [] [ txt "Blob" ]; p [] [ txt "%s" blob.content ] ]
+    in
+    Page.render ~page_title:(page_title repo)
+      {
+        title;
+        subtitle = repo_description repo;
+        topnav = Components.topnav repo;
+        content;
+      }
+
   let commit repo commit =
     let message = match commit.message with Some msg -> msg | None -> "" in
     let title = Printf.sprintf "%s : %s" repo commit.short_hash in
@@ -207,7 +231,7 @@ let error_page message =
       [
         head []
           [
-            title [] "Fatal Error";
+            title [] "Fatal error";
             link [ rel "stylesheet"; href "/static/styles.css" ];
             link
               [ rel "icon"; type_ "image/x-icon"; href "/static/git_icon.svg" ];