aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-data-service/web/repository/controller.scm113
-rw-r--r--guix-data-service/web/repository/html.scm27
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"))