Add first version of a page with the history of package derivations

Some filtering options need adding for the system and target, as it's
currently hardcoded, but the general page does work.

3 files changed, 232 insertions, 2 deletions

diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm
index c1cd2ae..0253a5a 100644
--- a/guix-data-service/model/package.scm
+++ b/guix-data-service/model/package.scm
@@ -12,7 +12,8 @@
             inferior-packages->package-ids
 
             select-package-versions-for-revision
-            package-versions-for-branch))
+            package-versions-for-branch
+            package-derivations-for-branch))
 
 (define (select-existing-package-entries package-entries)
   (string-append "SELECT id, packages.name, packages.version, "
@@ -236,3 +237,44 @@ ORDER BY first_datetime DESC, package_version DESC"
          (number->string git-repository-id)
          branch-name)))
 
+(define (package-derivations-for-branch conn
+                                        git-repository-id
+                                        branch-name
+                                        system
+                                        target
+                                        package-name)
+  (exec-query
+   conn
+   "
+SELECT package_version,
+       derivations.file_name,
+       first_guix_revisions.commit AS first_guix_revision_commit,
+       first_git_branches.datetime AS first_datetime,
+       last_guix_revisions.commit AS last_guix_revision_commit,
+       last_git_branches.datetime AS last_datetime
+FROM package_derivations_by_guix_revision_range
+INNER JOIN derivations
+  ON package_derivations_by_guix_revision_range.derivation_id = derivations.id
+INNER JOIN guix_revisions AS first_guix_revisions
+  ON first_guix_revision_id = first_guix_revisions.id
+INNER JOIN git_branches AS first_git_branches
+  ON first_guix_revisions.git_repository_id = first_git_branches.git_repository_id
+ AND first_guix_revisions.commit = first_git_branches.commit
+INNER JOIN guix_revisions AS last_guix_revisions
+  ON last_guix_revision_id = last_guix_revisions.id
+INNER JOIN git_branches AS last_git_branches
+  ON last_guix_revisions.git_repository_id = last_git_branches.git_repository_id
+ AND last_guix_revisions.commit = last_git_branches.commit
+WHERE package_name = $1
+AND package_derivations_by_guix_revision_range.git_repository_id = $2
+AND package_derivations_by_guix_revision_range.branch_name = $3
+AND first_git_branches.name = $3
+AND last_git_branches.name = $3
+AND package_derivations_by_guix_revision_range.system = $4
+AND package_derivations_by_guix_revision_range.target = $5
+ORDER BY first_datetime DESC, package_version DESC"
+   (list package-name
+         (number->string git-repository-id)
+         branch-name
+         system
+         target)))
diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm
index 23e3559..cdc89d6 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -111,6 +111,42 @@
                    branch-name
                    package-name
                    package-versions))))))
+    (('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history")
+     (let ((package-derivations
+            (package-derivations-for-branch conn
+                                            (string->number repository-id)
+                                            branch-name
+                                            "x86_64-linux"
+                                            "x86_64-linux"
+                                            package-name)))
+       (case (most-appropriate-mime-type
+              '(application/json text/html)
+              mime-types)
+         ((application/json)
+          (render-json
+           `((versions . ,(list->vector
+                           (map (match-lambda
+                                  ((package-version derivation-file-name
+                                                    first-guix-revision-commit
+                                                    first-datetime
+                                                    last-guix-revision-commit
+                                                    last-datetime)
+                                   `((version . ,package-version)
+                                     (derivation . ,derivation-file-name)
+                                     (first_revision
+                                      . ((commit . ,first-guix-revision-commit)
+                                         (datetime . ,first-datetime)))
+                                     (last_revision
+                                      . ((commit . ,last-guix-revision-commit)
+                                         (datetime . ,last-datetime))))))
+                                package-versions))))))
+         (else
+          (render-html
+           #:sxml (view-branch-package-derivations
+                   repository-id
+                   branch-name
+                   package-name
+                   package-derivations))))))
     (('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
      (let ((commit-hash
             (latest-processed-commit-for-branch conn repository-id branch-name)))
diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm
index 43f3df7..129279d 100644
--- a/guix-data-service/web/repository/html.scm
+++ b/guix-data-service/web/repository/html.scm
@@ -23,7 +23,8 @@
   #:export (view-git-repository
             view-branches
             view-branch
-            view-branch-package))
+            view-branch-package
+            view-branch-package-derivations))
 
 (define* (view-git-repository git-repository-id
                               label url cgit-url-base
@@ -277,3 +278,154 @@
                                 (rationalize margin-left 1)
                                 (rationalize width 1)))))))))))
                versions-by-revision-range))))))))))
