guix-data-service/guix-data-service/model/build-server.scm

;;; 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 model build-server)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (squee)
  #:use-module (guix-data-service database)
  #:use-module (guix-data-service model utils)
  #:export (select-build-servers
            select-build-server
            select-build-server-urls-by-id
            specify-build-servers))

(define (select-build-servers conn)
  (define query
    "
SELECT id, url, lookup_all_derivations, lookup_builds
FROM build_servers
ORDER BY id")

  (map
   (match-lambda
     ((id url lookup-all-derivations lookup-builds)
      (list (string->number id)
            url
            (string=? lookup-all-derivations "t")
            (string=? lookup-builds "t"))))
   (exec-query conn query)))

(define (select-build-server conn id)
  (define query
    "
SELECT url, lookup_all_derivations
FROM build_servers
WHERE id = $1")

  (match (exec-query conn query (list (number->string id)))
    (()
     #f)
    (((url lookup_all_derivations lookup_builds))
     (list url
           (string=? lookup_all_derivations "t")
           (string=? lookup_builds "t")))))

(define (select-build-server-urls-by-id conn)
  (map (match-lambda
         ((id url lookup-all-derivations? lookup-builds?)
          (cons id url)))
       (select-build-servers conn)))

(define (specify-build-servers build-servers)
  (define (specify-token-seeds conn
                               build-server-id
                               token-seeds)
    (define string-build-server-id
      (number->string build-server-id))

    (let* ((db-token-seeds
            (map
             car
             (exec-query
              conn
              "
SELECT token_seed
FROM build_server_token_seeds
WHERE build_server_id = $1"
              (list string-build-server-id))))
           (token-seeds-to-delete
            (lset-difference string=?
                             db-token-seeds
                             token-seeds))
           (token-seeds-to-insert
            (lset-difference string=?
                             token-seeds
                             db-token-seeds)))

      (for-each
       (lambda (seed)
         (exec-query
          conn
          "
DELETE FROM build_server_token_seeds
WHERE build_server_id = $1
  AND token_seed = $2"
          (list string-build-server-id
                seed)))
       token-seeds-to-delete)

      (for-each
       (lambda (seed)
         (exec-query
          conn
          "
INSERT INTO build_server_token_seeds
VALUES ($1, $2)"
          (list string-build-server-id
                seed)))
       token-seeds-to-insert)))

  (define (specify-build-config conn
                                build-server-id
                                systems-and-targets)
    (define string-build-server-id
      (number->string build-server-id))

    (define pair-equal?
      (match-lambda*
        (((s1 . t1) (s2 . t2))
         (and (string=? s1 s2)
              (string=? t1 t2)))))

    (let* ((db-systems-and-targets
            (map
             (match-lambda
               ((system target)
                (cons system target)))
             (exec-query
              conn
              "
SELECT system, target
FROM build_servers_build_config
WHERE build_server_id = $1"
              (list string-build-server-id))))
           (systems-and-targets-to-delete
            (lset-difference pair-equal?
                             db-systems-and-targets
                             systems-and-targets))
           (systems-and-targets-to-insert
            (lset-difference pair-equal?
                             systems-and-targets
                             db-systems-and-targets)))

      (for-each
       (match-lambda
         ((system . target)
          (exec-query
           conn
           "
DELETE FROM build_servers_build_config
WHERE build_server_id = $1
  AND system = $2
  AND target = $3"
           (list string-build-server-id
                 system
                 target))))
       systems-and-targets-to-delete)

      (for-each
       (match-lambda
         ((system . target)
          (exec-query
           conn
           "
INSERT INTO build_servers_build_config
VALUES ($1, $2, $3)"
           (list string-build-server-id
                 system
                 target))))
       systems-and-targets-to-insert)))

  (with-postgresql-connection
   "specify-build-servers"
   (lambda (conn)
     (with-postgresql-transaction
      conn
      (lambda (conn)
        (let* ((existing-ids
                (map first (select-build-servers conn)))
               (target-ids
                (map (lambda (repo)
                       (or (assq-ref repo 'id)
                           (error "build server missing id")))
                     build-servers))
               (build-servers-to-delete
                (lset-difference equal?
                                 existing-ids
                                 target-ids)))
          (for-each
           (lambda (id-to-remove)
             (simple-format (current-error-port)
                            "deleting build server ~A\n"
                            id-to-remove)
             (exec-query
              conn
              "DELETE FROM build_servers WHERE id = $1"
              (list (number->string id-to-remove))))
           build-servers-to-delete)

          (for-each
           (lambda (build-server)
             (let* ((related-table-keys '(systems-and-targets
                                          token-seeds))
                    (build-servers-without-related-data
                     (filter-map
                      (lambda (pair)
                        (if (memq (car pair) related-table-keys)
                            #f
                            pair))
                      build-server))
                    (fields (map car build-servers-without-related-data))
                    (field-vals (map cdr build-servers-without-related-data)))
               (update-or-insert
                conn
                "build_servers"
                fields
                field-vals)

               (specify-token-seeds
                conn
                (assq-ref build-server 'id)
                (or (assq-ref build-server 'token-seeds)
                    '()))

               (specify-build-config
                conn
                (assq-ref build-server 'id)
                (or (assq-ref build-server 'systems-and-targets)
                    '()))))
           build-servers)))))))