~whereiseveryone/toys

d267c7c54b3d0f49d4482c55efa8a940cbc42038 — unwox 2 months ago b9f28f0 master
Extract channel directory from .guix-channel
3 files changed, 55 insertions(+), 64 deletions(-)

M channels.scm
M guix/extensions/toys.scm
M toys/discovery.scm
M channels.scm => channels.scm +8 -20
@@ 62,7 62,6 @@
               (url "https://gitlab.inria.fr/guix-hpc/guix-hpc"))))
  (toys-box
    (forge "sourcehut")
    (directory "src")
    (channel (channel
               (name 'rde)
               (url "https://git.sr.ht/~abcdw/rde")


@@ 103,7 102,6 @@
                     "8D10 60B9 6BB8 292E 829B  7249 AED4 1CC1 93B7 01E2"))))))
  (toys-box
    (forge "gitlab")
    (directory "modules")
    (channel (channel
               (name 'guix-past)
               (url "https://gitlab.inria.fr/guix-hpc/guix-past")


@@ 124,7 122,6 @@
                     "CA4F 8CF4 37D7 478F DA05  5FD4 4213 7701 1A37 8446"))))))
  (toys-box
    (forge "cgit")
    (directory "guix")
    (channel (channel
               (name 'guix-forge)
               (url "https://git.systemreboot.net/guix-forge/")


@@ 136,7 133,6 @@
                     "7F73 0343 F2F0 9F3C 77BF  79D3 2E25 EE8B 6180 2BB3"))))))
  (toys-box
    (forge "github")
    (directory "src")
    (channel (channel
               (name 'crypto)
               (url "https://github.com/attila-lendvai/guix-crypto")


@@ 197,7 193,6 @@
                     "4DA1 9E0B 4161 3198 F4F5  9D9C 1A5A 96AD 307C D736"))))))
   #;(toys-box
     (forge "sourcehut")
     (directory "conf")
     (channel (channel
                (name 'confetti)
                (url "https://git.sr.ht/~whereiseveryone/confetti")


@@ 235,7 230,6 @@
               (url "https://github.com/Tass0sm/tassos-guix"))))
  (toys-box
   (forge "github")
   (directory "src")
   (channel (channel
             (name 'sheepfold)
             (url "https://github.com/dochang/sheepfold"))))


@@ 255,8 249,7 @@
    (channel (channel
               (name 'mobilizon-reshare)
               (url "https://git.sr.ht/~fishinthecalculator/mobilizon-reshare-guix")
               (branch "main")))
    (directory "modules"))
               (branch "main"))))
  #;(toys-box
    (forge "github")
    (channel (channel


@@ 327,7 320,6 @@
                "FF72 877C 4F21 FC4D 467D  20C4 DCCB 5255 2098 B6C1"))))))
  (toys-box
   (forge "cgit")
   (directory "gn")
   (channel
    (channel
     (name 'gn-bioinformatics)


@@ 347,7 339,6 @@
        "C3B6 ED99 DF87 B208 0C79  C8AC F86B 0628 26D4 C20A"))))))
  (toys-box
   (forge "sourcehut")
   (directory "modules")
   (channel (channel
             (name 'sops-guix)
             (url "https://git.sr.ht/~fishinthecalculator/sops-guix")


@@ 367,11 358,9 @@
              (make-channel-introduction
               "cdb78996334c4f63304ecce224e95bb96bfd4c7d"
               (openpgp-fingerprint
                "8D10 60B9 6BB8 292E 829B  7249 AED4 1CC1 93B7 01E2")))))
   (directory "modules"))
                "8D10 60B9 6BB8 292E 829B  7249 AED4 1CC1 93B7 01E2"))))))
  (toys-box
   (forge "github")
   (directory "modules")
   (channel (channel
             (name 'guixcn)
             (url "https://github.com/guixcn/guix-channel")


@@ 448,12 437,12 @@
               "9860ea17cb21131fe5809053ffcc148ac7549465"
               (openpgp-fingerprint
                "66E6 01AC 1756 020B 759B  E34B 7B65 F79C 3247 8510"))))))
  (toys-box
   (forge "sourcehut")
   (channel (channel
             (name 'hitwright)
             (url "https://git.sr.ht/~hitwright/personal-guix-channel")
             (branch "main"))))
  ; (toys-box
  ;  (forge "sourcehut")
  ;  (channel (channel
  ;            (name 'hitwright)
  ;            (url "https://git.sr.ht/~hitwright/personal-guix-channel")
  ;            (branch "main"))))
  (toys-box
   (forge "sourcehut")
   (channel (channel


@@ 469,7 458,6 @@
                "A28B F40C 3E55 1372 662D  14F7 41AA E7DC CA3D 8351"))))))
  (toys-box
   (forge "gogs")
   (directory "guix")
   (channel (channel
             (name 'wigust)
             (url "https://notabug.org/wigust/guix-wigust"))))

M guix/extensions/toys.scm => guix/extensions/toys.scm +27 -30
@@ 203,7 203,7 @@ The valid values for ACTION are:

(define (pull-data db boxes)
  "Removes existing data about symbols from DB and then pulls new data
  from BOXES into it."
from BOXES into it."
  (sqlite-exec
    db
    "PRAGMA synchronous=NORMAL;


@@ 213,6 213,7 @@ The valid values for ACTION are:
     DELETE FROM public_symbols;
     DELETE FROM service_types;
     DELETE FROM packages;")

  (for-each
    (lambda (wrapper)
      (let* ((stmt


@@ 231,7 232,7 @@ The valid values for ACTION are:
                 VALUES (?, ?, ?, ?)"
                #:cache? #t))
            (dir
              (assoc-ref wrapper 'dir))
              (assoc-ref wrapper 'module-dir))
            (box
              (assoc-ref wrapper 'box))
            (channel


@@ 253,22 254,21 @@ The valid values for ACTION are:
          search-stmt
          (list
            (symbol->string (channel-name channel))
            ""
            id
            "boxes"))))
            "" id "boxes"))))
    boxes)

  (fold-public-symbols
    (lambda (box module symbol variable result)
      (insert-public-symbol db module box symbol variable)
    (lambda (box module symbol variable box-wrapper result)
      (insert-public-symbol variable db module box symbol box-wrapper)

      (if (variable-bound? variable)
      (when (variable-bound? variable)
        (let ((var (variable-ref variable)))
          (cond
            ((service-type? var)
            (insert-service-type db box module var))
              (insert-service-type var db box module box-wrapper))
            ((package? var)
            (insert-package db box module var)))))
              (insert-package var db box module box-wrapper)))))

      '())
    '()
    boxes)


@@ 297,11 297,11 @@ The valid values for ACTION are:
;;; Locations
;;;

(define (location->url box file lineno)
(define (location->url box-wrapper file lineno)
  "Returns the URL for accessing specified BOX, FILE and LINENO via Web."
  (let* ((directory (string-trim
                      (or (toys-box-directory box)
                          "")
  (let* ((box (assoc-ref box-wrapper 'box))
         (directory (string-trim
                      (assoc-ref box-wrapper 'dir)
                      #\/))
         (channel (toys-box-channel box))
         (file (string-trim-both


@@ 361,7 361,7 @@ The valid values for ACTION are:
        (list (normalize license))
        '()))))

(define (serialize-public-symbol module box symbol variable)
(define (serialize-public-symbol variable module box symbol box-wrapper)
  "Serializes VARIABLE for database storage."
  (let* ((variable-procedure?
           (and (variable-bound? variable)


@@ 381,7 381,7 @@ The valid values for ACTION are:
         (url
           ;; TODO: figure out if it's possible to extract lineno from variable.
           ;; For now set it to 1.
           (location->url box file 1))
           (location->url box-wrapper file 1))
         (signature
           (or (and
                 variable-procedure?


@@ 409,7 409,7 @@ The valid values for ACTION are:
          doc
          stripped-signature)))

(define (insert-public-symbol db module box symbol variable)
(define (insert-public-symbol variable db module box symbol box-wrapper)
  "Serializes and inserts VARIABLE and corresponding search row into the DB."
  (let* ((stmt
           (sqlite-prepare


@@ 427,19 427,16 @@ The valid values for ACTION are:
              VALUES (?,?,?,?)"
             #:cache? #t))
         (data
           (serialize-public-symbol module box symbol variable)))
           (serialize-public-symbol variable module box symbol box-wrapper)))
    (define id
      (vector-ref
        (car (db-execute-stmt stmt data))
        0))
    (db-execute-stmt
      search-stmt
      (list (symbol->string symbol)
            ""
            id
            "public_symbols"))))
      (list (symbol->string symbol) "" id "public_symbols"))))

(define (serialize-service-type box module service-type)
(define (serialize-service-type service-type box module box-wrapper)
  "Serializes SERVICE-TYPE for database storage."
  (let* ((mod-name
           (string-join


@@ 456,7 453,7 @@ The valid values for ACTION are:
         (location
           (service-type-location service-type))
         (url
           (location->url box file (location-line location)))
           (location->url box-wrapper file (location-line location)))
         (description
           (service-type-description service-type)))
    (list name


@@ 466,7 463,7 @@ The valid values for ACTION are:
          url
          description)))

(define (insert-service-type db box module service-type)
(define (insert-service-type service-type db box module box-wrapper)
  "Serializes and inserts SERVICE-TYPE and corresponding search row
into the DB."
  (let* ((stmt


@@ 485,7 482,7 @@ into the DB."
              VALUES (?,?,?,?)"
             #:cache? #t))
         (data
           (serialize-service-type box module service-type)))
           (serialize-service-type service-type box module box-wrapper)))
    (define id
      (vector-ref
        (car (db-execute-stmt stmt data))


@@ 497,7 494,7 @@ into the DB."
            id
            "service_types"))))

(define (serialize-package box module package)
(define (serialize-package package box module box-wrapper)
  "Serializes PACKAGE for database storage."
  (let* ((name
          (package-name package))


@@ 516,7 513,7 @@ into the DB."
         (location
           (package-location package))
         (url
           (location->url box file (location-line location)))
           (location->url box-wrapper file (location-line location)))
         (homepage
           (package-home-page package))
         (licenses


@@ 554,7 551,7 @@ into the DB."
          propagated-inputs
          description)))

(define (insert-package db box module package)
(define (insert-package package db box module box-wrapper)
  "Serializes and inserts PACKAGE and corresponding search row into the DB."
  (let* ((stmt
           (sqlite-prepare


@@ 583,7 580,7 @@ into the DB."
              VALUES (?,?,?,?)"
             #:cache? #t))
         (data
           (serialize-package box module package)))
           (serialize-package package box module box-wrapper)))
    (define id
      (vector-ref
        (car (db-execute-stmt stmt data))

M toys/discovery.scm => toys/discovery.scm +20 -14
@@ 33,8 33,7 @@

            toys-box
            toys-box-channel
            toys-box-forge
            toys-box-directory))
            toys-box-forge))

;; Guix channel wrapper with additional data.
(define-record-type* <toys-box>


@@ 43,11 42,14 @@

  (channel toys-box-channel)        ; channel
  (forge toys-box-forge             ; string | #f
        (default #f))
  ;; subdirectory in repository where source code for channel is situated
  ;; TODO: parse from .guix-channel file?
  (directory toys-box-directory     ; string | #f
             (default #f)))
        (default #f)))

;; Forcefully export functions from (guix channels)
(define read-channel-metadata-from-source
  (@@ (guix channels) read-channel-metadata-from-source))

(define channel-metadata-directory
  (@@ (guix channels) channel-metadata-directory))

(define (fetch-boxes file)
  "Locally checkout and authenticate boxes specified in FILE.  Previous


@@ 87,11 89,15 @@ checkouts are cached."
              ;; FIXME: may not be "keyring" branch.
              #:keyring-reference "origin/keyring")))

        (define channel-metadata
          (read-channel-metadata-from-source checkout-dir))

        (define dir
          (channel-metadata-directory channel-metadata))

        `((box . ,box)
          (dir . ,(format #f "~a/~a"
                          checkout-dir
                          (or (toys-box-directory box)
                              ""))))))
          (dir . ,dir)
          (module-dir . ,(string-append checkout-dir dir)))))
    toy-boxes))

(define (fold-public-symbols kons knil boxes)


@@ 101,7 107,7 @@ value to append results to." (define old-load-path %load-path)
    (append
      (map
        (lambda (box-wrapper)
          (assoc-ref box-wrapper 'dir))
          (assoc-ref box-wrapper 'module-dir))
        ;; Filter out guix channel, it is scanned just fine without proper
        ;; importing.
        (filter


@@ 121,7 127,7 @@ value to append results to." (define old-load-path %load-path)
                    (toys-box-channel (assoc-ref box-wrapper 'box)))))
        (let*
          ((box (assoc-ref box-wrapper 'box))
           (dir (assoc-ref box-wrapper 'dir))
           (dir (assoc-ref box-wrapper 'module-dir))
           ;; FIXME: this leaks memory, there should be a way to remove modules
           ;; after they are resolve-interface'd and scanned.
           (introduction


@@ 135,7 141,7 @@ value to append results to." (define old-load-path %load-path)
            (fold-module-public-variables*
              (lambda (module symbol variable result)
                (apply kons
                       (list box module symbol variable result)))
                       (list box module symbol variable box-wrapper result)))
              knil
              modules)
            result)))