+
+(define (view-branch-package-derivations git-repository-id
+                                         branch-name
+                                         package-name
+                                         derivations-by-revision-range)
+  (define versions-list
+    (pair-fold (match-lambda*
+                 (((last) (count result ...))
+                  (cons (cons last count)
+                        result))
+                 (((a b rst ...) (count result ...))
+                  (peek a b)
+                  (if (string=? a b)
+                      (cons (+ 1 count)
+                            (cons #f result))
+                      (cons 1
+                            (cons (cons a count)
+                                  result)))))
+               '(1)
+               (reverse
+                (map first derivations-by-revision-range))))
+
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (a (@ (href ,(string-append "/repository/" git-repository-id)))
+           (h3 "Repository"))
+        (a (@ (href ,(string-append "/repository/" git-repository-id
+                                    "/branch/" branch-name)))
+           (h3 ,(string-append branch-name " branch")))
+        (a (@ (class "btn btn-default btn-lg pull-right")
+              (href ,(string-append
+                      "/repository/" git-repository-id
+                      "/branch/" branch-name
+                      "/package/" package-name
+                      ".json")))
+           "View JSON")
+        (h1 (@ (style "white-space: nowrap;"))
+            (samp ,package-name))))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-12"))
+        (table
+         (@ (class "table")
+            (style "table-layout: fixed;"))
+         (thead
+          (tr
+           (th (@ (class "col-sm-3")) "Version")
+           (th (@ (class "col-sm-5")) "Derivation")
+           (th (@ (class "col-sm-4")) "From")
+           (th (@ (class "col-sm-4")) "To")))
+         (tbody
+          ,@(let* ((times-in-seconds
+                    (map (lambda (d)
+                           (time-second
+                            (date->time-monotonic
+                             (string->date d "~Y-~m-~d ~H:~M:~S"))))
+                         (append (map fourth derivations-by-revision-range)
+                                 (map sixth derivations-by-revision-range))))
+                   (earliest-date-seconds
+                    (apply min
+                           times-in-seconds))
+                   (latest-date-seconds
+                    (apply max
+                           times-in-seconds))
+                   (min-to-max-seconds
+                    (- latest-date-seconds
+                       earliest-date-seconds)))
+              (map
+               (match-lambda*
+                 ((version-column-entry
+                   (package-version derivation-file-name
+                                    first-guix-revision-commit
+                                    first-datetime
+                                    last-guix-revision-commit
+                                    last-datetime))
+                  `((tr
+                     (@ (style "border-bottom: 0;"))
+                     ,@(match version-column-entry
+                         (#f '())
+                         ((package-version . rowspan)
+                          `((td (@ (rowspan ,(* 2 ; To account for the extra rows
+                                                rowspan)))
+                                ,package-version))))
+                     (td
+                      (a (@ (href ,derivation-file-name))
+                         ,(display-store-item-short derivation-file-name)))
+                     (td (a (@ (href ,(string-append
+                                       "/revision/" first-guix-revision-commit)))
+                            ,first-datetime)
+                         (br)
+                         (a (@ (href ,(string-append
+                                       "/revision/"
+                                       first-guix-revision-commit
+                                       "/package/"
+                                       package-name "/" package-version)))
+                            "(More information)"))
+                     (td (a (@ (href ,(string-append
+                                       "/revision/" last-guix-revision-commit)))
+                            ,last-datetime)
+                         (br)
+                         (a (@ (href ,(string-append
+                                       "/revision/"
+                                       last-guix-revision-commit
+                                       "/package/"
+                                       package-name "/" package-version)))
+                            "(More information)")))
+                    (tr
+                     (td
+                      (@ (colspan 3)
+                         (style "border-top: 0; padding-top: 0;"))
+                      (div
+                       (@
+                        (style
+                            ,(let* ((start-seconds
+                                     (time-second
+                                      (date->time-monotonic
+                                       (string->date first-datetime
+                                                     "~Y-~m-~d ~H:~M:~S"))))
+                                    (end-seconds
+                                     (time-second
+                                      (date->time-monotonic
+                                       (string->date last-datetime
+                                                     "~Y-~m-~d ~H:~M:~S"))))
+                                    (margin-left
+                                     (min
+                                      (* (/ (- start-seconds earliest-date-seconds)
+                                            min-to-max-seconds)
+                                         100)
+                                      98))
+                                    (width
+                                     (max
+                                      (- (* (/ (- end-seconds earliest-date-seconds)
+                                               min-to-max-seconds)
+                                            100)
+                                         margin-left)
+                                      2)))
+                               (simple-format
+                                #f
+                                "margin-left: ~A%; width: ~A%; height: 10px; background: #DCDCDC;"
+                                (rationalize margin-left 1)
+                                (rationalize width 1)))))))))))
+               versions-list
+               derivations-by-revision-range))))))))))