guix/data-service
2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/data-service.git synced 2023-12-14 03:23:03 +01:00
Code Issues Releases Wiki Activity
data-service/guix-data-service/web/repository/controller.scm

304 lines
14 KiB
Scheme
Raw Normal View History

Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future.
2019-10-14 19:28:25 +02:00
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service web repository controller)
#:use-module (ice-9 match)
Fix various warnings relating to the controller refactoring
2019-10-18 19:44:42 +02:00
#:use-module (web uri)
#:use-module (web request)
Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future.
2019-10-14 19:28:25 +02:00
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
Include builds on the derivation history page
2019-12-22 19:25:11 +01:00
#:use-module (guix-data-service model utils)
#:use-module (guix-data-service model build-server)
Don't hardcode the system and target for the derivation history page
2020-01-05 12:17:39 +01:00
#:use-module (guix-data-service model derivation)
Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future.
2019-10-14 19:28:25 +02:00
#:use-module (guix-data-service model package)
#:use-module (guix-data-service model git-branch)
#:use-module (guix-data-service model git-repository)
Fix various warnings relating to the controller refactoring
2019-10-18 19:44:42 +02:00
#:use-module (guix-data-service web view html)
#:use-module (guix-data-service web revision controller)
Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future.
2019-10-14 19:28:25 +02:00
#:use-module (guix-data-service web repository html)
#:export (repository-controller))
(define (repository-controller request
method-and-path-components
mime-types
body
conn)
Fix various warnings relating to the controller refactoring
2019-10-18 19:44:42 +02:00
(define path
(uri-path (request-uri request)))
Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future.
2019-10-14 19:28:25 +02:00
(match method-and-path-components
(('GET "repository" id)
(match (select-git-repository conn id)
((label url cgit-url-base)
(render-html
#:sxml
(view-git-repository
(string->number id)
label url cgit-url-base
(all-branches-with-most-recent-commit conn
(string->number id)))))
(#f
(render-html
#:sxml (general-not-found
"Repository not found"
"")
#:code 404))))
(('GET "repository" repository-id "branch" branch-name)
(let ((parsed-query-parameters
(parse-query-parameters
request
`((after_date ,parse-datetime)
(before_date ,parse-datetime)
(limit_results ,parse-result-limit #:default 100)))))
(render-html
#:sxml (if (any-invalid-query-parameters? parsed-query-parameters)
(view-branch repository-id
branch-name parsed-query-parameters '())
(view-branch
repository-id
branch-name
parsed-query-parameters
(most-recent-commits-for-branch
conn
(string->number repository-id)
branch-name
#:limit (assq-ref parsed-query-parameters 'limit_results)
#:after-date (assq-ref parsed-query-parameters
'after_date)
#:before-date (assq-ref parsed-query-parameters
'before_date)))))))
(('GET "repository" repository-id "branch" branch-name "package" package-name)
(let ((package-versions
(package-versions-for-branch conn
(string->number repository-id)
branch-name
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 first-guix-revision-commit
first-datetime
last-guix-revision-commit
last-datetime)
`((version . ,package-version)
(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
repository-id
branch-name
package-name
package-versions))))))
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.
2019-11-09 21:07:34 +01:00
(('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history")
Don't hardcode the system and target for the derivation history page
2020-01-05 12:17:39 +01:00
(render-branch-package-derivation-history request
mime-types
Extract out the derivation-history rendering code
2020-01-05 11:32:47 +01:00
conn
repository-id
branch-name
package-name))
Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future.
2019-10-14 19:28:25 +02:00
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
(let ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name)))
(if commit-hash
(render-view-revision mime-types
conn
commit-hash
#:path-base path
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name)))
(render-unknown-revision mime-types
conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages")
(let ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name)))
(if commit-hash
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
request
`((after_name ,identity)
(field ,identity #:multi-value
#:default ("version" "synopsis"))
(search_query ,identity)
(limit_results ,parse-result-limit
#:no-default-when (all_results)
#:default 100)
(all_results ,parse-checkbox-value)))
;; You can't specify a search query, but then also limit the
;; results by filtering for after a particular package name
'((after_name search_query)
(limit_results all_results)))))
(render-revision-packages mime-types
conn
commit-hash
parsed-query-parameters
#:path-base path
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name))
#:header-link
(string-append
"/repository/" repository-id
"/branch/" branch-name
"/latest-processed-revision")))
(render-unknown-revision mime-types
conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision"
"lint-warnings")
(let ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name)))
(if commit-hash
(let ((parsed-query-parameters
(parse-query-parameters
request
`((package_query ,identity)
(linter ,identity #:multi-value)
(message_query ,identity)
(field ,identity #:multi-value
#:default ("linter"
"message"
"location"))))))
(render-revision-lint-warnings mime-types
conn
commit-hash
parsed-query-parameters
#:path-base path
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name))
#:header-link
(string-append
"/repository/" repository-id
"/branch/" branch-name
"/latest-processed-revision")))
(render-unknown-revision mime-types
conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version)
(let ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name)))
(if commit-hash
(render-revision-package-version mime-types
conn
commit-hash
name
version
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name))
#:header-link
(string-append
"/repository/" repository-id
"/branch/" branch-name
Link to the versions page from the latest revision package page
2019-12-27 11:13:34 +01:00
"/latest-processed-revision")
#:version-history-link
(string-append
"/repository/" repository-id
"/branch/" branch-name
"/package/" name))
Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future.
2019-10-14 19:28:25 +02:00
(render-unknown-revision mime-types
conn
Handle unknown requests better within controllers
2019-10-18 18:23:59 +02:00
commit-hash))))
(_ #f)))
Extract out the derivation-history rendering code
2020-01-05 11:32:47 +01:00
Don't hardcode the system and target for the derivation history page
2020-01-05 12:17:39 +01:00
(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
Extract out the derivation-history rendering code
2020-01-05 11:32:47 +01:00
conn
repository-id
branch-name
package-name)
Don't hardcode the system and target for the derivation history page
2020-01-05 12:17:39 +01:00
(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)))))))
Copy permalink