Skip to content

Instantly share code, notes, and snippets.

Last active June 8, 2021 16:28
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
What would you like to do?
Script to bisect regression in SQLite leading to
#!/usr/bin/env -S guile --no-auto-compile
;; Mode: -*- Scheme;-*-
(use-modules (git repository)
(git reference)
(git oid)
(git commit)
(git describe)
(guix git)
(guix packages)
(guix utils)
(guix gexp)
(guix monads)
(guix store)
(guix derivations)
(gnu packages nss)
(gnu packages sqlite)
(gnu packages tcl)
((guix build utils) #:select (alist-replace))
(srfi srfi-71)
(rnrs io ports))
(define* (describe-checkout checkout
#:optional (options (make-describe-options
;; Consider unannotated tags.
#:strategy 'tags
;; ...but not their ancestors.
#:only-follow-first-parent? #t)))
"Get the current HEAD of CHECKOUT as well as its \"pretty name\"."
(let* ((repo (repository-open checkout))
(head (reference-target (repository-head repo)))
(commit (commit-lookup repo head))
(description (describe-commit commit options)))
(repository-close! repo)
(values (oid->string head) (describe-format description))))
(define %repository "/home/marius/src/sqlite-git")
(define sqlite/bisect
(let ((commit pretty (describe-checkout %repository)))
(inherit sqlite)
(source (git-checkout (url %repository) (commit commit)))
;; Drop the -version prefix from the tag name.
(version (string-drop pretty 8))
(substitute-keyword-arguments (package-arguments sqlite)
((#:configure-flags flags ''())
;; TCL is needed for creating the amalgamation, but we
;; don't want to install the extension.
`(cons "--disable-tcl" ,flags))
((#:phases phases)
`(modify-phases ,phases
(add-after 'configure 'make-amalgamation
(lambda _
(invoke "make" "sqlite3.c" "sqlite3.h")))))
;; Don't bother trying the tests.
((#:tests? _ #f) #f)))
`(("tcl" ,tcl)
,@(package-native-inputs sqlite))))))
(define nss/bisect
(inherit nss)
(inputs (alist-replace "sqlite" (list sqlite/bisect)
(package-inputs nss)))
(substitute-keyword-arguments (package-arguments nss)
;; We're not interested in the test suite, as we know
;; which test is failing and run it below.
((#:tests? _ #f) #f)))))
(define %dbdir "/tmp/guix-build-nss-3.66.drv-0/nss-3.66/tests_results\
(let ((result
(with-store store
(run-with-store store
(mlet* %store-monad ((nss (package->derivation nss/bisect))
(_ (built-derivations (list nss))))
(return (status:exit-val
(system* (string-append (derivation->output-path nss "bin")
"-d" %dbdir)))))))))
(if result
;; If dbtest returns 0, something went wrong.
(if (zero? result)
(exit 1)
(exit 0))
;; Skip if we got an exception, likely a build failure.
(exit 125)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment