diff options
| -rw-r--r-- | guix-data-service/web/controller.scm | 255 | ||||
| -rw-r--r-- | guix-data-service/web/server.scm | 21 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 11 | ||||
| -rw-r--r-- | scripts/guix-data-service.in | 158 |
4 files changed, 250 insertions, 195 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index b344101..b6ecfa7 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -71,6 +71,7 @@ #:use-module (guix-data-service web repository controller) #:use-module (guix-data-service web package controller) #:export (%show-error-details + handle-static-assets controller)) (define cache-control-default-max-age @@ -513,16 +514,26 @@ (define* (controller request method-and-path-components mime-types body - secret-key-base) - (define (controller-thunk) + secret-key-base + startup-completed?) + (define (running-controller-thunk) (actual-controller request method-and-path-components mime-types body secret-key-base)) + (define (startup-controller-thunk) + (or + (base-controller request method-and-path-components) + (render-html + #:sxml (server-starting-up-page) + #:code 503))) + (call-with-error-handling - controller-thunk + (if startup-completed? + running-controller-thunk + startup-controller-thunk) #:on-error 'backtrace #:post-error (lambda args (render-html #:sxml (error-page @@ -531,51 +542,8 @@ #f)) #:code 500)))) -(define (actual-controller request - method-and-path-components - mime-types - body - secret-key-base) - (define path - (uri-path (request-uri request))) - - (define (delegate-to f) - (or (f request - method-and-path-components - mime-types - body) - (render-html - #:sxml (general-not-found - "Page not found" - "") - #:code 404))) - - (define (delegate-to-with-secret-key-base f) - (or (f request - method-and-path-components - mime-types - body - secret-key-base) - (render-html - #:sxml (general-not-found - "Page not found" - "") - #:code 404))) - +(define (base-controller request method-and-path-components) (match method-and-path-components - (('GET) - (render-html - #:sxml (index - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (map - (lambda (git-repository-details) - (cons - git-repository-details - (all-branches-with-most-recent-commit - conn (first git-repository-details)))) - (all-git-repositories conn)))))))) (('GET "assets" rest ...) (or (handle-static-assets (string-join rest "/") (request-headers request)) @@ -610,75 +578,124 @@ "README not found" "The README.html file does not exist") #:code 404)))) - (('GET "builds") - (delegate-to build-controller)) - (('GET "statistics") - (letpar& ((guix-revisions-count - (with-thread-postgresql-connection count-guix-revisions)) - (count-derivations - (with-thread-postgresql-connection count-derivations))) - - (render-html - #:sxml (view-statistics guix-revisions-count - count-derivations)))) - (('GET "metrics") - (render-metrics)) - (('GET "revision" args ...) - (delegate-to revision-controller)) - (('GET "repositories") - (delegate-to repository-controller)) - (('GET "repository" _ ...) - (delegate-to repository-controller)) - (('GET "package" _ ...) - (delegate-to package-controller)) - (('GET "gnu" "store" filename) - ;; These routes are a little special, as the extensions aren't used for - ;; content negotiation, so just use the path from the request - (let ((path (uri-path (request-uri request)))) - (if (string-suffix? ".drv" path) - (render-derivation (uri-decode path)) - (render-store-item (uri-decode path))))) - (('GET "gnu" "store" filename "formatted") - (if (string-suffix? ".drv" filename) - (render-formatted-derivation (string-append "/gnu/store/" filename)) - (render-html - #:sxml (general-not-found - "Not a derivation" - "The formatted display is only for derivations, where the filename ends in .drv") - #:code 404))) - (('GET "gnu" "store" filename "plain") - (if (string-suffix? ".drv" filename) - (let ((raw-drv - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-serialized-derivation-by-file-name - conn - (string-append "/gnu/store/" filename))))))) - (if raw-drv - (render-text raw-drv) - (not-found (request-uri request)))) - (not-found (request-uri request)))) - (('GET "gnu" "store" filename "narinfos") - (render-narinfos filename)) - (('GET "gnu" "store" filename "json") - (if (string-suffix? ".drv" filename) - (render-json-derivation (string-append "/gnu/store/" filename)) - (render-json-store-item (string-append "/gnu/store/" filename)))) - (('GET "build-servers") - (delegate-to-with-secret-key-base build-server-controller)) - (('GET "dumps" _ ...) - (delegate-to dumps-controller)) - (((or 'GET 'POST) "build-server" _ ...) - (delegate-to-with-secret-key-base build-server-controller)) - (('GET "compare" _ ...) (delegate-to compare-controller)) - (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller)) - (('GET "jobs" _ ...) (delegate-to jobs-controller)) - (('GET "job" job-id) (delegate-to jobs-controller)) - (('GET _ ...) (delegate-to nar-controller)) - ((method path ...) - (render-html - #:sxml (general-not-found - "Page not found" - "") - #:code 404)))) + ((method path ...) #f))) + +(define (actual-controller request + method-and-path-components + mime-types + body + secret-key-base) + (define path + (uri-path (request-uri request))) + + (define (delegate-to f) + (or (f request + method-and-path-components + mime-types + body) + (render-html + #:sxml (general-not-found + "Page not found" + "") + #:code 404))) + + (define (delegate-to-with-secret-key-base f) + (or (f request + method-and-path-components + mime-types + body + secret-key-base) + (render-html + #:sxml (general-not-found + "Page not found" + "") + #:code 404))) + + (or + (base-controller request method-and-path-components) + (match method-and-path-components + (('GET) + (render-html + #:sxml (index + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (map + (lambda (git-repository-details) + (cons + git-repository-details + (all-branches-with-most-recent-commit + conn (first git-repository-details)))) + (all-git-repositories conn)))))))) + (('GET "builds") + (delegate-to build-controller)) + (('GET "statistics") + (letpar& ((guix-revisions-count + (with-thread-postgresql-connection count-guix-revisions)) + (count-derivations + (with-thread-postgresql-connection count-derivations))) + + (render-html + #:sxml (view-statistics guix-revisions-count + count-derivations)))) + (('GET "metrics") + (render-metrics)) + (('GET "revision" args ...) + (delegate-to revision-controller)) + (('GET "repositories") + (delegate-to repository-controller)) + (('GET "repository" _ ...) + (delegate-to repository-controller)) + (('GET "package" _ ...) + (delegate-to package-controller)) + (('GET "gnu" "store" filename) + ;; These routes are a little special, as the extensions aren't used for + ;; content negotiation, so just use the path from the request + (let ((path (uri-path (request-uri request)))) + (if (string-suffix? ".drv" path) + (render-derivation (uri-decode path)) + (render-store-item (uri-decode path))))) + (('GET "gnu" "store" filename "formatted") + (if (string-suffix? ".drv" filename) + (render-formatted-derivation (string-append "/gnu/store/" filename)) + (render-html + #:sxml (general-not-found + "Not a derivation" + "The formatted display is only for derivations, where the filename ends in .drv") + #:code 404))) + (('GET "gnu" "store" filename "plain") + (if (string-suffix? ".drv" filename) + (let ((raw-drv + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-serialized-derivation-by-file-name + conn + (string-append "/gnu/store/" filename))))))) + (if raw-drv + (render-text raw-drv) + (not-found (request-uri request)))) + (not-found (request-uri request)))) + (('GET "gnu" "store" filename "narinfos") + (render-narinfos filename)) + (('GET "gnu" "store" filename "json") + (if (string-suffix? ".drv" filename) + (render-json-derivation (string-append "/gnu/store/" filename)) + (render-json-store-item (string-append "/gnu/store/" filename)))) + (('GET "build-servers") + (delegate-to-with-secret-key-base build-server-controller)) + (('GET "dumps" _ ...) + (delegate-to dumps-controller)) + (((or 'GET 'POST) "build-server" _ ...) + (delegate-to-with-secret-key-base build-server-controller)) + (('GET "compare" _ ...) (delegate-to compare-controller)) + (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller)) + (('GET "jobs" _ ...) (delegate-to jobs-controller)) + (('GET "job" job-id) (delegate-to jobs-controller)) + (('GET _ ...) (delegate-to nar-controller)) + ((method path ...) + (render-html + #:sxml (general-not-found + "Page not found" + "") + #:code 404))))) diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm index 05c0a58..599288c 100644 --- a/guix-data-service/web/server.scm +++ b/guix-data-service/web/server.scm @@ -24,12 +24,22 @@ #:use-module (web request) #:use-module (web uri) #:use-module (system repl error-handling) + #:use-module (ice-9 atomic) #:use-module (fibers web server) #:use-module (guix-data-service web controller) #:use-module (guix-data-service web util) #:export (start-guix-data-service-web-server)) -(define (handler request body controller secret-key-base) +(define (check-startup-completed startup-completed) + (if (atomic-box-ref startup-completed) + (begin + ;; Just in case this atomic-box-ref is expensive, only do it when + ;; necessary + (set! check-startup-completed (const #t)) + #t) + #f)) + +(define (handler request body controller secret-key-base startup-completed) (display (format #f "~a ~a\n" (request-method request) @@ -42,14 +52,17 @@ request-components) mime-types body - secret-key-base)))) + secret-key-base + (check-startup-completed startup-completed))))) -(define* (start-guix-data-service-web-server port host secret-key-base) +(define* (start-guix-data-service-web-server port host secret-key-base + startup-completed) (call-with-error-handling (lambda () (run-server (lambda (request body) (handler request body controller - secret-key-base)) + secret-key-base + startup-completed)) #:host host #:port port)) #:on-error 'backtrace diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 3f2c2ae..db1cdc4 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -50,7 +50,8 @@ view-narinfos view-store-item view-derivation-source-file - error-page)) + error-page + server-starting-up-page)) (define* (header) `(nav @@ -1004,3 +1005,11 @@ `((b ,key) (pre ,args)))) '()))))) + +(define* (server-starting-up-page) + (layout + #:body + `(,(header) + (div (@ (class "container")) + (h1 "Server is starting up") + (p "Database migrations are running, this can take some time."))))) diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index 3e80f03..e0b35c6 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -26,6 +26,8 @@ (use-modules (srfi srfi-1) (srfi srfi-37) (ice-9 match) + (ice-9 atomic) + (ice-9 threads) (ice-9 textual-ports) (system repl server) (system repl repl) @@ -137,63 +139,6 @@ (when repl-port (spawn-server (make-tcp-server-socket #:port repl-port)))) - (when (assoc-ref opts 'update-database) - (let ((command - (list (%config 'sqitch) - "deploy" - "--db-client" (%config 'sqitch-psql) - ;; For some reason, sqitch behaves differently when the - ;; guix-data-service is packaged, and when it's not, so try - ;; and hack around this here. - "--chdir" (let ((base (dirname (%config 'sqitch-plan)))) - (if (string-prefix? "/gnu" (%config 'sqitch-plan)) - base - (dirname base))) - "--plan-file" (%config 'sqitch-plan) - "--mode" "change" ; this helps when migrations don't - ; have the revert bit implemented - (let* ((database-config (get-database-config)) - (params (string-join - (map - (match-lambda - ((key . val) - (string-append key "=" val))) - (filter - (match-lambda - ((key . _) - (not (member key '("user" - "host" - "dbname"))))) - database-config)) - "&"))) - (string-append "db:pg://" - (assoc-ref database-config "user") - "@" - (if (string=? (assoc-ref database-config "host") - "localhost") - "" ; This means the unix socket - ; connection will be used - (assoc-ref database-config "host")) - "/" - (assoc-ref database-config "dbname") - (if (string-null? params) - "" - "?") - params))))) - (simple-format #t "running command: ~A\n" - (string-join command)) - (unless (zero? (apply system* command)) - (simple-format - (current-error-port) - "error: sqitch command failed\n") - (exit 1)))) - - (let ((pid-file (assq-ref opts 'pid-file))) - (when pid-file - (call-with-output-file pid-file - (lambda (port) - (simple-format port "~A\n" (getpid)))))) - (parameterize ((%narinfo-signing-public-key (catch 'system-error @@ -228,20 +173,91 @@ (%show-error-details (assoc-ref opts 'show-error-details))) - (start-substitute-query-thread) + (let* ((startup-completed + (make-atomic-box + (if (assoc-ref opts 'update-database) + #f + #t))) + (server-thread + (call-with-new-thread + (lambda () + (with-postgresql-connection-per-thread + "web" + (lambda () + ;; Provide some visual space between the startup output and the server + ;; starting + (simple-format #t "\n\nStarting the server on http://~A:~A/\n\n" + (assq-ref opts 'host) + (assq-ref opts 'port)) - ;; Provide some visual space between the startup output and the server - ;; starting - (simple-format #t "\n\nStarting the server on http://~A:~A/\n\n" + (start-guix-data-service-web-server + (assq-ref opts 'port) (assq-ref opts 'host) - (assq-ref opts 'port)) + (assq-ref opts 'secret-key-base) + startup-completed)) + #:statement-timeout + (assq-ref opts 'postgresql-statement-timeout))))) - (with-postgresql-connection-per-thread - "web" - (lambda () - (start-guix-data-service-web-server - (assq-ref opts 'port) - (assq-ref opts 'host) - (assq-ref opts 'secret-key-base))) - #:statement-timeout - (assq-ref opts 'postgresql-statement-timeout)))) + (pid-file (assq-ref opts 'pid-file))) + + (when pid-file + (call-with-output-file pid-file + (lambda (port) + (simple-format port "~A\n" (getpid))))) + + (when (assoc-ref opts 'update-database) + (let ((command + (list (%config 'sqitch) + "deploy" + "--db-client" (%config 'sqitch-psql) + ;; For some reason, sqitch behaves differently when the + ;; guix-data-service is packaged, and when it's not, so try + ;; and hack around this here. + "--chdir" (let ((base (dirname (%config 'sqitch-plan)))) + (if (string-prefix? "/gnu" (%config 'sqitch-plan)) + base + (dirname base))) + "--plan-file" (%config 'sqitch-plan) + "--mode" "change" ; this helps when migrations don't + ; have the revert bit implemented + (let* ((database-config (get-database-config)) + (params (string-join + (map + (match-lambda + ((key . val) + (string-append key "=" val))) + (filter + (match-lambda + ((key . _) + (not (member key '("user" + "host" + "dbname"))))) + database-config)) + "&"))) + (string-append "db:pg://" + (assoc-ref database-config "user") + "@" + (if (string=? (assoc-ref database-config "host") + "localhost") + "" ; This means the unix socket + ; connection will be used + (assoc-ref database-config "host")) + "/" + (assoc-ref database-config "dbname") + (if (string-null? params) + "" + "?") + params))))) + (simple-format #t "running command: ~A\n" + (string-join command)) + (unless (zero? (apply system* command)) + (simple-format + (current-error-port) + "error: sqitch command failed\n") + (exit 1)) + + (atomic-box-set! startup-completed #t))) + + (start-substitute-query-thread) + + (join-thread server-thread)))) |