diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1120f7a --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +/config/config.lisp +/config/config.lisp.original diff --git a/DESIGN.md b/DESIGN.md index 5d25c53..22bb440 100644 --- a/DESIGN.md +++ b/DESIGN.md @@ -1,13 +1,13 @@ This is just a dumping ground about design of project. This should get updated at some point into a nice form, but for now it's just a list of things as I think of them. * Imports come from database. Don't use api to import information, except as reference. For instance, if the username from the api is different than in the database, figure out why and adjust. * Export go to api first, and then follow up with database edits. The API for any given system should set up objects correctly. Then, after initial, edit database directly. For instance, the user created date is probably set to `time.now()` when creating through the api, but we may want the user creation date to be set to what it was in the previous system. -* Each forge gets it's own component, and implements some top level generic methods. +* Each forge gets its own component, and implements some top level generic methods. diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..276487c --- /dev/null +++ b/Dockerfile @@ -0,0 +1,34 @@ +FROM debian:11 +RUN export DEBIAN_FRONTEND=noninteractive && \ + apt-get update && apt-get upgrade -y && \ + apt-get install -y \ + cl-quicklisp \ + default-libmysqlclient-dev \ + git \ + kubernetes-client \ + file + +RUN useradd -md /srv/forgerie -s /bin/bash forgerie +RUN mkdir -p /srv/phabricator /opt/forgerie /srv/forgerie/bin +COPY docker/.sbclrc /srv/forgerie/.sbclrc +COPY docker/.gitconfig /srv/forgerie/.gitconfig +COPY docker/entrypoint.sh /srv/forgerie/bin/entrypoint.sh +COPY docker/ssh /srv/forgerie/.ssh +RUN chown -R forgerie:forgerie /srv/forgerie /opt/forgerie + +USER forgerie +WORKDIR /srv/forgerie + +# install quicklisp and pulls core dependencies for it to run properly +RUN sbcl --no-sysinit --no-userinit --noprint \ + --load /usr/share/common-lisp/source/quicklisp/quicklisp.lisp \ + --eval '(quicklisp-quickstart:install :path "quicklisp")' \ + --quit # to install and configure quicklisp + +COPY . /opt/forgerie +ENV FORGERIE_PATH=/opt/forgerie/ + +# install quicklisp and pulls core dependencies for it to run properly +RUN sbcl --quit + +ENTRYPOINT [ "/srv/forgerie/bin/entrypoint.sh" ] diff --git a/README.md b/README.md index 693805a..53d80d7 100644 --- a/README.md +++ b/README.md @@ -1,46 +1,46 @@ # Forgerie Forgerie is an open source tool for converting software projects from one collaborative development forge to another (e.g., Phabricator -> GitLab). See the [DESIGN.md](DESIGN.md) for design decisions. # Install quicklisp Forgerie requires quicklisp on sbcl. Generally you can get sbcl through your distribution. Once installed, you then need to install quicklsip. Follow the installation instructions at [quicklisp.org](https://www.quicklisp.org/beta/) # Running ## Configure To configure: ``` -$ cp config/config.lisp.tmpl config/config.lisp +$ cp config/config.lisp.tmpl config/config.lisp $ $EDITOR config/config.lisp ``` A lot of these configuration options will lead you to need to take other actions, such as making sure the database for phabricator is local to the machine. You'll also need to ensure that keys are set up on various machines that will need to be sshed to. ## Run the script Run `bin/run` # Postmortem -After run, if `forgerie-core:*log-mapping-errors*` is turned out, running +After run, if `forgerie-core:*log-mapping-errors*` is turned on, running `bin/postmortem` will dump out a log of all the errors that happened during the run # Generating config.lisp.tmpl There's a helper script `bin/build-config-tmpl` to generate `config/config.lisp.tmpl` from inline documentation. diff --git a/bin/build-config-tmpl b/bin/build-config-tmpl index e821376..489204a 100755 --- a/bin/build-config-tmpl +++ b/bin/build-config-tmpl @@ -1,66 +1,73 @@ #!/usr/bin/env -S /usr/bin/sbcl --script (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))) (when (probe-file quicklisp-init) (load quicklisp-init))) +;; Make sure we can provide path to forgerie code... +(let ((forgerie-path (uiop:getenv "FORGERIE_PATH"))) + (when (and forgerie-path (probe-file forgerie-path)) + (push (pathname forgerie-path) asdf:*central-registry*))) + +;; so quicklisp is able to run the forgerie code and execute the script (ql:quickload :forgerie) (with-open-file (str "config/config.lisp.tmpl" :direction :output :if-exists :supersede) (format str -";;;; This template file is generated by bin/build-config-templ and should not be edited manuall. +";;;; This template file is generated by bin/build-config-templ and should not be edited manually. ;;;; ;;;; Install by copying to config.lisp~%~%") (mapcar (lambda (section) (format str ";;;;;;;;;;;;;;;;;;;~%;;; ~A~%;;;;;;;;;;;;;;;;;;;~%~%" (car section)) (mapcar (lambda (variable-def) (let ((variable-name (if (listp variable-def) (car variable-def) variable-def)) (default (if (listp variable-def) (cadr variable-def) "nil"))) - (format str + (format str "~{;~A~%~}(setf ~(~A~):~(~A~) ~A)~%~%" (mapcar (lambda (line) (if (< 0 (length line)) (cl-ppcre:regex-replace-all "^ ?" line " ") "")) (cl-ppcre:split "\\n" (documentation variable-name 'variable))) (package-name (symbol-package variable-name)) (symbol-name variable-name) default ))) (cdr section))) '(("system" (sb-impl::*default-external-format* ":UTF-8") (drakma:*drakma-default-external-format* "'UTF-8")) ("core" forgerie-core:*debug* forgerie-core:*log-mapping-errors* forgerie-core:*working-directory*) ("phabricator" forgerie-phabricator:*database-password* forgerie-phabricator:*database-username* forgerie-phabricator:*revisions-to-skip* forgerie-phabricator:*phabricator-location* forgerie-phabricator:*project-assignment-overrides* forgerie-phabricator:*repository-overrides* forgerie-phabricator:*pastes-to-skip* forgerie-phabricator:*user-overrides* forgerie-phabricator:*storage-location* forgerie-phabricator:*confidential-space-phids* forgerie-phabricator:*included-repositories* forgerie-phabricator:*staging-repository* forgerie-phabricator:*email-address-sanitizer*) ("gitlab" forgerie-gitlab:*private-token* forgerie-gitlab:*server-address* forgerie-gitlab:*default-project* forgerie-gitlab:*ssh-public-key* forgerie-gitlab:*default-group* - forgerie-gitlab:*rails-console-ssh-args* + forgerie-gitlab:*rails-command* + forgerie-gitlab:*rails-command-args* forgerie-gitlab:*merge-request-suffix* forgerie-gitlab:*ticket-suffix* forgerie-gitlab:*limit-to-active-users*)))) diff --git a/bin/postmortem b/bin/postmortem index c8e73f6..9290865 100755 --- a/bin/postmortem +++ b/bin/postmortem @@ -1,10 +1,15 @@ #!/usr/bin/env -S /usr/bin/sbcl --dynamic-space-size 4096 --script (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))) (when (probe-file quicklisp-init) (load quicklisp-init))) +;; Make sure we can provide path to forgerie code... +(let ((forgerie-path (uiop:getenv "FORGERIE_PATH"))) + (when (and forgerie-path (probe-file forgerie-path)) + (push (pathname forgerie-path) asdf:*central-registry*))) + (ql:quickload :forgerie) (forgerie-core:postmortem :phabricator :gitlab) diff --git a/bin/run b/bin/run index b01a485..128866c 100755 --- a/bin/run +++ b/bin/run @@ -1,10 +1,16 @@ #!/usr/bin/env -S /usr/bin/sbcl --dynamic-space-size 4096 --script + (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))) (when (probe-file quicklisp-init) (load quicklisp-init))) +;; Make sure we can provide path to forgerie code... +(let ((forgerie-path (uiop:getenv "FORGERIE_PATH"))) + (when (and forgerie-path (probe-file forgerie-path)) + (push (pathname forgerie-path) asdf:*central-registry*))) + (ql:quickload :forgerie) (forgerie-core:run :phabricator :gitlab) diff --git a/config/config.lisp.tmpl b/config/config.lisp.tmpl index f46102f..2f350d7 100644 --- a/config/config.lisp.tmpl +++ b/config/config.lisp.tmpl @@ -1,172 +1,182 @@ -;;;; This template file is generated by bin/build-config-templ and should not be edited manuall. +;;;; This template file is generated by bin/build-config-templ and should not be edited manually. ;;;; ;;;; Install by copying to config.lisp ;;;;;;;;;;;;;;;;;;; ;;; system ;;;;;;;;;;;;;;;;;;; (setf sb-ext:*default-external-format* :UTF-8) ; The default value for the external format keyword arguments of ; HTTP-REQUEST. The value of this variable will be interpreted by ; FLEXI-STREAMS. The initial value is the keyword :LATIN-1. ; (Note that Drakma binds *DEFAULT-EOL-STYLE* to :LF). (setf drakma:*drakma-default-external-format* 'UTF-8) ;;;;;;;;;;;;;;;;;;; ;;; core ;;;;;;;;;;;;;;;;;;; ; Set to T to enable output of trace level messaging, such ; as http requests, git commands, and database queries (setf forgerie-core:*debug* nil) ; Boolean which indicates whether mapping errors should be logged. Defaults ; to T to create a mapping errors file that can be later used to output ; what errors the run ran into. (setf forgerie-core:*log-mapping-errors* nil) ; The working directory for the run. Core files will be put into ; 'core' underneath this, and then each forgerie will base on this. (setf forgerie-core:*working-directory* nil) ;;;;;;;;;;;;;;;;;;; ;;; phabricator ;;;;;;;;;;;;;;;;;;; ; Password to access the mysql database. If NIL, will not enter password (setf forgerie-phabricator:*database-password* nil) ; Username to access the database. If NIL, will use the current user (setf forgerie-phabricator:*database-username* nil) ; List of revisions to skip. For instance, if they cause errors due to weird git ; history. They need to be handled manually. The list is of database ids. (setf forgerie-phabricator:*revisions-to-skip* nil) ; The HTTP location of the phabricator instance. This is only used for ; differentials that cannot be understood via the database. The raw diffs ; for these are pulled from the instance, and so they need to be accessible ; from the script. (setf forgerie-phabricator:*phabricator-location* nil) ; A list of plists of override commands for projects. Each item in the list is of the form ; '(:key KEY :repository SLUG) ; ; Where the KEY is the database id of the project, and the SLUG is which repository that this ; project should be a primary project of. Then the project will be removed from all other ; repositories it mgiht be assigned to. The ramification of this is that tasks that are ; part of this project, for instance, will be assigned to the repository in various forgeries ; that link project and repository. (setf forgerie-phabricator:*project-assignment-overrides* nil) ; A list of plists for overriding certain features of projects. The plists are of the form ; '(:key KEY :action ACTION) ; ; Where KEY is the id of the database. ACTION can be either :skip or :update. ; - :skip, the repository will be skipped (useful for things like the staging repository) ; - :update, will be require a further item :DATA which is a plist of overrides corresponding ; to database fields for the repository table. Useful when renaming items, or specifying ; slugs. (setf forgerie-phabricator:*repository-overrides* nil) ; Pastes that can't be migrated, and will need to be handled manually. This is a list of ; database ids. They need to be handled manually. (setf forgerie-phabricator:*pastes-to-skip* nil) ; A list of plists for overriding certain features of users. The plists are of the form ; '(:key KEY :action ACTION) ; ; Where KEY is the id of the database. ACTION can be only :update. ; - :update, will be require a further item :DATA which is a plist of overrides corresponding ; to database fields for the user table. Useful when renaming user names, or specifying ; other aspects of the user. (setf forgerie-phabricator:*user-overrides* nil) ; The path on the local file system for the local storage of files. The phabricator_file ; database can refer to local storage items, which are stored here (other options being ; that the file is stored in the database). (setf forgerie-phabricator:*storage-location* nil) ; List of spaces that should be marked as confidential on the export. (setf forgerie-phabricator:*confidential-space-phids* nil) ; When doing only a partial import, use to list which slugs to be imported. ; ; This means that any tasks will be not mappable to a repository, and may end up in the ; default project of the exporter, so when using this, you'll want to disable that feature ; in the exporter of choice (setf forgerie-phabricator:*included-repositories* nil) ; PHID of the staging repository, if used. If NIL, commits for differentials will ; not be extracted from staging. Used if set up with arcanist. (setf forgerie-phabricator:*staging-repository* nil) ; A function that takes a string representing an email address, and then returns ; one that should be used in its place. Used in testing mode to ensure that ; users aren't getting random emails from the export forgerie, as an extra precaution. (setf forgerie-phabricator:*email-address-sanitizer* nil) ;;;;;;;;;;;;;;;;;;; ;;; gitlab ;;;;;;;;;;;;;;;;;;; ; The private token with which to access the gitlab instance. Needs to be ; set up either from within gitlab, or via a script that uses the rails console ; directory (setf forgerie-gitlab:*private-token* nil) ; The fully qualitifed server address for the gitlab instance, including the scheme to ; use, e.g. https://gitlab.yourdomain.tld (setf forgerie-gitlab:*server-address* nil) ; A plist of the form '(:name NAME :slug SLUG) for the default project ; in which things like snippets, tickets that can't be assigned to a project, ; and other misc items go. NAME is the proper name of the project, with ; SLUG being the url slug to access it. (setf forgerie-gitlab:*default-project* nil) ; The public key that should be installed for the running user so that git commands ; work correctly. (setf forgerie-gitlab:*ssh-public-key* nil) ; A plist of the form '(:name NAME :path SLUG) that defines the group in which ; all created projects will be placed. NAME is the proper name for the group, ; while SLUG is the url slug. If NIL, the projects will all be created at the ; top level. (setf forgerie-gitlab:*default-group* nil) -; A tuple of the form '(HOST COMMAND) that informs the gitlab forgerie -; how to run rails commands over ssh. It will always use SSH, even if -; set up to run on localhost, so keys must be installed to ssh to localhost. +; The rails command to execute, by default this uses ssh. But one could use kubectl or +; docker instead. +(setf forgerie-gitlab:*rails-command* nil) + +; By default, using ssh, a tuple of the form '(HOST COMMAND) that informs the gitlab +; forgerie how to run rails commands over ssh. It will always use SSH, even if set up to +; run on localhost, so keys must be installed to ssh to localhost. When overriden to +; another command like kubectl, a list '(COMMAND) for the necessary extra args that the +; command requires to run. ; -; An example for a server using docker might be: +; When using ssh, an example for a server using docker might be: ; ; '("ssh.gitlab.yourdomain.tld" "docker exec -i gitlab /opt/gitlab/bin/gitlab-rails c") ; -; A useful thing to do is to run ssh on the server for non git purposes on port 2222, and then -; set up your .ssh/config to have the following: +; A useful thing to do is to run ssh on the server for non git purposes on port 2222, and +; then set up your .ssh/config to have the following: ; ; Host ssh.gitlab.yourdomain.tld ; User ; Port 2222 ; IdentityFile ~/.ssh/your_identity_file -(setf forgerie-gitlab:*rails-console-ssh-args* nil) +; +; When using kube, an example might be: +; +; '("exec -ti -n gitlab-system deployment/gitlab-toolbox -- /srv/gitlab/bin/rails console") +(setf forgerie-gitlab:*rails-command-args* nil) ; A function that takes an argument of a forgerie-core:merge-request and ; returns a string that will be appended to the description of created merge requests. ; ; Useful to create backlinks to the previous system, or addition migration information (setf forgerie-gitlab:*merge-request-suffix* nil) ; A function that takes an argument of a forgerie-core:ticket and ; returns a string that will be appended to the description of created tickets (issues). ; ; Useful to create backlinks to the previous system, or addition migration information (setf forgerie-gitlab:*ticket-suffix* nil) ; If non nil, will only add users to the gitlab instance if they are active in the ; items also coming over for processing. Useful when doing piecemeal conversions. (setf forgerie-gitlab:*limit-to-active-users* nil) diff --git a/docker/.gitconfig b/docker/.gitconfig new file mode 100644 index 0000000..3376be8 --- /dev/null +++ b/docker/.gitconfig @@ -0,0 +1,3 @@ +[user] + email = noreply@softwareheritage.org + name = Gitlab migration diff --git a/docker/.gitignore b/docker/.gitignore new file mode 100644 index 0000000..28581d6 --- /dev/null +++ b/docker/.gitignore @@ -0,0 +1 @@ +/ssh/id_ed25519* diff --git a/docker/.sbclrc b/docker/.sbclrc new file mode 100644 index 0000000..061341b --- /dev/null +++ b/docker/.sbclrc @@ -0,0 +1,12 @@ +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +;; Make sure we can provide path to forgerie code... +(let ((forgerie-path (uiop:getenv "FORGERIE_PATH"))) + (when (and forgerie-path (probe-file forgerie-path)) + (push (pathname forgerie-path) asdf:*central-registry*))) + +;; so quicklisp is able to run the forgerie code and execute the script +(ql:quickload :forgerie) diff --git a/docker/README.md b/docker/README.md new file mode 100644 index 0000000..562e5d5 --- /dev/null +++ b/docker/README.md @@ -0,0 +1,57 @@ +# Build + +``` +$ name=forgerie +$ docker build -t $name . +``` + +# Run script(s) + +Edit /docker/config.lisp according to your runtime requirements, then run: +``` +$ cd forgerie +$ docker run \ + -v $PWD/../forgerie:/opt/forgerie/ \ + -v $PWD/docker/ssh:/srv/forgerie/.ssh \ + -v /srv/phabricator:/srv/phabricator \ + -v ~/.kube:/srv/forgerie/.kube \ + -v /var/tmp/migrate-gitlab/forgerie:/tmp/forgerie \ + --ulimit nofile=1024 \ + --name forgerie --net=host -it forgerie +``` + +# postmortem + +After a crash, connect to the container with `docker exec` and execute +`/opt/forgerie/bin/postmortem`. + +# ssh configuration + +An ssh key pair is required for git commands to push repositories to migrate to the +gitlab instance. So first generate the keypair, then report such configuration in the +forgerie `config.lisp` (to make the migration script aware of it). + +## Key generation + +From your machine from the top-level of this repository: +``` +ssh-keygen -t ed25519 -f ./docker/ssh/id_ed25519 -N "" +``` + +or from the container: +``` +ssh-keygen -t ed25519 -f ~/.ssh/id_ed25519 -N "" +``` + + +## config.lisp + +We need the key to be loaded by the routine, so edit the `config.lisp` (copied out of +the template `config.lisp.tmpl`) with the following: + +``` +(with-open-file (file #P"/srv/forgerie/.ssh/id_ed25519.pub" :if-does-not-exist nil) + (when file + (setf forgerie-gitlab:*ssh-public-key* (read-line file nil nil)))) +``` +Note: `~` is `/srv/forgerie` in the docker context diff --git a/docker/entrypoint.sh b/docker/entrypoint.sh new file mode 100755 index 0000000..83bdc74 --- /dev/null +++ b/docker/entrypoint.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +logpath="/tmp/forgerie/run-$(date +%Y%m%d-%H%M).log"; +echo "## Running migration logs in $logpath ##"; + +time /opt/forgerie/bin/run | tee $logpath diff --git a/docker/ssh/config b/docker/ssh/config new file mode 100644 index 0000000..fed5492 --- /dev/null +++ b/docker/ssh/config @@ -0,0 +1,6 @@ +Host gitlab-staging.swh.network + User git + IdentitiesOnly yes + IdentityFile ~/.ssh/id_ed25519 + StrictHostKeyChecking no + UserKnownHostsFile=/dev/null diff --git a/forgerie.asd b/forgerie.asd index b686471..cc0ad83 100644 --- a/forgerie.asd +++ b/forgerie.asd @@ -1,40 +1,40 @@ (asdf:defsystem forgerie :description "Adapter between different software forges" :version "0.1" :maintainer "Open Tech Strategies" :author "Open Tech Strategies" :serial t :components ((:module "src/main" :components ((:module "core" :components ((:file "package") (:file "base") (:file "user") (:file "project") (:file "vc-repository") (:file "ticket") (:file "merge-request") (:file "snippet") (:file "utils") (:file "errors") (:file "run") (:file "postmortem"))) (:module "phabricator" :components ((:file "package") (:file "utils") (:file "base") (:file "import") (:file "postmortem"))) (:module "gitlab" :components ((:file "package") (:file "utils") (:file "base") (:file "export") (:file "postmortem"))))) (:module "config" :components ((:file "config")))) - :depends-on (:cl-mysql :drakma :jsown :cl-ppcre :cl-csv :cl-fad :ironclad)) + :depends-on (:cl-mysql :uiop :dexador :quri :jsown :cl-ppcre :cl-csv :cl-fad :ironclad)) diff --git a/src/main/gitlab/base.lisp b/src/main/gitlab/base.lisp index b3409af..3ffe823 100644 --- a/src/main/gitlab/base.lisp +++ b/src/main/gitlab/base.lisp @@ -1,68 +1,79 @@ (in-package #:forgerie-gitlab) (defvar *server-address* nil "The fully qualitifed server address for the gitlab instance, including the scheme to use, e.g. https://gitlab.yourdomain.tld") (defvar *private-token* nil "The private token with which to access the gitlab instance. Needs to be set up either from within gitlab, or via a script that uses the rails console directory") (defvar *default-project* nil "A plist of the form '(:name NAME :slug SLUG :disable-tickets DISABLE) for the default project in which things like snippets, tickets that can't be assigned to a project, and other misc items go. NAME is the proper name of the project, with SLUG being the url slug to access it. If DISABLE is set to T, then tickets that can't be assigned to a project will not be assigned to this default project.") (defvar *ssh-public-key* nil "The public key that should be installed for the running user so that git commands work correctly.") (defvar *default-group* nil "A plist of the form '(:name NAME :path SLUG) that defines the group in which all created projects will be placed. NAME is the proper name for the group, while SLUG is the url slug. If NIL, the projects will all be created at the top level.") ; For development only. Will limit all exporting to things having ; to do with the project with the name provided. (defvar *single-project* nil) -; The args (host and command are normal) for the ssh command to -; boot the rails console. Sometimes this is localhost. Keys -; have to be set up. -(defvar *rails-console-ssh-args* nil - "A tuple of the form '(HOST COMMAND) that informs the gitlab forgerie - how to run rails commands over ssh. It will always use SSH, even if - set up to run on localhost, so keys must be installed to ssh to localhost. +; The default rails-command to execute the rails console. +(defvar *rails-command* "/usr/bin/ssh" + "The rails command to execute, by default this uses ssh. But one could use kubectl or +docker instead.") - An example for a server using docker might be: +; The required args for the *rails-command*. +(defvar *rails-command-args* nil + "By default, using ssh, a tuple of the form '(HOST COMMAND) that informs the gitlab + forgerie how to run rails commands over ssh. It will always use SSH, even if set up to + run on localhost, so keys must be installed to ssh to localhost. When overriden to + another command like kubectl, a list '(COMMAND) for the necessary extra args that the + command requires to run. + + When using ssh, an example for a server using docker might be: '(\"ssh.gitlab.yourdomain.tld\" \"docker exec -i gitlab /opt/gitlab/bin/gitlab-rails c\") - A useful thing to do is to run ssh on the server for non git purposes on port 2222, and then - set up your .ssh/config to have the following: + A useful thing to do is to run ssh on the server for non git purposes on port 2222, and + then set up your .ssh/config to have the following: Host ssh.gitlab.yourdomain.tld User Port 2222 - IdentityFile ~/.ssh/your_identity_file") + IdentityFile ~/.ssh/your_identity_file + + When using kube, an example might be: + + '(\"exec -ti -n gitlab-system deployment/gitlab-toolbox -- /srv/gitlab/bin/rails console\") + +") (defvar *merge-request-suffix* nil "A function that takes an argument of a forgerie-core:merge-request and returns a string that will be appended to the description of created merge requests. Useful to create backlinks to the previous system, or addition migration information") (defvar *ticket-suffix* nil "A function that takes an argument of a forgerie-core:ticket and returns a string that will be appended to the description of created tickets (issues). Useful to create backlinks to the previous system, or addition migration information") (defvar *limit-to-active-users* nil "If non nil, will only add users to the gitlab instance if they are active in the items also coming over for processing. Useful when doing piecemeal conversions.") diff --git a/src/main/gitlab/export.lisp b/src/main/gitlab/export.lisp index f6e182b..acc1871 100644 --- a/src/main/gitlab/export.lisp +++ b/src/main/gitlab/export.lisp @@ -1,800 +1,809 @@ (in-package #:forgerie-gitlab) (define-condition unknown-note-mapping nil ((mapping :initarg :mapping :reader unknown-note-mapping-mapping))) (defvar *note-mapping-skips* nil) (defvar *notes-mode* nil) (defvar *files-to-upload* nil) (defun validate-vc-repositories (vc-repositories projects) (let ((valid-projects (mapcar (lambda (proj) (let ((repos-for-proj (forgerie-core:vc-repositories-with-primary-project proj vc-repositories))) (cond ((< 1 (length repos-for-proj)) (forgerie-core:add-mapping-error :gitlab-project-primary-in-multiple (forgerie-core:project-name proj) (format nil "Project ~A is the primary project in multiple repositories, and those repositories won't be included:~%~{ * ~A~%~}" (forgerie-core:project-name proj) (mapcar #'forgerie-core:vc-repository-name repos-for-proj))) nil) (proj)))) projects))) (remove nil (mapcar (lambda (vcr) (cond ((cl-ppcre:scan "[,()/+]" (forgerie-core:vc-repository-name vcr)) (forgerie-core:add-mapping-error :gitlab-repository-has-illegal-name (forgerie-core:vc-repository-name vcr) (format nil "VC Repository '~A' has an illegal name due to an illegal character, one of: ',()/+'." (forgerie-core:vc-repository-name vcr)))) ((cl-ppcre:scan "^ " (forgerie-core:vc-repository-name vcr)) (forgerie-core:add-mapping-error :gitlab-repository-has-illegal-name (forgerie-core:vc-repository-name vcr) (format nil "VC Repository '~A' has an illegal name due to starting with a space." (forgerie-core:vc-repository-name vcr)))) ((not (forgerie-core:vc-repository-primary-projects vcr)) (forgerie-core:add-mapping-error :gitlab-repository-has-no-projects (forgerie-core:vc-repository-name vcr) (format nil "VC Repository '~A' has no primary projects.~%" (forgerie-core:vc-repository-name vcr))) vcr) ((not (remove-if-not (lambda (proj) (find proj valid-projects :test #'equalp)) (forgerie-core:vc-repository-primary-projects vcr))) nil) (vcr))) vc-repositories)))) (defun validate-user (user) (cond ((< (length (forgerie-core:user-username user)) 2) (forgerie-core:add-mapping-error :gitlab-username-too-short (forgerie-core:user-username user) (format nil "User '~A' (~{~A~^,~}) has too short of a username." (forgerie-core:user-username user) (mapcar #'forgerie-core:email-address (forgerie-core:user-emails user))))) (user))) (defun validate-users (users) (remove nil (mapcar #'validate-user users))) (defun ticket-assignable-vc-repositories (ticket vc-repositories) (when (forgerie-core:ticket-projects ticket) (remove nil (remove-duplicates (apply #'append (mapcar (lambda (proj) (forgerie-core:vc-repositories-with-primary-project proj vc-repositories)) (forgerie-core:ticket-projects ticket))) :test #'equalp)))) ; This assumes that validate-vc-repositories passed, which is to say ; that every project of interest belongs to only one repository, and that ; every vc-repository has at least one primary project (defun validate-tickets (tickets vc-repositories) (remove nil (mapcar (lambda (ticket) (let ((vc-repos (ticket-assignable-vc-repositories ticket vc-repositories))) (cond ((not vc-repos) (forgerie-core:add-mapping-error :gitlab-ticket-assigned-to-default (forgerie-core:ticket-id ticket) (format nil "Ticket with id ~A is not assignable to a repository, so assigning to default" (forgerie-core:ticket-id ticket))) ticket) ((< 1 (length vc-repos)) (forgerie-core:add-mapping-error :gitlab-ticket-assigned-to-multiple (forgerie-core:ticket-id ticket) (format nil "Ticket with id ~A is assignable to multiple repositories:~%~{ * ~A~%~}" (forgerie-core:ticket-id ticket) (mapcar #'forgerie-core:vc-repository-name vc-repos))) nil) (ticket)))) tickets))) (defun validate-merge-requests (merge-requests vc-repositories) (remove nil (mapcar (lambda (mr) (if (not (find (forgerie-core:vc-repository-slug (forgerie-core:merge-request-vc-repository mr)) vc-repositories :test #'string= :key #'forgerie-core:vc-repository-slug)) (forgerie-core:add-mapping-error :gitlab-merge-request-not-assignable (forgerie-core:merge-request-id mr) (format nil "Merge Request with title ~A is not assignable to a repository~%" (forgerie-core:merge-request-title mr))) mr)) merge-requests))) ; We only cache this in memory, and not on disk, because we most likely want ; updated information any time a run is fresh. (defvar *projects-by-name* nil) (defvar *projects-by-id* nil) (defun find-project-by-name (name) (when (not (assoc name *projects-by-name* :test #'string=)) (let - ((project + ((project (find name (get-request "projects" :parameters `(("search" . ,name))) :test #'string= :key (lambda (gl-project) (getf gl-project :name))))) (setf *projects-by-name* (cons (cons name project) *projects-by-name*)) (setf *projects-by-id* (cons (cons (getf project :id) project) *projects-by-id*)))) (cdr (assoc name *projects-by-name* :test #'string=))) (defun find-project-by-id (id) (when (not (assoc id *projects-by-id*)) (let ((project (get-request (format nil "projects/~A" id)))) (setf *projects-by-id* (cons (cons (getf project :id) project) *projects-by-id*)))) (cdr (assoc id *projects-by-id*))) (defun default-project () (when *default-project* (find-project-by-name (getf *default-project* :name)))) (defun create-default-project () (when *default-project* (when-unmapped-with-update (:project :default-project) (post-request "projects" (append (when *default-group* (list (cons "namespace_id" (princ-to-string (getf (first (get-request "namespaces" :parameters `(("search" . ,(getf *default-group* :name))))) :id))))) `(("name" . ,(getf *default-project* :name)) ("issues_access_level" . "enabled") ("snippets_access_level" . "enabled") ("visibility" . "public") ("path" . ,(getf *default-project* :path)))))))) (defun default-group () (when *default-group* (get-request "groups" :parameters `(("search" . ,(getf *default-group* :name)))))) (defun create-default-group () (when *default-group* (when-unmapped-with-update (:group :default-group) (post-request "groups" `(("name" . ,(getf *default-group* :name)) ("path" . ,(getf *default-group* :path)) ("visibility" . "public")))))) (defun add-ssh-key () (let ((key-name "Forgerie Export Key")) (when-unmapped-with-update (:forgerie-key :main-key) (post-request "user/keys" `(("title" . ,key-name) ("key" . ,*ssh-public-key*)))))) (defun project-for-ticket (ticket vc-repositories) (let ((vc-repos (ticket-assignable-vc-repositories ticket vc-repositories))) (if vc-repos (find-project-by-name (forgerie-core:vc-repository-name (car vc-repos))) (when (not (getf *default-project* :disable-tickets)) (default-project))))) (defun remove-single-project () (when *single-project* (let ((project (find-project-by-name *single-project*))) (when project (cl-fad:delete-directory-and-files (format nil "~A~A/" *working-directory* (getf project :path)) :if-does-not-exist :ignore) (delete-request (format nil "/projects/~A" (getf project :id))) (setf *projects-by-name* nil) ; Gitlab returns immediately even though the project is being deleted.... (sleep 60))))) (defmethod forgerie-core:export-forge ((forge (eql :gitlab)) data) (setf *working-directory* (format nil "~Agitlab/" forgerie-core:*working-directory*)) (forgerie-core:check-for-stop) (ensure-directories-exist *working-directory*) (when *single-project* (remove-single-project)) (create-default-group) (create-default-project) (add-ssh-key) (let* ((*note-mapping-skips* nil) (*notes-mode* nil) (*files-to-upload* (getf data :files)) (vc-repositories (validate-vc-repositories (getf data :vc-repositories) (getf data :projects))) (tickets (remove-if-not #'identity (validate-tickets (getf data :tickets) vc-repositories))) (merge-requests (validate-merge-requests (getf data :merge-requests) vc-repositories))) (mapcar (lambda (user) (update-user-admin-status user t)) (validate-users (getf data :users))) (if *limit-to-active-users* ; Only add admins if we're limiting (mapcar #'create-user (remove-if-not #'forgerie-core:user-admin (validate-users (getf data :users)))) (mapcar #'create-user (validate-users (getf data :users)))) (mapcar #'create-project vc-repositories) (loop :with moved-forward := t :with completed := nil :with first-error := nil :with number-of-errors := 0 :while moved-forward :do (flet ((map-with-note-mapping-catch (fn collection) (mapcar (lambda (item) (let ((item-info (list (type-of item) (typecase item (forgerie-core:ticket (forgerie-core:ticket-id item)) (forgerie-core:merge-request (forgerie-core:merge-request-id item)) (forgerie-core:snippet (forgerie-core:snippet-id item)))))) (when (not (find item completed :test #'equalp)) (handler-case (progn (funcall fn item) (setf moved-forward t) (setf completed (cons item completed))) (unknown-note-mapping (e) (incf number-of-errors) (when (not first-error) (setf first-error (unknown-note-mapping-mapping e)))))))) collection))) (setf moved-forward nil) (setf first-error nil) (setf number-of-errors 0) (map-with-note-mapping-catch (lambda (ticket) (create-ticket ticket vc-repositories)) tickets) (map-with-note-mapping-catch #'create-snippet (getf data :snippets)) (map-with-note-mapping-catch #'create-merge-request merge-requests) (when (and (not first-error) (not *notes-mode*)) (setf *notes-mode* t) (setf completed nil) (setf moved-forward t)) (when (and (not moved-forward) first-error) (when forgerie-core:*debug* (format t "We failed to move forward...., so skipping item ~A~%" first-error)) (setf moved-forward t) (push first-error *note-mapping-skips*)))) (mapcar (lambda (ticket) (create-ticket-links ticket vc-repositories)) tickets) (mapcar #'add-commit-comments vc-repositories) (mapcar #'update-user-admin-status (validate-users (getf data :users))))) (defun add-commit-comments (vc-repository) (single-project-check (forgerie-core:vc-repository-name vc-repository) (let ((project (find-project-by-name (forgerie-core:vc-repository-name vc-repository)))) (mapcar (lambda (commit) (let* ((comment (forgerie-core:commit-parsed-comment commit)) (mappings (remove-if-not (lambda (item) (and (listp item) (find (car item) (list :ticket :merge-request :snippet)) (find-mapped-item (car item) (parse-integer (cadr item))))) comment)) (body (when mappings (format nil "Commit comment has updated locations:~%~%~{* ~A is now ~A~%~}" (apply #'append (mapcar (lambda (item) (let ((mi (find-mapped-item (car item) (parse-integer (cadr item)))) (c (cond ((eql :ticket (car item)) "#") ((eql :merge-request (car item)) "!") ((eql :snippet (car item)) "$")))) (list (caddr item) (if (equal (getf project :id) (mapped-item-project-id mi)) (format nil "~A~A" c (or (mapped-item-iid mi) (mapped-item-id mi))) (let ((other-project (find-project-by-id (mapped-item-project-id mi)))) (format nil "~A~A~A" (getf other-project :path) c (or (mapped-item-iid mi) (mapped-item-id mi)))))))) mappings)))))) (when body (when-unmapped (:commit-comment (forgerie-core:commit-sha commit)) (let ((commit-in-gitlab (get-request (format nil "/projects/~A/repository/commits/~A" (getf project :id) (forgerie-core:commit-sha commit))))) (post-request (format nil "/projects/~A/repository/commits/~A/discussions" (getf project :id) (forgerie-core:commit-sha commit)) `(("body" . ,body) ("created_at" . ,(getf commit-in-gitlab :created_at))))) (update-mapping (:commit-comment (forgerie-core:commit-sha commit))))))) (forgerie-core:vc-repository-commits vc-repository))))) ; Projects are created from vc repositories, since they are linked in gitlab. ; Some of the underlying information comes from core:projects that are ; the primary projects of the vc-repository (defun create-project (vc-repository) (single-project-check (forgerie-core:vc-repository-name vc-repository) (when-unmapped (:project (forgerie-core:vc-repository-slug vc-repository)) (let* ((tags (remove-duplicates (apply #'append (mapcar #'forgerie-core:project-tags (forgerie-core:vc-repository-projects vc-repository))) :test #'string=)) (gl-project (post-request "projects" (append (when *default-group* (list (cons "namespace_id" (princ-to-string (getf (first (get-request "namespaces" :parameters `(("search" . ,(getf *default-group* :name))))) :id))))) `(("name" . ,(forgerie-core:vc-repository-name vc-repository)) ("path" . ,(forgerie-core:vc-repository-slug vc-repository)) ("tag_list" . ,(format nil "~{~A~^,~}" tags)) ("issues_access_level" . "enabled") ("visibility" . ,(if (forgerie-core:vc-repository-private vc-repository) "private" "public")) ("merge_requests_access_level" . "enabled"))))) (working-path (format nil "~A~A/" *working-directory* (getf gl-project :path)))) (when (getf gl-project :empty_repo) (ensure-directories-exist working-path) (git-cmd gl-project "clone" "--mirror" (forgerie-core:vc-repository-git-location vc-repository) ".") (git-cmd gl-project "remote" "add" "gitlab" (getf gl-project :ssh_url_to_repo)) (git-cmd gl-project "push" "gitlab" "--all") (git-cmd gl-project "push" "gitlab" "--tags") (uiop/filesystem:delete-directory-tree (pathname working-path) :validate t) (update-mapping (:project (forgerie-core:vc-repository-slug vc-repository)) gl-project)))))) (defun process-note-text (note-text project-id) (format nil "~{~A~}" (mapcar (lambda (item) (flet ((mapped-item-p (item type) (and (eql type (car item)) (find-mapped-item type (parse-integer (cadr item))))) (handle-mapped-item (item type c) (let ((mi (find-mapped-item type (parse-integer (cadr item))))) (if (equal project-id (mapped-item-project-id mi)) (format nil "~A~A" c (or (mapped-item-iid mi) (mapped-item-id mi))) (let ((other-project (find-project-by-id (mapped-item-project-id mi)))) (format nil "~A~A~A" (getf other-project :path) c (or (mapped-item-iid mi) (mapped-item-id mi))))))) (handle-file (file-id) (let ((file-response (create-file file-id project-id))) (getf file-response :markdown)))) (cond ((stringp item) item) ((eql (car item) :file) (handle-file (cadr item))) ((eql (car item) :h1) (format nil "~%# ~A~%" (cadr item))) ((eql (car item) :h2) (format nil "~%## ~A~%" (cadr item))) ((eql (car item) :h3) (format nil "~%### ~A~%" (cadr item))) ((eql (car item) :h4) (format nil "~%#### ~A~%" (cadr item))) ((eql (car item) :h5) (format nil "~%##### ~A~%" (cadr item))) ((eql (car item) :link) (format nil "[~A](~A)" (cadr (cadr item)) (car (cadr item)))) ((mapped-item-p item :ticket) (handle-mapped-item item :ticket "#")) ((mapped-item-p item :merge-request) (handle-mapped-item item :merge-request "!")) ((mapped-item-p item :snippet) (handle-mapped-item item :snippet "$")) ((find item *note-mapping-skips* :test #'equalp) (caddr item)) (*notes-mode* (caddr item)) (t (error (make-instance 'unknown-note-mapping :mapping item)))))) note-text))) (defun create-note (project-id item-type item-id note) (when *notes-mode* (let ((note-text (process-note-text (forgerie-core:note-text note) project-id))) (when (not (cl-ppcre:scan "^\\s*$" note-text)) (when-unmapped-with-update (:note (forgerie-core:note-id note)) (post-request (format nil "/~A~A/~A/notes" (if project-id (format nil "projects/~A/" project-id) "") item-type item-id) `(("body" . ,note-text) ("created_at" . ,(to-iso-8601 (forgerie-core:note-date note)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:note-author note))))))))) (defun create-file (file-id project-id) (let ((file (find (parse-integer file-id) *files-to-upload* :key #'forgerie-core:file-id))) (when (not file) (error (format nil "Couldn't find file to upload with id ~S" (parse-integer file-id)))) (when-unmapped (:file-upoaded (forgerie-core:file-id file)) (update-file-mapping (:file-upoaded (forgerie-core:file-id file)) - (with-open-file (str (forgerie-core:file-location file) :element-type 'unsigned-byte) (post-request (format nil "projects/~A/uploads" project-id) - `(("file" . ,(list str :filename (drakma:url-encode (forgerie-core:file-name file) :utf-8)))))))) + `(("file" . ,(pathname (forgerie-core:file-location file))) + ("filename" . ,(quri:url-encode (forgerie-core:file-name file))))))) (retrieve-mapping :file-upoaded (forgerie-core:file-id file)))) (defun create-ticket (ticket vc-repositories) (single-project-check (let ((vc-repos (ticket-assignable-vc-repositories ticket vc-repositories))) (if vc-repos (forgerie-core:vc-repository-name (car vc-repos)) (getf *default-project* :name))) (when (project-for-ticket ticket vc-repositories) (when-unmapped (:ticket-completed (forgerie-core:ticket-id ticket)) (let ((project-id (getf (project-for-ticket ticket vc-repositories) :id))) (when-unmapped (:ticket (forgerie-core:ticket-id ticket)) (let ((gl-ticket (post-request (format nil "projects/~A/issues" project-id) `(("iid" . ,(prin1-to-string (forgerie-core:ticket-id ticket))) ("title" . ,(forgerie-core:ticket-title ticket)) ("labels" . ,(format nil "~{~A~^,~}" (cons (format nil "priority:~A" (forgerie-core:ticket-priority ticket)) (mapcar #'forgerie-core:project-name (forgerie-core:ticket-projects ticket))))) ,@(when (forgerie-core:ticket-assignee ticket) (list (cons "assignee_id" (princ-to-string (getf (retrieve-mapping :user (forgerie-core:user-username (ensure-user-created (forgerie-core:ticket-assignee ticket)))) :id))))) ("confidential" . ,(if (forgerie-core:ticket-confidential ticket) "true" "false")) ("description" . ,(process-note-text (append (forgerie-core:ticket-description ticket) (list (ticket-suffix ticket))) project-id)) ("created_at" . ,(to-iso-8601 (forgerie-core:ticket-date ticket)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:ticket-author ticket)))))) (mapcar (lambda (u) (post-request (format nil "projects/~A/issues/~A/subscribe" (getf gl-ticket :project_id) (getf gl-ticket :iid)) nil :sudo (forgerie-core:user-username (ensure-user-created u)))) (forgerie-core:ticket-subscribers ticket)) (update-mapping (:ticket (forgerie-core:ticket-id ticket)) gl-ticket))) (when (and *notes-mode* (not (find-mapped-item :ticket-completed (forgerie-core:ticket-id ticket)))) (let ((gl-ticket (get-request (format nil "projects/~A/issues/~A" project-id (forgerie-core:ticket-id ticket))))) (mapcar (lambda (note) (create-note (getf gl-ticket :project_id) "issues" (getf gl-ticket :iid) note)) (forgerie-core:ticket-notes ticket)) (when (eql :closed (forgerie-core:ticket-type ticket)) (put-request (format nil "projects/~A/issues/~A" project-id (getf gl-ticket :iid)) '(("state_event" . "close")))) (update-mapping (:ticket-completed (forgerie-core:ticket-id ticket)))))))))) (defun create-ticket-links (ticket vc-repositories) (when (find-mapped-item :ticket (forgerie-core:ticket-id ticket)) (when-unmapped (:ticket-links (forgerie-core:ticket-id ticket)) (single-project-check (let ((vc-repos (ticket-assignable-vc-repositories ticket vc-repositories))) (if vc-repos (forgerie-core:vc-repository-name (car vc-repos)) (getf *default-project* :name))) (let ((gl-ticket (retrieve-mapping :ticket (forgerie-core:ticket-id ticket)))) (mapcar (lambda (linked-ticket) (let ((gl-linked-ticket (ignore-errors (retrieve-mapping :ticket (forgerie-core:ticket-id linked-ticket))))) (if (not gl-linked-ticket) (forgerie-core:add-mapping-error :linked-ticket-not-found (forgerie-core:ticket-id linked-ticket) (format nil "Link was between ~A and ~A" (forgerie-core:ticket-id ticket) (forgerie-core:ticket-id linked-ticket))) (post-request (format nil "projects/~A/issues/~A/links" (getf gl-ticket :project_id) (getf gl-ticket :iid)) `(("target_project_id" . ,(princ-to-string (getf gl-linked-ticket :project_id))) ("target_issue_iid" . ,(princ-to-string (getf gl-linked-ticket :iid)))))))) (forgerie-core:ticket-linked-tickets ticket))) (update-mapping (:ticket-links (forgerie-core:ticket-id ticket))))))) (defun ensure-user-created (user) (when (and *limit-to-active-users* (validate-user user)) (create-user user)) user) (defun create-user (user) (when-unmapped-with-update (:user (forgerie-core:user-username user)) (let* ((avatar (forgerie-core:user-avatar user)) (avatar (when avatar (if (> (* 1024 200) (forgerie-core:file-size avatar)) avatar (progn (forgerie-core:add-mapping-error :user-avatar-too-big (forgerie-core:user-username user) (format nil "User ~A's avatar is ~A, which is bigger than the allowed 200k" (forgerie-core:user-username user) (forgerie-core:file-size avatar))))))) (avatar-filename (when avatar (if (find-if (lambda (ext) (cl-ppcre:scan (format nil "~A$" ext) (forgerie-core:file-name avatar))) (list "png" "jpg" "jpeg" "gif" "bmp" "tiff" "ico" "webp")) (forgerie-core:file-name avatar) (format nil "~A.~A" (forgerie-core:file-name avatar) (cond ((cl-ppcre:scan "^image/" (forgerie-core:file-mimetype avatar)) (subseq (forgerie-core:file-mimetype avatar) 6)) (t (error (format nil "Don't know profile mimetype ~A" (forgerie-core:file-mimetype avatar))))))))) + (avatar-filepath-with-mimetype + (when avatar-filename + (format nil "~A.~A" + (forgerie-core:file-location avatar) + (subseq (forgerie-core:file-mimetype avatar) 6)))) (gl-user - (with-open-file (str (if avatar (forgerie-core:file-location avatar) "/dev/null") :element-type 'unsigned-byte) - (post-request - "users" - `(("name" . ,(forgerie-core:user-name user)) - ("email" . ,(forgerie-core:email-address (forgerie-core:user-primary-email user))) - ; Everyone must be an admin to make some of the other import things work correctly - ; and then admin must be removed after - ("admin" . "true") - ("reset_password" . "true") - ("username" . ,(forgerie-core:user-username user)) - ,@(when avatar - (list (cons "avatar" (list str :content-type (forgerie-core:file-mimetype avatar) :filename (drakma:url-encode avatar-filename :utf-8)))))))))) + (progn + (when avatar-filepath-with-mimetype + (uiop:copy-file (forgerie-core:file-location avatar) avatar-filepath-with-mimetype)) + ;; using the new make-request implementation (dexador) does not work + ;; so use the previous slower implementation which works + (post-request + "users" + `(("name" . ,(forgerie-core:user-name user)) + ("email" . ,(forgerie-core:email-address (forgerie-core:user-primary-email user))) + ; Everyone must be an admin to make some of the other import things work correctly + ; and then admin must be removed after + ("admin" . "true") + ("reset_password" . "true") + ("username" . ,(forgerie-core:user-username user)) + ,@(when avatar-filepath-with-mimetype + `(("avatar" . ,(pathname avatar-filepath-with-mimetype))))))))) (mapcar (lambda (email) (post-request (format nil "/users/~A/emails" (getf gl-user :id)) `(("email" . ,(forgerie-core:email-address email))))) (remove-if #'forgerie-core:email-is-primary (forgerie-core:user-emails user))) gl-user))) (defun update-user-admin-status (user &optional override) (when (find-mapped-item :user (forgerie-core:user-username user)) (let ((gl-user (retrieve-mapping :user (forgerie-core:user-username user)))) (put-request (format nil "/users/~A" (getf gl-user :id)) `(("admin" . ,(if (or override (forgerie-core:user-admin user)) "true" "false"))))))) (defun add-users-to-projects (vc-repositories users) (let ((users-to-gl-users (mapcar (lambda (user) (list (forgerie-core:user-username user) (retrieve-mapping :user (forgerie-core:user-username user)))) (remove-if-not (lambda (user) (find-mapped-item :user (forgerie-core:user-username user))) users)))) (mapcar (lambda (vc-repository) (when-unmapped (:members-added-to-project (forgerie-core:vc-repository-slug vc-repository)) (let ((gl-project (find-project-by-name (forgerie-core:vc-repository-name vc-repository)))) (mapcar (lambda (user) (let ((gl-user (cadr (find (forgerie-core:user-username user) users-to-gl-users :key #'car :test #'string=)))) (when gl-user (handler-case (post-request (format nil "/projects/~A/members" (getf gl-project :id)) `(("user_id" . ,(prin1-to-string (getf gl-user :id))) ("access_level" . "30"))) (http-error (e) (format t "Ran into error on members ~S~%" e)))))) users)) (update-mapping (:members-added-to-project (forgerie-core:vc-repository-slug vc-repository))))) vc-repositories))) (defun create-local-checkout (project) (when (not (probe-file (format nil "~A~A" *working-directory* (getf project :path)))) (ensure-directories-exist (format nil "~A~A/" *working-directory* (getf project :path))) (git-cmd project "clone" "-o" "gitlab" (getf project :ssh_url_to_repo) "."))) (defun create-change-comments (gl-mr change) (let* ((versions (get-request (format nil "/projects/~A/merge_requests/~A/versions" (getf gl-mr :project_id) (getf gl-mr :iid)))) ; This may not work! We may have to figure out how to correlate version with this commit (version-for-change (car versions))) (mapcar (lambda (comment) (let ((note-text (process-note-text (forgerie-core:merge-request-change-comment-text comment) (getf gl-mr :project_id)))) (when (and note-text (not (zerop (length note-text)))) (handler-case (let ((discussion (post-request (format nil "/projects/~A/merge_requests/~A/discussions" (getf gl-mr :project_id) (getf gl-mr :iid)) `(("position[position_type]" . "text") ("position[base_sha]" . ,(getf version-for-change :base_commit_sha)) ("position[head_sha]" . ,(getf version-for-change :head_commit_sha)) ("position[start_sha]" . ,(getf version-for-change :start_commit_sha)) ;("position[line_range][start][line_code]" . "40606d8fa72800ddf68b5f2cf2b0b30e1d2de8e2_224_131") ;("position[line_range][start][type]" . "new") ;("position[line_range][start][new_line]" . "131") ;("position[line_range][end][line_code]" . "40606d8fa72800ddf68b5f2cf2b0b30e1d2de8e2_224_134") ;("position[line_range][end][type]" . "new") ;("position[line_range][end][new_line]" . "134") ,@(when (forgerie-core:merge-request-change-comment-new-line comment) (list (cons "position[new_line]" (princ-to-string (cadr (forgerie-core:merge-request-change-comment-new-line comment)))))) ,@(when (forgerie-core:merge-request-change-comment-old-line comment) (list (cons "position[old_line]" (princ-to-string (cadr (forgerie-core:merge-request-change-comment-new-line comment)))))) ("position[old_path]" . ,(forgerie-core:merge-request-change-comment-file comment)) ("position[new_path]" . ,(forgerie-core:merge-request-change-comment-file comment)) ("body" . ,note-text) ("created_at" . ,(to-iso-8601 (forgerie-core:merge-request-change-comment-date comment)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:merge-request-change-comment-author comment)))))) (mapcar (lambda (comment) (let ((note-text (process-note-text (forgerie-core:merge-request-change-comment-text comment) (getf gl-mr :project_id)))) (when (and note-text (not (zerop (length note-text)))) (post-request (format nil "/projects/~A/merge_requests/~A/discussions/~A/notes" (getf gl-mr :project_id) (getf gl-mr :iid) (getf discussion :id)) `(("body" . ,note-text) ("created_at" . ,(to-iso-8601 (forgerie-core:merge-request-change-comment-date comment)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:merge-request-change-comment-author comment))))))) (forgerie-core:merge-request-change-comment-replies comment))) (http-error (e) (cond ((= 400 (http-error-code e)) (format t "400 error in create-change-comments: ~A~%" (http-error-resp e))) ((= 500 (http-error-code e)) (format t "500 error in create-change-comments: ~A~%" (http-error-resp e))) (t (error e)))))))) (forgerie-core:merge-request-change-comments change)))) (defun create-merge-request (mr) (single-project-check (forgerie-core:vc-repository-name (forgerie-core:merge-request-vc-repository mr)) (when-unmapped (:merge-request-completed (forgerie-core:merge-request-id mr)) (let* ((project-name (forgerie-core:vc-repository-name (forgerie-core:merge-request-vc-repository mr))) (project (find-project-by-name project-name))) (when-unmapped (:merge-request (forgerie-core:merge-request-id mr)) (when (not project) (error "Could not find project with name: ~A" project-name)) (create-local-checkout project) ; We do this first, because if this errors, we want to bomb out first without doing the work ; to create all the branches and whatnot. The other option would be to add a mapping for ; the git work we need to do, but this seemed more elegant. (process-note-text (forgerie-core:merge-request-description mr) (getf project :id)) (when (not (zerop (git-cmd-code project "show-ref" "--verify" "--quiet" (format nil "refs/heads/~A" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr)))))) (git-cmd project "branch" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr)) (forgerie-core:commit-sha (forgerie-core:branch-commit (forgerie-core:merge-request-source-branch mr))))) (when (not (zerop (git-cmd-code project "show-ref" "--verify" "--quiet" (format nil "refs/heads/~A" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr)))))) (git-cmd project "branch" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr)) (forgerie-core:commit-sha (forgerie-core:branch-commit (forgerie-core:merge-request-source-branch mr))))) (git-cmd project "checkout" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))) (mapcar (lambda (change) (let ((commit (forgerie-core:merge-request-change-change change))) (typecase commit (forgerie-core:commit (git-cmd project "merge" (forgerie-core:commit-sha commit))) (forgerie-core:patch (let ((patch-file (format nil "~A/working.patch" *working-directory*))) (with-open-file (str patch-file :direction :output :if-exists :supersede :if-does-not-exist :create) (princ (forgerie-core:patch-diff commit) str)) (git-cmd project "am" patch-file) (delete-file patch-file)))))) (forgerie-core:merge-request-changes mr)) (git-cmd project "push" "gitlab" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))) (git-cmd project "push" "gitlab" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr))) (update-mapping (:merge-request (forgerie-core:merge-request-id mr)) (post-request (format nil "projects/~A/merge_requests" (getf project :id)) `(("source_branch" . ,(forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))) ("target_branch" . ,(forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr))) ("description" . ,(process-note-text (append (forgerie-core:merge-request-description mr) (list (merge-request-suffix mr))) (getf project :id))) ("title" . ,(forgerie-core:merge-request-title mr))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:merge-request-author mr)))))) (when *notes-mode* (let ((gl-mr (retrieve-mapping :merge-request (forgerie-core:merge-request-id mr)))) (rails-command (format nil "mr = MergeRequest.find(~A)" (getf gl-mr :id))) (rails-command (format nil "mr.created_at = Time.parse(\"~A\")" (to-iso-8601 (forgerie-core:merge-request-date mr)))) (rails-command "mr.save") (mapcar (lambda (note) (create-note (getf gl-mr :project_id) "merge_requests" (getf gl-mr :iid) note)) (forgerie-core:merge-request-notes mr)) (mapcar (lambda (change) (create-change-comments gl-mr change)) (forgerie-core:merge-request-changes mr)) (when (eql :closed (forgerie-core:merge-request-type mr)) (put-request (format nil "projects/~A/merge_requests/~A" (getf project :id) (getf gl-mr :iid)) '(("state_event" . "close"))) (git-cmd project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))) (git-cmd project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr)))) (update-mapping (:merge-request-completed (forgerie-core:merge-request-id mr))))))))) (defun create-snippet (snippet) (single-project-check (getf *default-project* :name) (when (default-project) (when-unmapped (:snippet-completed (forgerie-core:snippet-id snippet)) (when (/= 1 (length (forgerie-core:snippet-files snippet))) (error "Can only export snippets with exactly one file for now")) (let ((default-project (default-project)) (file (first (forgerie-core:snippet-files snippet)))) (if (zerop (forgerie-core:file-size file)) (forgerie-core:add-mapping-error :gitlab-snippet-empty (forgerie-core:snippet-id snippet) (format nil "Skipping snippet ~A because empty content" (forgerie-core:snippet-id snippet))) (progn (when-unmapped (:snippet (forgerie-core:snippet-id snippet)) (handler-case (update-mapping (:snippet (forgerie-core:snippet-id snippet)) (let ((content (with-open-file (str (forgerie-core:file-location file) :element-type 'unsigned-byte) (let ((seq (make-sequence 'vector (file-length str)))) (read-sequence seq str) (map 'string #'code-char seq))))) (post-request (format nil "/projects/~A/snippets" (getf default-project :id)) ; This is deprecated, but it's an easier interface for now. Someday we may have ; an importer that has more than one file, or gitlab may fully remove this, and ; then this code will need to be updated ; ; See https://docs.gitlab.com/ee/api/snippets.html#create-new-snippet `(("title" . ,(or (forgerie-core:snippet-title snippet) "Forgerie Generated Title")) ("content" . ,content) ("visibility" . "public") ("file_name" . ,(forgerie-core:file-name file)))))) (error (e) (format t "Failed to create snippet with title ~A~%, due to error ~A~%" (forgerie-core:snippet-title snippet) e) (forgerie-core:add-mapping-error :gitlab-snippet-error (forgerie-core:snippet-id snippet) (format nil "Failed to create snippet with title ~A, due to error ~A" (forgerie-core:snippet-title snippet) e))))) (when *notes-mode* (let ((gl-snippet (retrieve-mapping :snippet (forgerie-core:snippet-id snippet)))) (list gl-snippet (mapcar (lambda (note) (create-note (getf default-project :id) "snippets" (getf gl-snippet :id) note)) (forgerie-core:snippet-notes snippet))) (rails-command (format nil "s = Snippet.find(~A)" (getf gl-snippet :id))) (rails-command (format nil "u = User.find_by_username(\"~A\")" (forgerie-core:user-username (ensure-user-created (forgerie-core:snippet-author snippet))))) (rails-command (format nil "s.created_at = Time.parse(\"~A\")" (to-iso-8601 (forgerie-core:snippet-date snippet)))) (rails-command "s.author = u") (rails-command "s.save") (update-mapping (:snippet-completed (forgerie-core:snippet-id snippet)) gl-snippet)))))))))) diff --git a/src/main/gitlab/package.lisp b/src/main/gitlab/package.lisp index c91a9fd..eb6c047 100644 --- a/src/main/gitlab/package.lisp +++ b/src/main/gitlab/package.lisp @@ -1,5 +1,5 @@ (defpackage #:forgerie-gitlab (:use :cl) (:export #:*private-token* #:*server-address* #:*default-project* #:*ssh-public-key* - #:*default-group* #:*single-project* #:*rails-console-ssh-args* #:*merge-request-suffix* - #:*ticket-suffix* #:*limit-to-active-users*)) + #:*default-group* #:*single-project* #:*rails-command* #:*rails-command-args* + #:*merge-request-suffix* #:*ticket-suffix* #:*limit-to-active-users*)) diff --git a/src/main/gitlab/utils.lisp b/src/main/gitlab/utils.lisp index c7d3458..d8348d4 100644 --- a/src/main/gitlab/utils.lisp +++ b/src/main/gitlab/utils.lisp @@ -1,245 +1,247 @@ (in-package #:forgerie-gitlab) (define-condition http-error nil ((code :initarg :code :reader http-error-code) (path :initarg :path :reader http-error-path) (method :initarg :method :reader http-error-method) (parameters :initarg :parameters :reader http-error-parameters) (resp :initarg :resp :reader http-error-resp)) (:report (lambda (condition stream) (format stream "Http error code: ~A, resp: ~A" (http-error-code condition) (http-error-resp condition))))) (defun convert-js-to-plist (jsown) (cond ((not (listp jsown)) jsown) ((eql :obj (car jsown)) (apply #'append (mapcar (lambda (keyword) (list (intern (string-upcase keyword) :keyword) (convert-js-to-plist (jsown:val jsown keyword)))) (jsown:keywords jsown)))) ((listp jsown) (mapcar #'convert-js-to-plist jsown)) (t (error "Don't know how to handle ~S" jsown)))) (defun make-request (path method parameters &key sudo) (let ((parameters (append (when sudo (list (cons "sudo" sudo))) parameters))) - (multiple-value-bind - (body code headers uri stream must-close reason-phrase) - (drakma:http-request (format nil "~A/api/v4/~A" *server-address* path) :method method :parameters parameters - :additional-headers (list (cons "PRIVATE-TOKEN" *private-token*))) - (when - (not (= 304 code)) ; 304s are empty, and can be ignored - (let - ((resp (convert-js-to-plist (jsown:parse (map 'string #'code-char body))))) - (when forgerie-core:*debug* - (format t "*****************~%Gitlab request ~A (~A): ~S~%Status Code: ~S~%Response: ~S~%" - path - method - parameters - code - resp)) - (when (not (<= 200 code 299)) + (handler-case + (multiple-value-bind + (body code headers uri stream) + (dex:request (format nil "~A/api/v4/~A" *server-address* path) :method method :content parameters + :headers (list (cons "PRIVATE-TOKEN" *private-token*))) + (when + (not (= 304 code)) ; 304s are empty, and can be ignored + (let + ((resp (convert-js-to-plist (jsown:parse body)))) + (when forgerie-core:*debug* + (format t "*****************~%Gitlab request ~A (~A): ~S~%Status Code: ~S~%Response: ~S~%" + path + method + parameters + code + resp)) + resp))) + (dex:http-request-failed (e) (error (make-instance 'http-error - :code code + :code (dex:response-status e) :path path :method method :parameters parameters - :resp resp + :resp (convert-js-to-plist (jsown:parse (dex:response-body e))) ))) - resp))))) + ))) (defun git-cmd (project cmd &rest args) - (forgerie-core:git-cmd - (format nil "~A~A" *working-directory* (getf project :path)) cmd args)) + (forgerie-core:git-cmd + (format nil "~A~A" *working-directory* (getf project :path)) cmd args)) (defun git-cmd-code (project cmd &rest args) (forgerie-core:git-cmd (format nil "~A~A" *working-directory* (getf project :path)) cmd args :error nil)) (defun get-request (path &key parameters sudo) (make-request path :get parameters :sudo sudo)) (defun post-request (path parameters &key sudo) (make-request path :post parameters :sudo sudo)) (defun delete-request (path) (make-request path :delete nil)) (defun put-request (path parameters &key sudo) (make-request path :put parameters :sudo sudo)) (defun merge-request-suffix (mr) (if *merge-request-suffix* (funcall *merge-request-suffix* mr) "")) (defun ticket-suffix (ticket) (if *ticket-suffix* (funcall *ticket-suffix* ticket) "")) (defun to-iso-8601 (d) (multiple-value-bind (sec min hr date month year) (decode-universal-time d 0) (format nil "~A-~2,,,'0@A-~2,,,'0@AT~2,,,'0@A:~2,,,'0@A:~2,,,'0@AZ" year month date hr min sec))) (defstruct mapped-item type original-id id iid project-id) (defstruct mapped-file type original-id response) (defun mapping-file () (format nil "~A/mapping" *working-directory*)) (defvar *mapping* nil) (defun mapping () (or *mapping* (setf *mapping* (when (probe-file (mapping-file)) (with-open-file (str (mapping-file)) (loop :for obj := (read str nil) :while obj :collect obj)))))) (defun find-mapped-item (type original-id) (find (list type original-id) (mapping) :key (lambda (mi) (typecase mi (mapped-item (list (mapped-item-type mi) (mapped-item-original-id mi))) (mapped-file (list (mapped-file-type mi) (mapped-file-original-id mi))))) :test #'equalp)) (defmacro when-unmapped ((type original-id) &rest body) `(when (not (find-mapped-item ,type ,original-id)) ,@body)) (defmacro when-unmapped-with-update ((type original-id) &rest body) `(when-unmapped (,type ,original-id) (update-mapping (,type ,original-id) ,@body))) (defmacro update-mapping ((type original-id) &rest body) (let ((result (gensym)) (str (gensym)) (mapped-item (gensym))) `(let* ((,result ,@body) (,mapped-item (make-mapped-item :type ,type :original-id ,original-id :id (getf ,result :id) :iid (getf ,result :iid) :project-id (getf ,result :project_id)))) (setf *mapping* (cons ,mapped-item (mapping))) (with-open-file (,str (mapping-file) :direction :output :if-exists :append :if-does-not-exist :create) (format ,str "~S" ,mapped-item)) (forgerie-core:check-for-stop) ,result))) (defmacro update-file-mapping ((type original-id) &rest body) (let ((result (gensym)) (str (gensym)) (mapped-item (gensym))) `(let* ((,result ,@body) (,mapped-item (make-mapped-file :type ,type :original-id ,original-id :response ,result))) (setf *mapping* (cons ,mapped-item (mapping))) (with-open-file (,str (mapping-file) :direction :output :if-exists :append :if-does-not-exist :create) (format ,str "~S" ,mapped-item)) (forgerie-core:check-for-stop) ,result))) (defun retrieve-mapping (type original-id) (let ((mi (find-mapped-item type original-id))) (when (not mi) (error "Failed to retrieve mapping for ~S" (list type original-id))) (typecase mi (mapped-item (if (mapped-item-project-id mi) (get-request (format nil "projects/~A/~A/~A" (mapped-item-project-id mi) (case (mapped-item-type mi) (:snippet "snippets") (:merge-request "merge_requests") (:ticket "issues")) (or (mapped-item-iid mi) (mapped-item-id mi)))) (get-request (format nil "~A/~A" (case (mapped-item-type mi) (:user "users")) (or (mapped-item-iid mi) (mapped-item-id mi)))))) (mapped-file (mapped-file-response mi))))) ; This is for development, so that we can export only one project ; and all the tickets/prs associated with it. (defmacro single-project-check (name &rest body) `(when (or (not *single-project*) (string= *single-project* ,name)) ,@body)) (defvar *rails-connection* nil) ; Each command needs to be a one liner standalone (defun rails-command (cmd) (when (not *rails-connection*) (setf *rails-connection* - (sb-ext:run-program "/usr/bin/ssh" *rails-console-ssh-args* + (sb-ext:run-program *rails-command* *rails-command-args* :input :stream :output :stream :wait nil)) (format (sb-ext:process-input *rails-connection*) "0~%" cmd) (force-output (sb-ext:process-input *rails-connection*)) (loop for line = (read-line (sb-ext:process-output *rails-connection*)) do (when forgerie-core:*debug* (format t "Booting: ~A~%" line)) until (string= line "0"))) ; The reason we append a 0 on the end of this, is because irb does some funky ; things, expecting you to be running from a terminal with a tty. So just ; doing a 0 and then checking for that output means we'll A) know when the ; command is done and B) not run into these no tty errors. (format (sb-ext:process-input *rails-connection*) "~A;0~%" cmd) (force-output (sb-ext:process-input *rails-connection*)) (let ((line (read-line (sb-ext:process-output *rails-connection*)))) (loop for line = (read-line (sb-ext:process-output *rails-connection*)) do (when forgerie-core:*debug* (format t "Running: ~A~%" line)) until (string= line "0")))) diff --git a/src/main/phabricator/base.lisp b/src/main/phabricator/base.lisp index cd21b12..79064a6 100644 --- a/src/main/phabricator/base.lisp +++ b/src/main/phabricator/base.lisp @@ -1,80 +1,84 @@ (in-package #:forgerie-phabricator) +(defvar *database-host* nil + "Database host to access.") +(defvar *database-port* 3306 + "Database host to access.") (defvar *database-username* nil "Username to access the database. If NIL, will use the current user") (defvar *database-password* nil "Password to access the mysql database. If NIL, will not enter password") (defvar *revisions-to-skip* nil "List of revisions to skip. For instance, if they cause errors due to weird git history. They need to be handled manually. The list is of database ids.") (defvar *pastes-to-skip* nil "Pastes that can't be migrated, and will need to be handled manually. This is a list of database ids. They need to be handled manually.") ; This is the http location of the phabricator server (defvar *phabricator-location* nil "The HTTP location of the phabricator instance. This is only used for differentials that cannot be understood via the database. The raw diffs for these are pulled from the instance, and so they need to be accessible from the script.") ; The local filesystem storage location (defvar *storage-location* nil "The path on the local file system for the local storage of files. The phabricator_file database can refer to local storage items, which are stored here (other options being that the file is stored in the database).") (defvar *working-directory* nil) ; A list of plists, each having the keys :key and :repository ; For each of these, the project at key :key will be assigned to, and only to, repository :repository (defvar *project-assignment-overrides* nil "A list of plists of override commands for projects. Each item in the list is of the form '(:key KEY :repository SLUG) Where the KEY is the database id of the project, and the SLUG is which repository that this project should be a primary project of. Then the project will be removed from all other repositories it mgiht be assigned to. The ramification of this is that tasks that are part of this project, for instance, will be assigned to the repository in various forgeries that link project and repository.") (defvar *repository-overrides* nil "A list of plists for overriding certain features of projects. The plists are of the form '(:key KEY :action ACTION) Where KEY is the id of the database. ACTION can be either :skip or :update. - :skip, the repository will be skipped (useful for things like the staging repository) - :update, will be require a further item :DATA which is a plist of overrides corresponding to database fields for the repository table. Useful when renaming items, or specifying slugs.") (defvar *user-overrides* nil "A list of plists for overriding certain features of users. The plists are of the form '(:key KEY :action ACTION) Where KEY is the id of the database. ACTION can be only :update. - :update, will be require a further item :DATA which is a plist of overrides corresponding to database fields for the user table. Useful when renaming user names, or specifying other aspects of the user.") ; List of spaces for tasks that should be marked as confidential (defvar *confidential-space-phids* nil "List of spaces that should be marked as confidential on the export.") ; List of repositories to process, keyed by repository slug (defvar *included-repositories* nil "When doing only a partial import, use to list which slugs to be imported. This means that any tasks will be not mappable to a repository, and may end up in the default project of the exporter, so when using this, you'll want to disable that feature in the exporter of choice") (defvar *staging-repository* nil "PHID of the staging repository, if used. If NIL, commits for differentials will not be extracted from staging. Used if set up with arcanist.") (defvar *email-address-sanitizer* nil "A function that takes a string representing an email address, and then returns one that should be used in its place. Used in testing mode to ensure that users aren't getting random emails from the export forgerie, as an extra precaution.") diff --git a/src/main/phabricator/import.lisp b/src/main/phabricator/import.lisp index eed4506..9ce6044 100644 --- a/src/main/phabricator/import.lisp +++ b/src/main/phabricator/import.lisp @@ -1,984 +1,988 @@ (in-package #:forgerie-phabricator) ; This is really a stepping stone to more structured data, but nice ; while what we're getting out of the database and whatnot is more fluid. (defmacro getf-convenience (type &rest fields) `(progn ,@(mapcar (lambda (field) `(defun ,(intern (format nil "~A-~A" type field)) (o) (getf o ,(intern (symbol-name field) :keyword)))) fields))) (getf-convenience differential-diff id) (getf-convenience edge dst) (getf-convenience email address isprimary) (getf-convenience file id storageengine storageformat storagehandle name location mimetype bytesize phid) (getf-convenience file-storageblob data) (getf-convenience paste id phid title filephid file comments author authorphid datecreated) (getf-convenience paste-comment id author authorphid content datecreated) (getf-convenience project id phid icon name tags) (getf-convenience project-slug slug) (getf-convenience repository id phid repositoryslug name localpath projects primary-projects commits spacephid) (getf-convenience repository-commit id phid repositoryid commitidentifier parents patch comments git-comment) (getf-convenience task id phid title status projects comments owner author ownerphid authorphid description datecreated priority spacephid linked-tasks subscribers) (getf-convenience task-comment id author authorphid content datecreated) (getf-convenience user id username realname phid emails isadmin profileimage profileimagephid) (getf-convenience differential-revision id title summary testplan phid status repository repositoryphid datecreated related-commits author authorphid comments change-comments activediffphid) (getf-convenience differential-transaction-comment phid content changesetid isnewfile linenumber linelength replytocommentphid diff replies author authorphid datecreated) (getf-convenience differential-diff sourcecontrolbaserevision filename phid) (getf-convenience differential-comment id author authorphid content datecreated) (defvar *query-cache* nil) (defun query (query) (when (not (assoc query *query-cache* :test #'string=)) (when forgerie-core:*debug* (format t "~S~%" query)) (setf *query-cache* (cons (cons query (let* ((result (car (cl-mysql:query query))) (rows (car result)) (definitions (cadr result))) (mapcar (lambda (row) (apply #'append (mapcar (lambda (col def) (list (intern (string-upcase (car def)) :keyword) col)) row definitions))) rows))) *query-cache*))) (cdr (assoc query *query-cache* :test #'string=))) +; https://github.com/hackinghat/cl-mysql/blob/3fbf6e1421484f64c5bcf2ff3c4b96c6f0414f09/pool.lisp#L283 (defun initialize () - (cl-mysql:connect :user *database-username* :password *database-password*) + (if *database-host* + (cl-mysql:connect :host *database-host* :port *database-port* + :user *database-username* :password *database-password* ) + (cl-mysql:connect :user *database-username* :password *database-password*)) (cl-mysql:query "set names 'utf8'")) (defun sanitize-address (address) (when *email-address-sanitizer* (funcall *email-address-sanitizer* address))) (defun user-primary-email (user) (find 1 (user-emails user) :key #'email-isprimary)) (defun get-emails (user-phid) (query (format nil "select * from phabricator_user.user_email where userphid = '~A'" user-phid))) (defun annotate-user (user) (append (let ((override (find (user-id user) *user-overrides* :key (lambda (override) (getf override :key))))) (when (and override (eql :update (getf override :action))) (getf override :data))) user (list :profileimage (when (user-profileimagephid user) (get-file (user-profileimagephid user)))) (list :emails (get-emails (user-phid user))))) (defun get-user (phid) (annotate-user (first (query (format nil "select id, username, realName, phid, isadmin, profileimagephid from phabricator_user.user where phid = '~A'" phid))))) (defun get-users () (mapcar #'annotate-user (query "select id, username, realName, phid, isadmin, profileimagephid from phabricator_user.user"))) (defun fill-out-project (proj) (append (list :tags (mapcar #'project-slug-slug (query (format nil "select slug from phabricator_project.project_slug where projectphid = '~A'" (project-phid proj))))) proj)) (defun get-project (id &optional (key "phid")) (fill-out-project (first (query (format nil "select id, phid, color, name, icon from phabricator_project.project where ~A = '~A'" key id))))) (defun get-projects () (mapcar #'fill-out-project (query "select id, phid, color, name, icon from phabricator_project.project"))) (defun add-author-to-task-comment (comment) (append comment (list :author (get-user (task-comment-authorphid comment))))) (defun get-task-comments (task) (mapcar #'add-author-to-task-comment (query (format nil "select mtc.id, mtc.authorphid, mt.datecreated, mtc.content from phabricator_maniphest.maniphest_transaction mt left join phabricator_maniphest.maniphest_transaction_comment mtc on mtc.phid = mt.commentphid where commentphid is not null and mtc.isdeleted = 0 and objectphid = '~A' and transactiontype = 'core:comment' order by mt.datecreated" (task-phid task))))) (defun annotate-task (task) (append task (list :owner (when (task-ownerphid task) (get-user (task-ownerphid task))) :author (when (task-authorphid task) (get-user (task-authorphid task))) :comments (get-task-comments task)) (list :subscribers (mapcar (lambda (phid) (get-user phid)) (mapcar #'edge-dst (query (format nil "select dst from phabricator_maniphest.edge where src = '~A' and type = 21" (task-phid task)))))) (list :linked-tasks (mapcar (lambda (phid) (get-task phid :shallow t)) (mapcar #'edge-dst (query (format nil "select dst from phabricator_maniphest.edge where src = '~A' and type = 3" (task-phid task)))))) (list :projects (mapcar #'get-project (mapcar #'edge-dst (query (format nil "select dst from phabricator_maniphest.edge where src = '~A' and dst like 'PHID-PROJ%'" (task-phid task)))))))) (defun get-task (phid &key shallow) (let ((task (first (query (format nil "select * from phabricator_maniphest.maniphest_task where phid = '~A'" phid))))) (if shallow task (annotate-task task)))) (defun get-tasks () (mapcar #'annotate-task (query "select * from phabricator_maniphest.maniphest_task"))) (defun attach-projects-to-repository (repo) (let ((associated-projects (mapcar #'get-project (mapcar #'edge-dst (query (format nil "select * from phabricator_repository.edge where src = '~A' and dst like 'PHID-PROJ%'" (repository-phid repo))))))) (append (let ((override (find (repository-id repo) *repository-overrides* :key (lambda (override) (getf override :key))))) (when (and override (eql :update (getf override :action))) (getf override :data))) repo (list :primary-projects (append (mapcar (lambda (override) (get-project (getf override :key) "id")) (remove-if-not (lambda (override) (and (repository-repositoryslug repo) (string= (repository-repositoryslug repo) (getf override :repository)))) *project-assignment-overrides*)) (remove nil (mapcar (lambda (project) (when (and (string= "folder" (project-icon project)) ; We remove projects that have override defs, because we add them back in later (not (find (project-id project) *project-assignment-overrides* :key (lambda (override) (getf override :key))))) project)) associated-projects)))) (list :projects associated-projects)))) (defun annotate-repository-commits (repo) (append (list :commits (cached "repository-commits" (repository-phid repo) (mapcar (lambda (sha) (list :commitidentifier sha :git-comment (nth-value 1 (forgerie-core:git-cmd (repository-localpath repo) "log" (list "--format=%B" "-n" "1" sha))))) (mapcar #'car (get-shas-and-details repo))))) repo)) (defun get-repository (phid) (attach-projects-to-repository (first (query (format nil "select id, phid, repositoryslug, name, localpath, spacephid from phabricator_repository.repository where phid = '~A'" phid))))) (defun get-repository-by-slug (slug) (attach-projects-to-repository (first (query (format nil "select id, phid, repositoryslug, name, localpath, spacephid from phabricator_repository.repository where repositoryslug = '~A'" slug))))) (defun get-repository-by-id (id) (attach-projects-to-repository (first (query (format nil "select id, phid, repositoryslug, name, localpath, spacephid from phabricator_repository.repository where id = '~A'" id))))) (defun get-repositories () (let ((repositories (remove-if (lambda (repository) (and *included-repositories* (not (find (repository-repositoryslug repository) *included-repositories* :test #'string=)))) (query "select id, phid, repositoryslug, name, localpath, spacephid from phabricator_repository.repository where repositoryslug is not null")))) (mapcar #'annotate-repository-commits (mapcar #'attach-projects-to-repository (remove-if (lambda (repo) (eql :skip (getf (find (repository-id repo) *repository-overrides* :key (lambda (override) (getf override :key))) :action))) repositories))))) (defun db-file (file-phid) (first (query (format nil "select id, phid, name, storageEngine, storageFormat, storageHandle, mimetype, bytesize from phabricator_file.file where phid = '~A'" file-phid)))) (defun put-file-on-disk (out file) (cond ((and (string= "blob" (file-storageengine file)) (string= "raw" (file-storageformat file))) (write-sequence (file-storageblob-data (first (query (format nil "select data from phabricator_file.file_storageblob where id = '~A';" (file-storagehandle file))))) out)) ((and (string= "local-disk" (file-storageengine file)) (string= "raw" (file-storageformat file))) (with-open-file (str (format nil "~A/~A" *storage-location* (file-storagehandle file)) :element-type 'unsigned-byte) (let ((data (make-array (file-bytesize file)))) (read-sequence data str) (write-sequence data out)))) ((string= "chunks" (file-storageengine file)) (mapcar (lambda (chunk) (put-file-on-disk out (db-file (getf chunk :datafilephid))) (force-output out)) (query (format nil "select dataFilePHID from phabricator_file.file_chunk where chunkhandle = '~A' order by byteStart" (file-storagehandle file))))) (t (error "Don't know how to handle files of with engine,format,mimetype of ~A,~A,~A encounted on ~A" (file-storageengine file) (file-storageformat file) (file-mimetype file) (file-phid file))))) (defun get-file (file-phid) (let* ((file (db-file file-phid)) (dir (format nil "~A/files/~A/" *working-directory* (subseq file-phid (- (length file-phid) 3)))) (location (format nil "~A~A" dir file-phid))) (when (not (probe-file location)) (ensure-directories-exist dir) (with-open-file (out location :direction :output :element-type 'unsigned-byte) (put-file-on-disk out file))) (append file (list :location location)))) (defun get-captured-files () (mapcar #'get-file (mapcar (lambda (file-id) (getf (first (query (format nil "select phid from phabricator_file.file where id = ~A" file-id))) :phid)) (with-open-file (str (format nil "~A/everything/captured-files" *working-directory*)) (remove-duplicates (loop :for obj := (read str nil) :while obj :collect obj) :test #'string=))))) (defun capture-file (id) (with-open-file (str (format nil "~A/everything/captured-files" *working-directory*) :direction :output :if-exists :append :if-does-not-exist :create) (format str "~S" id))) (defun add-author-to-paste-comment (comment) (append comment (list :author (get-user (paste-comment-authorphid comment))))) (defun get-paste-comments (paste) (mapcar #'add-author-to-paste-comment (query (format nil "select ptc.id, ptc.authorphid, pt.datecreated, ptc.content from phabricator_paste.paste_transaction pt left join phabricator_paste.paste_transaction_comment ptc on ptc.phid = pt.commentphid where commentphid is not null and ptc.isdeleted = 0 and objectphid = '~A' and transactiontype = 'core:comment' order by pt.datecreated" (paste-phid paste))))) (defun get-pastes () (mapcar (lambda (paste) (append paste (list :author (get-user (paste-authorphid paste)) :comments (get-paste-comments paste)))) (remove nil (mapcar (lambda (paste) (let ((file (get-file (paste-filephid paste)))) (when file (append (list :file file) paste)))) (remove-if (lambda (paste) (find (paste-id paste) *pastes-to-skip*)) (query "select id, title, phid, filePHID, datecreated, authorPHID from phabricator_paste.paste")))))) (defun get-commit (phid &optional (with-parents t)) (let ((commit (first (query (format nil "select id, repositoryid, commitidentifier from phabricator_repository.repository_commit where phid = '~A'" phid))))) (append commit (list :parents (if with-parents (mapcar (lambda (parent-phid) (get-commit parent-phid nil)) (mapcar #'repository-commit-phid (query (format nil "select rc.phid from phabricator_repository.repository_parents rp join phabricator_repository.repository_commit rc on rp.parentcommitid = rc.id where childcommitid = '~A'" (repository-commit-id commit))))) :unfetched))))) (defun order-related-commits (commits) (when (find-if (lambda (commit) (< 1 (length (repository-commit-parents commit)))) commits) (error "There's a merge commit in the differential commit list?! Investigate further")) (cond ((not commits) nil) ((= 1 (length commits)) commits) (t (let* ((parents (apply #'append (mapcar #'repository-commit-parents commits))) (non-parent-commits (remove-if (lambda (commit) (find (repository-commit-commitidentifier commit) parents :key #'repository-commit-commitidentifier :test #'string=)) commits))) (when (< 1 (length non-parent-commits)) (format t "~S~%" non-parent-commits) (error "There's multiple commits that are not a parent in the set, meaning this commit chain is weird")) (cons (car non-parent-commits) (order-related-commits (remove (car non-parent-commits) commits))))))) (defun get-commits-from-db (revision) (let ((repository (get-repository (differential-revision-repositoryphid revision)))) (reverse (order-related-commits (remove-if (lambda (commit) (or (not (eql (repository-commit-repositoryid commit) (repository-id repository))) ; Is this commit reachable? (not (zerop (forgerie-core:git-cmd (repository-localpath repository) "cat-file" (list "-t" (repository-commit-commitidentifier commit))))) (string= (format nil "undefined~%") (nth-value 1 (forgerie-core:git-cmd (repository-localpath repository) "name-rev" (list "--name-only" (repository-commit-commitidentifier commit))))) ; Remove merge commits (< 1 (length (repository-commit-parents commit))))) (mapcar #'get-commit (mapcar #'edge-dst ; type of 31 is the same as DifferentialRevisionHasCommitEdgeType (query (format nil "select dst from phabricator_differential.edge where src = '~A' and type = 31" (differential-revision-phid revision)))))))))) (defun get-details (repository sha) (with-output-to-string (out) (sb-ext:run-program (asdf:system-relative-pathname :forgerie "bin/getdetails.sh") (list sha (repository-localpath repository)) :wait t :output out))) (defun get-shas-and-details (repository) (forgerie-core:check-for-stop) (cached "shas-and-details" (repository-phid repository) (mapcar (lambda (sha) (list sha (get-details repository sha))) (cl-ppcre:split "\\n" (nth-value 1 (forgerie-core:git-cmd (repository-localpath repository) "log" (list "--all" "--pretty=%H"))))))) (defun get-commits-from-staging (revision) (let* ((staging-repository (get-repository *staging-repository*)) (repository (get-repository (differential-revision-repositoryphid revision))) (latest-diff (first (query (format nil "select id from phabricator_differential.differential_diff where revisionid = '~A' order by id desc limit 1" (differential-revision-id revision))))) (all-shas-and-details (get-shas-and-details repository))) (labels ((build-commit-chain (diff-id &optional (n 0)) (when (> n 20) (error "We have failed to find a matching commit in the previous 20")) (let* ((diff-details (get-details staging-repository (format nil "phabricator/diff/~A~~~A" diff-id n))) (repo-details (find diff-details all-shas-and-details :test #'string= :key #'cadr))) (if repo-details (list (list :commitidentifier (car repo-details) :repository repository)) (cons (list :patch (nth-value 1 (forgerie-core:git-cmd (repository-localpath staging-repository) "format-patch" (list "-k" "-1" "--stdout" (format nil "phabricator/diff/~A~~~A" diff-id n))))) (build-commit-chain diff-id (1+ n))))))) (let ((commit-chain (reverse (build-commit-chain (differential-diff-id latest-diff))))) (cons (append (second commit-chain) (list :parents (list (first commit-chain)))) (cddr commit-chain)))))) (defun build-raw-commit (revision) (let* ((repository (get-repository (differential-revision-repositoryphid revision))) (user (get-user (differential-revision-authorphid revision))) (path (format nil "~A/~A/" *working-directory* (repository-repositoryslug repository))) (raw-diff - (drakma:http-request + (dex:get (format nil "~A/D~A?download=true" *phabricator-location* (differential-revision-id revision))))) (when (not (probe-file path)) (ensure-directories-exist path) (forgerie-core:git-cmd path "clone" (list (repository-localpath repository) "."))) (labels ((sha-applicable (sha) (forgerie-core:git-cmd path "checkout" (list sha)) (zerop (with-input-from-string (in raw-diff) (forgerie-core:git-cmd path "apply" (list "-") :input in :error nil)))) (find-parent-sha (&optional (shas (mapcar #'car (get-shas-and-details repository)))) (cond ((not shas) (with-open-file (debug-file "~/diff.patch" :direction :output :if-exists :supersede) (princ raw-diff debug-file)) (error "Couldn't find a sha for which this could be applied")) ((sha-applicable (car shas)) (car shas)) (t (find-parent-sha (cdr shas)))))) (let ((parent-commit-sha (find-parent-sha))) (forgerie-core:git-cmd path "add" (list ".")) (forgerie-core:git-cmd path "commit" (list "--author" (format nil "~A <~A>" (user-realname user) (email-address (user-primary-email user))) "-m" (format nil "Generated commit for differential D~A" (differential-revision-id revision)))) (list (list :repositoryid (repository-id repository) :patch (nth-value 1 (forgerie-core:git-cmd path "format-patch" (list "-k" "-1" "--stdout"))) :parents (list (list :repositoryid (repository-id repository) :commitidentifier parent-commit-sha)))))))) (defun add-author-to-differential-comment (comment) (append comment (list :author (get-user (differential-comment-authorphid comment))))) (defun get-revision-comments (rev) (mapcar #'add-author-to-differential-comment (query (format nil "select rtc.id, rtc.authorphid, rt.datecreated, rtc.content from phabricator_differential.differential_transaction rt left join phabricator_differential.differential_transaction_comment rtc on rtc.phid = rt.commentphid where commentphid is not null and rtc.isdeleted = 0 and objectphid = '~A' and transactiontype = 'core:comment' order by rt.datecreated" (differential-revision-phid rev))))) (defun get-revision-inline-comments (rev) (let* ((phid (differential-revision-phid rev)) (comments (query (format nil "select * from phabricator_differential.differential_transaction_comment where revisionphid = '~A' and isdeleted = 0 and changesetid is not null" phid)))) (mapcar (lambda (comment) (append comment (list :author (get-user (differential-transaction-comment-authorphid comment)) :diff (car (query (format nil "select diff.*, changeset.filename from phabricator_differential.differential_diff diff join phabricator_differential.differential_changeset changeset on changeset.diffid = diff.id where changeset.id = ~A" (differential-transaction-comment-changesetid comment))))))) comments))) (defun attach-inline-comments-to-commits (commits inline-comments) (flet ((comment-attached-to-commit (comment commit) (find (differential-diff-sourcecontrolbaserevision (differential-transaction-comment-diff comment)) (mapcar #'repository-commit-commitidentifier (repository-commit-parents commit)) :test #'string=))) (let ((attached-comments (remove-if (lambda (comment) (notany (lambda (commit) (comment-attached-to-commit comment commit)) commits)) inline-comments)) (unattached-comments (remove-if-not (lambda (comment) (notany (lambda (commit) (comment-attached-to-commit comment commit)) commits)) inline-comments))) (values (mapcar (lambda (commit) (setf (getf commit :comments) (remove-if-not (lambda (comment) (comment-attached-to-commit comment commit)) attached-comments)) commit) commits) unattached-comments)))) (defun thread-inline-comments (comments) (labels ((thread-comment (comment-to-thread comments) (when comments (mapcar (lambda (comment) (if (string= (differential-transaction-comment-replytocommentphid comment-to-thread) (differential-transaction-comment-phid comment)) (progn (setf (getf comment :replies) (append (differential-transaction-comment-replies comment) (list comment-to-thread))) comment) (progn (setf (getf comment :replies) (thread-comment comment-to-thread (differential-transaction-comment-replies comment))) comment))) comments)))) (let ((comment-to-thread (find-if #'differential-transaction-comment-replytocommentphid comments))) (if (not comment-to-thread) comments (thread-inline-comments (thread-comment comment-to-thread (remove comment-to-thread comments :test #'equalp))))))) (defun get-revision-commits (rev) (let ((inline-comments (thread-inline-comments (get-revision-inline-comments rev))) (commits (cached "revision_commits" (differential-revision-id rev) (or (get-commits-from-db rev) (when *staging-repository* (handler-case (get-commits-from-staging rev) (error (e) (format t "Failed to get commit from staging due to error ~A, falling back.~%" e)))) (build-raw-commit rev))))) (attach-inline-comments-to-commits commits inline-comments))) (defun annotate-revision (rev) (forgerie-core:check-for-stop) (when forgerie-core:*debug* (format t "---------------~%Loading revision ~A~%~%~%" (differential-revision-id rev))) (let ((repository (get-repository (differential-revision-repositoryphid rev)))) (when (or (not *included-repositories*) (find (repository-repositoryslug repository) *included-repositories* :test #'string=)) (handler-case (cached "revisions" (differential-revision-id rev) (append rev (list :author (get-user (differential-revision-authorphid rev))) (list :comments (get-revision-comments rev)) (multiple-value-bind (commits unattached-comments) (get-revision-commits rev) (let ((comments-to-attach (remove-if-not (lambda (comment) (string= (differential-diff-phid (differential-transaction-comment-diff comment)) (differential-revision-activediffphid rev))) unattached-comments))) (list :change-comments comments-to-attach :related-commits commits))) (list :repository repository))) (error (e) (format t "Failed to handle revision ~A, due to error ~A, skipping.~%" (differential-revision-id rev) e)))))) (defun get-revision (id) (car (query (format nil "select id, title, summary, testplan, phid, status, repositoryphid, datecreated, authorphid, activediffphid from phabricator_differential.differential_revision where id = ~A" id)))) (defun get-revisions () (remove nil (mapcar #'annotate-revision (remove-if (lambda (rev) (find (differential-revision-id rev) *revisions-to-skip*)) (query "select id, title, summary, testplan, phid, status, repositoryphid, datecreated, authorphid, activediffphid from phabricator_differential.differential_revision"))))) (defun parse-comment (comment) (let ; This is an oddity in how phabricator represents this part of markdown, and thus it's converted ; to actual markdown (checkbox list items need to be prefaced by a list element like -) ((comment (cl-ppcre:regex-replace-all "\\n( *)\\[(.)\\]" comment (format nil "~%\\1 - [\\2]")))) (labels ((first-instance-of (regex type &key with-aftercheck (comment comment)) (multiple-value-bind (start end match-starts match-ends) (cl-ppcre:scan regex comment) (cond ((not start) nil) ((eql type :link) (list start end type (list (subseq comment (aref match-starts 0) (aref match-ends 0)) (subseq comment (aref match-starts 1) (aref match-ends 1))) (subseq comment start end))) ((or (zerop start) (= end (length comment))) (list start end type (subseq comment (aref match-starts 0) (aref match-ends 0)) (subseq comment start end))) ((and with-aftercheck (cl-ppcre:scan "[\\d\\w]" (subseq comment (1- start) start))) (first-instance-of regex type :comment (subseq comment end))) ((and with-aftercheck (cl-ppcre:scan "[\\d\\w]" (subseq comment end (1+ end)))) (first-instance-of regex type :comment (subseq comment end))) (t (list start end type (subseq comment (aref match-starts 0) (aref match-ends 0)) (subseq comment start end))))))) (let* ((first-instance (car (sort (remove-if-not #'identity (list (first-instance-of "\\n= ([^\\n]*) =\\n" :h1) (first-instance-of "\\n== ([^\\n]*) ==\\n" :h2) (first-instance-of "\\n=== ([^\\n]*) ===\\n" :h3) (first-instance-of "\\n==== ([^\\n]*) ====\\n" :h4) (first-instance-of "\\n===== ([^\\n]*) =====\\n" :h5) (first-instance-of "\\[\\[ *([^| ]*) *\\| *([^\\]]*) *\\]\\]" :link) (first-instance-of "\{F(\\d+)\}" :file) (first-instance-of "T(\\d+)(#\\d+)?" :ticket) (first-instance-of "P(\\d+)(#\\d+)?" :snippet) (first-instance-of "D(\\d+)(#\\d+)?" :merge-request))) #'< :key #'car)))) (when (and first-instance (equal :file (third first-instance))) (capture-file (fourth first-instance))) (cond ((zerop (length comment)) nil) ((not first-instance) (list comment)) (t (append (when (not (zerop (car first-instance))) (list (subseq comment 0 (car first-instance)))) (list (cddr first-instance)) (parse-comment (subseq comment (cadr first-instance)))))))))) (defun convert-commit-to-core (commit) (cond ((repository-commit-commitidentifier commit) (forgerie-core:make-commit :sha (repository-commit-commitidentifier commit) :parsed-comment (when (repository-commit-git-comment commit) (parse-comment (repository-commit-git-comment commit))))) ((repository-commit-patch commit) (forgerie-core:make-patch :diff (repository-commit-patch commit))))) (defun convert-change-comment-to-core (comment) (forgerie-core:make-merge-request-change-comment :old-line (when (zerop (differential-transaction-comment-isnewfile comment)) (list (differential-transaction-comment-linenumber comment) (+ (differential-transaction-comment-linenumber comment) (differential-transaction-comment-linelength comment)))) :new-line (when (not (zerop (differential-transaction-comment-isnewfile comment))) (list (differential-transaction-comment-linenumber comment) (+ (differential-transaction-comment-linenumber comment) (differential-transaction-comment-linelength comment)))) :date (unix-to-universal-time (differential-transaction-comment-datecreated comment)) :file (map 'string #'code-char (differential-diff-filename (differential-transaction-comment-diff comment))) :text (parse-comment (map 'string #'code-char (differential-transaction-comment-content comment))) :author (convert-user-to-core (differential-transaction-comment-author comment)) :replies (mapcar #'convert-change-comment-to-core (differential-transaction-comment-replies comment)))) (defun convert-change-to-core (commit) (forgerie-core:make-merge-request-change :change (convert-commit-to-core commit) :comments (mapcar #'convert-change-comment-to-core (repository-commit-comments commit)))) (defun convert-differential-comment-to-core (comment) (forgerie-core:make-note :id (format nil "D~A" (differential-comment-id comment)) :text (parse-comment (map 'string #'code-char (differential-comment-content comment))) :author (convert-user-to-core (differential-comment-author comment)) :date (unix-to-universal-time (differential-comment-datecreated comment)))) (defun convert-revision-to-core (revision-def) (let ((type (cond ((find (differential-revision-status revision-def) (list "published" "abandoned") :test #'string=) :closed) ((find (differential-revision-status revision-def) (list "changes-planned" "needs-review" "needs-revision" "accepted" "draft") :test #'string=) :open) (t (error "Unknown revision type: ~A" (differential-revision-status revision-def)))))) (forgerie-core:make-merge-request :id (differential-revision-id revision-def) :title (differential-revision-title revision-def) :description (parse-comment (format nil "~A~A" (map 'string #'code-char (differential-revision-summary revision-def)) (if (differential-revision-testplan revision-def) (format nil "~%~%== Test Plan ==~%~%~A" (map 'string #'code-char (differential-revision-testplan revision-def))) ""))) :author (convert-user-to-core (differential-revision-author revision-def)) :vc-repository (convert-repository-to-core (differential-revision-repository revision-def)) :date (unix-to-universal-time (differential-revision-datecreated revision-def)) :type type :target-branch (forgerie-core:make-branch :name ; Defaults to master, but that may be wrong after more investigation (if (eql :open type) "master" (format nil "generated-differential-D~A-target" (differential-revision-id revision-def))) :commit (convert-commit-to-core (car (repository-commit-parents (car (differential-revision-related-commits revision-def)))))) :source-branch (forgerie-core:make-branch :name (format nil "generated-differential-D~A-source" (differential-revision-id revision-def)) :commit (convert-commit-to-core (car (repository-commit-parents (car (differential-revision-related-commits revision-def)))))) :changes (mapcar #'convert-change-to-core (differential-revision-related-commits revision-def)) :other-change-comments (mapcar #'convert-change-comment-to-core (differential-revision-change-comments revision-def)) :notes (mapcar #'convert-differential-comment-to-core (differential-revision-comments revision-def))))) (defun convert-repository-to-core (repository-def) (forgerie-core:make-vc-repository :name (repository-name repository-def) :slug (repository-repositoryslug repository-def) :projects (mapcar #'convert-project-to-core (repository-projects repository-def)) :primary-projects (mapcar #'convert-project-to-core (repository-primary-projects repository-def)) :git-location (repository-localpath repository-def) :private (not (not (find (repository-spacephid repository-def) *confidential-space-phids* :test #'string=))) :commits (mapcar #'convert-commit-to-core (repository-commits repository-def)))) (defun convert-project-to-core (project-def) (forgerie-core:make-project :tags (project-tags project-def) :name (project-name project-def))) (defun convert-email-to-core (email-def) (forgerie-core:make-email :address (sanitize-address (email-address email-def)) :is-primary (eql (email-isprimary email-def) 1))) (defun convert-user-to-core (user-def) (when user-def (forgerie-core:make-user :username (user-username user-def) :name (user-realname user-def) :admin (equal (user-isadmin user-def) 1) :emails (mapcar #'convert-email-to-core (user-emails user-def)) :avatar (when (user-profileimage user-def) (convert-file-to-core (user-profileimage user-def)))))) (defun convert-task-comment-to-core (comment) (forgerie-core:make-note :id (format nil "T~A" (task-comment-id comment)) :text (parse-comment (map 'string #'code-char (task-comment-content comment))) :author (convert-user-to-core (task-comment-author comment)) :date (unix-to-universal-time (task-comment-datecreated comment)))) (defun convert-task-to-core (task-def) (let ((type (cond ((find (task-status task-def) (list "open" "wip") :test #'string=) :open) ((find (task-status task-def) (list "duplicate" "invalid" "resolved" "spite" "wontfix") :test #'string=) :closed) (t (error "Unknown revision type: ~A" (differential-revision-status revision-def)))))) (forgerie-core:make-ticket :id (task-id task-def) :title (task-title task-def) :author (convert-user-to-core (task-author task-def)) :assignee (convert-user-to-core (task-owner task-def)) :description (parse-comment (map 'string #'code-char (task-description task-def))) :projects (mapcar #'convert-project-to-core (task-projects task-def)) :date (unix-to-universal-time (task-datecreated task-def)) :confidential (not (not (find (task-spacephid task-def) *confidential-space-phids* :test #'string=))) :linked-tickets (mapcar #'convert-task-to-core (task-linked-tasks task-def)) :subscribers (mapcar #'convert-user-to-core (task-subscribers task-def)) :priority (case (task-priority task-def) (100 "Unbreak!") (90 "Triage") (80 "High") (50 "Normal") (25 "Low") (0 "Wish")) :type type :notes (mapcar #'convert-task-comment-to-core (task-comments task-def))))) (defun convert-paste-comment-to-core (comment) (forgerie-core:make-note :id (format nil "P~A" (paste-comment-id comment)) :text (parse-comment (map 'string #'code-char (paste-comment-content comment))) :author (convert-user-to-core (paste-comment-author comment)) :date (unix-to-universal-time (paste-comment-datecreated comment)))) (defun convert-file-to-core (file-def) (forgerie-core:make-file :id (file-id file-def) :name (file-name file-def) :location (file-location file-def) :size (file-bytesize file-def) :mimetype (file-mimetype file-def))) (defun convert-paste-to-core (paste-def) (forgerie-core:make-snippet :id (paste-id paste-def) :date (unix-to-universal-time (paste-datecreated paste-def)) :title (paste-title paste-def) :files (list (convert-file-to-core (paste-file paste-def))) :author (convert-user-to-core (paste-author paste-def)) :notes (mapcar #'convert-paste-comment-to-core (paste-comments paste-def)))) (defmethod forgerie-core:import-forge ((forge (eql :phabricator))) (setf *working-directory* (format nil "~Aphabricator" forgerie-core:*working-directory*)) (let ((override-everything-cache (and *included-repositories* (not (equal *included-repositories* (cached "everything" "included-repositories" nil)))))) (cached "everything" "included-repositories" *included-repositories* t) (initialize) (list :users (cached "everything" "users" (mapcar #'convert-user-to-core (get-users)) override-everything-cache) :projects (cached "everything" "projects" (mapcar #'convert-project-to-core (get-projects)) override-everything-cache) :vc-repositories (cached "everything" "repositories" (mapcar #'convert-repository-to-core (get-repositories)) override-everything-cache) :snippets (cached "everything" "snippets" (mapcar #'convert-paste-to-core (get-pastes)) override-everything-cache) :merge-requests (cached "everything" "merge-requests" (mapcar #'convert-revision-to-core (get-revisions)) override-everything-cache) :tickets (cached "everything" "tickets" (mapcar #'convert-task-to-core (get-tasks)) override-everything-cache) :files (cached "everything" "files" (mapcar #'convert-file-to-core (get-captured-files)) override-everything-cache)))) diff --git a/src/main/phabricator/package.lisp b/src/main/phabricator/package.lisp index 37add5a..b129c43 100644 --- a/src/main/phabricator/package.lisp +++ b/src/main/phabricator/package.lisp @@ -1,6 +1,7 @@ (defpackage #:forgerie-phabricator (:use :cl) (:export - #:*database-password* #:*database-username* #:*revisions-to-skip* #:*phabricator-location* - #:*project-assignment-overrides* #:*repository-overrides* - #:*pastes-to-skip* #:*user-overrides* #:*storage-location* #:*confidential-space-phids* - #:*included-repositories* #:*staging-repository* #:*email-address-sanitizer*)) + #:*database-password* #:*database-username* #:*database-host* #:*database-port* + #:*revisions-to-skip* #:*phabricator-location* #:*project-assignment-overrides* + #:*repository-overrides* #:*pastes-to-skip* #:*user-overrides* #:*storage-location* + #:*confidential-space-phids* #:*included-repositories* #:*staging-repository* + #:*email-address-sanitizer*))