Don't hardcode the system and target for the derivation history page

2 files changed, 95 insertions, 45 deletions

diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm
index e77b574..30e7ffd 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -24,6 +24,7 @@
   #:use-module (guix-data-service web util)
   #:use-module (guix-data-service model utils)
   #:use-module (guix-data-service model build-server)
+  #:use-module (guix-data-service model derivation)
   #:use-module (guix-data-service model package)
   #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service model git-repository)
@@ -114,7 +115,8 @@
                    package-name
                    package-versions))))))
     (('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history")
-     (render-branch-package-derivation-history mime-types
+     (render-branch-package-derivation-history request
+                                               mime-types
                                                conn
                                                repository-id
                                                branch-name
@@ -229,50 +231,73 @@
                                     commit-hash))))
     (_ #f)))
 
-(define (render-branch-package-derivation-history mime-types
+(define (parse-build-system conn)
+  (let ((systems
+         (valid-systems conn)))
+    (lambda (s)
+      (if (member s systems)
+          s
+          (make-invalid-query-parameter
+           s "unknown system")))))
+
+(define (render-branch-package-derivation-history request
+                                                  mime-types
                                                   conn
                                                   repository-id
                                                   branch-name
                                                   package-name)
-  (let ((package-derivations
-         (package-derivations-for-branch conn
-                                         (string->number repository-id)
-                                         branch-name
-                                         "x86_64-linux"
-                                         "x86_64-linux"
-                                         package-name))
-        (build-server-urls
-         (group-to-alist
-          (match-lambda
-            ((id url lookup-all-derivations)
-             (cons id url)))
-          (select-build-servers conn))))
-    (case (most-appropriate-mime-type
-           '(application/json text/html)
-           mime-types)
-      ((application/json)
-       (render-json
-        `((derivations . ,(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-derivations))))))
-      (else
-       (render-html
-        #:sxml (view-branch-package-derivations
-                repository-id
-                branch-name
-                package-name
-                build-server-urls
-                package-derivations))))))
+  (let ((parsed-query-parameters
+         (parse-query-parameters
+          request
+          `((system  ,(parse-build-system conn)
+                     #:default "x86_64-linux")
+            (target  ,(parse-build-system conn)
+                     #:default "x86_64-linux")))))
+    (let* ((system
+            (assq-ref parsed-query-parameters 'system))
+           (target
+            (assq-ref parsed-query-parameters 'target))
+           (package-derivations
+            (package-derivations-for-branch conn
+                                            (string->number repository-id)
+                                            branch-name
+                                            system
+                                            target
+                                            package-name))
+           (build-server-urls
+           (group-to-alist
+            (match-lambda
+              ((id url lookup-all-derivations)
+               (cons id url)))
+            (select-build-servers conn))))
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          `((derivations . ,(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-derivations))))))
+        (else
+         (render-html
+          #:sxml (view-branch-package-derivations
+                  parsed-query-parameters
+                  repository-id
+                  branch-name
+                  package-name
+                  (valid-systems conn)
+                  build-server-urls
+                  package-derivations)))))))
diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm
index 37aaadc..4503f08 100644
--- a/guix-data-service/web/repository/html.scm
+++ b/guix-data-service/web/repository/html.scm
@@ -290,9 +290,11 @@
                                 (rationalize width 1)))))))))))
                versions-by-revision-range))))))))))
 
-(define (view-branch-package-derivations git-repository-id
+(define (view-branch-package-derivations query-parameters
+                                         git-repository-id
                                          branch-name
                                          package-name
+                                         valid-systems
                                          build-server-urls
                                          derivations-by-revision-range)
   (define versions-list
@@ -335,6 +337,29 @@
         (h1 (@ (style "white-space: nowrap;"))
             (samp ,package-name))))
       (div
+       (@ (class "col-md-12"))
+       (div
+        (@ (class "well"))
+        (form
+         (@ (method "get")
+            (action "")
+            (class "form-horizontal"))
+         ,(form-horizontal-control
+           "System" query-parameters
+           #:options valid-systems
+           #:allow-selecting-multiple-options #f
+           #:help-text "Show derivations with this system.")
+         ,(form-horizontal-control
+           "Target" query-parameters
+           #:options valid-systems
+           #:allow-selecting-multiple-options #f
+           #:help-text "Show derivations with this target.")
+         (div (@ (class "form-group form-group-lg"))
+              (div (@ (class "col-sm-offset-2 col-sm-10"))
+                   (button (@ (type "submit")
+                              (class "btn btn-lg btn-primary"))
+                           "Update results"))))))
+      (div
        (@ (class "row"))
        (div
         (@ (class "col-md-12"))