├── .github ├── ISSUE_TEMPLATE │ ├── bug_report.md │ └── feature_request.md └── workflows │ ├── ubuntu-focal.yml │ └── ubuntu-jammy.yml ├── .gitignore ├── COPYING ├── README.org ├── build-generator.asd ├── build-generator.commandline-interface.asd ├── build-generator.commandline-options.asd ├── build-generator.commands.asd ├── build-generator.more-conditions-patch.asd ├── changes.sexp ├── data └── jenkins-install │ ├── config │ ├── common │ │ ├── config.xml │ │ ├── hudson.plugins.analysis.core.GlobalSettings.xml │ │ ├── io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml │ │ ├── jenkins.CLI.xml │ │ └── start_jenkins │ ├── legacy-warnings │ │ ├── config.xml │ │ ├── hudson.plugins.analysis.core.GlobalSettings.xml │ │ ├── hudson.plugins.warnings.WarningsPublisher.xml │ │ ├── io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml │ │ ├── jenkins.CLI.xml │ │ └── start_jenkins │ ├── local-docker │ │ ├── config.xml │ │ ├── hudson.plugins.analysis.core.GlobalSettings.xml │ │ ├── io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml │ │ ├── jenkins.CLI.xml │ │ ├── jobs │ │ │ └── build-docker-images │ │ │ │ └── config.xml │ │ ├── scriptApproval.xml │ │ └── start_jenkins │ └── single-user │ │ ├── config.xml │ │ ├── hudson.plugins.analysis.core.GlobalSettings.xml │ │ ├── io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml │ │ ├── jenkins.CLI.xml │ │ └── start_jenkins │ └── user-config.xml.in ├── lib └── jenkins.api │ ├── COPYING │ ├── README.org │ ├── jenkins.api.asd │ ├── src │ ├── api │ │ ├── api.lisp │ │ ├── classes.lisp │ │ ├── conditions.lisp │ │ ├── conversion.lisp │ │ ├── csrf.lisp │ │ ├── http.lisp │ │ ├── model │ │ │ ├── build.lisp │ │ │ ├── interface.lisp │ │ │ ├── job-build-wrapper.lisp │ │ │ ├── job-builder.lisp │ │ │ ├── job-property.lisp │ │ │ ├── job-publisher.lisp │ │ │ ├── job-scm.lisp │ │ │ ├── job-trigger.lisp │ │ │ ├── job.lisp │ │ │ ├── model-class.lisp │ │ │ └── view.lisp │ │ ├── package.lisp │ │ ├── protocol.lisp │ │ ├── types.lisp │ │ └── util.lisp │ └── scripting │ │ ├── build.lisp │ │ ├── package.lisp │ │ ├── release.lisp │ │ ├── resources.lisp │ │ └── util.lisp │ └── test │ └── management │ ├── package.lisp │ └── setup.lisp ├── src ├── analysis │ ├── analysis.lisp │ ├── ant.lisp │ ├── archive.lisp │ ├── asdf.lisp │ ├── autotools.lisp │ ├── cache.lisp │ ├── cmake.lisp │ ├── conditions.lisp │ ├── dependencies.lisp │ ├── git.lisp │ ├── license.lisp │ ├── maven.lisp │ ├── mercurial.lisp │ ├── mps.lisp │ ├── package.lisp │ ├── pkg-config.lisp │ ├── platform.lisp │ ├── protocol.lisp │ ├── ros-package.lisp │ ├── ros-packages.lisp │ ├── scm-null.lisp │ ├── setuptools.lisp │ ├── subversion.lisp │ ├── util.lisp │ └── variables.lisp ├── bcrypt │ ├── base64.lisp │ ├── bcrypt.lisp │ └── package.lisp ├── commandline-interface │ ├── configuration.lisp │ ├── main.lisp │ ├── package.lisp │ └── value-types.lisp ├── commandline-options │ ├── conditions.lisp │ ├── help.lisp │ ├── macros.lisp │ ├── options.lisp │ ├── package.lisp │ ├── protocol.lisp │ └── types.lisp ├── commands │ ├── command-analyze.lisp │ ├── command-config.lisp │ ├── command-create-jenkins-user.lisp │ ├── command-generate.lisp │ ├── command-help.lisp │ ├── command-info-aspects.lisp │ ├── command-info-variables.lisp │ ├── command-install-jenkins.lisp │ ├── command-platform-requirements.lisp │ ├── command-report.lisp │ ├── command-validate.lisp │ ├── command-version.lisp │ ├── commands-generate.lisp │ ├── conditions.lisp │ ├── functions-check.lisp │ ├── functions-input.lisp │ ├── functions-version.lisp │ ├── mixins.lisp │ ├── package.lisp │ ├── phases.lisp │ ├── protocol.lisp │ ├── util.lisp │ └── value-types.lisp ├── deployment │ ├── build │ │ ├── README.org │ │ ├── aspects.lisp │ │ ├── execution.lisp │ │ ├── model.lisp │ │ ├── package.lisp │ │ └── target.lisp │ ├── conditions.lisp │ ├── defaults.lisp │ ├── dockerfile │ │ ├── aspects.lisp │ │ ├── model.lisp │ │ ├── output.lisp │ │ ├── package.lisp │ │ ├── target.lisp │ │ └── util.lisp │ ├── jenkins │ │ ├── distribution.lisp │ │ ├── job.lisp │ │ ├── package.lisp │ │ ├── target.lisp │ │ └── util.lisp │ ├── makefile │ │ ├── README.org │ │ ├── aspects.lisp │ │ ├── package.lisp │ │ ├── target.lisp │ │ └── util.lisp │ ├── mixins.lisp │ ├── package.lisp │ ├── protocol.lisp │ └── util.lisp ├── model │ ├── aspects │ │ ├── aspect.lisp │ │ ├── aspects-artifacts.lisp │ │ ├── aspects-build.lisp │ │ ├── aspects-publish.lisp │ │ ├── aspects-scm.lisp │ │ ├── aspects.lisp │ │ ├── conditions.lisp │ │ ├── contrib.lisp │ │ ├── macros.lisp │ │ ├── mixins.lisp │ │ ├── package.lisp │ │ ├── protocol.lisp │ │ └── util.lisp │ ├── conditions.lisp │ ├── mixins.lisp │ ├── package.lisp │ ├── project │ │ ├── classes-model.lisp │ │ ├── classes-spec.lisp │ │ ├── concrete-syntax │ │ │ ├── builder.lisp │ │ │ ├── conditions.lisp │ │ │ ├── locations.lisp │ │ │ ├── recipe-repository.lisp │ │ │ ├── util.lisp │ │ │ └── yaml.lisp │ │ ├── mixins.lisp │ │ ├── package.lisp │ │ ├── protocol.lisp │ │ ├── util.lisp │ │ └── variables.lisp │ ├── protocol.lisp │ ├── schema.lisp │ └── variables │ │ ├── aggregation.lisp │ │ ├── conditions.lisp │ │ ├── evaluation.lisp │ │ ├── grammar.lisp │ │ ├── mixins.lisp │ │ ├── model.lisp │ │ ├── package.lisp │ │ ├── protocol.lisp │ │ ├── schema.lisp │ │ ├── trace.lisp │ │ ├── types.lisp │ │ └── variables.lisp ├── more-conditions-patch.lisp ├── report │ ├── catalog.lisp │ ├── conditions.lisp │ ├── graphviz.lisp │ ├── json.lisp │ ├── package.lisp │ └── protocol.lisp ├── resources │ ├── conditions.lisp │ ├── package.lisp │ ├── protocol.lisp │ └── resources.lisp ├── steps │ ├── jenkins-install-legacy.lisp │ ├── jenkins-install.lisp │ ├── macros.lisp │ ├── package.lisp │ └── protocol.lisp ├── util │ ├── files.lisp │ ├── package.lisp │ ├── restarts.lisp │ ├── sorting.lisp │ └── strings.lisp └── version │ ├── package.lisp │ └── version.lisp ├── test ├── commandline-interface │ └── value-types.lisp ├── model │ ├── aspects │ │ └── test.lisp │ ├── project │ │ ├── concrete-syntax │ │ │ ├── builder.lisp │ │ │ └── recipe-repository.lisp │ │ └── package.lisp │ └── variables │ │ ├── evaluation.lisp │ │ ├── grammar.lisp │ │ ├── model.lisp │ │ └── package.lisp ├── package.lisp └── project │ ├── grammar.lisp │ └── variables.lisp ├── tools-for-build ├── release.lisp └── which-libssl-package.lisp └── version-string.sexp /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Use this if the generator does not do what it should 4 | title: '' 5 | labels: bug 6 | assignees: scymtym 7 | 8 | --- 9 | 10 | **Which generator version are you using?** 11 | 12 | ```sh 13 | build-generator version 14 | # Add the output of the above command here 15 | ``` 16 | 17 | **What did you do?** 18 | 19 | 1. *(If applicable)* The relevant recipes look like this 20 | 21 | * `distributions/foo.distribution`: 22 | 23 | ```yaml 24 | versions: 25 | - bar 26 | … 27 | ``` 28 | 29 | * `projects/bar.project`: 30 | 31 | ```yaml 32 | variables: 33 | … 34 | ``` 35 | 36 | 2. Generator configuration and invocation 37 | *(If applicable)* Configuration file: 38 | ```ini 39 | # Insert contents effective configuration file or files, e.g. ${HOME}/.config/build-generator.conf 40 | ``` 41 | Generator invocation and output: 42 | ```shell 43 | build-generator generate … 44 | # Depending on what seems relevant, insert complete output or only relevant parts 45 | ``` 46 | 47 | **Which behavior did you expect?** 48 | A clear and concise description of what you expected to happen. Which output should the generator have produced? Which Jenkins job configuration should have been generated? 49 | 50 | **What happened instead?** 51 | Describe what happened instead of the expected behavior? 52 | 53 | *If applicable, add screenshots of the generator output or Jenkins pages to help explain the problem.* 54 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest a feature for the generator 4 | title: '' 5 | labels: enhancement 6 | assignees: scymtym 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | A clear and concise description of what the problem is. 12 | Example: When I call the generator like this: 13 | ```sh 14 | build-generator generate … 15 | ``` 16 | the output does not tell me … 17 | 18 | **Describe the solution you'd like** 19 | A clear and concise description of what you want to happen. 20 | Example: It would be really helpful if the output of the above contained something like 21 | ``` 22 | … 23 | ``` 24 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /version.sexp 2 | -------------------------------------------------------------------------------- /build-generator.commandline-interface.asd: -------------------------------------------------------------------------------- 1 | ;;;; build-generator.commandline-interface.asd --- System definition for generator binary. 2 | ;;;; 3 | ;;;; Copyright (C) 2013-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (defsystem "build-generator.commandline-interface" 8 | :description "Commandline interface of the generator program." 9 | :license "GPLv3" ; see COPYING file for details. 10 | 11 | :author "Jan Moringen " 12 | :maintainer "Jan Moringen " 13 | 14 | :version (:read-file-form "version-string.sexp") 15 | :depends-on ("alexandria" 16 | (:version "let-plus" "0.2") 17 | (:version "more-conditions" "0.2") 18 | 19 | (:version "configuration.options" "0.10") 20 | (:version "configuration.options-syntax-ini" "0.10") 21 | (:version "configuration.options-and-puri" "0.10") 22 | 23 | (:version "build-generator" (:read-file-form "version-string.sexp")) 24 | (:version "build-generator.more-conditions-patch" (:read-file-form "version-string.sexp")) 25 | (:version "build-generator.commands" (:read-file-form "version-string.sexp"))) 26 | 27 | :components ((:module "commandline-interface" 28 | :pathname "src/commandline-interface" 29 | :serial t 30 | :components ((:file "package") 31 | (:file "value-types") 32 | (:file "configuration") 33 | (:file "main")))) 34 | 35 | :build-operation program-op 36 | :build-pathname "build-generator" 37 | :entry-point "BUILD-GENERATOR.COMMANDLINE-INTERFACE:MAIN") 38 | -------------------------------------------------------------------------------- /build-generator.commandline-options.asd: -------------------------------------------------------------------------------- 1 | ;;;; build-generator.commandline-options.asd --- System definition for build-generator.commandline-options. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (defsystem "build-generator.commandline-options" 8 | :description "Commandline options of the generator program." 9 | :license "GPLv3" ; see COPYING file for details. 10 | 11 | :author "Jan Moringen " 12 | :maintainer "Jan Moringen " 13 | 14 | :version (:read-file-form "version-string.sexp") 15 | :depends-on ("alexandria" 16 | "split-sequence" 17 | (:version "let-plus" "0.2") 18 | (:version "more-conditions" "0.2") 19 | 20 | (:version "configuration.options" "0.10")) 21 | 22 | :components ((:module "commandline-options" 23 | :pathname "src/commandline-options" 24 | :serial t 25 | :components ((:file "package") 26 | (:file "types") 27 | (:file "conditions") 28 | (:file "protocol") 29 | (:file "options") 30 | (:file "macros") 31 | (:file "help"))))) 32 | -------------------------------------------------------------------------------- /build-generator.more-conditions-patch.asd: -------------------------------------------------------------------------------- 1 | ;;;; build-generator.more-conditions-patch.asd --- Patch for more-conditions system. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (defsystem "build-generator.more-conditions-patch" 8 | :description "Patch more-conditions system." 9 | :license "GPLv3" ; see COPYING file for details. 10 | 11 | :author "Jan Moringen " 12 | :maintainer "Jan Moringen " 13 | 14 | :version (:read-file-form "version-string.sexp") 15 | :depends-on ((:version "more-conditions" "0.2")) 16 | 17 | :components ((:file "more-conditions-patch" 18 | :pathname "src/more-conditions-patch"))) 19 | -------------------------------------------------------------------------------- /data/jenkins-install/config/common/config.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 1.0 5 | RESTART 6 | 2 7 | NORMAL 8 | true 9 | 10 | false 11 | 12 | 13 | true 14 | false 15 | 16 | false 17 | 18 | ${ITEM_ROOTDIR}/workspace 19 | ${ITEM_ROOTDIR}/builds 20 | 21 | 22 | 23 | 24 | 25 | 0 26 | 0 27 | 28 | 29 | 30 | all 31 | false 32 | false 33 | 34 | 35 | 36 | all 37 | 0 38 | 39 | JNLP-connect 40 | JNLP2-connect 41 | JNLP3-connect 42 | 43 | 44 | 45 | false 46 | 47 | 48 | 49 | true 50 | 51 | -------------------------------------------------------------------------------- /data/jenkins-install/config/common/hudson.plugins.analysis.core.GlobalSettings.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | false 4 | false 5 | true 6 | -------------------------------------------------------------------------------- /data/jenkins-install/config/common/jenkins.CLI.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | false 4 | -------------------------------------------------------------------------------- /data/jenkins-install/config/common/start_jenkins: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | trap "kill $$" SIGINT 4 | 5 | # Define the home directory for Jenkins. 6 | root="$( cd "$(dirname "${BASH_SOURCE[0]}")" && pwd )" 7 | export JENKINS_HOME="${root}" 8 | 9 | # Create self-signed certificate, if necessary. 10 | secrets_directory="${root}/secrets/" 11 | keystore="${secrets_directory}/jenkins.jks" 12 | dname="CN=toolkit-jenkins,OU=citec,O=uni-bielefeld,L=Bielefeld,S=NRW,C=DE" 13 | 14 | if [ ! -f "${keystore}" ] ; then 15 | echo "Keystore not found. Generating new self-signed certificate..." 16 | mkdir -p "${secrets_directory}" 17 | keytool -genkey \ 18 | -keystore "${keystore}" \ 19 | -deststoretype pkcs12 \ 20 | -alias toolkit \ 21 | -keyalg RSA \ 22 | -keysize 2048 \ 23 | -dname "${dname}" \ 24 | -storepass keystore \ 25 | -keypass keystore 26 | fi 27 | 28 | # Execute the process 29 | exec java \ 30 | -Dpermissive-script-security.enabled=true \ 31 | -jar "${root}/jenkins.war" \ 32 | --httpsPort=8080 --httpPort=-1 \ 33 | --httpsKeyStore="${keystore}" --httpsKeyStorePassword=keystore 34 | -------------------------------------------------------------------------------- /data/jenkins-install/config/legacy-warnings/config.xml: -------------------------------------------------------------------------------- 1 | ../common/config.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/legacy-warnings/hudson.plugins.analysis.core.GlobalSettings.xml: -------------------------------------------------------------------------------- 1 | ../common/hudson.plugins.analysis.core.GlobalSettings.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/legacy-warnings/io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml: -------------------------------------------------------------------------------- 1 | ../common/io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/legacy-warnings/jenkins.CLI.xml: -------------------------------------------------------------------------------- 1 | ../common/jenkins.CLI.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/legacy-warnings/start_jenkins: -------------------------------------------------------------------------------- 1 | ../common/start_jenkins -------------------------------------------------------------------------------- /data/jenkins-install/config/local-docker/hudson.plugins.analysis.core.GlobalSettings.xml: -------------------------------------------------------------------------------- 1 | ../common/hudson.plugins.analysis.core.GlobalSettings.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/local-docker/io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml: -------------------------------------------------------------------------------- 1 | ../common/io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/local-docker/jenkins.CLI.xml: -------------------------------------------------------------------------------- 1 | ../common/jenkins.CLI.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/local-docker/jobs/build-docker-images/config.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | false 6 | 7 | 8 | master 9 | false 10 | false 11 | false 12 | false 13 | 14 | 15 | * * * * * 16 | 17 | 18 | false 19 | 20 | 21 | cat <<'EOF' > Dockerfile 22 | FROM ubuntu:xenial 23 | 24 | LABEL Maintainer="Jan Moringen" 25 | LABEL Description="Jenkins slave with sudo on Ubuntu Xenial" 26 | 27 | RUN DEBIAN_FRONTEND=noninteractive apt-get -qq update \ 28 | && DEBIAN_FRONTEND=noninteractive apt-get -qq upgrade \ 29 | && DEBIAN_FRONTEND=noninteractive apt-get -qq -y install \ 30 | sudo openjdk-8-jre-headless curl git gnupg2 \ 31 | wget unp unzip sloccount \ 32 | && rm -rf /var/cache/apt/ 33 | 34 | ENV HOME /home/jenkins 35 | RUN groupadd -g 10000 jenkins \ 36 | && useradd -c "Jenkins user" -d $HOME -u 10000 -g 10000 -m jenkins \ 37 | && echo "jenkins ALL=(ALL:ALL) NOPASSWD:SETENV: /usr/bin/apt-get" >> /etc/sudoers 38 | 39 | ARG VERSION=3.7 40 | RUN curl --create-dirs \ 41 | -sSLo /usr/share/jenkins/slave.jar \ 42 | https://repo.jenkins-ci.org/public/org/jenkins-ci/main/remoting/${VERSION}/remoting-${VERSION}.jar \ 43 | && chmod 755 /usr/share/jenkins \ 44 | && chmod 644 /usr/share/jenkins/slave.jar 45 | 46 | ENV LC_ALL=C.UTF-8 47 | 48 | USER jenkins 49 | WORKDIR /home/jenkins 50 | EOF 51 | 52 | 53 | . 54 | 55 | 56 | docker-slave-ubuntu-xenial-sudo 57 | 58 | false 59 | 60 | false 61 | false 62 | docker 63 | 64 | 65 | 66 | 68 | false 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /data/jenkins-install/config/local-docker/scriptApproval.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 122efad66957512d0f9207374d693759190b5558 5 | 4c5a64a7c691aebdf7692b34c10094e30de124e5 6 | 5cbfc16f1339a920922030f97e370fac262862c8 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /data/jenkins-install/config/local-docker/start_jenkins: -------------------------------------------------------------------------------- 1 | ../common/start_jenkins -------------------------------------------------------------------------------- /data/jenkins-install/config/single-user/config.xml: -------------------------------------------------------------------------------- 1 | ../common/config.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/single-user/hudson.plugins.analysis.core.GlobalSettings.xml: -------------------------------------------------------------------------------- 1 | ../common/hudson.plugins.analysis.core.GlobalSettings.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/single-user/io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml: -------------------------------------------------------------------------------- 1 | ../common/io.jenkins.plugins.analysis.warnings.groovy.ParserConfiguration.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/single-user/jenkins.CLI.xml: -------------------------------------------------------------------------------- 1 | ../common/jenkins.CLI.xml -------------------------------------------------------------------------------- /data/jenkins-install/config/single-user/start_jenkins: -------------------------------------------------------------------------------- 1 | ../common/start_jenkins -------------------------------------------------------------------------------- /data/jenkins-install/user-config.xml.in: -------------------------------------------------------------------------------- 1 | 2 | 3 | USER 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | All 16 | false 17 | false 18 | 19 | 20 | 21 | 22 | 23 | false 24 | 25 | 26 | PASSWORD_HASH 27 | 28 | 29 | EMAIL 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /lib/jenkins.api/README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: jenkins.api README 2 | #+AUTHOR: Jan Moringen 3 | #+EMAIL: jmoringe@techfak.uni-bielefeld.de 4 | #+DESCRIPTION: README for jenkins.api system 5 | #+KEYWORDS: jenkins, rest, api 6 | #+LANGUAGE: en 7 | 8 | * Introduction 9 | The =jenkins.api= system provides Common Lisp bindings for the REST 10 | API of the [[http://jenkins-ci.org/][Jenkins CI Server]]. It goals is to allow the enumeration, 11 | inspectation and mutation of the most important aspect of a Jenkins 12 | instance: 13 | + Nodes 14 | + Jobs 15 | + Builds 16 | * Tutorial 17 | This tutorial briefly demonstates how to establish a connection to a 18 | Jenkins server and how access the Jenkins objects mentioned above. 19 | ** URL and Credentials 20 | The following special variables are used to control 21 | authentication to the server: 22 | + =jenkins.api:*base-url*= 23 | + =jenkins.api:*username*= 24 | + =jenkins.api:*password*= 25 | 26 | API tokens are not yet supported but will probably be implemented. 27 | ** Nodes 28 | *** Finding Nodes 29 | #+BEGIN_SRC common-lisp 30 | CL-USER> (jenkins.api:all-nodes) 31 | (# 32 | # 33 | # 34 | # 35 | # 36 | # 37 | # 38 | # 39 | # 40 | #) 41 | #+END_SRC 42 | 43 | #+BEGIN_SRC common-lisp 44 | CL-USER> (mapcar #'jenkins.api:online? (jenkins.api:all-nodes)) 45 | (T T T T T T T T T T) 46 | #+END_SRC 47 | *** TODO Modifying Nodes 48 | ** Jobs 49 | *** TODO Finding Jobs 50 | *** Modifying Jobs 51 | Jobs are ordinary instances of the class =jenkins.api.job= and can 52 | thus be manipulated using slot readers and writers. Such changes 53 | only affect the respective object, making it go out of sync with 54 | the server. To persist changes, it is necessary to call 55 | =jenkins.api:commit!=. 56 | 57 | Typically =jenkins.api:commit!= will be called after performing a 58 | batch of changes: 59 | #+BEGIN_SRC common-lisp 60 | CL-USER> (let ((job (jenkins.api:job "foo"))) 61 | (setf (jenkins.api:keep/days job) 30 62 | (jenkins.api:keep/count job) 10) 63 | (jenkins.api:commit! job)) 64 | # 65 | #+END_SRC 66 | ** Builds 67 | *** TODO Finding Builds 68 | -------------------------------------------------------------------------------- /lib/jenkins.api/jenkins.api.asd: -------------------------------------------------------------------------------- 1 | ;;;; jenkins.api.asd --- System definition for the jenkins.api system. 2 | ;;;; 3 | ;;;; Copyright (C) 2011-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (defsystem "jenkins.api" 8 | :description "Bindings for Jenkins' REST API." 9 | :license "GPLv3" ; see COPYING file for details. 10 | 11 | :author "Jan Moringen " 12 | :maintainer "Jan Moringen " 13 | 14 | :version "0.1.0" 15 | :depends-on ("alexandria" 16 | (:version "split-sequence" "1.1") 17 | (:version "closer-mop" "0.61") 18 | (:version "let-plus" "0.1") 19 | (:version "more-conditions" "0.1.0") 20 | (:version "utilities.print-items" "0.3") 21 | (:version "log4cl" "1.1.3") 22 | 23 | (:version "cl-ppcre" "2.0.3") 24 | "puri" 25 | (:version "drakma" "1.2.8") 26 | (:version "xml.location" "0.2.0") 27 | (:version "cl-json" "0.4.1")) 28 | 29 | :components ((:module "api-early" 30 | :pathname "src/api" 31 | :serial t 32 | :components ((:file "package") 33 | (:file "types") 34 | (:file "conditions") 35 | (:file "util") 36 | (:file "protocol") 37 | (:file "conversion"))) 38 | 39 | (:module "model" 40 | :pathname "src/api/model" 41 | :depends-on ("api-early") 42 | :serial t 43 | :components ((:file "model-class") 44 | (:file "interface") 45 | 46 | (:file "build") 47 | 48 | (:file "job-scm") 49 | (:file "job-trigger") 50 | (:file "job-builder") 51 | (:file "job-build-wrapper") 52 | (:file "job-property") 53 | (:file "job-publisher") 54 | (:file "job") 55 | 56 | (:file "view"))) 57 | 58 | (:module "api-late" 59 | :pathname "src/api" 60 | :depends-on ("api-early" "model") 61 | :serial t 62 | :components ((:file "classes") 63 | 64 | (:file "http") 65 | (:file "csrf") 66 | (:file "api"))))) 67 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/classes.lisp: -------------------------------------------------------------------------------- 1 | ;;;; classes.lisp --- Classes used by the api module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | ;;; `node' class 10 | 11 | (define-model-class node () 12 | ((name :type string) 13 | (description :type string) 14 | (host :type string 15 | :xpath "launcher/host/text()") 16 | (mode :type keyword) 17 | (label :type (list/space string) 18 | :xpath "label/text()") 19 | (environment :type tree-map/plist 20 | :xpath "/slave/nodeProperties/hudson.slaves.EnvironmentVariablesNodeProperty/envVars/tree-map")) 21 | (:root? t) 22 | (:name-slot nil)) 23 | 24 | (defmethod print-object ((object node) stream) 25 | (print-unreadable-object (object stream :type t :identity t) 26 | (format stream "~A ~:[off~;on~]line" 27 | (name object) (online? object)))) 28 | 29 | ;;; `item' class (Queue items) 30 | 31 | (define-model-class item () 32 | ((job-name :type string 33 | :xpath "task/name/text()")) 34 | (:root? t)) 35 | 36 | (defmethod job ((item item) &key &allow-other-keys) 37 | (job (job-name item))) 38 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/csrf.lisp: -------------------------------------------------------------------------------- 1 | ;;;; csrf.lisp --- Support Jenkins' CSRF protection. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | ;;; CSRF 10 | 11 | (defparameter *csrf-protection-token-url* 12 | (make-instance 'puri:uri 13 | :path "crumbIssuer/api/xml" 14 | :query "xpath=concat(//crumbRequestField,\":\",//crumb)")) 15 | 16 | (defun obtain-csrf-protection-token (&key (endpoint *endpoint*)) 17 | (log:info "Trying to obtain CSRF protection token from ~A" endpoint) 18 | (more-conditions:with-condition-translation 19 | (((request-failed-error failed-to-obtain-csrf-token-error) 20 | :endpoint endpoint 21 | :relative-url *csrf-protection-token-url*) 22 | ((error jenkins-connect-error) 23 | :endpoint endpoint)) 24 | (let* ((result (checked-request *csrf-protection-token-url* 25 | :endpoint endpoint 26 | :if-not-found nil)) 27 | (header (when result 28 | (apply #'cons (split-sequence #\: result))))) 29 | (log:info "~@" 30 | (drakma:cookie-jar-cookies (cookies endpoint))) 31 | (log:info "~@<~:[CSRF protection not enabled~;Got CSRF protection ~ 32 | token header ~:*~S~]~@:>" 33 | header) 34 | (or header t)))) 35 | 36 | (defun ensure-csrf-protection-token (&key (endpoint *endpoint*)) 37 | (or (csrf-token endpoint) 38 | (setf (csrf-token endpoint) 39 | (obtain-csrf-protection-token :endpoint endpoint)))) 40 | 41 | ;;; Jenkins version 42 | 43 | (defun jenkins-version (&key (endpoint *endpoint*)) 44 | (log:info "~@" endpoint) 45 | (more-conditions:with-condition-translation 46 | (((error jenkins-connect-error) :endpoint endpoint)) 47 | (let+ (((&values &ign &ign headers) (checked-request "" :endpoint endpoint)) 48 | (version (assoc-value headers :x-jenkins))) 49 | (unless version 50 | (error "~@")) 52 | (log:info "~@" version) 53 | version))) 54 | 55 | (defun ensure-jenkins-version (&key (endpoint *endpoint*)) 56 | (or (version endpoint) 57 | (setf (version endpoint) (jenkins-version :endpoint endpoint)))) 58 | 59 | (defun verify-jenkins (&key (endpoint *endpoint*)) 60 | (ensure-csrf-protection-token :endpoint endpoint) 61 | (ensure-jenkins-version :endpoint endpoint)) 62 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/model/build.lisp: -------------------------------------------------------------------------------- 1 | ;;;; build.lisp --- Build model class. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | (define-interface-implementations 10 | (action :class-location (xloc:val "@*[local-name() = '_class']")) 11 | 12 | ((git-build-data "hudson.plugins.git.util.BuildData") 13 | ((last-built-revision/sha1 :type string 14 | :xpath "lastBuiltRevision/SHA1/text()")) 15 | (:name-slot last-built-revision/sha1)) 16 | 17 | ((git-build-details "hudson.plugins.git.util.BuildDetails") 18 | ((revision/sha1 :type string 19 | :xpath "build/revision/SHA1/text()")) 20 | (:name-slot revision/sha1)) 21 | 22 | ((subversion-change-log-set "hudson.scm.SubversionChangeLogSet") 23 | ((revision :type string 24 | :xpath "revision/revision/text()")) 25 | (:name-slot revision))) 26 | 27 | (define-model-class build () 28 | ((building? :type boolean 29 | :xpath "building/text()") 30 | (slave-name :type string 31 | :xpath "builtOn/text()") 32 | (result :type keyword 33 | :xpath "result/text()") 34 | (actions :type action 35 | ;; Treat Subversion changeSet as action even though it 36 | ;; isn't. 37 | :xpath ("*[(local-name() = 'action' or local-name() = 'changeSet') 38 | and @*[local-name() = '_class']]" 39 | :if-multiple-matches :all))) 40 | (:root? t) 41 | (:name-slot nil)) 42 | 43 | (defmethod job ((build build) &key &allow-other-keys) 44 | (job (first (split-sequence #\/ (id build))))) 45 | 46 | (defmethod slave ((build build) &key &allow-other-keys) 47 | (node (slave-name build))) 48 | 49 | (defmethod failed? ((build build)) 50 | (eq (result build) :failure)) 51 | 52 | (defmethod print-object ((object build) stream) 53 | (print-unreadable-object (object stream :type t :identity t) 54 | (format stream "~A ~A" 55 | (id object) (if (building? object) 56 | :in-progress 57 | (result object))))) 58 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/model/job-build-wrapper.lisp: -------------------------------------------------------------------------------- 1 | ;;;; job-build-wrapper.lisp --- Model classes for build-wrapper implementations. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | (define-interface-implementations (build-wrapper) 10 | ;; We use the EnvInjectJobProperty instead 11 | #+disabled ((environment "EnvInjectBuildWrapper" :plugin "envinject@2.1.6") 12 | ((entries :type (equals+newline/plist keyword string) 13 | :xpath "info/propertiesContent/text()" 14 | :initform '())) 15 | (:name-slot nil)) 16 | 17 | ((timeout "hudson.plugins.build__timeout.BuildTimeoutWrapper" 18 | :plugin "build-timeout@1.11") 19 | ((kind :type (keyword/downcase :absolute) 20 | :xpath "timeoutType/text()" 21 | :initform :absolute) 22 | (timeout/minutes :type real 23 | :xpath "timeoutMinutes/text()") 24 | (fail-build? :type boolean 25 | :xpath "failBuild/text()" 26 | :initform nil)) 27 | (:name-slot kind)) 28 | 29 | ((sonar "hudson.plugins.sonar.SonarBuildWrapper" 30 | :plugin "sonar@2.6.1") 31 | () 32 | (:name-slot nil)) 33 | 34 | ((timestamper "hudson.plugins.timestamper.TimestamperBuildWrapper" 35 | :plugin "timestamper@1.9") 36 | () 37 | (:name-slot nil)) 38 | 39 | ((ansi-color "hudson.plugins.ansicolor.AnsiColorBuildWrapper" 40 | :plugin "ansicolor@0.6.2") 41 | ((color-map :type string 42 | :xpath "colorMapName/text()" 43 | :initform "xterm")) 44 | (:name-slot color-map))) 45 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/model/job-trigger.lisp: -------------------------------------------------------------------------------- 1 | ;;;; job-trigger.lisp --- Model classes for trigger implementations. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | (define-interface-implementations (trigger) 10 | ((scm "hudson.triggers.SCMTrigger") 11 | ((spec :type string) 12 | (ignore-post-commit-hooks? :type boolean 13 | :xpath "ignorePostCommitHooks/text()" 14 | :initform nil)) 15 | (:name-slot spec)) 16 | 17 | ((timer "hudson.triggers.TimerTrigger") 18 | ((spec :type string)) 19 | (:name-slot spec)) 20 | 21 | ((github "com.cloudbees.jenkins.GitHubPushTrigger" 22 | :plugin "github@1.4") 23 | ((spec :type string)) 24 | (:name-slot spec)) 25 | 26 | ((reverse "jenkins.triggers.ReverseBuildTrigger") 27 | ((spec :type string ; seems to be unused in Jenkins 28 | :xpath "spec/text()" 29 | :initform "") 30 | (upstream-projects :type (list/comma string) 31 | :xpath "upstreamProjects/text()" 32 | :initform '()) 33 | (threshold :type stupid-threshold 34 | :xpath "threshold" 35 | :initform :success)) 36 | (:name-slot upstream-projects))) 37 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/model/view.lisp: -------------------------------------------------------------------------------- 1 | ;;;; view.lisp --- View model class. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | (defparameter *default-columns* 10 | '("hudson.views.StatusColumn" 11 | "hudson.views.WeatherColumn" 12 | "hudson.views.BuildButtonColumn" 13 | "hudson.views.JobColumn" 14 | "hudson.views.LastSuccessColumn" 15 | "hudson.views.LastFailureColumn" 16 | "hudson.views.LastDurationColumn")) 17 | 18 | (deftype string/column () 19 | 'string) 20 | 21 | (defmethod xloc:xml-> ((value stp:element) 22 | (type (eql 'string/column)) 23 | &key inner-types) 24 | (declare (ignore inner-types)) 25 | (stp:local-name value)) 26 | 27 | (defmethod xloc:->xml ((value string) 28 | (dest stp:element) 29 | (type (eql 'string/column)) 30 | &key inner-types) 31 | (declare (ignore inner-types)) 32 | (setf (stp:local-name dest) value)) 33 | 34 | (define-model-class view () 35 | ((id :type string 36 | :xpath "name/text()" 37 | :optional? nil) 38 | (description :type (or null string) 39 | :xpath "description/text()" 40 | :initform nil) 41 | (properties :type (singleton-element "text()") 42 | :xpath ("properties[@class=\"hudson.model.View$PropertyList\"]/property" 43 | :if-multiple-matches :all) 44 | :initform '() 45 | :optional? nil) 46 | (jobs :type (singleton-element "text()") 47 | :xpath ("jobNames[comparator[@class=\"hudson.util.CaseInsensitiveComparator\"]]/string" 48 | :if-multiple-matches :all) 49 | :initform '() 50 | :optional? nil) 51 | (job-filters :type (singleton-element "text()") 52 | :xpath ("jobFilters/filter" 53 | :if-multiple-matches :all) 54 | :initform '() 55 | :optional? nil) 56 | (columns :type string/column 57 | :xpath ("columns/*" 58 | :if-multiple-matches :all) 59 | :initform *default-columns* 60 | :optional? nil)) 61 | (:default-initargs 62 | :data (stp:make-document (stp:make-element "hudson.model.ListView"))) 63 | (:root? t)) 64 | 65 | ;;; HACK: Jenkins requires a sorted list 66 | ;;; (w.r.t. hudson.util.CaseInsensitiveComparator). 67 | (defmethod (setf jobs) :around ((new-value list) (view view)) 68 | (call-next-method (sort (copy-list new-value) #'string-lessp) view)) 69 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;;; protocol.lisp --- Protocol provided by the api module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012, 2013, 2015 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | ;;; Generic model object protocol 10 | 11 | (defgeneric id (object) 12 | (:documentation 13 | "TODO")) 14 | 15 | (defgeneric commit! (object) 16 | (:documentation 17 | "Write transient changes to OBJECT back to the Jenkins server to 18 | have them take effect and make them permanent.")) 19 | 20 | (defgeneric rename (object new-name) 21 | (:documentation 22 | "TODO(jmoringe): document")) 23 | 24 | (defgeneric delete* (object) 25 | (:documentation 26 | "TODO(jmoringe): document")) 27 | 28 | ;;; Node protocol 29 | 30 | #+no (defgeneric make-slave (name) 31 | (:documentation 32 | "TODO(jmoringe): document")) 33 | 34 | (defgeneric online? (node) 35 | (:documentation 36 | "TODO")) 37 | 38 | (defgeneric mark-online! (node 39 | &key 40 | if-online) 41 | (:documentation 42 | "TODO")) 43 | 44 | (defgeneric mark-offline! (node 45 | &key 46 | if-offline) 47 | (:documentation 48 | "TODO")) 49 | 50 | ;;; Job protocol 51 | 52 | #+no (defgeneric make-job (name) 53 | (:documentation 54 | "TODO(jmoringe): document")) 55 | 56 | (defgeneric enable! (job) 57 | (:documentation 58 | "TODO")) 59 | 60 | (defgeneric disable! (job) 61 | (:documentation 62 | "TODO")) 63 | 64 | (defgeneric relate (parent child &key if-related) 65 | (:documentation 66 | "Add PARENT to the list of upstreams of CHILD. 67 | 68 | IF-RELATED controls the behavior in case PARENT is already in the 69 | list of upstreams of CHILD.")) 70 | 71 | (defgeneric unrelate (parent child &key if-not-related) 72 | (:documentation 73 | "Remove PARENT from the list of upstream of CHILD. 74 | 75 | IF-NOT-RELATED controls the behavior in case PARENT is not in the 76 | list of upstreams of CHILD.")) 77 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; types.lisp --- Types used by the api module. 2 | ;;;; 3 | ;;;; Copyright (C) 2013, 2015 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | (deftype unmapped-marker () 10 | "Objects of this type are used as placeholders for unmapped 11 | interface implementations." 12 | `(cons (eql :unimplemented) (cons symbol (cons string (cons t null))))) 13 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/api/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities used in the api module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2018 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.api) 8 | 9 | (defmacro define-enum-type (name-and-options &body names-and-values) 10 | (let+ ((names '()) 11 | 12 | ((name &key (test 'string=) (deftype? t)) 13 | (ensure-list name-and-options)) 14 | 15 | (value->name-clauses '()) 16 | ((&flet value->name (name values) 17 | (push (if (length= 1 values) 18 | `((,test value ,(first values)) 19 | ,name) 20 | `((member value '(,@values) :test #',test) 21 | ,name)) 22 | value->name-clauses))) 23 | 24 | (name->value-clauses '()) 25 | ((&flet name->value (name values) 26 | (push `((,name) ,(first values)) 27 | name->value-clauses))) 28 | 29 | ((&flet+ clause ((name &rest values)) 30 | (push name names) 31 | (value->name name values) 32 | (name->value name values)))) 33 | (map nil #'clause names-and-values) 34 | `(progn 35 | ,@(when deftype? 36 | `((deftype ,name () 37 | '(member ,@names)))) 38 | 39 | (defmethod xloc:xml-> ((value string) 40 | (type (eql ',name)) 41 | &key &allow-other-keys) 42 | (cond ,@value->name-clauses 43 | (t 44 | (error "~@" 45 | ',name value)))) 46 | 47 | (defmethod xloc:->xml ((value symbol) 48 | (dest (eql 'string)) 49 | (type (eql ',name)) 50 | &key &allow-other-keys) 51 | (ecase value 52 | ,@name->value-clauses))))) 53 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/scripting/build.lisp: -------------------------------------------------------------------------------- 1 | ;;;; build.lisp --- 2 | ;;;; 3 | ;;;; Copyright (C) 2012, 2013 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.scripting) 8 | 9 | (defun rebuild-failed () 10 | (dolist (build (last-builds)) 11 | (when (eq (result build) :failure) 12 | (format t "Failed build ~A -> building ~A~%" 13 | build (job build)) 14 | (handler-case 15 | (build! (job build)) 16 | (error (condition) 17 | (format t "Failed to trigger build for job ~A: ~A~%" 18 | (job build) condition)))))) 19 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/scripting/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the scripting module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012, 2013 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:jenkins.scripting 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:split-sequence 12 | #:let-plus 13 | #:iterate 14 | 15 | #:jenkins.api) 16 | 17 | (:export 18 | #:diff-configs) 19 | 20 | (:export 21 | #:assign-unique-ports) 22 | 23 | (:documentation 24 | "TODO")) 25 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/scripting/resources.lisp: -------------------------------------------------------------------------------- 1 | ;;;; resources.lisp --- 2 | ;;;; 3 | ;;;; Copyright (C) 2012, 2013 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.scripting) 8 | 9 | (defun counter (&key (start 4000) (step '(("spread_port" . 2) 10 | ("socket_port" . 60) 11 | (t . 1)))) 12 | "Return a function, which when called with one argument - a resource 13 | name - returns a port number for that resource." 14 | (let ((state start)) 15 | (lambda (name) 16 | (let ((step (or (cdr (assoc name step :test #'string=)) 17 | (cdr (assoc t step :test #'eq)) 18 | 1))) 19 | (prog1 20 | state 21 | (incf state step)))))) 22 | 23 | (defun assign-unique-ports (&key 24 | (jobs (all-jobs)) 25 | (generator (counter))) 26 | (dolist (job jobs) 27 | (when (and (environment job) 28 | (some (compose (curry #'ppcre:scan "port") #'string-downcase) 29 | (environment job))) 30 | (setf (environment job) 31 | (iter (for (key value) on (environment job) :by #'cddr) 32 | (collect key) 33 | (collect 34 | (if (ppcre:scan "port" (string-downcase key)) 35 | (princ-to-string (funcall generator (string-downcase key))) 36 | value)))) 37 | (format t "~A~%~2@T~S~%" (id job) (environment job)) 38 | (commit! job)))) 39 | -------------------------------------------------------------------------------- /lib/jenkins.api/src/scripting/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- 2 | ;;;; 3 | ;;;; Copyright (C) 2012, 2013 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.scripting) 8 | 9 | (defun %diff-configs (name-a config-a name-b config-b 10 | &optional 11 | (stream *standard-output*)) 12 | (let+ (((&flet write-config (name dom) 13 | (let ((filename (format nil "/tmp/~A.xml" name))) 14 | (write-string-into-file 15 | (stp:serialize dom (cxml:make-string-sink)) 16 | filename 17 | :if-does-not-exist :create 18 | :if-exists :supersede) 19 | filename))) 20 | (filename-a (write-config name-a config-a)) 21 | (filename-b (write-config name-b config-b))) 22 | (unwind-protect 23 | (sb-ext:run-program "diff" (list "-u" filename-a filename-b) 24 | :search t 25 | :wait t 26 | :output stream) 27 | (ignore-errors (delete-file filename-a)) 28 | (ignore-errors (delete-file filename-b))) 29 | (values))) 30 | 31 | (defmethod diff-configs ((a string) (b string)) 32 | (diff-configs (job a) (job b))) 33 | 34 | (defmethod diff-configs ((a job) (b job)) 35 | (%diff-configs (id a) (job-config (id a)) 36 | (id b) (job-config (id b)))) 37 | 38 | (defmethod diff-configs ((a node) (b node)) 39 | (%diff-configs (id a) (node-config (id a)) 40 | (id b) (node-config (id b)))) 41 | -------------------------------------------------------------------------------- /lib/jenkins.api/test/management/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for unit tests of the management module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012, 2013 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:jenkins.management.test 8 | (:use 9 | #:cl 10 | #:let-plus 11 | #:lift 12 | 13 | #:jenkins.management) 14 | 15 | (:documentation 16 | "This package contains unit tests for the management module")) 17 | 18 | (cl:in-package #:jenkins.management.test) 19 | 20 | (deftestsuite management-root () 21 | () 22 | (:documentation 23 | "Root unit test suite for the management module.")) 24 | -------------------------------------------------------------------------------- /lib/jenkins.api/test/management/setup.lisp: -------------------------------------------------------------------------------- 1 | ;;;; setup.lisp --- 2 | ;;;; 3 | ;;;; Copyright (C) 2012, 2013 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:jenkins.management.test) 8 | 9 | #+no 10 | (deploy-sbcl "azurit" "/tmp/sbcl-test/") 11 | 12 | ;; linux slaves 13 | (dolist (slave '(("localhost" :port 4444) 14 | #+no ("localhost" :port 4445))) 15 | (let+ (((host &rest args) slave)) 16 | (bt:make-thread 17 | (lambda () 18 | (apply #'install-sbcl host (format nil "/vol/cl/sbcl-~A" *sbcl-version*) 19 | :host-lisp-program "/vol/cl/sbcl-1.0.54/bin/sbcl" 20 | args))))) 21 | 22 | 23 | ;; macos slave 24 | (install-sbcl "localhost" (format nil "/vol/cl/sbcl-~A" *sbcl-version*) 25 | :port 4446 26 | :host-lisp-program "/vol/cl/sbcl-1.0.54/bin/sbcl" 27 | :environment '("SBCL_HOME" "/vol/cl/sbcl-1.0.54/lib/sbcl") 28 | :features '(:sb-thread :sb-core-compression)) 29 | 30 | #+no 31 | (let ((stream (open/ssh "localhost" "/tmp/bla.txt" :direction :output :port 22))) 32 | (format stream "bla~%") 33 | (close stream)) 34 | 35 | #+macabeo 36 | (install-sbcl "macabeo" "/homes/abarch/opt/sbcl-1.0.54" 37 | :user "abarch" 38 | :host-lisp-program "/homes/abarch/opt/sbcl/bin/sbcl" 39 | :environment '("SBCL_HOME" "/homes/abarch/opt/sbcl/lib/sbcl") 40 | :features '(:sb-core-compression)) 41 | 42 | #+no 43 | (install-quicklisp "macabeo" 44 | :user "abarch" 45 | :lisp "/homes/abarch/opt/sbcl-1.0.54/bin/sbcl") 46 | -------------------------------------------------------------------------------- /src/analysis/ant.lisp: -------------------------------------------------------------------------------- 1 | ;;;; ant.lisp --- Dummy analysis for ant projects. 2 | ;;;; 3 | ;;;; Copyright (C) 2015, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | (defmethod analyze ((source pathname) (kind (eql :ant)) &key) 10 | '()) 11 | -------------------------------------------------------------------------------- /src/analysis/autotools.lisp: -------------------------------------------------------------------------------- 1 | ;;;; autotools.lisp --- Dummy analysis for autotools projects. 2 | ;;;; 3 | ;;;; Copyright (C) 2015, 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | (defmethod analyze ((source pathname) (kind (eql :autotools)) &key) 10 | `(:natures (,kind) :programming-languages ("C"))) 11 | -------------------------------------------------------------------------------- /src/analysis/cache.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cache.lisp --- Caching of analysis results. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | ;;; Keys 10 | 11 | (defun octets->hex-string (octets prefix) 12 | (format nil "~A:~@[~(~{~2,'0X~}~)~]" prefix (coerce octets 'list))) 13 | 14 | (defun sub-directory->key (sub-directory prefix) 15 | (let* ((octets (when sub-directory 16 | (sb-ext:string-to-octets 17 | (namestring sub-directory) :external-format :utf-8))) 18 | (hash (when octets 19 | (ironclad:digest-sequence 'ironclad:sha256 octets)))) 20 | (octets->hex-string hash prefix))) 21 | 22 | (defun natures->key (natures prefix) 23 | (let* ((natures (or natures '(:none))) 24 | (sorted (sort (map 'list #'string-downcase natures) #'string<))) 25 | (format nil "~A:~{~A~^;~}" prefix sorted))) 26 | 27 | ;;; Cache 28 | 29 | (defun ensure-cache-directory (cache-directory) 30 | (unless (probe-file cache-directory) 31 | (log:info "~@" 32 | cache-directory) 33 | (ensure-directories-exist cache-directory))) 34 | 35 | (defun cache-restore (cache-directory key &key age-limit) 36 | (with-simple-restart (continue "~@") 37 | (let ((file (merge-pathnames key cache-directory))) 38 | (log:info "~@" file) 39 | (when (probe-file file) 40 | (log:info "~@" file) 41 | (let+ (((version timestamp data) (let ((entry (cl-store:restore file))) 42 | (typecase entry 43 | ((cons string (cons integer (cons t null))) 44 | entry) 45 | ((cons string t) 46 | (list (car entry) nil (cdr entry)))))) 47 | (age)) 48 | (cond ((not (string= version *cache-version*)) 49 | (log:warn "~@" 51 | version *cache-version*) 52 | nil) 53 | ((and age-limit 54 | (or (not timestamp) 55 | (> (setf age (- (get-universal-time) timestamp)) 56 | age-limit))) 57 | (log:info "~@" 60 | timestamp age age-limit) 61 | nil) 62 | (t 63 | data))))))) 64 | 65 | (defun cache-store (cache-directory key results) 66 | (with-simple-restart (continue "~@") 67 | (unless (probe-file cache-directory) 68 | (log:info "~@" 69 | cache-directory) 70 | (ensure-directories-exist cache-directory)) 71 | (let ((file (merge-pathnames key cache-directory))) 72 | (log:info "~@" file) 73 | (let ((entry (list *cache-version* (get-universal-time) results))) 74 | (cl-store:store entry file))))) 75 | 76 | (defun cache-or-compute (cache-directory key thunk &key age-limit) 77 | (let ((cachable? (and cache-directory key))) 78 | (or (when cachable? 79 | (cache-restore cache-directory key :age-limit age-limit)) 80 | (let ((results (funcall thunk))) 81 | (when cachable? 82 | (cache-store cache-directory key results)) 83 | results)))) 84 | -------------------------------------------------------------------------------- /src/analysis/dependencies.lisp: -------------------------------------------------------------------------------- 1 | ;;;; dependencies.lisp --- Dependency-related functions. 2 | ;;;; 3 | ;;;; Copyright (C) 2013-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | ;;; Natures and targets 10 | 11 | (defun same-target? (left-nature left-target right-nature right-target) 12 | (and (eq left-nature right-nature) 13 | (or (string= left-target right-target) 14 | (and (eq left-nature :cmake) 15 | (string-equal left-target right-target))))) 16 | 17 | (defun target-matches? (required-nature required-target 18 | provided-nature provided-target) 19 | (same-target? required-nature required-target 20 | provided-nature provided-target)) 21 | 22 | (defun+ dependency-matches? 23 | ((required-nature required-target &optional required-version) 24 | (provided-nature provided-target &optional provided-version)) 25 | (and (target-matches? required-nature required-target 26 | provided-nature provided-target) 27 | (version:version-matches required-version provided-version))) 28 | 29 | ;;; Dependencies 30 | 31 | (defun effective-requires (requires provides) 32 | (set-difference requires provides :test #'dependency-matches?)) 33 | 34 | (defun merge-dependencies (dependencies &key (test #'version:version>=)) 35 | (let ((test (ensure-function test)) 36 | (seen (make-hash-table :test #'equal))) 37 | (map nil (lambda+ ((&whole dependency nature name &optional version)) 38 | (let ((key (cons nature (case nature 39 | (:cmake (string-downcase name)) 40 | (t name))))) 41 | (setf (gethash key seen) 42 | (let ((current (gethash key seen))) 43 | (if (or (not current) 44 | (funcall test version (third current))) 45 | dependency 46 | current))))) 47 | dependencies) 48 | (hash-table-values seen))) 49 | 50 | ;;; Indexed dependencies 51 | 52 | (defun dependency-key (dependency) 53 | (let+ (((nature target &optional version) dependency)) 54 | (cond 55 | ((eq nature :cmake) (list nature (string-downcase target))) 56 | (version (list nature target)) 57 | (t dependency)))) 58 | 59 | (defun make-provider-index () 60 | (make-hash-table :test #'equal)) 61 | 62 | (defun index-provider! (provided provider index) 63 | (let ((key (dependency-key provided))) 64 | (push (cons provided provider) (gethash key index '())) 65 | index)) 66 | 67 | (defun lookup-providers (required index) 68 | (gethash (dependency-key required) index)) 69 | -------------------------------------------------------------------------------- /src/analysis/license.lisp: -------------------------------------------------------------------------------- 1 | ;;;; license.lisp --- Analysis of license files. 2 | ;;;; 3 | ;;;; Copyright (C) 2013-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | (declaim (inline whitespace?)) 10 | (defun whitespace? (character) 11 | (or (char= character #\Space) 12 | (char= character #\Tab) 13 | (char= character #\Newline) 14 | (char= character #\Return))) 15 | 16 | (defun normalize-text (string) 17 | (loop :for previous = nil :then current 18 | :for current :across string 19 | :for whitespace? = (whitespace? current) 20 | :when (and (not whitespace?) previous (whitespace? previous)) 21 | :collect #\Space :into result 22 | :unless whitespace? 23 | :collect (char-downcase current) :into result 24 | :finally (return 25 | (when result 26 | (when (whitespace? (first result)) 27 | (pop result)) 28 | (coerce result 'simple-string))))) 29 | 30 | (defun directory-licenses (directory) 31 | (loop :for file :in (directory (merge-pathnames "**/*.*" directory)) 32 | :for name = (namestring (make-pathname :directory nil :defaults file)) 33 | :collect (cons name (normalize-text 34 | (util:read-file-into-string* file))))) 35 | 36 | (defvar *licenses* 37 | (let ((system-licenses (directory-licenses "/usr/share/common-licenses/")) 38 | (extra-licenses (directory-licenses (asdf:system-relative-pathname 39 | :build-generator "data/licenses/")))) 40 | (log:info "~@<~:[~ 41 | Not including any system licenses~ 42 | ~;~:*~ 43 | Including system licenses~@:_~ 44 | ~<~{• ~A~^~@:_~}~:>~@:_~ 45 | ~]~ 46 | ~:[~ 47 | Not including any extra licenses~ 48 | ~;~:*~ 49 | Including extra licenses~@:_~ 50 | ~<~{• ~A~^~@:_~}~:>~@:_~ 51 | ~]~:>" 52 | (when system-licenses 53 | (list (map 'list #'first system-licenses))) 54 | (when extra-licenses 55 | (list (map 'list #'first extra-licenses)))) 56 | (append system-licenses extra-licenses))) 57 | 58 | (defun identify-license (text &key (known-licenses *licenses*) (threshold 100)) 59 | (when-let ((normalized (normalize-text text))) ; Could even warn here if empty 60 | (or ;; Fast path: exact match. 61 | (car (find normalized known-licenses :test #'string= :key #'cdr)) 62 | ;; Slow path: edit distance. 63 | (let ((threshold (clamp (truncate threshold (/ (length normalized))) 1 2000))) 64 | (car (find normalized known-licenses 65 | :test (lambda (text license) 66 | (< (util:edit-distance 67 | text license :upper-bound threshold) 68 | threshold)) 69 | :key #'cdr)))))) 70 | 71 | (defvar *license-file-patterns* 72 | '("COPYING.*" "LICENSE.*" "*/**/COPYING.*" "*/**/LICENSE.*")) 73 | 74 | (defmethod analyze ((directory pathname) 75 | (kind (eql :license)) 76 | &key 77 | (threshold .2)) 78 | (with-trivial-progress (:analyze/license "~A" directory) 79 | (loop :with files = (util:make-file-generator 80 | directory *license-file-patterns*) 81 | :for file = (funcall files) 82 | :while file 83 | :do (when-let* ((text (util:read-file-into-string* file)) 84 | (license (identify-license text :threshold threshold))) 85 | (return-from analyze `(:license ,license)))))) 86 | -------------------------------------------------------------------------------- /src/analysis/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the analysis module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.analysis 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:split-sequence 12 | #:iterate 13 | #:let-plus 14 | #:more-conditions) 15 | 16 | (:local-nicknames 17 | (#:util #:build-generator.util) 18 | (#:version #:build-generator.version)) 19 | 20 | ;; Conditions 21 | (:export 22 | #:analysis-condition 23 | #:analysis-condition-specification 24 | 25 | #:analysis-error 26 | 27 | #:repository-access-error 28 | 29 | #:repository-analysis-error 30 | 31 | #:project-analysis-error 32 | 33 | #:dependency-condition 34 | #:dependency-condition-dependency 35 | 36 | #:unfulfilled-project-dependency-error 37 | #:unfulfilled-project-dependency-candidates 38 | 39 | #:unfulfilled-platform-dependency-error) 40 | 41 | ;; Natures, targets and dependencies 42 | (:export 43 | #:same-target? 44 | #:target-matches? 45 | 46 | #:dependency-matches? 47 | 48 | #:merge-dependencies 49 | #:effective-requires 50 | 51 | #:dependency-key 52 | #:make-provider-index 53 | #:index-provider! 54 | #:lookup-providers) 55 | 56 | ;; Analysis protocol 57 | (:export 58 | #:analyze) 59 | 60 | (:export 61 | #:current-platform 62 | #:installed-packages) 63 | 64 | (:documentation 65 | "Functions for analyzing various kinds of projects.")) 66 | -------------------------------------------------------------------------------- /src/analysis/pkg-config.lisp: -------------------------------------------------------------------------------- 1 | ;;;; pkg-config.lisp --- Analyze pkg-config files. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | (defmethod analyze ((source pathname) (kind (eql :pkg-config)) 10 | &key) 11 | (with-open-stream (stream (apply #'open source (util:safe-external-format-argument))) 12 | (analyze stream kind :name (pathname-name source)))) 13 | 14 | (defmethod analyze ((source stream) (kind (eql :pkg-config)) 15 | &key 16 | (name (missing-required-argument :name))) 17 | (let+ ((version) 18 | ((&flet parse-requires (value) 19 | (iter (for spec in (split-sequence-if 20 | (rcurry #'member '(#\Space #\Tab)) value 21 | :remove-empty-subseqs t)) 22 | (collect `(:pkg-config ,spec)))))) 23 | (iter (for line in-stream source :using #'read-line) 24 | (ppcre:register-groups-bind (key value) 25 | ("[ \\t]*([^:]+):[ \\t]*([^ \\t#]*)" line) 26 | (cond 27 | ((string= key "Version") 28 | (setf version (version:parse-version value))) 29 | ((string= key "Requires") 30 | (appending (parse-requires value) :into requires)))) 31 | (finally (return `(:provides ((:pkg-config ,name ,version)) 32 | :requires ,requires)))))) 33 | -------------------------------------------------------------------------------- /src/analysis/platform.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the analysis module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | ;;; Current platform 10 | 11 | #+linux 12 | (defun lsb-distribution () 13 | (inferior-shell:run/ss '("lsb_release" "-si"))) 14 | 15 | #+linux 16 | (defun current-platform () 17 | (values (string-downcase (lsb-distribution)) 18 | (inferior-shell:run/ss '("lsb_release" "-sc")) 19 | (inferior-shell:run/ss '("uname" "-m")))) 20 | 21 | #+darwin 22 | (defun current-platform () 23 | (values "macos" 24 | "?" 25 | (inferior-shell:run/ss '("uname" "-m")))) 26 | 27 | ;;; Installed packages 28 | 29 | (defun installed-packages/not-implemented (type &key (signal-via #'error)) 30 | (funcall signal-via "~@" 32 | (ensure-list type))) 33 | 34 | ;; Linux 35 | 36 | ;; lsb_release distribution => { Debian, Ubuntu } 37 | (defun installed-packages/linux/debian-like () 38 | (let+ (((&flet list-packages (name-format) 39 | (let ((lines (inferior-shell:run/lines 40 | `("dpkg-query" 41 | ,(format nil "--showformat=${~A} ${Version} ${Status}\\n" 42 | name-format) 43 | "--show")))) 44 | (iter (for line in lines) 45 | (when (ends-with-subseq "install ok installed" line) 46 | (let+ (((name version) 47 | (subseq (split-sequence #\Space line) 0 2))) 48 | (collect (list name (version:parse-version version)))))))))) 49 | (union (list-packages "binary:package") 50 | (list-packages "Package") 51 | :test #'equalp))) 52 | 53 | ;; lsb_release distribution => Arch 54 | (defun installed-packages/linux/arch () 55 | (let ((lines (inferior-shell:run/lines '("pacman" "-Q")))) 56 | (iter (for line in lines) 57 | (let+ (((name version) (split-sequence #\Space line))) 58 | (collect (list name (version:parse-version version))))))) 59 | 60 | (defvar *installed-packages-functions/linux* 61 | `(("Ubuntu" . installed-packages/linux/debian-like) 62 | ("Debian" . installed-packages/linux/debian-like) 63 | ("Arch" . installed-packages/linux/arch))) 64 | 65 | (defun installed-packages/linux () 66 | (when-let* ((distribution (lsb-distribution)) 67 | (function (or (cdr (assoc distribution *installed-packages-functions/linux* 68 | :test #'string=)) 69 | (curry #'installed-packages/not-implemented 70 | (list distribution "Linux"))))) 71 | (log:info "~@" distribution) 72 | (funcall function))) 73 | 74 | (defvar *installed-packages-functions* 75 | `(("Linux" . installed-packages/linux))) 76 | 77 | (defun installed-packages () 78 | (with-simple-restart (continue "~@") 80 | (when-let* ((type (software-type)) 81 | (function (or (cdr (assoc type *installed-packages-functions* 82 | :test #'string=)) 83 | (curry #'installed-packages/not-implemented 84 | type :signal-via #'warn)))) 85 | (log:info "~@" type) 86 | (funcall function)))) 87 | -------------------------------------------------------------------------------- /src/analysis/protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;;; protocol.lisp --- Protocol for the analysis module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | ;;; Analysis protocol 10 | 11 | (defgeneric analyze (source kind &key &allow-other-keys) 12 | (:documentation 13 | "Analyze the project in SOURCE assuming project kind KIND. 14 | 15 | * If SOURCE is a pathname, return analysis results in form of a 16 | plist containing at least the keys `:provides' and `:requires'. 17 | 18 | * If SOURCE is a pathname and KIND is `:guess', an attempt is 19 | made to guess the project kind from SOURCE. 20 | 21 | * If SOURCE is a `puri:uri', return a list containing such 22 | analysis results, the elements corresponding to revisions in the 23 | repository designated by the URI SOURCE. Elements are of the 24 | form 25 | 26 | ((:version \"VERSION\" :branch \"BRANCH\" :commit \"COMMIT\") 27 | . RESULTS-PLIST) 28 | 29 | . 30 | 31 | * If SOURCE is a `puri:uri' and KIND is `:guess', an attempt is 32 | made to guess the version control system from SOURCE and the 33 | project kind from the content of SOURCE.")) 34 | 35 | (defvar *outermost?* t) 36 | 37 | (defmethod analyze :around ((source t) (kind t) &key project &allow-other-keys) 38 | (labels ((do-it () 39 | (let ((result (multiple-value-list (call-next-method)))) 40 | (log:debug "~@" 41 | source kind result) 42 | (apply #'values result))) 43 | (do-it/generic-translation () 44 | (with-condition-translation (((error analysis-error) 45 | :specification source)) 46 | (let ((*outermost?* nil)) 47 | (do-it))))) 48 | (cond ((not *outermost?*) 49 | (do-it)) 50 | ((not project) 51 | (do-it/generic-translation)) 52 | (t 53 | (with-condition-translation (((error project-analysis-error) 54 | :specification project)) 55 | (do-it/generic-translation)))))) 56 | 57 | (defvar *outermost-pathname* nil) 58 | 59 | (defmethod analyze :around ((source pathname) (kind t) &key) 60 | (let ((*outermost-pathname* (or *outermost-pathname* source))) 61 | (with-condition-translation (((error repository-analysis-error) 62 | :specification source 63 | :context-directory *outermost-pathname*)) 64 | (call-next-method)))) 65 | -------------------------------------------------------------------------------- /src/analysis/ros-packages.lisp: -------------------------------------------------------------------------------- 1 | ;;;; ros-packages.lisp --- Analysis of multi-ROS package repositories. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | (defun meta-package? (package-filename) 10 | (let ((document (cxml:parse package-filename (stp:make-builder)))) 11 | (unless (xpath:node-set-empty-p 12 | (xpath:evaluate "package/export/metapackage" document)) 13 | (log:info "~@" package-filename) 14 | t))) 15 | 16 | (defmethod analyze ((directory pathname) 17 | (kind (eql :ros-packages)) 18 | &key) 19 | (let+ ((candidates (directory (merge-pathnames "**/package.xml" directory))) 20 | (packages (remove-if #'meta-package? candidates)) 21 | (directories (mapcar #'uiop:pathname-directory-pathname packages)) 22 | (results (mapcan 23 | (lambda (directory) 24 | (with-simple-restart (continue "Skip sub-directory ~S" 25 | directory) 26 | (list (analyze directory :ros-package)))) 27 | directories)) 28 | ((&flet property-values (name) 29 | (loop :for result in results 30 | :for package-name = (second (first (getf result :provides))) 31 | :for package-value = (getf result name) 32 | :when package-value 33 | :collect (list package-name package-value)))) 34 | ;; Use the first value available in any of the analyzed 35 | ;; packages. 36 | ((&flet property-value/first (name) 37 | (second (first (property-values name))))) 38 | ((&flet maybe-property/first (name) 39 | (when-let ((value (property-value/first name))) 40 | `(,name ,value)))) 41 | ;; Combine the values in the analyzed packages. 42 | ((&flet property-value/merge-persons (name) 43 | (rosetta-project.model.resource:merge-persons! 44 | (reduce #'append (property-values name) :key #'second)))) 45 | ((&flet maybe-property/merge-persons (name) 46 | (when-let ((value (property-value/merge-persons name))) 47 | `(,name ,value)))) 48 | ((&flet property-value/dependencies (name) 49 | (merge-dependencies 50 | (reduce #'append (property-values name) :key #'second)))) 51 | ;; Combine descriptions of analyzed packages. 52 | ((&flet maybe-property/description (name) 53 | (let ((values (property-values name))) 54 | (case (length values) 55 | (0 nil) 56 | (1 `(,name ,(second (first values)))) 57 | (t `(,name ,(format nil "The project contains the following packages:~ 58 | ~2%~ 59 | ~{~{~A: ~A~}~^~2%~}" 60 | (sort (remove-duplicates values :test #'equal) 61 | #'string< :key #'first)))))))) 62 | (requires (property-value/dependencies :requires)) 63 | (provides (property-value/dependencies :provides))) 64 | ;; Final result. 65 | `(:natures (,kind) 66 | :provides ,provides 67 | :requires ,(effective-requires requires provides) 68 | ,@(maybe-property/description :description) 69 | ,@(maybe-property/merge-persons :authors) 70 | ,@(maybe-property/merge-persons :maintainers) 71 | ,@(maybe-property/first :license)))) 72 | -------------------------------------------------------------------------------- /src/analysis/scm-null.lisp: -------------------------------------------------------------------------------- 1 | ;;;; scm-null.lisp --- Analysis for projects without repository. 2 | ;;;; 3 | ;;;; Copyright (C) 2014, 2015, 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | (defmethod analyze ((source (eql nil)) (kind t) 10 | &key 11 | (versions (missing-required-argument :versions))) 12 | (make-list (length versions))) 13 | -------------------------------------------------------------------------------- /src/analysis/variables.lisp: -------------------------------------------------------------------------------- 1 | ;;;; variables.lisp --- Variables used in the analysis module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.analysis) 8 | 9 | (defvar *cache-version* 10 | (asdf:component-version (asdf:find-system :build-generator))) 11 | -------------------------------------------------------------------------------- /src/bcrypt/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the bcrypt module. 2 | ;;;; 3 | ;;;; Copyright (C) 2014-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.bcrypt 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | 13 | #:nibbles) 14 | 15 | ;; bcrypt-specific base64 encoding 16 | (:export 17 | #:base64-encode 18 | #:base64-decode) 19 | 20 | ;; Text format conversion 21 | (:export 22 | #:parse-password-hash 23 | #:print-password-hash) 24 | 25 | ;; Interface 26 | (:export 27 | #:make-salt 28 | #:hash-password) 29 | 30 | (:documentation 31 | "An implementation of the bcrypt key derivation.")) 32 | -------------------------------------------------------------------------------- /src/commandline-interface/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the commandline-interface module. 2 | ;;;; 3 | ;;;; Copyright (C) 2013-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.commandline-interface 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:more-conditions) 13 | 14 | (:local-nicknames 15 | (#:options #:configuration.options) 16 | 17 | (#:util #:build-generator.util) 18 | 19 | (#:analysis #:build-generator.analysis) 20 | 21 | (#:model #:build-generator.model) 22 | (#:var #:build-generator.model.variables) 23 | (#:project #:build-generator.model.project) 24 | 25 | (#:commands #:build-generator.commands) 26 | (#:commandline #:build-generator.commandline-options)) 27 | 28 | (:export 29 | #:main) 30 | 31 | (:documentation 32 | "The commandline interface of the build-generator system.")) 33 | -------------------------------------------------------------------------------- /src/commandline-options/macros.lisp: -------------------------------------------------------------------------------- 1 | ;;;; macros.lisp --- Macros provided by the commandline-options module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commandline-options) 8 | 9 | (defmacro define-option-mapping ((schema context) &body clauses) 10 | (let+ (((&flet+ register-info ((designators option-name 11 | &optional argument-name mandatory?)) 12 | (let* ((designators (ensure-list designators)) 13 | (positional? (every (of-type 'positional-option-designator) 14 | designators)) 15 | (named? (every (of-type 'named-option-designator) 16 | designators)) 17 | (class (cond 18 | (positional? 19 | 'positional-option-info) 20 | ((and named? (not argument-name)) 21 | 'named-without-argument-option-info) 22 | (named? 23 | 'named-with-argument-option-info) 24 | (t 25 | (error "~@" 27 | designators))))) 28 | `(let* ((option (configuration.options:find-option 29 | (list ,context ,option-name) ,schema))) 30 | (register-option 31 | ,context (make-instance ',class 32 | :option option 33 | :designators '(,@designators) 34 | :argument-name ,argument-name 35 | :mandatory? ,mandatory?))))))) 36 | `(progn 37 | (setf (find-options ,context) 38 | (find-options ,context :if-does-not-exist '())) 39 | ,@(map 'list #'register-info clauses)))) 40 | -------------------------------------------------------------------------------- /src/commandline-options/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the commandline-options module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.commandline-options 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:more-conditions) 13 | 14 | (:local-nicknames 15 | (#:util #:build-generator.util)) 16 | 17 | ;; Conditions 18 | (:export 19 | #:option-context-condition 20 | #:context 21 | 22 | #:context-not-found-error 23 | 24 | #:option-condition 25 | #:option 26 | 27 | #:option-not-found-error 28 | #:option-argument-error) 29 | 30 | ;; Option info protocol 31 | (:export 32 | #:option-value) 33 | 34 | ;; Option contexts 35 | (:export 36 | #:find-options 37 | #:register-option) 38 | 39 | ;; Individual options 40 | (:export 41 | #:find-option 42 | #:value-for-option) 43 | 44 | ;; High-level interface 45 | (:export 46 | #:map-commandline-options) 47 | 48 | ;; Macros 49 | (:export 50 | #:define-option-mapping) 51 | 52 | ;; Help 53 | (:export 54 | #:print-option 55 | #:print-usage 56 | #:print-options) 57 | 58 | (:documentation 59 | "Handling of commandline options. 60 | 61 | Based on a configuration option schema, this package allows 62 | associating commandline option information to configuration 63 | options and to process commandline argument according to this 64 | information. 65 | 66 | The option information is organized into several contexts 67 | corresponding to global commandline options and 68 | sub-command-specific commandline options.")) 69 | -------------------------------------------------------------------------------- /src/commandline-options/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; types.lisp --- Types used in the commandline-options module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commandline-options) 8 | 9 | (deftype positional-option-designator () 10 | '(or non-negative-integer (eql &rest))) 11 | 12 | (defun named-option-designator? (thing) 13 | (and (stringp thing) (starts-with #\- thing))) 14 | 15 | (deftype named-option-designator () 16 | `(and string (satisfies named-option-designator?))) 17 | 18 | (deftype option-designator () 19 | `(or positional-option-designator named-option-designator)) 20 | -------------------------------------------------------------------------------- /src/commands/command-create-jenkins-user.lisp: -------------------------------------------------------------------------------- 1 | ;;;; command-create-jenkins-user.lisp --- Create a user in a Jenkins instance. 2 | ;;;; 3 | ;;;; Copyright (C) 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | (defclass create-jenkins-user (output-directory-mixin) 10 | (;; Output 11 | (output-directory :documentation 12 | #.(format nil "Home directory of the Jenkins ~ 13 | instance in which the user should be ~ 14 | created.")) 15 | ;; User creation 16 | (username :initarg :username 17 | :type (or null string) 18 | :reader username 19 | :initform nil 20 | :documentation 21 | "Username for the new user account.") 22 | (email :initarg :email 23 | :type (or null string) 24 | :reader email 25 | :initform nil 26 | :documentation 27 | "Email-address for the new user account.") 28 | (password :initarg :password 29 | :type (or null string) 30 | :reader password 31 | :initform nil 32 | :documentation 33 | "Password for the new user account.")) 34 | (:documentation 35 | #.(format nil "Create a user account in a Jenkins instance."))) 36 | 37 | (service-provider:register-provider/class 38 | 'command :create-jenkins-user :class 'create-jenkins-user) 39 | 40 | (build-generator.commandline-options:define-option-mapping 41 | (*command-schema* "create-jenkins-user") 42 | (0 "output-directory" "DIRECTORY" t) 43 | 44 | (("--username" "-u") "username" "USENAME" t) 45 | (("--email" "-e") "email" "EMAIL-ADDRESS" t) 46 | (("--password" "-p") "password" "PASSWORD" t)) 47 | 48 | (defmethod command-execute ((command create-jenkins-user)) 49 | (let+ (((&accessors-r/o output-directory username email password) command)) 50 | (as-phase (:configure) 51 | (steps:execute (steps:make-step :jenkins/create-user) nil 52 | :destination-directory output-directory 53 | :username username 54 | :email email 55 | :password password)))) 56 | -------------------------------------------------------------------------------- /src/commands/command-info-aspects.lisp: -------------------------------------------------------------------------------- 1 | ;;;; command-info-aspects.lisp --- Command for printing aspect information. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | (defclass info-aspects () 10 | () 11 | (:documentation 12 | "Print information about available aspects.")) 13 | 14 | (service-provider:register-provider/class 15 | 'command :info-aspects :class 'info-aspects) 16 | 17 | (build-generator.commandline-options:define-option-mapping 18 | (*command-schema* "info-aspects")) 19 | 20 | (defmethod command-execute ((command info-aspects)) 21 | (let* ((stream *standard-output*) 22 | (providers (service-provider:service-providers 'aspects::aspect)) 23 | (providers (sort (copy-list providers) #'string< 24 | :key (compose #'string #'service-provider:provider-name)))) 25 | (format stream "~{~<~ 26 | ~(~A~)~ 27 | ~@[~@:_~4@T~<~{~{~ 28 | \"~(~A~)\"~@[: ~(~A~)~]~@[ = ~A~]~ 29 | ~@[~@:_~A~]~ 30 | ~}~^~@:_~}~:>~]~ 31 | ~@[~@:_~2@T~A~]~ 32 | ~:>~^~2%~}" 33 | (mapcar (lambda (provider) 34 | (list (service-provider:provider-name provider) 35 | (when-let ((stuff (mapcar (lambda (parameter) 36 | (let ((variable (aspects:aspect-parameter-variable parameter))) 37 | (list (var:variable-info-name variable) 38 | (unless (eq (var:variable-info-type variable) t) 39 | (var:variable-info-type variable)) 40 | (json:encode-json-to-string 41 | (aspects:aspect-parameter-default-value parameter)) 42 | (var:variable-info-documentation variable)))) 43 | (aspects:aspect-parameters 44 | (service-provider:provider-class provider))))) 45 | (list stuff)) 46 | (documentation provider t))) 47 | providers)))) 48 | -------------------------------------------------------------------------------- /src/commands/command-info-variables.lisp: -------------------------------------------------------------------------------- 1 | ;;;; command-info-variables.lisp --- Command for printing variable information. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | (defclass info-variables () 10 | ((filter :type (or null string function) ; TODO string is a hack 11 | :reader filter 12 | :accessor %filter 13 | :initform nil 14 | :documentation 15 | "Restrict output to matching variables.")) 16 | (:documentation 17 | "Print information about recognized variables.")) 18 | 19 | (defmethod shared-initialize :after ((instance info-variables) (slot-names t) 20 | &key 21 | (filter nil filter-supplied?)) 22 | (when filter-supplied? 23 | (setf (%filter instance) 24 | (etypecase filter 25 | ((or null function) 26 | filter) 27 | (string 28 | (lambda (variable-info) 29 | (let ((name (string-downcase 30 | (var:variable-info-name variable-info)))) 31 | (ppcre:scan filter name)))))))) 32 | 33 | (service-provider:register-provider/class 34 | 'command :info-variables :class 'info-variables) 35 | 36 | (build-generator.commandline-options:define-option-mapping 37 | (*command-schema* "info-variables") 38 | (("--filter" "-f") "filter" "REGEX")) 39 | 40 | (defmethod command-execute ((command info-variables)) 41 | (let* ((stream *standard-output*) 42 | (relevant (if-let ((filter (filter command))) 43 | (delete-if-not filter (copy-list (var:all-variables))) 44 | (copy-list (var:all-variables)))) 45 | (sorted (sort relevant #'string< :key #'var:variable-info-name))) 46 | (format stream "~@<~{~{~ 47 | \"~(~A~)\"~@[: ~(~A~)~]~ 48 | ~@[~@:_~2@T~<~A~:>~]~ 49 | ~}~^~@:_~@:_~}~:>" 50 | (mapcar (lambda (variable) 51 | (let+ (((&accessors-r/o (name var:variable-info-name) 52 | (type var:variable-info-type) 53 | (documentation var:variable-info-documentation)) 54 | variable)) 55 | (list name 56 | (unless (eq type t) type) 57 | (when documentation (list documentation))))) 58 | sorted)))) 59 | -------------------------------------------------------------------------------- /src/commands/command-platform-requirements.lisp: -------------------------------------------------------------------------------- 1 | ;;;; command-platform-requirements.lisp --- Compute requirements for a given platform. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | (defclass platform-requirements (distribution-input-mixin 10 | mode-mixin) 11 | ((platform :initarg :platform 12 | :type string 13 | :reader platform 14 | :documentation 15 | #.(format nil "The platform for which dependencies should ~ 16 | be computed.~@ 17 | ~@ 18 | 19 | The platform is specified as a space-separated ~ 20 | sequence of increasingly specific component ~ 21 | strings:~@ 22 | ~@ 23 | ~2@TSYSTEM-NAME [SYSTEM-VERSION [ARCHITECTURE]]~@ 24 | ~@ 25 | Examples:~@ 26 | ~@ 27 | • \"ubuntu\"~@ 28 | ~@ 29 | • \"ubuntu bionic\"~@ 30 | ~@ 31 | • \"ubuntu bionic x86_64\""))) 32 | (:documentation 33 | "Analyze system packages required on a given platform.")) 34 | 35 | (service-provider:register-provider/class 36 | 'command :platform-requirements :class 'platform-requirements) 37 | 38 | (build-generator.commandline-options:define-option-mapping 39 | (*command-schema* "platform-requirements") 40 | (&rest "distributions" "DISTRIBUTION-NAME" t) 41 | 42 | (("--mode" "-m") "mode" "MODE") 43 | (("--set" "-D") "overwrites" "VARIABLE-NAME=VALUE") 44 | 45 | (("--platform" "-p") "platform" "PLATFORM-SPEC" t)) 46 | 47 | (defmethod command-execute ((command platform-requirements)) 48 | (let+ (((&accessors-r/o distributions mode overwrites platform) command) 49 | ((&values distributions projects) 50 | (generate-load distributions mode overwrites 51 | :generator-version (generator-version) 52 | :cache-directory *cache-directory*)) 53 | (distributions 54 | (generate-analyze distributions projects 55 | :generator-version (generator-version) 56 | :temp-directory *temp-directory* 57 | :cache-directory *cache-directory* 58 | :age-limit *age-limit*)) 59 | (distributions 60 | (as-phase (:instantiate) 61 | (mapcan (lambda (distribution-spec) 62 | (when-let ((distribution (model:instantiate distribution-spec))) 63 | (list distribution))) 64 | distributions))) 65 | (platform (split-sequence:split-sequence #\Space platform)) 66 | (requirements (as-phase (:check-platform-requirements) 67 | (project:platform-requires distributions platform)))) 68 | (report-platform-requirements requirements platform))) 69 | -------------------------------------------------------------------------------- /src/commands/command-validate.lisp: -------------------------------------------------------------------------------- 1 | ;;;; command-validate.lisp --- Validate a recipe repository. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | (defclass validate () 10 | ((recipes :initarg :recipes 11 | :type pathname 12 | :reader recipes 13 | :documentation 14 | "Distribution recipe or root directory of recipe repository.")) 15 | (:documentation 16 | "Perform basic sanity checks for a given recipe repository.")) 17 | 18 | (service-provider:register-provider/class 19 | 'command :validate :class 'validate) 20 | 21 | (build-generator.commandline-options:define-option-mapping 22 | (*command-schema* "validate") 23 | (0 "recipes" "FILENAME-OR-DIRECTORY" t)) 24 | 25 | (defmethod command-execute ((command validate)) 26 | (let* ((recipes (recipes command)) 27 | (distribution-files 28 | (cond 29 | ((wild-pathname-p recipes) 30 | (directory recipes)) 31 | ((equal (pathname-type recipes) "distribution") 32 | (list recipes)) 33 | (t 34 | (directory 35 | (merge-pathnames 36 | "distributions/*.distribution" 37 | (uiop:ensure-directory-pathname recipes))))))) 38 | (generate-load distribution-files "toolkit" '() 39 | :generator-version (generator-version) 40 | :cache-directory *cache-directory*))) 41 | -------------------------------------------------------------------------------- /src/commands/command-version.lisp: -------------------------------------------------------------------------------- 1 | ;;;; command-version.lisp --- Command for printing relevant versions. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | (defclass version () 10 | ((changelog-count :initarg :changelog-count 11 | :type (or boolean positive-integer) 12 | :reader changelog-count 13 | :initform nil 14 | :documentation 15 | #.(format nil "Number of releases for which a list ~ 16 | of changes should be printed.~@ 17 | ~@ 18 | True to print changes for all releases.~@ 19 | ~@ 20 | False to not print any changes."))) 21 | (:documentation 22 | #.(format nil "Print the version of this program and some ~ 23 | components.~@ 24 | ~@ 25 | Optionally, also print changelog entries for a range of ~ 26 | releases."))) 27 | 28 | (service-provider:register-provider/class 29 | 'command :version :class 'version) 30 | 31 | (build-generator.commandline-options:define-option-mapping 32 | (*command-schema* "version") 33 | (("-c" "--changelog") "changelog-count" "COUNT")) 34 | 35 | (defmethod command-execute ((command version)) 36 | (let* ((stream *standard-output*) 37 | (versions `(("build-generator" ,(generator-version)) 38 | ("asdf" ,(asdf:asdf-version)) 39 | (,(lisp-implementation-type) ,(lisp-implementation-version)))) 40 | (max-width (reduce #'max versions 41 | :initial-value 0 42 | :key (compose #'length #'first)))) 43 | ;; Print version information. 44 | (format stream "~{~{~V:A ~:[~{~D.~D~^.~D~^-~A~}~;~A~]~}~&~}" 45 | (loop :for (name version) :in versions 46 | :collect `(,max-width ,name ,(stringp version) ,version))) 47 | ;; If requested, print changelog entries for specified range of 48 | ;; releases. 49 | (when-let ((count (changelog-count command))) 50 | (let ((count (if (eq count t) nil count))) 51 | (format stream "~2%") 52 | (print-changelog (changelog :count count) :stream stream))))) 53 | -------------------------------------------------------------------------------- /src/commands/functions-check.lisp: -------------------------------------------------------------------------------- 1 | ;;;; functions-check.lisp --- Functions for checking recipes. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | (defun check-distribution-access (distributions) 10 | (mapcan (lambda (distribution) 11 | (with-simple-restart 12 | (continue "~@" distribution) 13 | (let+ (((&values access? problem) 14 | (model:check-access distribution t))) 15 | (cond (access? 16 | (list distribution)) 17 | (problem 18 | (error problem)) 19 | (t 20 | (error "~@" 22 | distribution)))))) 23 | distributions)) 24 | 25 | (defun unresolved-platform-requirements 26 | (distributions 27 | &key 28 | (platform (multiple-value-list (analysis:current-platform)))) 29 | (let ((installed-packages (analysis:installed-packages)) 30 | (requirements (project:platform-requires distributions platform))) 31 | (log:info "~@" 32 | (length installed-packages)) 33 | (log:debug "~@" 34 | (length requirements) requirements) 35 | (when (and platform installed-packages) 36 | (values (with-sequence-progress (:check-platform-requirements requirements) 37 | (remove-if (lambda (requirement) 38 | (progress "~A" requirement) 39 | (find requirement installed-packages 40 | :test #'string= :key #'first)) 41 | requirements)) 42 | platform)))) 43 | 44 | (defun report-platform-requirements (requirements platform &key label) 45 | (let ((requirements (sort (copy-list requirements) #'string<))) 46 | (format t "~@~@ 48 | ~@ 49 | ~@[~2@T~{~<~T\\~%~2@T~1,:;~A~>~^ ~}~]~%" 50 | (length requirements) label platform requirements))) 51 | -------------------------------------------------------------------------------- /src/commands/functions-version.lisp: -------------------------------------------------------------------------------- 1 | ;;;; functions-version.lisp --- Functions related to the program version. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | ;;; Version 10 | 11 | (defparameter *generator-version* 12 | (asdf:component-version (asdf:find-system :build-generator))) 13 | 14 | (defun generator-version () 15 | *generator-version*) 16 | 17 | ;;; Changelog 18 | 19 | (deftype changelog-level () 20 | '(member nil :enhancement :bugfix :incompatible-change t)) 21 | 22 | (defparameter *changelog* 23 | (uiop:read-file-form (asdf:system-relative-pathname 24 | :build-generator.commands "changes.sexp"))) 25 | 26 | (defun changelog (&key count) 27 | (let ((changelog *changelog*)) 28 | (subseq changelog 0 (min (length changelog) 29 | (or count most-positive-fixnum))))) 30 | 31 | (defun print-changelog (changelog &key (stream *standard-output*)) 32 | (labels ((rec (stream item) 33 | (optima:ematch item 34 | 35 | ((list* :release version date changes) 36 | (format stream "Release ~A ~:[«no yet ~ 37 | released»~;~:*(~A)~]~:@_" 38 | version date) 39 | (if changes 40 | (map nil (lambda (change) 41 | (rec stream change) 42 | (format stream "~@:_~@:_")) 43 | changes) 44 | (format stream "«no changes yet»~@:_"))) 45 | 46 | ((list* (and kind (type changelog-level)) body) 47 | (format stream "• ~A~:@_ " kind) 48 | (pprint-logical-block (stream body :per-line-prefix "") 49 | (rec stream body))) 50 | 51 | ((list* :ul items) 52 | (pprint-newline :linear stream) 53 | (mapl (lambda+ ((first &rest rest)) 54 | (format stream "• ") 55 | (pprint-logical-block (stream (ensure-list first) 56 | :per-line-prefix "") 57 | (rec stream first)) 58 | (when rest 59 | (pprint-newline :mandatory stream))) 60 | items)) 61 | 62 | ((list :verb (and content (type string))) 63 | (when (find #\Newline content) 64 | (pprint-newline :mandatory stream)) 65 | (write-string content stream)) 66 | 67 | ((list* (type symbol) body) 68 | (map nil (curry #'rec stream) body)) 69 | 70 | ((type cons) 71 | (mapl (lambda+ ((item &rest rest)) 72 | (rec stream item) 73 | (when rest 74 | (format stream " ~:_"))) 75 | item)) 76 | 77 | ((type string) 78 | (format stream "~{~A~^ ~:_~}" 79 | (split-sequence:split-sequence-if 80 | (lambda (element) 81 | (member element '(#\Space #\Newline))) 82 | item :remove-empty-subseqs t)))))) 83 | (pprint-logical-block (stream changelog) 84 | (map nil (lambda (release) 85 | (rec stream release) 86 | (pprint-newline :mandatory stream)) 87 | changelog)))) 88 | -------------------------------------------------------------------------------- /src/commands/mixins.lisp: -------------------------------------------------------------------------------- 1 | ;;;; mixins.lisp --- Mixins classes used in the commands module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | ;;; `distribution-input-mixin' 10 | 11 | (defclass distribution-input-mixin () 12 | ((distributions :initarg :distributions 13 | :type (or null (cons string list)) 14 | :reader distributions 15 | :documentation 16 | "Distribution recipes(s) which should be processed.")) 17 | (:default-initargs 18 | :distributions (missing-required-initarg 19 | 'distribution-input-mixin :distributions)) 20 | (:documentation 21 | "Adds distributions slot to command classes.")) 22 | 23 | ;;; `mode-mixin' 24 | 25 | (defclass mode-mixin () 26 | ((mode :initarg :mode 27 | :type string 28 | :reader mode 29 | :initform "toolkit" 30 | :documentation 31 | #.(format nil "The mode according to which build ~ 32 | commands should be selected.~@ 33 | ~@ 34 | Selects the set of templates stored in the ~ 35 | templates/MODE directory.")) 36 | (overwrites :initarg :overwrites 37 | :type (or null (cons variable-assignment list)) 38 | :reader overwrites 39 | :initform '() 40 | :documentation 41 | #.(format nil "Overwrite a variable after loading the ~ 42 | distribution(s).~@ 43 | ~@ 44 | Arguments to this option have to be of the form ~ 45 | VARIABLE-NAME=VALUE."))) 46 | (:documentation 47 | "Adds a mode and an overwrites slot to command classes.")) 48 | 49 | ;;; `output-directory-mixin' 50 | 51 | (defclass output-directory-mixin () 52 | ((output-directory :initarg :output-directory 53 | :type configuration.options:directory-pathname 54 | :reader output-directory 55 | :documentation 56 | "Directory into which output should be written.")) 57 | (:default-initargs 58 | :output-directory (missing-required-initarg 59 | 'output-directory-mixin :output-directory)) 60 | (:documentation 61 | "Adds an output-directory slot to command classes.")) 62 | -------------------------------------------------------------------------------- /src/commands/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the commands module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.commands 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:iterate 13 | #:more-conditions) 14 | 15 | (:local-nicknames 16 | (#:util #:build-generator.util) 17 | 18 | (#:analysis #:build-generator.analysis) 19 | 20 | (#:model #:build-generator.model) 21 | (#:var #:build-generator.model.variables) 22 | (#:project #:build-generator.model.project) 23 | (#:aspects #:build-generator.model.aspects) 24 | 25 | (#:deploy #:build-generator.deployment) 26 | (#:steps #:build-generator.steps)) 27 | 28 | (:shadow 29 | #:phase) 30 | 31 | ;; Conditions 32 | (:export 33 | #:command-condition 34 | #:command 35 | 36 | #:command-configuration-problem 37 | 38 | #:command-not-found-error 39 | 40 | #:option-configuration-problem 41 | 42 | #:option-value-error 43 | #:value) 44 | 45 | ;; Command protocol 46 | (:export 47 | #:command-execute 48 | #:make-command) 49 | 50 | ;; High-level interface 51 | (:export 52 | #:configure-command 53 | #:execute-command) 54 | 55 | (:documentation 56 | "Command classes implementing user-level blocks of functionality.")) 57 | -------------------------------------------------------------------------------- /src/commands/phases.lisp: -------------------------------------------------------------------------------- 1 | ;;;; phases.lisp --- Machinery for phases within commands. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | ;;; Error collection 10 | 11 | (defun defer (condition &key debug?) 12 | (when-let ((restart (find-restart 'defer condition))) 13 | (invoke-restart restart condition :debug? debug?))) 14 | 15 | (defun call-with-error-collection (thunk) 16 | (let+ ((errors '()) 17 | (errors-lock (bt:make-lock)) 18 | ((&flet collect-error (condition &key debug?) 19 | (when debug? 20 | (bt:with-lock-held (errors-lock) 21 | (terpri) 22 | (princ condition) 23 | (terpri) 24 | (sb-debug:print-backtrace))) 25 | (bt:with-lock-held (errors-lock) 26 | (appendf errors (list condition))))) 27 | ((&flet deferrable-error (condition) 28 | (restart-bind ((defer (lambda (condition &key debug?) 29 | (collect-error condition :debug? debug?) 30 | (invoke-restart 31 | (util:find-continue-restart 32 | condition)) 33 | (abort)) 34 | :test-function #'util:find-continue-restart)) 35 | (error condition))))) 36 | (lparallel:task-handler-bind 37 | ;; TODO workaround lparallel bug 38 | ((error (lambda (condition) 39 | (when (typep condition 'util:continuable-error) 40 | (deferrable-error condition))))) 41 | (handler-bind 42 | (((and error util:continuable-error) 43 | #'deferrable-error)) 44 | (funcall thunk (lambda () errors)))))) 45 | 46 | (defmacro with-error-collection ((errors) &body body) 47 | (with-gensyms (errors-reader) 48 | `(call-with-error-collection 49 | (lambda (,errors-reader) 50 | (symbol-macrolet ((,errors (funcall ,errors-reader))) 51 | ,@body))))) 52 | 53 | ;;; Phase timing 54 | 55 | (defun call-with-phase-timing (thunk phase print?) 56 | (let ((start (get-internal-real-time))) 57 | (when print? 58 | (format t "START ~A~%" phase)) 59 | (unwind-protect 60 | (funcall thunk) 61 | (let ((end (get-internal-real-time))) 62 | (when print? 63 | (format t "~&END ~A, ~,3F second~:P~2%" 64 | phase 65 | (/ (- end start) 66 | internal-time-units-per-second))))))) 67 | 68 | (defmacro with-phase-timing ((phase &key print?) &body body) 69 | `(call-with-phase-timing (lambda () ,@body) ,phase ,print?)) 70 | 71 | ;;; Phase 72 | 73 | (defun call-as-phase (thunk name) 74 | (let (phase-errors) 75 | (multiple-value-prog1 76 | (with-error-collection (errors) 77 | (multiple-value-prog1 78 | (with-phase-timing (name) 79 | (funcall thunk)) 80 | (setf phase-errors errors))) 81 | (when phase-errors 82 | (deferred-phase-cerror name phase-errors))))) 83 | 84 | (defmacro as-phase ((name) &body body) 85 | `(call-as-phase (lambda () ,@body) ,name)) 86 | -------------------------------------------------------------------------------- /src/commands/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities used in the commands module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | ;;; Password redaction 10 | 11 | (defun sensitive-option? (option) 12 | (let ((name (last-elt (configuration.options:option-name option)))) 13 | (find name '("password" "api-token") :test #'string=))) 14 | 15 | (defun sensitive-commandline-option? (designator context) 16 | (when-let ((option (build-generator.commandline-options:option 17 | (build-generator.commandline-options:find-option 18 | designator context :if-does-not-exist nil)))) 19 | (when (sensitive-option? option) 20 | (values t option)))) 21 | 22 | (defun maybe-redact-argument (argument previous context 23 | &key (replacement "********")) 24 | (flet ((sensitive? (designator) 25 | (sensitive-commandline-option? designator context))) 26 | (cond ((and previous (sensitive? previous)) 27 | replacement) 28 | ((when-let* ((index (position #\= argument)) 29 | (prefix (subseq argument 0 index))) 30 | (when (sensitive? prefix) 31 | (format nil "~A=~A" prefix replacement)))) 32 | (t 33 | argument)))) 34 | 35 | ;;; Invocation description 36 | 37 | (defun filtered-commandline-arguments (context &key (replacement "********")) 38 | (let ((arguments (uiop:command-line-arguments))) 39 | (loop :for previous = nil :then argument 40 | :for argument :in arguments 41 | :collect (maybe-redact-argument argument previous context 42 | :replacement replacement)))) 43 | -------------------------------------------------------------------------------- /src/commands/value-types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; value-types.lisp --- Option value types used in the commands module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.commands) 8 | 9 | ;;; `variable-assignment' 10 | 11 | (deftype variable-assignment () 12 | `(cons keyword t)) 13 | (setf (get 'variable-assignment 'configuration.options::dont-expand) t) 14 | 15 | (defmethod configuration.options:raw->value-using-type 16 | ((schema-item t) 17 | (raw string) 18 | (type (eql 'variable-assignment)) 19 | &key inner-type) 20 | (declare (ignore inner-type)) 21 | (let+ ((position (or (position #\= raw) 22 | (error "~@" 24 | raw))) 25 | (name/raw (subseq raw 0 position)) 26 | (name (make-keyword (string-upcase name/raw))) 27 | (value/raw (subseq raw (1+ position))) 28 | (value (if (and (not (emptyp value/raw)) 29 | (let ((first (aref value/raw 0))) 30 | (or (member first '(#\" #\{ #\[)) 31 | (digit-char-p first)))) 32 | (let ((json:*json-identifier-name-to-lisp* #'string-upcase)) 33 | (json:decode-json-from-string value/raw)) 34 | value/raw))) 35 | (var:value-cons name value))) 36 | 37 | (defmethod configuration.options:value->string-using-type 38 | ((schema-item t) 39 | (value cons) 40 | (type (eql 'variable-assignment)) 41 | &key inner-type) 42 | (declare (ignore inner-type)) 43 | (let+ (((variable . value) value) 44 | (value/json (typecase value 45 | (string 46 | value) 47 | (t 48 | (let ((json:*lisp-identifier-name-to-json* 49 | #'string-downcase)) 50 | (json:encode-json-to-string value)))))) 51 | (format nil "~(~A~)=~A" variable (var:value-unparse value/json)))) 52 | 53 | ;;; `jenkins-username' 54 | 55 | (setf (get 'steps:jenkins-username 'configuration.options::dont-expand) t) 56 | 57 | (defmethod configuration.options:raw->value-using-type 58 | ((schema-item t) 59 | (raw string) 60 | (type (eql 'steps:jenkins-username)) 61 | &key inner-type) 62 | (declare (ignore inner-type)) 63 | (unless (typep raw 'steps:jenkins-username) 64 | (error "~@")) 66 | raw) 67 | -------------------------------------------------------------------------------- /src/deployment/build/README.org: -------------------------------------------------------------------------------- 1 | * Introduction 2 | 3 | When this target is used, the generator directly builds the specified projects on the local machine without generating intermediate build instructions such as Makefiles and without employing containers, a CI server or CI service. 4 | Only full builds (as opposed to incremental ones) are supported since the progress of an incomplete build cannot be persisted. 5 | Dependencies between projects and individual steps within a project are respected. 6 | Individual steps can be executed in parallel. 7 | -------------------------------------------------------------------------------- /src/deployment/build/model.lisp: -------------------------------------------------------------------------------- 1 | ;;;; model.lisp --- Model used by the deployment.build module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019, 2020, 2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment.build) 8 | 9 | ;;; `project-steps' 10 | 11 | (defclass project-steps (model:implementation-mixin 12 | aspects::aspect-builder-defining-mixin) 13 | ((%directory :initarg :directory 14 | :reader directory) 15 | (%steps :initarg :steps 16 | :accessor steps 17 | :initform '())) 18 | (:documentation 19 | "A collection of `step' instances for one project.")) 20 | 21 | (defun make-project-steps (specification directory) 22 | (make-instance 'project-steps :directory directory 23 | :specification specification)) 24 | 25 | (defmethod add-step ((step t) (steps project-steps)) 26 | (push step (steps steps)) 27 | (setf (%directory step) (directory steps)) 28 | steps) 29 | 30 | ;;; `step' 31 | 32 | (defclass step (deploy:command-mixin 33 | print-items:print-items-mixin) 34 | ((%name :initarg :name 35 | :reader name) 36 | (%dependencies :initarg :dependencies 37 | :accessor dependencies 38 | :initform '()) 39 | (%early? :initarg :early? 40 | :type boolean 41 | :reader early? 42 | :initform nil 43 | :documentation 44 | "Controls whether the rule can be executed 45 | \"early\", that is disregarding inter-project 46 | dependencies.") 47 | (%directory :initarg :directory 48 | :reader directory 49 | :writer (setf %directory)) 50 | ;; HACK 51 | (%builder-class :initarg :builder-class 52 | :reader builder-class 53 | :initform nil)) 54 | (:default-initargs 55 | :name (more-conditions:missing-required-initarg 'step :name))) 56 | 57 | (defun make-step (name command 58 | &key (dependencies '()) early? directory builder-class) 59 | (make-instance 'step :name name 60 | :command command 61 | :dependencies dependencies 62 | :early? early? 63 | :directory directory 64 | :builder-class builder-class)) 65 | 66 | (defmethod print-items:print-items append ((object step)) 67 | `(((:name (:before :command)) "~A " ,(name object)))) 68 | -------------------------------------------------------------------------------- /src/deployment/build/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the deployment.build module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.deployment.build 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus) 12 | 13 | (:shadow 14 | #:directory 15 | #:step) 16 | 17 | (:local-nicknames 18 | (#:util #:build-generator.util) 19 | 20 | (#:model #:build-generator.model) 21 | (#:var #:build-generator.model.variables) 22 | (#:project #:build-generator.model.project) 23 | (#:aspects #:build-generator.model.aspects) 24 | 25 | (#:deploy #:build-generator.deployment))) 26 | -------------------------------------------------------------------------------- /src/deployment/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; conditions.lisp --- Conditions used by the deployment module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment) 8 | 9 | (define-condition deployment-condition (chainable-condition) 10 | ((thing :initarg :thing 11 | :reader thing 12 | :documentation 13 | "The thing the deployment of which caused the condition.") 14 | (target :initarg :target 15 | :reader target 16 | :documentation 17 | "The target of the deployment which caused the condition.")) 18 | (:default-initargs 19 | :thing (missing-required-initarg 'deployment-condition :thing) 20 | :target (missing-required-initarg 'deployment-condition :target)) 21 | (:documentation 22 | "Subclasses of this condition are signaled to indicate certain 23 | conditions during the deployment of things.")) 24 | 25 | (define-condition deployment-error (error 26 | deployment-condition) 27 | () 28 | (:report 29 | (lambda (condition stream) 30 | (format stream "~@" 32 | (thing condition) (target condition) condition))) 33 | (:documentation 34 | "This error is signaled when an error is encountered during 35 | deployment of a thing.")) 36 | 37 | (define-condition project-deployment-error (deployment-error) 38 | () 39 | (:report 40 | (lambda (condition stream) 41 | (format stream "~@" 44 | (print-items:print-items (thing condition)) 45 | (target condition) 46 | condition)))) 47 | -------------------------------------------------------------------------------- /src/deployment/defaults.lisp: -------------------------------------------------------------------------------- 1 | ;;;; defaults.lisp --- Default behavior of the deployment protocol. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment) 8 | 9 | ;;; `project:distribution' 10 | 11 | (defmethod deploy ((thing project:distribution) (target t)) 12 | (let ((versions (project:versions thing))) 13 | (with-sequence-progress (:deploy/project versions) 14 | (mappend (lambda (version) 15 | (progress "~/print-items:format-print-items/" 16 | (print-items:print-items version)) 17 | (more-conditions::without-progress 18 | (with-simple-restart 19 | (continue "~@" version) 20 | (flatten (deploy version target))))) 21 | versions)))) 22 | 23 | ;;; `project:version' 24 | 25 | (defvar *outermost-version?* t) 26 | 27 | (defmethod deploy :around ((thing project:version) (target t)) 28 | (if *outermost-version?* 29 | (with-condition-translation (((error project-deployment-error) 30 | :thing thing :target target)) 31 | (let ((*outermost-version?* nil)) 32 | (call-next-method))) 33 | (call-next-method))) 34 | 35 | (defmethod deploy ((thing project:version) (target t)) 36 | (let ((jobs (project:jobs thing))) 37 | (with-sequence-progress (:deploy/job jobs) 38 | (mappend (lambda (job) 39 | (progress "~/print-items:format-print-items/" 40 | (print-items:print-items job)) 41 | (list (deploy job target))) 42 | jobs)))) 43 | -------------------------------------------------------------------------------- /src/deployment/dockerfile/model.lisp: -------------------------------------------------------------------------------- 1 | ;;;; model.lisp --- Model for the dockerfile target. 2 | ;;;; 3 | ;;;; Copyright (C) 2018-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment.dockerfile) 8 | 9 | ;;; Dockerfile 10 | ;;; 11 | ;;; A list of stages (can be a single stage) which are executed 12 | ;;; sequentially to build a particular image. 13 | 14 | (defclass dockerfile () 15 | ((%stages :initarg :stages 16 | :type list 17 | :reader stages 18 | :initform '()))) 19 | 20 | ;;; Stage 21 | ;;; 22 | ;;; Starts with a base image, performs a number of steps, makes the 23 | ;;; resulting image available for later stages. 24 | 25 | (defclass stage-mixin () 26 | ((%base-image :initarg :base-image 27 | :reader base-image) 28 | (%run-strategy :initarg :run-strategy 29 | :reader run-strategy) 30 | (%steps :initarg :steps 31 | :type list 32 | :reader steps 33 | :initform '()))) 34 | 35 | (defclass pseudo-stage (stage-mixin) 36 | ()) 37 | 38 | (defclass stage (model:named-mixin 39 | stage-mixin) 40 | ()) 41 | 42 | ;;; Step 43 | ;;; 44 | ;;; A somewhat self-contained operation that is executed as part of a 45 | ;;; stage to modify the state of the container in a particular way. 46 | 47 | (defclass title-mixin () 48 | ((%title :initarg :title 49 | :type string 50 | :reader title))) 51 | 52 | (defclass command-step (title-mixin 53 | deploy:command-mixin) 54 | () 55 | (:documentation 56 | "Execute a command within a stage without writing a script file.")) 57 | 58 | (defclass script-step (model:named-mixin 59 | title-mixin 60 | deploy:command-mixin) 61 | () 62 | (:documentation 63 | "Execute a command within a stage by writing a script file.")) 64 | 65 | (defclass copy-step () 66 | ((%from-stage :initarg :from-stage 67 | :reader from-stage) 68 | (%source :initarg :source 69 | :type string 70 | :reader source) 71 | (%target :initarg :target 72 | :type string 73 | :reader target)) 74 | (:documentation 75 | "Copy results from an earlier stages.")) 76 | 77 | (defclass dockerfile-job (model:named-mixin 78 | model:implementation-mixin 79 | aspects::aspect-builder-defining-mixin) 80 | ((%builders :accessor builders 81 | :initform '())) 82 | (:documentation 83 | "Execute builders defined in a project description to process the 84 | project.")) 85 | 86 | ;;; Builders 87 | ;;; 88 | ;;; A step that processes (that is builds, installs, etc.) a project 89 | ;;; is comprised of one or more "builders" which basically just 90 | ;;; execute shell commands. 91 | 92 | (defclass shell-command (deploy:command-mixin 93 | print-items:print-items-mixin) 94 | ((%aspect :initarg :aspect 95 | :reader aspect))) 96 | 97 | (defun shell-command (aspect format-control &rest format-arguments) 98 | (let ((command (if format-arguments 99 | (apply #'format nil format-control format-arguments) 100 | format-control))) 101 | (make-instance 'shell-command :aspect aspect :command command))) 102 | -------------------------------------------------------------------------------- /src/deployment/dockerfile/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the deployment.dockerfile module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.deployment.dockerfile 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus) 12 | 13 | (:shadow 14 | #:directory) 15 | 16 | (:local-nicknames 17 | (#:util #:build-generator.util) 18 | 19 | (#:model #:build-generator.model) 20 | (#:var #:build-generator.model.variables) 21 | (#:project #:build-generator.model.project) 22 | (#:aspects #:build-generator.model.aspects) 23 | 24 | (#:deploy #:build-generator.deployment))) 25 | -------------------------------------------------------------------------------- /src/deployment/dockerfile/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities used by the target.dockerfile module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment.dockerfile) 8 | 9 | ;;; Commands 10 | 11 | (defun trim-command (command) 12 | (string-trim '(#\Space #\Tab #\Newline) command)) 13 | -------------------------------------------------------------------------------- /src/deployment/jenkins/distribution.lisp: -------------------------------------------------------------------------------- 1 | ;;;; distribution.lisp --- Deployment of distributions as Jenkins jobs. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2020 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment.jenkins) 8 | 9 | (defmethod deploy:deploy ((thing project:distribution) (target target)) 10 | (let ((jobs (call-next-method)) 11 | (orchestration-jobs '()) 12 | (views '())) 13 | ;; Add dependencies for generated jobs. 14 | (when-let ((dependency-jobs 15 | (remove :none jobs 16 | :key (rcurry #'var:value/cast :dependencies.mode)))) 17 | (with-sequence-progress (:deploy/dependencies jobs) 18 | (map nil (lambda (job) 19 | (progress "~/print-items:format-print-items/" 20 | (print-items:print-items job)) 21 | (deploy:deploy-dependencies job target)) 22 | dependency-jobs))) 23 | ;; Configure orchestration for the distribution. 24 | (with-simple-restart 25 | (continue "~@" 27 | (print-items:print-items thing)) 28 | (setf orchestration-jobs (configure-orchestration thing target))) 29 | ;; Configure view(s) for the distribution. 30 | (with-simple-restart 31 | (continue "~@" 33 | (print-items:print-items thing)) 34 | (when (var:value/cast thing :view.create? nil) 35 | (let ((all-jobs (append jobs orchestration-jobs)) 36 | (name (var:value/cast thing :view.name)) 37 | (columns (var:value/cast thing :view.columns nil))) 38 | (push (apply #'configure-view name all-jobs 39 | (when columns (list :columns columns))) 40 | views)))) 41 | (values jobs orchestration-jobs views))) 42 | 43 | ;;; Orchestration 44 | 45 | (defun configure-orchestration (distribution target) 46 | (with-trivial-progress (:orchestration "Configuring orchestration jobs") 47 | (let* ((templates (list (project:find-template "orchestration"))) 48 | (project-spec (make-instance 'project::project-spec 49 | :name "orchestration" 50 | :templates templates)) 51 | (version-spec (make-instance 'project::version-spec 52 | :name "orchestration" 53 | :parent project-spec)) 54 | (version (progn 55 | (reinitialize-instance project-spec 56 | :versions (list version-spec)) 57 | (model:instantiate version-spec :parent distribution)))) 58 | (flatten (deploy:deploy version target))))) 59 | 60 | ;;; Views 61 | 62 | (defun configure-view (name jobs &key columns) 63 | (with-trivial-progress (:view "~A" name) 64 | (let ((jenkins-jobs (mappend #'model:implementations jobs)) 65 | (view (jenkins.api:view name))) 66 | (if (jenkins.api::view? name) 67 | (jenkins.api::update! view) 68 | (jenkins.api:make-view name (jenkins.api::%data view))) 69 | (setf (jenkins.api:jobs view) (mapcar #'jenkins.api:id jenkins-jobs)) 70 | (when columns 71 | (setf (jenkins.api::columns view) columns)) 72 | (jenkins.api:commit! view) 73 | view))) 74 | -------------------------------------------------------------------------------- /src/deployment/jenkins/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the deployment.jenkins module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.deployment.jenkins 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:more-conditions) 13 | 14 | (:local-nicknames 15 | (#:model #:build-generator.model) 16 | (#:var #:build-generator.model.variables) 17 | (#:project #:build-generator.model.project) 18 | (#:aspects #:build-generator.model.aspects) 19 | 20 | (#:deploy #:build-generator.deployment))) 21 | -------------------------------------------------------------------------------- /src/deployment/jenkins/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities used in the deployment.jenkins module. 2 | ;;;; 3 | ;;;; Copyright (C) 2019, 2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment.jenkins) 8 | 9 | (defun jenkins-job-id (job) 10 | (substitute-if-not #\_ #'jenkins.api:job-name-character? 11 | (var:value/cast job :build-job-name))) 12 | -------------------------------------------------------------------------------- /src/deployment/makefile/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the deployment.makefile module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.deployment.makefile 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus) 12 | 13 | (:shadow 14 | #:directory) 15 | 16 | (:local-nicknames 17 | (#:util #:build-generator.util) 18 | 19 | (#:model #:build-generator.model) 20 | (#:var #:build-generator.model.variables) 21 | (#:project #:build-generator.model.project) 22 | (#:aspects #:build-generator.model.aspects) 23 | 24 | (#:deploy #:build-generator.deployment))) 25 | -------------------------------------------------------------------------------- /src/deployment/makefile/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities used in the deployment.makefile module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment.makefile) 8 | 9 | ;;; Escape dollars in shell fragments 10 | 11 | (defun escape-dollars (string) 12 | (with-output-to-string (stream) 13 | (loop :for char :across string 14 | :when (char= char #\$) 15 | :do (write-char #\$ stream) 16 | :do (write-char char stream)))) 17 | 18 | ;;; Work around problems with recipe lines starting with -, + or @ 19 | ;;; 20 | ;;; One of these characters at the start of a recipe line causes make 21 | ;;; to interpret it and strip it from the recipe before passing the 22 | ;;; remainder to the shell. To avoid problems with, for example, 23 | ;;; patches (which contain lines starting with +, - and @) processed 24 | ;;; via here-documents, we detect recipes which contain such lines and 25 | ;;; switch to a completely different representation. We replace the 26 | ;;; recipe with one that contains the original recipe in a 27 | ;;; base64-encoded here-document which is decoded and then evaluated 28 | ;;; by the shell. 29 | 30 | (defun forbidden-at-start-of-line? (char) 31 | (member char '(#\- #\+ #\@))) 32 | 33 | (defun contains-problematic-line-beginning? (string) 34 | (loop :with at-line-beginning? = t 35 | :for char :across string 36 | :do (cond ((char= char #\Newline) 37 | (setf at-line-beginning? t)) 38 | ((and at-line-beginning? 39 | (forbidden-at-start-of-line? char)) 40 | (return t)) 41 | (t 42 | (setf at-line-beginning? nil))))) 43 | 44 | (defun base64-encode (string) 45 | (let ((variable "commands") 46 | (eof-marker (format nil "EOF~16,'0X" 47 | (ldb (byte (* 16 8) 0) 48 | (random most-positive-fixnum)))) 49 | (blob (cl-base64:string-to-base64-string string :columns 70))) 50 | (format nil "# The following blob contains shell commands that ~@ 51 | # cannot be expressed as make recipes (such as ~@ 52 | # here-documents containing lines starting with +, - or ~@ 53 | # @). The blob is decoded and passed to the shell ~@ 54 | # function eval.~@ 55 | OLD_IFS=\"${IFS}\"~@ 56 | export IFS=''~@ 57 | ~A=$(echo \"export IFS='${OLD_IFS}'\" && cat <<'~A' | base64 -d~@ 58 | ~A~@ 59 | ~2:*~A~@ 60 | )~@ 61 | eval ${~2:*~A}" 62 | variable eof-marker blob))) 63 | 64 | (defun maybe-base64-encode (string) 65 | (if (contains-problematic-line-beginning? string) 66 | (base64-encode string) 67 | string)) 68 | -------------------------------------------------------------------------------- /src/deployment/mixins.lisp: -------------------------------------------------------------------------------- 1 | ;;;; mixins.lisp --- Mixins provided by the deployment module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019, 2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment) 8 | 9 | (defclass command-mixin () 10 | ((%command :initarg :command 11 | :reader command)) 12 | (:default-initargs 13 | :command (more-conditions:missing-required-initarg 'command-mixin :command))) 14 | 15 | (defmethod print-items:print-items append ((object command-mixin)) 16 | (multiple-value-bind (command shortened?) 17 | (util:maybe-truncate (command object)) 18 | `((:command "~{\"~A~:[~;…~]\"~}" ,(list command shortened?))))) 19 | -------------------------------------------------------------------------------- /src/deployment/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the deployment module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.deployment 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:more-conditions) 13 | 14 | (:local-nicknames 15 | (#:util #:build-generator.util) 16 | 17 | (#:model #:build-generator.model) 18 | (#:var #:build-generator.model.variables) 19 | (#:project #:build-generator.model.project) 20 | (#:aspects #:build-generator.model.aspects)) 21 | 22 | ;; Conditions 23 | (:export 24 | #:deployment-condition 25 | #:thing 26 | #:target 27 | 28 | #:deployment-error 29 | 30 | #:project-deployment-error) 31 | 32 | ;; Deployment protocol 33 | (:export 34 | #:deploy 35 | #:deploy-dependencies) 36 | 37 | ;; Target service 38 | (:export 39 | #:target ; service name 40 | 41 | #:make-target) 42 | 43 | ;; String utilities 44 | (:export 45 | #:job-full-name 46 | 47 | #:print-heading) 48 | 49 | ;; `command-mixin' 50 | (:export 51 | #:command-mixin 52 | 53 | #:command)) 54 | -------------------------------------------------------------------------------- /src/deployment/protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;;; protocol.lisp --- Protocol provided by the deployment module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment) 8 | 9 | ;;; Deployment protocol 10 | 11 | (defgeneric deploy (thing target) 12 | (:documentation 13 | "Deploy THING for TARGET. 14 | 15 | Signal `deployment-condition's such as `deployment-error' when 16 | conditions such as errors are encountered.")) 17 | 18 | (defgeneric deploy-dependencies (thing target) 19 | (:documentation 20 | "Deploy dependencies of THING for TARGET. 21 | 22 | Signal `deployment-condition's such as `deployment-error' when 23 | conditions such as errors are encountered.")) 24 | 25 | ;; Default behavior 26 | 27 | (defmethod deploy :around ((thing t) (target t)) 28 | (with-condition-translation (((error deployment-error) 29 | :thing thing :target target)) 30 | (call-next-method))) 31 | 32 | (defmethod deploy ((thing sequence) (target t)) 33 | (flet ((deploy-one (element) 34 | (with-simple-restart 35 | (continue "~@" 36 | element target) 37 | (deploy element target)))) 38 | (if (listp thing) 39 | (mappend #'deploy-one thing) 40 | (let ((result (mappend #'deploy-one (coerce thing 'list)))) 41 | (coerce result (class-of thing)))))) 42 | 43 | (defmethod deploy-dependencies :around ((thing t) (target t)) 44 | (with-condition-translation (((error deployment-error) 45 | :thing thing :target target)) 46 | (with-simple-restart (continue "~@" 48 | thing target) 49 | (call-next-method)))) 50 | 51 | ;;; Service 52 | 53 | (service-provider:define-service target 54 | (:documentation 55 | "Providers implement different kinds of deployments.")) 56 | 57 | (defun make-target (kind &rest initargs &key &allow-other-keys) 58 | (apply #'service-provider:make-provider 'target kind initargs)) 59 | -------------------------------------------------------------------------------- /src/deployment/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities provided by the deployment module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.deployment) 8 | 9 | (defun job-full-name (thing &key (separator "@")) 10 | (let* ((version (model:parent thing)) 11 | (project (model:parent (model:specification version)))) 12 | (format nil "~A~A~A" 13 | (model:name project) separator (model:name version)))) 14 | 15 | (defun print-heading (stream title &key (width 80)) 16 | (format stream "##~V,,,'#<~>##~@ 17 | # ~:*~V<~A~;~> #~@ 18 | ~2:*##~V,,,'#<~>##~2%" 19 | width title)) 20 | -------------------------------------------------------------------------------- /src/model/aspects/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; conditions.lisp --- Conditions used in the model.aspects module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.aspects) 8 | 9 | (define-condition parameter-condition (condition) 10 | ((aspect :initarg :aspect 11 | :reader parameter-condition-aspect 12 | :documentation 13 | "Stores the aspect to which the parameter is associated.") 14 | (parameter :initarg :parameter 15 | :reader parameter-condition-parameter 16 | :documentation 17 | "Stores the parameter for which the invalid value has 18 | been supplied.")) 19 | (:default-initargs 20 | :aspect (missing-required-initarg 'parameter-condition :aspect) 21 | :parameter (missing-required-initarg 'parameter-condition :parameter)) 22 | (:documentation 23 | "Superclass for aspect parameter-related condition classes.")) 24 | 25 | (define-condition missing-argument-error (parameter-condition 26 | error) 27 | () 28 | (:report 29 | (lambda (condition stream) 30 | (let* ((aspect (parameter-condition-aspect condition)) 31 | (parameter (parameter-condition-parameter condition)) 32 | (variable (aspect-parameter-variable parameter)) 33 | (name (var:variable-info-name variable))) 34 | (format stream "~@" 36 | name aspect)))) 37 | (:documentation 38 | "Signaled when a required aspect parameter is not supplied.")) 39 | 40 | (defun missing-argument-error (aspect parameter) 41 | (error 'missing-argument-error :aspect aspect :parameter parameter)) 42 | 43 | (define-condition argument-condition (parameter-condition) 44 | ((value :initarg :value 45 | :reader argument-condition-value 46 | :documentation 47 | "Stores value that caused the condition to be signaled.")) 48 | (:default-initargs 49 | :value (missing-required-initarg 'argument-condition :value)) 50 | (:documentation 51 | "Superclass for aspect argument-related condition classes.")) 52 | 53 | (define-condition argument-type-error (argument-condition 54 | chainable-condition 55 | error) 56 | () 57 | (:report 58 | (lambda (condition stream) 59 | (let* ((aspect (parameter-condition-aspect condition)) 60 | (parameter (parameter-condition-parameter condition)) 61 | (value (argument-condition-value condition)) 62 | (variable (aspect-parameter-variable parameter)) 63 | (name (var:variable-info-name variable)) 64 | (type (var:variable-info-type variable))) 65 | (format stream "~@" 68 | value name aspect type condition)))) 69 | (:documentation 70 | "Signaled when an aspect argument is not of the expected type.")) 71 | -------------------------------------------------------------------------------- /src/model/aspects/contrib.lisp: -------------------------------------------------------------------------------- 1 | ;;;; contrib.lisp --- Obsolete or currently unused aspects. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.aspects) 8 | 9 | ;;; Win32-related aspects 10 | 11 | (define-aspect dependency-download/win32 (builder-defining-mixin) () 12 | (puse (constraint! () 13 | (batch (:command "cd upstream 14 | unzip -o *.zip 15 | move *.zip .. 16 | move RSC* RSC 17 | move RSBProtocol* RSBProtocol 18 | move ..\*.zip ."))) 19 | (builders job))) 20 | 21 | ;;; Debian packaging-related aspects 22 | 23 | (define-aspect (debian-package :job-var job) () () 24 | ;; Add console-based parser for lintian. 25 | (with-interface (jenkins.api:publishers job) (warnings (jenkins.api:publisher/warnings)) 26 | (pushnew (make-instance 'jenkins.api:warning-parser/console :name "Lintian") 27 | (jenkins.api:console-parsers warnings) 28 | :test #'string= 29 | :key #'name)) 30 | 31 | ;; Archive the generated Debian package. 32 | (with-interface (jenkins.api:publishers job) 33 | (archiver (jenkins.api:publisher/archive-artifacts 34 | :files nil 35 | :only-latest? nil)) 36 | (pushnew #?"${(var/typed :build-dir 'string)}/*.deb" (files archiver) 37 | :test #'string=))) 38 | 39 | (define-aspect (debian-package/cmake) (debian-package 40 | builder-defining-mixin) 41 | () 42 | (push (constraint! (build ((:after cmake/unix))) 43 | (shell (:command #?"mkdir -p ${(var/typed :build-dir 'string)} && cd ${(var/typed :build-dir 'string)} 44 | cmake -DCPACK_CONFIG_FILE=${(var/typed :aspect.debian-package/cmake.cpack-config-file 'string)} \\ 45 | -DCPACK_PACKAGE_REVISION=\${PACKAGE_REVISION} \\ 46 | .. 47 | umask 022 48 | \${FAKEROOT_FOR_CPACK} make package 49 | lintian -i *.deb || true 50 | "))) 51 | (jenkins.api:builders job))) 52 | -------------------------------------------------------------------------------- /src/model/aspects/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for aspects module. 2 | ;;;; 3 | ;;;; Copyright (C) 2015, 2016, 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.model.aspects 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:split-sequence 12 | #:iterate 13 | #:let-plus 14 | #:more-conditions 15 | #:print-items) 16 | 17 | (:local-nicknames 18 | (#:util #:build-generator.util) 19 | 20 | (#:model #:build-generator.model) 21 | (#:var #:build-generator.model.variables)) 22 | 23 | ;; Conditions 24 | (:export 25 | #:parameter-condition 26 | #:parameter-condition-aspect 27 | #:parameter-condition-parameter 28 | 29 | #:missing-argument-error 30 | 31 | #:argument-condition 32 | #:argument-condition-value 33 | 34 | #:argument-type-error) 35 | 36 | ;; Aspect parameter protocol 37 | (:export 38 | #:aspect-parameter-variable 39 | #:aspect-parameter-binding-name 40 | #:aspect-parameter-default-value) 41 | 42 | ;; Aspect protocol 43 | (:export 44 | #:aspect-parameters 45 | #:aspect-process-parameters 46 | #:aspect-process-parameter 47 | 48 | #:aspect< 49 | 50 | #:extend!) 51 | 52 | ;; Aspect creation protocol 53 | (:export 54 | #:make-aspect) 55 | 56 | ;; Aspect container protocol 57 | (:export 58 | #:aspects) 59 | 60 | (:documentation 61 | "Aspects extend the target being generated with behavior fragments.")) 62 | -------------------------------------------------------------------------------- /src/model/aspects/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities used in the model.aspects module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.aspects) 8 | 9 | (defun format-constraints (stream constraints &optional colon? at?) 10 | (declare (ignore colon? at?)) 11 | (format stream "~:[~ 12 | ~ 13 | ~;~ 14 | ~:*~{• ~{~6A ~A~^ ~A~}~^~@:_~}~ 15 | ~]" 16 | constraints)) 17 | -------------------------------------------------------------------------------- /src/model/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; conditions.lisp --- Conditions used by the project module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model) 8 | 9 | ;;; Instantiation-related conditions 10 | 11 | (define-condition instantiation-condition (chainable-condition) 12 | ((specification :initarg :specification 13 | :reader instantiation-condition-specification 14 | :documentation 15 | "The specification the instantiation of which caused 16 | the condition.")) 17 | (:default-initargs 18 | :specification (missing-required-initarg 19 | 'instantiation-condition :specification)) 20 | (:documentation 21 | "Subclasses of this condition are signaled to indicate certain 22 | condition during the instantiation of specifications.")) 23 | 24 | (define-condition instantiation-error (error 25 | instantiation-condition) 26 | () 27 | (:report 28 | (lambda (condition stream) 29 | (format stream "~@" 31 | (instantiation-condition-specification condition) 32 | condition))) 33 | (:documentation 34 | "This error is signaled when an error is encountered during the 35 | instantiation of a specification.")) 36 | -------------------------------------------------------------------------------- /src/model/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for aspects module. 2 | ;;;; 3 | ;;;; Copyright (C) 2015, 2016, 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.model 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:split-sequence 12 | #:iterate 13 | #:let-plus 14 | #:more-conditions) 15 | 16 | (:local-nicknames 17 | (#:var #:build-generator.model.variables)) 18 | 19 | ;; Conditions 20 | (:export 21 | #:instantiation-condition 22 | #:instantiation-condition-specification 23 | 24 | #:instantiation-error) 25 | 26 | ;; Name protocols and mixin classes 27 | (:export 28 | #:name 29 | 30 | #:named-mixin 31 | 32 | #:name-variable 33 | 34 | #:named+builtin-entries-mixin) 35 | 36 | ;; Parent protocol and mixin class 37 | (:export 38 | #:parent 39 | #:ancestors 40 | 41 | #:parented-mixin) 42 | 43 | ;; Named and ancestors protocol 44 | (:export 45 | #:ancestor-names) 46 | 47 | ;; Dependency protocol 48 | (:export 49 | #:direct-dependencies 50 | #:dependencies 51 | #:minimal-dependencies) 52 | 53 | ;; Access protocol 54 | (:export 55 | #:access 56 | #:check-access) 57 | 58 | ;; Instantiation protocol 59 | (:export 60 | #:instantiate? 61 | #:instantiate 62 | #:add-dependencies!) 63 | 64 | ;; Conditional instantiation protocol 65 | (:export 66 | #:conditions 67 | #:instantiate? 68 | 69 | #:conditional-mixin) 70 | 71 | ;; Implementation protocol and mixin class 72 | (:export 73 | #:specification 74 | 75 | #:implementation-mixin) 76 | 77 | ;; Specification protocol 78 | (:export 79 | #:implementation 80 | #:implementations 81 | 82 | #:specification-mixin) 83 | 84 | (:documentation 85 | "The data model of the build-generator system.")) 86 | -------------------------------------------------------------------------------- /src/model/project/concrete-syntax/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; conditions.lisp --- Conditions used in the recipe concrete syntax. 2 | ;;;; 3 | ;;;; Copyright (C) 2016-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.project) 8 | 9 | ;;; Source location conditions 10 | 11 | (define-condition annotation-condition () 12 | ((annotations :initarg :annotations 13 | :accessor annotations 14 | :initform '()))) 15 | 16 | (defmethod print-object :around ((object annotation-condition) stream) 17 | (let ((annotations (annotations object))) 18 | (let ((*print-circle* nil)) 19 | (pprint-logical-block (stream annotations) 20 | (call-next-method) 21 | (loop :repeat 2 :do (pprint-newline :mandatory stream)) 22 | (text.source-location.print::print-annotations stream annotations))))) 23 | 24 | (define-condition simple-object-error (error 25 | annotation-condition 26 | simple-condition) 27 | ()) 28 | 29 | (defun make-object-error (annotated-objects 30 | &optional format-control &rest format-arguments) 31 | (if-let ((annotations 32 | (loop :for (object text kind) :in annotated-objects 33 | :for location = (location-of object) 34 | :when location 35 | :collect (apply #'text.source-location:make-annotation 36 | location text (when kind (list :kind kind)))))) 37 | (make-condition 'simple-object-error 38 | :annotations annotations 39 | :format-control format-control 40 | :format-arguments format-arguments) 41 | (make-condition 'simple-error 42 | :format-control format-control 43 | :format-arguments format-arguments))) 44 | 45 | (defun object-error (annotated-objects 46 | &optional format-control &rest format-arguments) 47 | (error (apply #'make-object-error 48 | annotated-objects format-control format-arguments))) 49 | 50 | ;;; YAML syntax 51 | 52 | (define-condition recipe-not-found-error (error) 53 | ((%kind :initarg :kind 54 | :reader kind) 55 | (%name :initarg :name 56 | :reader name) 57 | (%repository :initarg :repository 58 | :reader repository)) 59 | (:report 60 | (lambda (condition stream) 61 | (format stream "~@<~A recipe \"~A\" does not exist in repository ~ 62 | ~A~@:>" 63 | (kind condition) 64 | (name condition) 65 | (repository condition)))) 66 | (:documentation 67 | "Signaled when a given recipe does not exist in the repository.")) 68 | 69 | (define-condition yaml-syntax-error (error 70 | annotation-condition 71 | more-conditions:chainable-condition) 72 | () 73 | (:report 74 | (lambda (condition stream) 75 | (let* ((cause (more-conditions:cause condition)) 76 | (context (esrap::esrap-parse-error-context cause))) 77 | (esrap::error-report context stream))))) 78 | -------------------------------------------------------------------------------- /src/model/project/concrete-syntax/locations.lisp: -------------------------------------------------------------------------------- 1 | ;;;; locations.lisp --- Source locations for recipe concrete syntax. 2 | ;;;; 3 | ;;;; Copyright (C) 2016-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.project) 8 | 9 | (defvar *locations* (make-hash-table :test #'eq)) 10 | 11 | (defvar *locations-lock* (bt:make-lock "locations")) 12 | 13 | (defun location-of (object) 14 | (bt:with-lock-held (*locations-lock*) 15 | (gethash object *locations*))) 16 | 17 | (defun (setf location-of) (new-value object) 18 | (bt:with-lock-held (*locations-lock*) 19 | (setf (gethash object *locations*) new-value))) 20 | 21 | (defun copy-location (old-object new-object) 22 | (setf (location-of new-object) (location-of old-object)) 23 | new-object) 24 | -------------------------------------------------------------------------------- /src/model/project/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for project module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.model.project 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:split-sequence 12 | #:iterate 13 | #:let-plus 14 | #:more-conditions) 15 | 16 | (:local-nicknames 17 | (#:bp #:architecture.builder-protocol) 18 | 19 | (#:util #:build-generator.util) 20 | 21 | (#:analysis #:build-generator.analysis) 22 | 23 | (#:model #:build-generator.model) 24 | (#:var #:build-generator.model.variables) 25 | (#:aspects #:build-generator.model.aspects)) 26 | 27 | (:shadow 28 | #:node) 29 | 30 | (:import-from #:build-generator.version 31 | #:parse-version 32 | #:version>= 33 | #:version-matches) 34 | 35 | ;; Conditions 36 | (:export 37 | #:recipe-not-found-error 38 | #:kind 39 | #:name 40 | #:repository) 41 | 42 | ;; People 43 | (:export 44 | #:all-persons 45 | #:ensure-persons!) 46 | 47 | ;; Template protocol 48 | (:export 49 | #:find-template) 50 | 51 | ;; Distribution specification protocol 52 | (:export 53 | #:direct-includes 54 | #:direct-versions 55 | #:versions) 56 | 57 | ;; Project include protocol and class 58 | (:export 59 | #:distribution-include 60 | 61 | #:distribution) 62 | 63 | ;; Project include protocol and class 64 | (:export 65 | #:project-include 66 | 67 | #:project 68 | #:version) 69 | 70 | ;; Resolved project include protocol and class 71 | (:export 72 | #:resolved-project-include 73 | 74 | #:version) 75 | 76 | ;; Project specification protocol 77 | (:export 78 | #:templates 79 | #:versions 80 | #:jobs) 81 | 82 | ;; Version specification protocol and class 83 | (:export 84 | #:version-spec) 85 | 86 | ;; Template specification protocol 87 | (:export 88 | #:inherit 89 | #:jobs) 90 | 91 | ;; Project protocol 92 | (:export 93 | #:find-project) 94 | 95 | ;; Version protocol 96 | (:export 97 | #:context) 98 | 99 | ;; Include context protocol 100 | (:export 101 | #:distribution) 102 | 103 | ;; Provider registry 104 | (:export 105 | #:find-provider/version) 106 | 107 | ;; Requires/provides protocol 108 | (:export 109 | #:direct-requires #:requires #:requires-of-kind 110 | #:direct-provides #:provides #:provides-of-kind 111 | 112 | #:direct-dependencies/reasons) 113 | 114 | ;; Person container protocol 115 | (:export 116 | #:persons 117 | #:persons-in-roles/plist 118 | #:persons-in-role) 119 | 120 | ;; Platform requirements protocol 121 | (:export 122 | #:platform-requires 123 | #:platform-provides) 124 | 125 | ;; Mode protocol 126 | (:export 127 | #:name 128 | #:parent 129 | 130 | #:mode ; class 131 | #:ensure-mode) 132 | 133 | ;; Recipe repository protocol 134 | (:export 135 | #:name 136 | #:root-directory 137 | #:mode ; accessor 138 | 139 | #:recipe-directory 140 | 141 | #:recipe-path 142 | 143 | #:probe-recipe-pathname 144 | #:recipe-truename 145 | #:recipe-truenames 146 | 147 | #:recipe-name 148 | 149 | #:populate-recipe-repository! 150 | 151 | #:recipe-repository 152 | #:make-recipe-repository 153 | #:make-populated-recipe-repository 154 | 155 | #:load-repository) 156 | 157 | ;; YAML stuff 158 | (:export 159 | #:load-person/yaml 160 | #:load-template/yaml 161 | #:load-project-spec/yaml 162 | #:load-distribution/yaml) 163 | 164 | (:documentation 165 | "Contains distribution, project and related concepts of the model.")) 166 | -------------------------------------------------------------------------------- /src/model/project/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp --- Utilities used in the model.project module. 2 | ;;;; 3 | ;;;; Copyright (C) 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.project) 8 | 9 | (defun parse-dependency-spec (spec) 10 | (flet ((result (nature target &optional version) 11 | (list* (make-keyword (string-upcase nature)) 12 | target 13 | (etypecase version 14 | (null '()) 15 | (cons version) 16 | (string (list (parse-version version))))))) 17 | (optima:match spec 18 | ;; Legacy syntax: [ "NATURE", "TARGET", VERSION ] 19 | ((list* (and nature (type string)) 20 | (and target (type string)) 21 | (or (list (and version (type string))) '())) 22 | (result nature target version)) 23 | 24 | ;; Shorthand: NATURE: TARGET 25 | ((list (cons (and nature (type keyword)) 26 | (and target (type string)))) 27 | (result (string-downcase nature) target)) 28 | 29 | ;; New syntax: 30 | ;; nature: NATURE 31 | ;; target: TARGET 32 | ;; version: VERSION 33 | ((and (assoc :nature (and nature (type string))) 34 | (assoc :target (and target (type string))) 35 | (or (assoc :version (and version (type string))) 36 | (and))) 37 | (check-keys spec '((:nature t string) 38 | (:target t string) 39 | (:version nil string))) 40 | (result nature target version)) 41 | 42 | (otherwise 43 | (object-error 44 | (list (list spec "specified here" :error)) 45 | "~@"))))) 48 | -------------------------------------------------------------------------------- /src/model/variables/aggregation.lisp: -------------------------------------------------------------------------------- 1 | ;;;; aggregation.lisp --- Aggregation of variable values. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables) 8 | 9 | ;;; Append strategy 10 | 11 | (defmethod aggregate-values ((value t) 12 | (children t) 13 | (name t) 14 | (strategy (eql :append))) 15 | (remove-duplicates 16 | (append value (mappend (lambda (version) 17 | (value version name '())) 18 | children)) 19 | :test #'string=)) 20 | 21 | ;;; Merge strategy 22 | 23 | (defun merge-alists (left right &key (merge (rcurry #'union :test #'equal))) 24 | (let+ ((result (cons nil '())) 25 | ((&labels merge-cell (result-value-cell value) 26 | (setf (cdr result-value-cell) 27 | (funcall merge (cdr result-value-cell) value)))) 28 | ((&labels visit-cell (result-value-cell source-value) 29 | (typecase source-value 30 | ((cons (cons keyword t) list) 31 | (visit-alist result-value-cell source-value)) 32 | (t 33 | (merge-cell result-value-cell source-value))))) 34 | ((&labels visit-alist (result-list-cell source-list) 35 | (map nil (lambda+ ((key . value)) 36 | (let ((result-value-cell 37 | (or (assoc key (cdr result-list-cell)) 38 | (let ((cell (cons key '()))) 39 | (push cell (cdr result-list-cell)) 40 | cell)))) 41 | (visit-cell result-value-cell value))) 42 | source-list)))) 43 | (visit-alist result left) 44 | (visit-alist result right) 45 | (cdr result))) 46 | 47 | (defmethod aggregate-values ((value t) 48 | (children t) 49 | (name t) 50 | (strategy (eql :merge))) 51 | (reduce (lambda (merged version) 52 | (merge-alists merged (value version name '()))) 53 | children :initial-value value)) 54 | 55 | ;;; Histogram strategy 56 | 57 | (defmethod aggregate-values ((value t) 58 | (children t) 59 | (name t) 60 | (strategy (eql :histogram))) 61 | (let ((counts (make-hash-table :test #'eq))) 62 | (map nil (lambda (child) 63 | (map nil (lambda (value) 64 | (incf (gethash (make-keyword value) counts 0))) 65 | (value child name '()))) 66 | children) 67 | (hash-table-alist counts))) 68 | -------------------------------------------------------------------------------- /src/model/variables/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; conditions.lisp --- Conditions used in the model.variables module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables) 8 | 9 | ;;; Evaluation-related conditions 10 | 11 | (define-condition expression-cycle-error (error) 12 | ((path :initarg :path 13 | :type list 14 | :reader expression-cycle-error-path)) 15 | (:report 16 | (lambda (condition stream) 17 | (format stream "~@ ~}~ 20 | ~@:_~@:_.~@:>" 21 | (expression-cycle-error-path condition)))) 22 | (:default-initargs 23 | :path (missing-required-initarg 'expression-cycle-error :path)) 24 | (:documentation 25 | "This error is signaled when a cycle is detected during variable 26 | expansion.")) 27 | 28 | ;;; Variable schema conditions 29 | 30 | (define-condition variable-condition (condition) 31 | ((name :initarg :name 32 | :reader variable-condition-name 33 | :documentation 34 | "Stores the name of the variable.")) 35 | (:default-initargs 36 | :name (missing-required-initarg 'variable-condition :name)) 37 | (:documentation 38 | "Superclass for variable-related condition classes.")) 39 | 40 | (define-condition unused-variable-warning (variable-condition 41 | style-warning) 42 | () 43 | (:report 44 | (lambda (condition stream) 45 | (format stream "~@" 46 | (variable-condition-name condition)))) 47 | 48 | (:documentation 49 | "Signaled when an access to an undefined variable is detected at 50 | compile-time.")) 51 | 52 | (define-condition undefined-variable-condition (variable-condition) 53 | () 54 | (:report 55 | (lambda (condition stream) 56 | (format stream "~@" 57 | (variable-condition-name condition)))) 58 | (:documentation 59 | "Superclass for condition classes related to access to undefined 60 | variables.")) 61 | 62 | (define-condition undefined-variable-warning (undefined-variable-condition 63 | style-warning) 64 | () 65 | (:documentation 66 | "Signaled when an access to an undefined variable is detected at 67 | compile-time.")) 68 | 69 | (define-condition undefined-variable-error (undefined-variable-condition 70 | error) 71 | () 72 | (:documentation 73 | "Signaled when an access to an undefined variable occurs at 74 | runtime.")) 75 | -------------------------------------------------------------------------------- /src/model/variables/grammar.lisp: -------------------------------------------------------------------------------- 1 | ;;;; grammar.lisp --- Grammar for value expressions. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables) 8 | 9 | (defun maybe-first (thing) 10 | (if (and (length= 1 thing) 11 | (typep (first thing) '(or string (cons (member :ref :ref/list))))) 12 | (first thing) 13 | thing)) 14 | 15 | (esrap:defrule escaped-syntactic-character 16 | (and #\\ (or #\$ #\@ #\})) 17 | (:function second)) 18 | 19 | (esrap:defrule uninterpreted-$-or-@ 20 | (and (or #\$ #\@) (esrap:! #\{)) 21 | (:function first)) 22 | 23 | (esrap:defrule text 24 | (+ (or escaped-syntactic-character 25 | uninterpreted-$-or-@ 26 | (not (or #\$ #\@)))) 27 | (:text t)) 28 | 29 | (esrap:defrule variable-reference/content 30 | (+ (not (or #\| #\} #\$ #\@))) 31 | (:text t)) 32 | 33 | (esrap:defrule text/ended-by-} 34 | (and (+ (or escaped-syntactic-character (not (or #\$ #\@ #\})))) 35 | (esrap:& #\})) 36 | (:function first) 37 | (:text t)) 38 | 39 | (esrap:defrule text/not-started-by-{ 40 | (and (esrap:! #\}) text) 41 | (:function second)) 42 | 43 | (esrap:defrule reference-expr 44 | (+ (or variable-reference/content variable-reference))) 45 | 46 | (esrap:defrule default-expr 47 | (and (+ (or variable-reference text/ended-by-} text/not-started-by-{)) 48 | (esrap:& #\})) 49 | (:function first) 50 | (:function maybe-first)) 51 | 52 | (esrap:defrule variable-reference 53 | (and (or #\$ #\@) #\{ 54 | reference-expr (esrap:? (and #\| (esrap:? default-expr))) 55 | #\}) 56 | (:destructure (kind open content default close) 57 | (declare (ignore open close)) 58 | (let ((default (when default 59 | (list :default (unless (equal (second default) "[]") 60 | (second default)))))) 61 | (cond 62 | ((string= kind "$") 63 | (list* :ref content default)) 64 | ((string= kind "@") 65 | (list* :ref/list content default)))))) 66 | 67 | (esrap:defrule expr 68 | (* (or variable-reference text))) 69 | -------------------------------------------------------------------------------- /src/model/variables/mixins.lisp: -------------------------------------------------------------------------------- 1 | ;;;; mixins.lisp --- Generic mixin classes used by project, templates, etc. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables) 8 | 9 | ;;; `direct-variables-mixin' 10 | 11 | (defclass direct-variables-mixin () 12 | ((variables :initarg :variables 13 | :type list ; alist 14 | :accessor %direct-variables 15 | :reader direct-variables 16 | :initform '() 17 | :documentation 18 | "Stores direct variables definitions as an alist with 19 | elements of the form 20 | 21 | (NAME . EXPRESSION) 22 | 23 | where NAME is a keyword naming the variable and 24 | EXPRESSION a `variable-expression', the unevaluated 25 | value of the variable.")) 26 | (:documentation 27 | "Adds a list of direct variable definition cells.")) 28 | 29 | (defmethod shared-initialize :around ((instance direct-variables-mixin) 30 | (slot-names t) 31 | &key) 32 | (call-next-method) 33 | (loop :with locations = *variable-locations* 34 | :for cell :in (%direct-variables instance) 35 | :unless (gethash cell locations) 36 | :do (setf (gethash cell locations) instance))) 37 | 38 | (defmethod variables append ((thing direct-variables-mixin)) 39 | (copy-list (direct-variables thing))) 40 | 41 | (defmethod direct-lookup ((thing direct-variables-mixin) (name t)) 42 | (if-let ((cell (find name (direct-variables thing) 43 | :test #'eq 44 | :key #'car))) 45 | (values cell '() t) 46 | (values nil '() nil))) 47 | 48 | (defmethod lookup ((thing direct-variables-mixin) (name t) 49 | &key if-undefined) 50 | (declare (ignore if-undefined)) 51 | (direct-lookup thing name)) 52 | 53 | (defmethod (setf lookup) ((new-value t) 54 | (thing direct-variables-mixin) 55 | (name t) 56 | &key if-undefined) 57 | (declare (ignore if-undefined)) 58 | (removef (%direct-variables thing) name :key #'car) 59 | (let ((cell (value-cons name new-value))) 60 | (push cell (%direct-variables thing)) 61 | (setf (gethash cell *variable-locations*) thing) 62 | new-value)) 63 | 64 | ;;; `builtin-entries-mixin' 65 | 66 | (defclass builtin-entries-mixin () 67 | ()) 68 | 69 | (defmethod shared-initialize :after ((instance builtin-entries-mixin) 70 | (slot-names t) 71 | &key 72 | (variables nil variables-supplied?)) 73 | (declare (ignore variables)) 74 | (when variables-supplied? 75 | (loop :for (name . value) :in (builtin-entries instance) 76 | :do (if-let ((cell (assoc name (%direct-variables instance) :test #'eq))) 77 | (setf (cdr cell) value) 78 | (push (cons name value) (%direct-variables instance)))))) 79 | -------------------------------------------------------------------------------- /src/model/variables/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the model.variables module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.model.variables 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:more-conditions) 13 | 14 | ;; Conditions 15 | (:export 16 | #:expression-cycle-error 17 | #:expression-cycle-error-path 18 | 19 | #:variable-condition 20 | #:variable-condition-name 21 | 22 | #:unused-variable-warning 23 | 24 | #:undefined-variable-condition 25 | #:undefined-variable-warning 26 | #:undefined-variable-error) 27 | 28 | ;; Types 29 | (:export 30 | #:list-of) 31 | 32 | ;; Variables 33 | (:export 34 | #:*traced-variables*) 35 | 36 | ;; Value protocol 37 | (:export 38 | #:value-list 39 | #:value-list* 40 | #:value-cons 41 | #:value-acons 42 | #:value-parse 43 | #:value-unparse 44 | 45 | #:to-value) 46 | 47 | ;; Lookup protocol 48 | (:export 49 | #:merge-lookup-results 50 | #:merge-lookup-values 51 | 52 | #:direct-lookup 53 | #:lookup ; also setf 54 | #:expand 55 | #:value 56 | #:evaluate 57 | 58 | #:as 59 | #:value/cast 60 | 61 | #:aggregate-values) 62 | 63 | ;; Variable protocol and mixin class 64 | (:export 65 | #:direct-variables 66 | #:variables 67 | 68 | #:direct-variables-mixin) 69 | 70 | ;; Builtin entries protocol and mixin class 71 | (:export 72 | #:builtin-entries 73 | 74 | #:builtin-entries-mixin) 75 | 76 | ;; Variable schema protocol 77 | (:export 78 | #:variable-info 79 | #:variable-info-name 80 | #:variable-info-type 81 | #:inheritance 82 | #:aggregation 83 | #:variable-info-documentation 84 | 85 | #:make-variable-info 86 | 87 | #:all-variables 88 | #:find-variable ; also setf 89 | #:note-variable 90 | 91 | #:define-variable 92 | 93 | #:check-variable-liveness 94 | #:check-variable-access) 95 | 96 | (:documentation 97 | "Variable model, syntax, lookup, expansion and schema.")) 98 | -------------------------------------------------------------------------------- /src/model/variables/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; types.lisp --- Types used in the model.variables module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables) 8 | 9 | (deftype list-of (&whole whole thing) 10 | (let+ ((name/string (concatenate 'string "EVERY-" (symbol-name thing))) 11 | ((&flet name (package) 12 | (find-symbol name/string package))) 13 | (name (or (name (symbol-package thing)) 14 | (name (symbol-package 'list-of)) 15 | (error "~@" thing whole)))) 17 | `(and list (satisfies ,name)))) 18 | 19 | (defun every-string (thing) 20 | (and (listp thing) (every #'stringp thing))) 21 | -------------------------------------------------------------------------------- /src/model/variables/variables.lisp: -------------------------------------------------------------------------------- 1 | ;;;; variables.lisp --- Variable provided by the model.variables module. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables) 8 | 9 | (defvar *variable-locations* (make-hash-table :weakness :value)) 10 | 11 | (defvar *traced-variables* '()) 12 | -------------------------------------------------------------------------------- /src/more-conditions-patch.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:more-conditions) 2 | 3 | (defvar *without-progress* nil) 4 | 5 | (defmacro without-progress (&body body) 6 | `(let ((*without-progress* t)) 7 | ,@body)) 8 | 9 | (defun %progress (&optional operation progress 10 | format-control-or-condition-class 11 | &rest format-arguments-or-initargs) 12 | (declare (type progress-designator progress)) 13 | (when *without-progress* 14 | (return-from %progress)) 15 | (typecase format-control-or-condition-class 16 | ((or string function) ; assume formatter when function 17 | (signal 'simple-progress-condition 18 | :operation operation 19 | :progress progress 20 | :format-control format-control-or-condition-class 21 | :format-arguments format-arguments-or-initargs)) 22 | (t 23 | (apply #'signal (or format-control-or-condition-class 24 | 'progress-condition) 25 | :operation operation 26 | :progress progress 27 | format-arguments-or-initargs)))) 28 | -------------------------------------------------------------------------------- /src/report/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; conditions.lisp --- Conditions signaled by the report module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.report) 8 | 9 | (define-condition report-condition (chainable-condition) 10 | ((style :initarg :style 11 | :reader style 12 | :documentation 13 | "The style of the report for which the condition is 14 | signaled.") 15 | (object :initarg :object 16 | :reader object 17 | :documentation 18 | "The object for which the report was being produced.")) 19 | (:default-initargs 20 | :style (missing-required-initarg 'report-condition :style) 21 | :object (missing-required-initarg 'report-condition :object))) 22 | 23 | (define-condition report-error (report-condition 24 | error) 25 | () 26 | (:report 27 | (lambda (condition stream) 28 | (let+ (((&accessors-r/o style object) condition)) 29 | (format stream "~@" 32 | style (print-items:print-items object) condition))))) 33 | -------------------------------------------------------------------------------- /src/report/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the report module. 2 | ;;;; 3 | ;;;; Copyright (C) 2015, 2016, 2017, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.report 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:iterate 12 | #:let-plus 13 | #:more-conditions) 14 | 15 | (:local-nicknames 16 | (#:util #:build-generator.util) 17 | 18 | (#:model #:build-generator.model) 19 | (#:var #:build-generator.model.variables) 20 | (#:project #:build-generator.model.project)) 21 | 22 | ;; Report protocol 23 | (:export 24 | #:report) 25 | 26 | (:documentation 27 | "This package contains functionality for reporting information 28 | gathered from recipes merged with analysis results.")) 29 | -------------------------------------------------------------------------------- /src/report/protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;;; protocol.lisp --- Protocol provided by the report module. 2 | ;;;; 3 | ;;;; Copyright (C) 2015, 2016, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.report) 8 | 9 | (defgeneric report (object style target) 10 | (:documentation 11 | "Send report for OBJECT with STYLE to TARGET. 12 | 13 | TARGET is usually a stream.")) 14 | -------------------------------------------------------------------------------- /src/resources/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; conditions.lisp --- Conditions signaled by the resources module. 2 | ;;;; 3 | ;;;; Copyright (C) 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.resources) 8 | 9 | (define-condition entry-does-not-exist-error (error) 10 | ((%name :initarg :name 11 | :type pathname 12 | :reader name) 13 | (%group :initarg :group 14 | :reader group)) 15 | (:default-initargs 16 | :name (missing-required-initarg 'entry-does-not-exist-error :name) 17 | :group (missing-required-initarg 'entry-does-not-exist-error :group)) 18 | (:report 19 | (lambda (condition stream) 20 | (format stream "~@" 21 | (name condition) (group condition))))) 22 | 23 | (define-condition group-does-not-exist-error (error) 24 | ((%name :initarg :name 25 | :type symbol 26 | :reader name) 27 | (%resources :initarg :resources 28 | :reader resources)) 29 | (:default-initargs 30 | :name (missing-required-initarg 'group-does-not-exist-error :name) 31 | :resources (missing-required-initarg 'group-does-not-exist-error :resources)) 32 | (:report 33 | (lambda (condition stream) 34 | (format stream "~@" 35 | (name condition) (resources condition))))) 36 | -------------------------------------------------------------------------------- /src/resources/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the resources module. 2 | ;;;; 3 | ;;;; Copyright (C) 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.resources 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:more-conditions) 12 | 13 | ;; Conditions 14 | (:export 15 | #:entry-does-not-exist-error 16 | #:name 17 | #:group 18 | 19 | #:group-does-not-exist-error 20 | #:name 21 | #:resources) 22 | 23 | ;; Name protocol 24 | (:export 25 | #:name) 26 | 27 | ;; Size protocol 28 | (:export 29 | #:octet-count) 30 | 31 | ;; Entry protocol 32 | (:export 33 | #:content 34 | #:info) 35 | 36 | ;; Group protocol 37 | (:export 38 | #:parent 39 | 40 | #:entries 41 | #:find-entry ; also `setf' 42 | #:add-file) 43 | 44 | ;; Resources protocol 45 | (:export 46 | #:find-group ; also `setf' 47 | 48 | #:ensure-datum) 49 | 50 | ;; Global resource group registry 51 | (:export 52 | #:make-group 53 | #:find-group*)) 54 | -------------------------------------------------------------------------------- /src/resources/protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;;; protocol.lisp --- Protocol provided by the resources module. 2 | ;;;; 3 | ;;;; Copyright (C) 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.resources) 8 | 9 | ;;; Name protocol 10 | 11 | (defgeneric name (thing) 12 | (:documentation 13 | "Return the name of THING.")) 14 | 15 | ;;; Size protocol 16 | 17 | (defgeneric octet-count (container) 18 | (:documentation 19 | "Return the number of octets stored in CONTAINER.")) 20 | 21 | ;;; Entry protocol 22 | 23 | (defgeneric content (entry) 24 | (:documentation 25 | "Return the content of ENTRY a `nibbles:octet-vector'.")) 26 | 27 | (defgeneric info (entry) 28 | (:documentation 29 | "Return the info plist of ENTRY.")) 30 | 31 | ;;; Group protocol 32 | 33 | (defgeneric parent (group) 34 | (:documentation 35 | "Return the resource container containing GROUP.")) 36 | 37 | (defgeneric entries (group) 38 | (:documentation 39 | "Return a list of the entries of GROUP.")) 40 | 41 | (defgeneric find-entry (name group &key if-does-not-exist) 42 | (:documentation 43 | "Return entry named NAME in GROUP. 44 | 45 | IF-DOES-NOT-EXIST controls the behavior in case such an entry does 46 | not exist.")) 47 | 48 | (defgeneric (setf find-entry) (new-value name group &key if-does-not-exist) 49 | (:documentation 50 | "Store the entry NEW-VALUE under the NAME in GROUP. 51 | 52 | IF-DOES-NOT-EXIST is accepted for parity with `find-entry'.")) 53 | 54 | (defgeneric add-file (container file &key base-directory name info)) 55 | 56 | ;;; Resources protocol 57 | 58 | (defgeneric find-group (name container &key if-does-not-exist) 59 | (:documentation 60 | "Return the resource group named NAME in CONTAINER. 61 | 62 | IF-DOES-NOT-EXIST controls the behavior in case NAME does not name 63 | a resource group in CONTAINER.")) 64 | 65 | (defgeneric (setf find-group) (new-value name container &key if-does-not-exist) 66 | (:documentation 67 | "Store the resource group NEW-VALUE under NAME in CONTAINER. 68 | 69 | IF-DOES-NOT-EXIST is accepted for parity with `find-group'.")) 70 | -------------------------------------------------------------------------------- /src/steps/jenkins-install-legacy.lisp: -------------------------------------------------------------------------------- 1 | ;;;; jenkins-install-legacy.lisp --- Steps for setting up a Jenkins instance. 2 | ;;;; 3 | ;;;; Copyright (C) 2015-2025 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.steps) 8 | 9 | (define-constant +default-jenkins-download-url+ 10 | (puri:uri "https://archives.jenkins.io/war-stable/latest/jenkins.war") 11 | :test #'puri:uri=) 12 | 13 | (defun jenkins-plugin-url (name &key (base-url +jenkins-plugins-base-url+)) 14 | (puri:merge-uris (format nil "~A.hpi" name) base-url)) 15 | 16 | (define-constant +jenkins-plugin-manifest-filename+ 17 | "META-INF/MANIFEST.MF" 18 | :test #'string=) 19 | 20 | (defgeneric jenkins-plugin-dependencies (thing) 21 | (:method ((thing string)) 22 | (let+ ((clean (ppcre:regex-replace-all 23 | #.(format nil "~C~%(:? )?" #\Return) thing 24 | (lambda (whole space) 25 | (declare (ignore whole)) 26 | (if (emptyp space) (string #\Newline) "")) 27 | :simple-calls t)) 28 | ((&flet parse-dependency (spec) 29 | (ppcre:register-groups-bind (name version optional?) 30 | ("([^:]+):([^;]+)(;resolution:=optional)?" spec) 31 | (list name version (when optional? t)))))) 32 | (ppcre:register-groups-bind (dependencies) 33 | ("Plugin-Dependencies: +(.+)" clean) 34 | (mapcar #'parse-dependency 35 | (split-sequence:split-sequence #\, dependencies))))) 36 | (:method ((thing pathname)) 37 | (jenkins-plugin-dependencies 38 | (zip:with-zipfile (zip thing) 39 | (let ((manifest (zip:get-zipfile-entry +jenkins-plugin-manifest-filename+ zip))) 40 | (sb-ext:octets-to-string (zip:zipfile-entry-contents manifest))))))) 41 | -------------------------------------------------------------------------------- /src/steps/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the steps module. 2 | ;;;; 3 | ;;;; Copyright (C) 2014-2025 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.steps 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:more-conditions) 13 | 14 | (:local-nicknames 15 | (#:analysis #:build-generator.analysis) 16 | 17 | (#:res #:build-generator.resources)) 18 | 19 | ;; Step protocol 20 | (:export 21 | #:execute) 22 | 23 | ;; Step creation protocol 24 | (:export 25 | #:make-step) 26 | 27 | ;; Step runtime support 28 | (:export 29 | #:map-with-restart/sequential #:map-with-restart/sequential/progress 30 | #:map-with-restart/parallel #:map-with-restart/parallel/progress) 31 | 32 | ;; Step macros 33 | (:export 34 | #:with-sequence-processing 35 | 36 | #:define-step 37 | #:define-sequence-step) 38 | 39 | ;; Jenkins install steps 40 | (:export 41 | #:jenkins-username? 42 | #:jenkins-username)) 43 | -------------------------------------------------------------------------------- /src/steps/protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;;; protocol.lisp --- Protocol provided by the steps module. 2 | ;;;; 3 | ;;;; Copyright (C) 2014-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.steps) 8 | 9 | ;;; Step protocol 10 | 11 | (defgeneric execute (step context &key &allow-other-keys) 12 | (:documentation 13 | "Execute STEP in CONTEXT. 14 | 15 | Input data items are supplied via keyword parameters.")) 16 | 17 | ;;; Step creation protocol 18 | 19 | (defgeneric make-step (spec &rest args) 20 | (:documentation 21 | "Create and return a step according to SPEC and ARGS.")) 22 | 23 | ;;; Default behavior 24 | 25 | (defmethod make-step ((spec t) &rest args) 26 | (apply #'service-provider:make-provider 'step spec args)) 27 | 28 | ;;; Step service 29 | 30 | (service-provider:define-service step 31 | (:documentation 32 | "Providers of this service consume zero or more input items, 33 | perform some coherent operation and produce zero or more output 34 | items. 35 | 36 | The execution of such steps is usually organized in a plan to 37 | perform larger computations.")) 38 | -------------------------------------------------------------------------------- /src/util/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the util module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018-2022 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.util 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | #:iterate) 13 | 14 | (:shadow 15 | #:directory) 16 | 17 | ;; Conditions and Restarts 18 | (:export 19 | #:some-cause 20 | 21 | #:continuable-error 22 | #:find-continue-restart 23 | 24 | #:call-with-retry-restart 25 | #:with-retry-restart 26 | #:call-with-retries 27 | #:with-retries) 28 | 29 | ;; Strings 30 | (:export 31 | #:maybe-truncate 32 | #:safe-name 33 | 34 | #:edit-distance 35 | #:closest-matches) 36 | 37 | ;; Files 38 | (:export 39 | #:safe-enough-namestring 40 | 41 | #:ensure-exists 42 | #:ensure-deleted 43 | #:temporary-directory 44 | #:make-temporary-directory 45 | #:temporary-sub-directory 46 | #:make-temporary-sub-directory 47 | 48 | #:find-files 49 | #:make-file-generator 50 | #:safe-external-format-argument 51 | #:read-file-into-string*) 52 | 53 | ;; Sorting 54 | (:export 55 | #:sort-with-partial-order)) 56 | -------------------------------------------------------------------------------- /src/util/restarts.lisp: -------------------------------------------------------------------------------- 1 | ;;;; restarts.lisp --- String-related utilities. 2 | ;;;; 3 | ;;;; Copyright (C) 2015, 2016, 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.util) 8 | 9 | ;;; Conditions 10 | 11 | (defun some-cause (predicate condition) 12 | (labels ((rec (condition) 13 | (cond ((funcall predicate condition) 14 | t) 15 | ((when-let ((cause (more-conditions:cause condition))) 16 | (rec cause))) 17 | (t 18 | nil)))) 19 | (rec condition))) 20 | 21 | ;;; Continuing 22 | 23 | (deftype continuable-error () 24 | ;; SBCL establishes `continue' restarts when signaling the following 25 | ;; conditions. Using these restarts in an error policy causes an 26 | ;; infinite loop (and potentially hides a programming error). So 27 | ;; don't consider these errors continuable. 28 | `(not (or unbound-variable undefined-function))) 29 | 30 | (defun find-continue-restart (condition) 31 | ;; Recent SBCL versions establish a `continue' restart in `open' 32 | ;; that actually just retries the operation. Using this restart in 33 | ;; an error policy causes an infinite loop. So ignore the 34 | ;; problematic restart when looking for `continue' restarts. 35 | #+sbcl (find-if (lambda (restart) 36 | (and (eq (restart-name restart) 'continue) 37 | (not (search "Retry opening" 38 | (princ-to-string restart))))) 39 | (compute-restarts condition)) 40 | #-sbcl (find-restart 'continue condition)) 41 | 42 | ;;; Retrying 43 | 44 | (defun call-with-retry-restart (thunk report) 45 | (tagbody 46 | :start 47 | (restart-case 48 | (return-from call-with-retry-restart 49 | (funcall thunk)) 50 | (retry () 51 | :report (lambda (stream) (funcall report stream)) 52 | (go :start))))) 53 | 54 | (defmacro with-retry-restart ((format-control &rest format-arguments) &body body) 55 | `(call-with-retry-restart 56 | (lambda () ,@body) 57 | (lambda (stream) 58 | (format stream ,format-control ,@format-arguments)))) 59 | 60 | (defun call-with-retries (thunk condition-type limit) 61 | (let ((retry-count 0)) 62 | (handler-bind 63 | ((condition (lambda (condition) 64 | (cond 65 | ((not (typep condition condition-type))) 66 | ((>= retry-count limit) 67 | (error "~@" 69 | retry-count condition)) 70 | (t 71 | (when-let ((restart (find-restart 'retry condition))) 72 | (incf retry-count) 73 | (log:warn "~@" 75 | restart retry-count limit) 76 | (invoke-restart restart))))))) 77 | (funcall thunk)))) 78 | 79 | (defmacro with-retries ((condition-type &key limit) &body body) 80 | `(call-with-retries (lambda () ,@body) ',condition-type ,limit)) 81 | -------------------------------------------------------------------------------- /src/util/sorting.lisp: -------------------------------------------------------------------------------- 1 | ;;;; sorting.lisp --- Functions for sorting. 2 | ;;;; 3 | ;;;; Copyright (C) 2013-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.util) 8 | 9 | (define-condition cycle-error (error) 10 | ((path :initarg :path 11 | :reader cycle-error-path)) 12 | (:default-initargs 13 | :path (more-conditions:missing-required-initarg 'cycle-error :path)) 14 | (:report 15 | (lambda (condition stream) 16 | (format stream "~@ ~}~@:>" 18 | (cycle-error-path condition))))) 19 | 20 | (defstruct (node 21 | (:constructor make-node (object)) 22 | (:predicate nil) 23 | (:copier nil)) 24 | (object nil :read-only t) 25 | (edges '() :type list) 26 | (state :new :type (member :new :in-progress :done))) 27 | 28 | (defun topological-sort (nodes) 29 | (let+ ((result '()) 30 | ((&labels visit (node) 31 | (case (node-state node) 32 | (:in-progress 33 | (list node)) 34 | (:new 35 | (setf (node-state node) :in-progress) 36 | (when-let ((cycle (some #'visit (node-edges node)))) 37 | (return-from visit (list* node cycle))) 38 | (setf (node-state node) :done) 39 | (push node result) 40 | nil)))) 41 | ((&flet new? (node) 42 | (eq (node-state node) :new)))) 43 | (loop :for node := (find-if #'new? nodes) 44 | :while node :do 45 | (when-let ((cycle (visit node))) 46 | (error 'cycle-error 47 | :path (mapcar #'node-object cycle)))) 48 | result)) 49 | 50 | (defun sort-with-partial-order (sequence predicate) 51 | (declare (type sequence sequence)) 52 | (let* ((predicate (ensure-function predicate)) 53 | (nodes (map '(simple-array t 1) #'make-node sequence)) 54 | (length (length nodes))) 55 | ;; Build graph by checking PREDICATE for all pairs of distinct 56 | ;; elements of SEQUENCE. 57 | (loop :for i :below length 58 | :for node1 = (aref nodes i) 59 | :for object1 = (node-object node1) :do 60 | (loop :for j :from (1+ i) :below length 61 | :for node2 = (aref nodes j) 62 | :for object2 = (node-object node2) :do 63 | (when (funcall predicate object1 object2) 64 | (push node2 (node-edges node1))) 65 | (when (funcall predicate object2 object1) 66 | (push node1 (node-edges node2))))) 67 | ;; Topologically sort nodes and extract objects. 68 | (mapcar #'node-object (topological-sort nodes)))) 69 | -------------------------------------------------------------------------------- /src/version/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for the version module. 2 | ;;;; 3 | ;;;; Copyright (C) 2014, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.version 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:split-sequence 12 | #:iterate 13 | #:let-plus) 14 | 15 | ;; Versions 16 | (:export 17 | #:parse-version 18 | #:print-version 19 | #:version= 20 | #:version< 21 | #:version>= 22 | #:version-matches) 23 | 24 | (:documentation 25 | "This package contains version-related functions.")) 26 | -------------------------------------------------------------------------------- /src/version/version.lisp: -------------------------------------------------------------------------------- 1 | ;;;; version.lisp --- Simple version model. 2 | ;;;; 3 | ;;;; Copyright (C) 2013, 2014, 2017, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.version) 8 | 9 | (defun parse-version (string) 10 | "Example: 11 | 12 | (parse-version \"0.9-ALPHA\")" 13 | (mapcar (lambda (component) 14 | (let+ (((&values number consumed) 15 | (parse-integer component :junk-allowed t))) 16 | (if (length= consumed component) 17 | number 18 | component))) 19 | (split-sequence-if (rcurry #'member '(#\- #\.)) string 20 | :remove-empty-subseqs t))) 21 | 22 | (defun print-version (stream version &optional colon? at?) 23 | "Example: 24 | 25 | (format nil \"~/build-generator.analysis:print-version/\" 26 | '(9 2 3 \"APLPHA\"))" 27 | (declare (ignore colon? at?)) 28 | (iter (for component in version) 29 | (unless (first-iteration-p) 30 | (write-char (etypecase component 31 | (real #\.) 32 | (string #\-)) 33 | stream)) 34 | (princ component stream))) 35 | 36 | (defun version-component-< (left right) 37 | (let+ (((&flet ensure-string (thing) 38 | (etypecase thing 39 | (real (princ-to-string thing)) 40 | (string thing))))) 41 | (cond 42 | ((and (realp left) (realp right)) 43 | (< left right)) 44 | (t 45 | (string< (ensure-string left) (ensure-string right)))))) 46 | 47 | (defun version= (left right) 48 | (equal left right)) 49 | 50 | (defun version< (left right) 51 | "Example: 52 | 53 | (version< '(\"0\" \"8\" \"alpha\") '(\"0\" \"7\" \"beta\"))" 54 | (let+ (((&labels+ rec ((&optional left &rest rest-left) 55 | (&optional right &rest rest-right)) 56 | (cond 57 | ((null left) 58 | (typecase right 59 | (string 60 | (rec (list* "" rest-left) (list* right rest-right))) 61 | (real 62 | (rec (list* 0 rest-left) (list* right rest-right))))) 63 | ((null right) 64 | (typecase left 65 | (string 66 | (rec (list* left rest-left) (list* "" rest-right))) 67 | (real 68 | (rec (list* left rest-left) (list* 0 rest-right))))) 69 | ((version-component-< left right) t) 70 | ((equal left right) (rec rest-left rest-right)))))) 71 | (rec left right))) 72 | 73 | (defun version>= (left right) 74 | (not (version< left right))) 75 | 76 | (defun version-matches (query version) 77 | "Example: 78 | 79 | (version-matches '(0 8 \"ALPHA\") '(0 8 1))" 80 | (not (version< version query))) 81 | -------------------------------------------------------------------------------- /test/commandline-interface/value-types.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:build-generator.commandline-interface.test) 2 | 3 | (esrap:parse 'multi "dependency-error=>abort:object-error=>abort:instantiation-error=>abort:abort") 4 | 5 | (configuration.options:raw->value-using-type 6 | nil 7 | "object-error=>abort:instantiation-error=>abort:abort" 8 | 'error-policy) 9 | 10 | (configuration.options:raw->value-using-type 11 | nil 12 | "abort" 13 | 'error-policy) 14 | 15 | (configuration.options:value->string-using-type 16 | nil 17 | '((error . :fail) (t . :abort)) 18 | 'error-policy) 19 | 20 | (configuration.options:value->string-using-type 21 | nil 22 | '((caused-by-unfulfilled-project-dependency-error . :fail) (t . :abort)) 23 | 'error-policy) 24 | -------------------------------------------------------------------------------- /test/model/aspects/test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:build-generator.model.aspects.test) 2 | 3 | ;; `make-remove-directory-contents/unix' smoke test 4 | 5 | (assert 6 | (string= (make-remove-directory-contents/unix) 7 | "find . -mindepth 1 -maxdepth 1 -exec rm -rf {} \\;")) 8 | (assert 9 | (string= (make-remove-directory-contents/unix :exclude "foo") 10 | "find . -mindepth 1 -maxdepth 1 -not -name \"foo\" -exec rm -rf {} \\;")) 11 | (assert 12 | (string= (make-remove-directory-contents/unix :exclude '("b\"ar" "foo")) 13 | "find . -mindepth 1 -maxdepth 1 -not \\( -name \"b\\\"ar\" -o -name \"foo\" \\) -exec rm -rf {} \\;")) 14 | 15 | ;; `wrap-shell-command' smoke test 16 | 17 | (flet ((test-case (expected command pre post) 18 | (let ((actual (with-output-to-string (stream) 19 | (wrap-shell-command stream "foo" nil nil)))) 20 | (assert (string= expected actual))))) 21 | (test-case "foo" "foo" nil nil) 22 | (test-case "foobaz" "foo" nil "baz") 23 | (test-case "barfoo" "foo" "bar" nil) 24 | (test-case "barfoobaz" "foo" "bar" "baz") 25 | 26 | (test-case (format nil "#!/bin/sh~%foo") 27 | (format nil "#!/bin/sh~%foo") nil nil) 28 | (test-case (format nil "#!/bin/sh~%foobaz") 29 | (format nil "#!/bin/sh~%foo") nil "baz") 30 | (test-case (format nil "#!/bin/sh~%barfoo") 31 | (format nil "#!/bin/sh~%foo") "bar" nil) 32 | (test-case (format nil "#!/bin/sh~%barfoobaz") 33 | (format nil "#!/bin/sh~%foo") "bar" "baz")) 34 | 35 | ;; `parse-constraint' smoke test 36 | 37 | (mapc (lambda+ ((json expected)) 38 | (assert (equal expected (parse-constraint 39 | (json:decode-json-from-string json))))) 40 | '(("[ \"before\", \"\" ]" (:before t t)) 41 | ("[ \"before\", \"foo\" ]" (:before foo t)) 42 | ("[ \"before\", { \"type\": \"foo\" } ]" (:before foo t)) 43 | ("[ \"before\", { \"type\": \"\" } ]" (:before t t)) 44 | ("[ \"before\", { \"name\": \"bar\" } ]" (:before t "bar")) 45 | ("[ \"before\", { \"name\": \"\" } ]" (:before t t)) 46 | ("[ \"before\", { \"type\": \"fez\", \"name\": \"baz\" } ]" (:before fez "baz")))) 47 | 48 | ;; `builder<' smoke test 49 | 50 | (let+ (((&flet check-case (spec-a spec-b &optional no-relation?) 51 | (log:info spec-a spec-b) 52 | (let* ((*step-constraints* '()) 53 | (constraints (constraints-table 'build))) 54 | (setf (gethash :a constraints) spec-a 55 | (gethash :b constraints) spec-b) 56 | (if no-relation? 57 | (assert (not (step< :a :b constraints))) 58 | (assert (step< :a :b constraints))) 59 | (assert (not (step< :b :a constraints))))))) 60 | 61 | (check-case '(aspect-a "name-a" ((:before t))) 62 | '(aspect-b "name-b" ())) 63 | (check-case '(aspect-a "name-a" ((:before t))) 64 | '(aspect-b "name-b" ((:before t))) 65 | t) 66 | (check-case '(aspect-a "name-a" ((:before aspect-b))) 67 | '(aspect-b "name-b" ())) 68 | (check-case '(aspect-a "name-a" ((:before aspect-b))) 69 | '(aspect-b "name-b" ((:before t)))) 70 | (check-case '(aspect-a "name-a" ((:before aspect-b "name-b"))) 71 | '(aspect-b "name-b" ((:before aspect-a))))) 72 | -------------------------------------------------------------------------------- /test/model/project/concrete-syntax/builder.lisp: -------------------------------------------------------------------------------- 1 | ;;;; builder.lisp --- Unit tests for the concrete syntax builder. 2 | ;;;; 3 | ;;;; Copyright (C) 2019, 2020 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.project.test) 8 | 9 | (in-suite :build-generator.model.project.concrete-syntax) 10 | 11 | (test expand-pathname.smoke 12 | "Smoke test for the `expand-pathname' function." 13 | 14 | (mapc 15 | (lambda+ ((base-path root-path pathname expected)) 16 | (let* ((builder (make-instance 'build-generator.model.project::recipe-builder 17 | :base-path base-path :root-path root-path)) 18 | (result (build-generator.model.project::expand-pathname 19 | builder pathname))) 20 | (is (equalp expected result)))) 21 | '((#P"/directory/name.type" #P"/root/" "foo" #P"/directory/foo") 22 | (#P"/directory/name.type" #P"/root/" "foo.bar" #P"/directory/foo.bar") 23 | (#P"/directory/name.type" #P"/root/" "sub/foo" #P"/directory/sub/foo") 24 | (#P"/directory/name.type" #P"/root/" "sub/foo.bar" #P"/directory/sub/foo.bar") 25 | 26 | (#P"/directory/name.type" #P"/root/" "/foo" #P"/foo") 27 | (#P"/directory/name.type" #P"/root/" "/foo.bar" #P"/foo.bar") 28 | (#P"/directory/name.type" #P"/root/" "/sub/foo" #P"/sub/foo") 29 | (#P"/directory/name.type" #P"/root/" "/sub/foo.bar" #P"/sub/foo.bar") 30 | 31 | (#P"/directory/name.type" #P"/root/" "//foo" #P"/root/foo") 32 | (#P"/directory/name.type" #P"/root/" "//foo.bar" #P"/root/foo.bar") 33 | (#P"/directory/name.type" #P"/root/" "//sub/foo" #P"/root/sub/foo") 34 | (#P"/directory/name.type" #P"/root/" "//sub/foo.bar" #P"/root/sub/foo.bar") 35 | 36 | (#P"/directory/name" #P"/root/" "foo" #P"/directory/foo") 37 | (#P"/directory/name" #P"/root/" "foo.bar" #P"/directory/foo.bar") 38 | (#P"/directory/name" #P"/root/" "sub/foo" #P"/directory/sub/foo") 39 | (#P"/directory/name" #P"/root/" "sub/foo.bar" #P"/directory/sub/foo.bar") 40 | 41 | (#P"/directory/name" #P"/root/" "/foo" #P"/foo") 42 | (#P"/directory/name" #P"/root/" "/foo.bar" #P"/foo.bar") 43 | (#P"/directory/name" #P"/root/" "/sub/foo" #P"/sub/foo") 44 | (#P"/directory/name" #P"/root/" "/sub/foo.bar" #P"/sub/foo.bar") 45 | 46 | (#P"/directory/name" #P"/root/" "//foo" #P"/root/foo") 47 | (#P"/directory/name" #P"/root/" "//foo.bar" #P"/root/foo.bar") 48 | (#P"/directory/name" #P"/root/" "//sub/foo" #P"/root/sub/foo") 49 | (#P"/directory/name" #P"/root/" "//sub/foo.bar" #P"/root/sub/foo.bar")))) 50 | 51 | (test protect-string.smoke 52 | "Smoke test for the `protect-string' function." 53 | 54 | (let ((raw "${foo} \\${bar} \\baz $fez \\\\")) 55 | (is (equal raw (build-generator.model.variables:value-parse 56 | (build-generator.model.project::protect-string raw)))))) 57 | -------------------------------------------------------------------------------- /test/model/project/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package definition for unit tests of the model.project module. 2 | ;;;; 3 | ;;;; Copyright (C) 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.model.project.test 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | 13 | #:fiveam 14 | 15 | #:build-generator.model.project)) 16 | 17 | (cl:in-package #:build-generator.model.project.test) 18 | 19 | (def-suite :build-generator.model.project 20 | :in :build-generator 21 | :description 22 | "Unit tests for the model.project module.") 23 | 24 | (def-suite :build-generator.model.project.concrete-syntax 25 | :in :build-generator.model.project) 26 | -------------------------------------------------------------------------------- /test/model/variables/evaluation.lisp: -------------------------------------------------------------------------------- 1 | ;;;; evaluation.lisp --- Unit tests for variable evaluation. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables.test) 8 | 9 | (in-suite :build-generator.model.variables) 10 | 11 | ;;; Merge functions 12 | 13 | (test merge-lookup-results.smoke 14 | "Smoke test for the `merge-lookup-results' function." 15 | 16 | (mapc 17 | (lambda+ ((left right expected)) 18 | (is (equal expected (merge-lookup-results left right)))) 19 | '(((nil () nil) 20 | (nil () nil) 21 | (nil () nil)) 22 | 23 | (((:a . 1) ((:a . 2) (:a . 3)) t) 24 | (nil () nil) 25 | ((:a . 1) ((:a . 2) (:a . 3)) t)) 26 | 27 | ((nil () nil) 28 | ((:a . 4) ((:a . 5) (:a . 6)) t) 29 | ((:a . 4) ((:a . 5) (:a . 6)) t)) 30 | 31 | (((:a . 1) ((:a . 2) (:a . 3)) t) 32 | ((:a . 4) ((:a . 5) (:a . 6)) t) 33 | ((:a . 1) ((:a . 2) (:a . 3) (:a . 4) (:a . 5) (:a . 6)) t))))) 34 | 35 | 36 | (test merge-lookup-values.smoke 37 | "Smoke test for the `merge-lookup-values' function." 38 | 39 | (is (equal (values nil () nil) 40 | (merge-lookup-values nil '() nil nil '() nil))) 41 | 42 | (is (equal (values '(:a . 1) 43 | '((:a . 2) (:a . 3) (:a . 4) (:a . 5) (:a . 6)) 44 | t) 45 | (merge-lookup-values '(:a . 1) '((:a . 2) (:a . 3)) t 46 | '(:a . 4) '((:a . 5) (:a . 6)) t)))) 47 | 48 | (test merge-alists.smoke 49 | "Smoke test for the `merge-alists' function." 50 | 51 | (labels ((alist-tree-equal (left right) 52 | (and (eq (car left) (car right)) 53 | (typecase (cdr left) 54 | ((cons cons) 55 | (set-equal (cdr left) (cdr right) :test #'alist-tree-equal)) 56 | (t 57 | (set-equal (cdr left) (cdr right)))))) 58 | (set-equal/alist-tree-equal (left right) 59 | (set-equal left right :test #'alist-tree-equal))) 60 | (is (set-equal/alist-tree-equal 61 | '((:a . (1 2 5 6)) 62 | (:b . (3 4)) 63 | (:c . ((:d . (7 8)) 64 | (:e . (9 10 11))))) 65 | (merge-alists '((:a . (1 2)) 66 | (:c . ((:d . (7 8)) (:e . (9 10))))) 67 | '((:b . (3 4)) 68 | (:a . (5 6)) 69 | (:c . ((:e . (9 11)))))))))) 70 | 71 | ;;; Casts 72 | 73 | (test as.smoke 74 | "Smoke test for the `as' generic function." 75 | 76 | (is (equal :system (as "system" '(or (eql :system) (eql :normal) string)))) 77 | (is (equal :normal (as "normal" '(or (eql :system) (eql :normal) string)))) 78 | (is (equal "foo" (as "foo" '(or (eql :system) (eql :normal) string))))) 79 | -------------------------------------------------------------------------------- /test/model/variables/grammar.lisp: -------------------------------------------------------------------------------- 1 | ;;;; grammar.lisp --- Unit tests for the variable grammar. 2 | ;;;; 3 | ;;;; Copyright (C) 2012-2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables.test) 8 | 9 | (in-suite :build-generator.model.variables) 10 | 11 | (test parse.smoke 12 | "Smoke test for parsing expressions of the variable language." 13 | 14 | (mapc 15 | (lambda+ ((input expected)) 16 | (flet ((do-it () 17 | (esrap:parse 'build-generator.model.variables::expr input))) 18 | (case expected 19 | (error (signals esrap:esrap-parse-error (do-it))) 20 | (t (is (equal expected (do-it))))))) 21 | 22 | '(("" nil) 23 | ("foo" ("foo")) 24 | ("foo$bar" ("foo$bar")) 25 | ("foo{bar" ("foo{bar")) 26 | ("foo}bar" ("foo}bar")) 27 | ("foo\\${" ("foo${")) 28 | ("foo\\@{" ("foo@{")) 29 | 30 | ("${a" error) 31 | ("${a}" ((:ref ("a")))) 32 | ("${a|}" ((:ref ("a") :default nil))) 33 | ("${a|b}" ((:ref ("a") :default "b"))) 34 | ("${a|{b}}" ((:ref ("a") :default "{b") "}")) 35 | ("${a|${b}}" ((:ref ("a") :default (:ref ("b"))))) 36 | ("${${a}}" ((:ref ((:ref ("a")))))) 37 | 38 | ("@{a" error) 39 | ("@{a}" ((:ref/list ("a")))) 40 | ("@{a|}" ((:ref/list ("a") :default nil))) 41 | ("@{a|b}" ((:ref/list ("a") :default "b"))) 42 | ("@{a|{b}}" ((:ref/list ("a") :default "{b") "}")) 43 | ("@{a|${b}}" ((:ref/list ("a") :default (:ref ("b"))))) 44 | ("@{a|a${b}}" ((:ref/list ("a") :default ("a" (:ref ("b")))))) 45 | ("@{@{a}}" ((:ref/list ((:ref/list ("a")))))) 46 | 47 | ("foo${a}" ("foo" (:ref ("a"))))))) 48 | -------------------------------------------------------------------------------- /test/model/variables/model.lisp: -------------------------------------------------------------------------------- 1 | ;;;; model.lisp --- Unit tests for variable evaluation. 2 | ;;;; 3 | ;;;; Copyright (C) 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:in-package #:build-generator.model.variables.test) 8 | 9 | (in-suite :build-generator.model.variables) 10 | 11 | (test value-unparse.smoke 12 | "Smoke test for the `value-unparse' function." 13 | 14 | (mapc (lambda+ ((parsed expected)) 15 | (is (equalp expected (value-unparse parsed)))) 16 | 17 | `((,(value-parse #1=t) #1#) 18 | (,(value-parse #2=nil) #2#) 19 | (,(value-parse #3=1) #3#) 20 | 21 | (,(value-parse #4="foo") #4#) 22 | (,(value-parse #5="foo\\${foo}") #5#) 23 | 24 | (,(value-parse #6="${bar}") #6#) 25 | (,(value-parse #7="${bar|default}") #7#) 26 | (,(value-parse #8="@{bar}") #8#) 27 | (,(value-parse #9="@{bar|default}") #9#) 28 | 29 | (,(value-parse '#10=(1 "foo" "@{bar|default}")) #10#) 30 | 31 | (,(value-parse '#11=((:foo . 1) (:bar "@{bar|default}"))) #11#)))) 32 | -------------------------------------------------------------------------------- /test/model/variables/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package for tests of the model.variables module. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.model.variables.test 8 | (:use 9 | #:cl 10 | #:alexandria 11 | #:let-plus 12 | 13 | #:fiveam 14 | 15 | #:build-generator.model.variables) 16 | 17 | (:import-from #:build-generator.model.variables 18 | #:merge-alists)) 19 | 20 | (cl:in-package #:build-generator.model.variables.test) 21 | 22 | (def-suite :build-generator.model.variables 23 | :in :build-generator) 24 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp --- Package for tests of the build-generator system. 2 | ;;;; 3 | ;;;; Copyright (C) 2018, 2019 Jan Moringen 4 | ;;;; 5 | ;;;; Author: Jan Moringen 6 | 7 | (cl:defpackage #:build-generator.test 8 | (:use 9 | #:cl 10 | 11 | #:fiveam) 12 | 13 | (:export 14 | #:run-tests)) 15 | 16 | (cl:in-package #:build-generator.test) 17 | 18 | (def-suite :build-generator) 19 | 20 | (defun run-tests () 21 | (run! :build-generator)) 22 | -------------------------------------------------------------------------------- /test/project/grammar.lisp: -------------------------------------------------------------------------------- 1 | (parse "${toolkit.volume}/${toolkit.version}/\\${NODE_ARCHITECTURE}") 2 | -------------------------------------------------------------------------------- /test/project/variables.lisp: -------------------------------------------------------------------------------- 1 | (progn 2 | (parse "a@{b}c") 3 | (expand (parse "a${VAR:BVAR:B}c") 4 | (lambda (x) 5 | (optima:ematch x 6 | (:b "var:b") 7 | (:|VAR:BVAR:B| (list "d" "e"))))) 8 | 9 | (expand (parse "a@{${b}${b}}c") 10 | (lambda (x) 11 | (optima:ematch x 12 | (:b "var:b") 13 | (:|VAR:BVAR:B| (list "d" "e"))))) 14 | 15 | (expand (parse (list "a" "${${b}${b}}" "c")) 16 | (lambda (x) 17 | (optima:ematch x 18 | (:b "var:b") 19 | (:|VAR:BVAR:B| (list (list "d" "e") (list "e" "f")))))) 20 | 21 | (expand (parse (list "a" "@{${b}${b}}" "c")) 22 | (lambda (x) 23 | (optima:ematch x 24 | (:b "var:b") 25 | (:|VAR:BVAR:B| (list (list "d" "e") (list "e" "f")))))) 26 | 27 | (expand (parse (list "a" "${${b}${b}}" "c")) 28 | (lambda (x) 29 | (optima:ematch x 30 | (:b "var:b") 31 | (:|VAR:BVAR:B| (list "d" "e")))))) 32 | 33 | #+no (let ((a (make-instance 'version-spec 34 | :name "bla" 35 | :variables '(:a1 ("foo" "${b2} ${b2}" "bar") 36 | :a2 "<@{b2}>" 37 | :a3 "${a2}" 38 | :b1 "${c}" 39 | :b2 "@{c}" 40 | :b3 ("foo" "@{c}" "bar") 41 | :c ("a" "b"))))) 42 | (values-list (mapcar (lambda (x) 43 | (expand (parse (format nil "${~A}" x)) 44 | (lambda (y) (lookup a y)))) 45 | '(:a1 :a2 :a3 :b1 :b2 :b3 :c)))) 46 | 47 | #+test (let ((a (make-instance 'version-spec 48 | :name "bla" 49 | :variables '(:a1 ("foo" "${b2} ${b2}" "bar") 50 | :a2 "<@{b2}>" 51 | :a3 "${a2}" 52 | :b1 "${c}" 53 | :b2 "@{c}" 54 | :b3 ("foo" "@{c}" "bar") 55 | :c ("a" "b"))))) 56 | (values-list (mapcar (curry #'value a) '(:a1 :a2 :a3 :b1 :b2 :b3 :c)))) 57 | ;; exptected: 58 | ;; ("foo" "ab ab" "bar") 59 | ;; (("<" "a" ">") ("<" "b" ">")) 60 | ;; "" 61 | ;; "ab" 62 | ;; ("a" "b") 63 | ;; ("foo" ("a" "b") "bar") 64 | ;; ("a" "b") 65 | 66 | ;;; Newer Tests 67 | 68 | (defclass foo (direct-variables-mixin 69 | parented-mixin) 70 | ()) 71 | 72 | (let* ((distribution (make-instance 73 | 'foo 74 | :variables ())) 75 | (project (make-instance 76 | 'foo 77 | :parent distribution 78 | :variables (list :foo "${next-value|ABC}" 79 | :shell.command "echo ${foo} 80 | echo ${bar|XYZ} 81 | ")))) 82 | (value project :shell.command)) 83 | 84 | (let ((distribution (make-instance 85 | 'foo 86 | :variables (list :toolkit.dir "dir" 87 | :ros.install.prefix "${next-value|${toolkit.dir}}" 88 | :shell.command "foo ${ros.install.prefix}")))) 89 | (value distribution :shell.command)) 90 | -------------------------------------------------------------------------------- /tools-for-build/which-libssl-package.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload '(:cl+ssl :split-sequence :inferior-shell)) 2 | 3 | (defun libssl-pathname () 4 | (let ((libssl (find "libssl" (cffi:list-foreign-libraries) 5 | :key (alexandria:compose #'string-downcase #'cffi:foreign-library-name) 6 | :test #'search))) 7 | (cffi:foreign-library-pathname libssl))) 8 | 9 | (defun restrict-to-architecture (packages) 10 | (let ((architecture (inferior-shell:run '("dpkg" "--print-architecture") 11 | :output '(:string :stripped t)))) 12 | (remove architecture packages 13 | :key #'second :test-not #'string=))) 14 | 15 | (defun libssl-package () 16 | (let* ((pathname (libssl-pathname)) 17 | (lines (inferior-shell:run 18 | `("dpkg" "-S" ,(format nil "*/~A" pathname)) 19 | :output '(:lines :stripped t) :error-output *error-output*)) 20 | (parsed (mapcar (lambda (line) 21 | (split-sequence:split-sequence #\: line)) 22 | lines)) 23 | (matches (restrict-to-architecture parsed)) 24 | (package (first (first matches)))) 25 | (unless (alexandria:length= 1 matches) 26 | (warn "~@" 28 | pathname matches)) 29 | package)) 30 | -------------------------------------------------------------------------------- /version-string.sexp: -------------------------------------------------------------------------------- 1 | "0.36.0" 2 | --------------------------------------------------------------------------------