diff --git a/README.md b/README.md index 1ebeb97..693805a 100644 --- a/README.md +++ b/README.md @@ -1,18 +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: +## Configure + +To configure: ``` $ 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 +`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 new file mode 100755 index 0000000..e821376 --- /dev/null +++ b/bin/build-config-tmpl @@ -0,0 +1,66 @@ +#!/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))) + +(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. +;;;; +;;;; 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 + "~{;~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:*merge-request-suffix* + forgerie-gitlab:*ticket-suffix* + forgerie-gitlab:*limit-to-active-users*)))) diff --git a/config/config.lisp.tmpl b/config/config.lisp.tmpl index 1ffce3a..f46102f 100644 --- a/config/config.lisp.tmpl +++ b/config/config.lisp.tmpl @@ -1,7 +1,172 @@ -(setf forgerie-gitlab:*private-token* "__PRIVATE_TOKEN__") -(setf forgerie-gitlab:*server-address* "__ADDRESS__") +;;;; This template file is generated by bin/build-config-templ and should not be edited manuall. +;;;; +;;;; Install by copying to config.lisp -(setf forgerie-phabricator:*database-password* "__PASSWORD__") -(setf forgerie-phabricator:*git-location* "__GIT_LOCATION__") -(setf forgerie-phabricator:*phabricator-location* "__PHABRICATOR_LOCATION__") +;;;;;;;;;;;;;;;;;;; +;;; 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. +; +; 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: +; +; Host ssh.gitlab.yourdomain.tld +; User +; Port 2222 +; IdentityFile ~/.ssh/your_identity_file +(setf forgerie-gitlab:*rails-console-ssh-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/src/main/core/base.lisp b/src/main/core/base.lisp index 8b345d5..ead0124 100644 --- a/src/main/core/base.lisp +++ b/src/main/core/base.lisp @@ -1,38 +1,40 @@ (in-package #:forgerie-core) -(defvar *working-directory* nil) +(defvar *working-directory* "/tmp/forgerie/" + "The working directory for the run. Core files will be put into + 'core' underneath this, and then each forgerie will base on this.") (define-condition stop-processing nil nil) (defvar *continue-processing* t) (defun check-for-stop () (when (not *continue-processing*) (error (make-instance 'stop-processing)))) (defgeneric import-forge (forge)) (defgeneric export-forge (forge data)) ; Files should be stored on disk somewhere (defstruct file id name size location mimetype) ; A branch in forgerie exists outside of git branches. Because ; we import things that exist at certain times, the branch may ; not even exist anymore in the git repository, or may be on a ; commit that doesn't make sense for the instance of the branch ; in the forgerie format. Consider a PR in github against the ; main branch from a year ago. We want to create that PR in the ; target forge against main as it was at that point in time. (defstruct branch name commit) ; The parsed comment here is a comment after being parsed by the ; source systems, allowing target systems to do interesting things ; like update mappings and provide information. (defstruct commit sha parsed-comment) (defstruct patch diff) ; "text" here is actually a list of: ; - string - just a string ; - (:merge-request ) ; - (:ticket ) ; - (:snippet ) (defstruct note id text author date) diff --git a/src/main/core/errors.lisp b/src/main/core/errors.lisp index 8353bb3..ad7962c 100644 --- a/src/main/core/errors.lisp +++ b/src/main/core/errors.lisp @@ -1,52 +1,55 @@ (in-package #:forgerie-core) -(defvar *log-mapping-errors* t) +(defvar *log-mapping-errors* t + "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.") (defgeneric display-mapping-error (error-type object-id description)) (defstruct mapping-error error-type object-id description) (defvar *mapping-errors* nil) (defun mapping-errors-file () - (format nil "~A/errors" *working-directory*)) + (format nil "~Acore/errors" *working-directory*)) (defun mapping-errors () (or *mapping-errors* (setf *mapping-errors* (when (probe-file (mapping-errors-file)) (with-open-file (str (mapping-errors-file)) (loop :for obj := (read str nil) :while obj :collect obj)))))) (defun add-mapping-error (error-type object-id description) (when (and *log-mapping-errors* (not (find-if (lambda (mapping-error) (and (equal (mapping-error-error-type mapping-error) error-type) (equal (mapping-error-object-id mapping-error) object-id))) (mapping-errors)))) (let ((mapping-error (make-mapping-error :error-type error-type :object-id object-id :description description))) (setf *mapping-errors* (cons mapping-error (mapping-errors))) (with-open-file (str (mapping-errors-file) :direction :output :if-exists :append) (format str "~S" mapping-error))) (forgerie-core:check-for-stop))) diff --git a/src/main/core/utils.lisp b/src/main/core/utils.lisp index ea0bf24..6591a84 100644 --- a/src/main/core/utils.lisp +++ b/src/main/core/utils.lisp @@ -1,38 +1,40 @@ (in-package #:forgerie-core) -(defvar *debug* nil) +(defvar *debug* nil + "Set to T to enable output of trace level messaging, such +as http requests, git commands, and database queries") (defun vc-repositories-with-primary-project (project vc-repositories) (remove-if-not (lambda (repo) (find project (vc-repository-primary-projects repo) :test #'equalp)) vc-repositories)) (defun git-cmd (git-dir cmd args &key (error t) (debug *debug*) (input nil)) (if debug (format t "Executing git command ~A with args ~S in dir ~A" cmd args git-dir)) (let* ((err nil) (out nil) (code nil)) (setf err (with-output-to-string (err-str) (setf out (with-output-to-string (out-str) (setf code (sb-ext:process-exit-code (sb-ext:run-program "/usr/bin/git" (append (list "-C" git-dir) (list cmd) args) :output out-str :error err-str :input input :wait t))))))) (if debug (format t "Return Code: ~A~%Standard output:~%~A~%Error output:~%~A~%" code out err)) (if (and error (not (zerop code))) (error "Got error running git command ~A with args ~S in dir ~A" cmd args git-dir)) (values code out err))) diff --git a/src/main/gitlab/base.lisp b/src/main/gitlab/base.lisp index fe92aed..7ed1e5e 100644 --- a/src/main/gitlab/base.lisp +++ b/src/main/gitlab/base.lisp @@ -1,41 +1,68 @@ (in-package #:forgerie-gitlab) -(defvar *server-address* nil) -(defvar *private-token* nil) +(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 *working-directory* "/tmp/forgerie/gitlab/") +(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") -; This is a plist of the form: -; '(:name :slug ) -(defvar *default-project* nil) +(defvar *working-directory* (format nil "~Agitlab/" forgerie-core:*working-directory*)) -(defvar *ssh-public-key* nil) +(defvar *default-project* 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.") -; This is of the form -; '(:name :path ) -(defvar *default-group* nil) +(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) +(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. + + 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: + + Host ssh.gitlab.yourdomain.tld + User + Port 2222 + IdentityFile ~/.ssh/your_identity_file") + +(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. -; A funciton that takes a forgerie-core:merge-request and adds a string -; that should be appended to the description of merge requests. -(defvar *merge-request-suffix* nil) + Useful to create backlinks to the previous system, or addition migration information") -; A funciton that takes a forgerie-core:ticket and return a string -; that should be appended to the description of tickets. -(defvar *ticket-suffix* nil) +(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). -; If non nil, the users will only be added to gitlab if they are -; active in the items that have come over for processing -(defvar *limit-to-active-users* nil) + Useful to create backlinks to the previous system, or addition migration information") -; If non nil, will not create the default project. If it's already created, will -; write nothing to it -(defvar *omit-default-project* nil) +(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 d169e4b..49146a9 100644 --- a/src/main/gitlab/export.lisp +++ b/src/main/gitlab/export.lisp @@ -1,798 +1,798 @@ (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 (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 (not *omit-default-project*) + (when *default-project* (find-project-by-name (getf *default-project* :name)))) (defun create-default-project () - (when (not *omit-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))) (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) (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" . "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)))))))) (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))))))))) (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)))))))))) (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 "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 28f0a48..c91a9fd 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* #:*working-directory* #:*ssh-public-key* + #:*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* #:*omit-default-project*)) + #:*ticket-suffix* #:*limit-to-active-users*)) diff --git a/src/main/phabricator/base.lisp b/src/main/phabricator/base.lisp index 6000c57..e525197 100644 --- a/src/main/phabricator/base.lisp +++ b/src/main/phabricator/base.lisp @@ -1,33 +1,80 @@ (in-package #:forgerie-phabricator) -(defvar *database-password* nil) +(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") -; These are differentials that can't be migrated, and need to be handled manually -; if at all. -(defvar *revisions-to-skip* nil) +(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.") -; Pastes that can't be migrated, and will need to be handled manually -(defvar *pastes-to-skip* nil) +(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) +(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) +(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* "/tmp/forgerie/phabricator") +(defvar *working-directory* (format nil "~Aphabricator" forgerie-core:*working-directory*)) ; 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) -(defvar *repository-overrides* nil) -(defvar *user-overrides* nil) +(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) +(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 -; 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 *included-repositories* nil) +(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 5ba487b..836a6eb 100644 --- a/src/main/phabricator/import.lisp +++ b/src/main/phabricator/import.lisp @@ -1,973 +1,972 @@ (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) (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) (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=))) (defun initialize () - (cl-mysql:connect :password *database-password*) + (cl-mysql:connect :user *database-username* :password *database-password*) (cl-mysql:query "set names 'utf8'")) -; This function is only for development mode. While we have emails -; turned off for gitlab, there's a chance that something screwed up will happen -; so we should make it so the aren't real email addresses (defun sanitize-address (address) - (format nil "~A@opentechstrategies.com" (cl-ppcre:regex-replace-all "@" 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 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 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 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 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, 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 "PHID-REPO-cuxcaqw5u7vepi4b4bpg")) + ((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 (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) - (handler-case - (get-commits-from-staging rev) - (error (e) (format t "Failed to get commit from staging due to error ~A, falling back.~%" e))) + (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) :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) :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))) (initialize) (list :users (cached "everything" "users" (mapcar #'convert-user-to-core (get-users))) :projects (cached "everything" "projects" (mapcar #'convert-project-to-core (get-projects))) :vc-repositories (cached "everything" "repositories" (mapcar #'convert-repository-to-core (get-repositories)) *included-repositories*) :snippets (cached "everything" "snippets" (mapcar #'convert-paste-to-core (get-pastes))) :merge-requests (cached "everything" "merge-requests" (mapcar #'convert-revision-to-core (get-revisions)) *included-repositories*) :tickets (cached "everything" "tickets" (mapcar #'convert-task-to-core (get-tasks))) :files (cached "everything" "files" (mapcar #'convert-file-to-core (get-captured-files)) *included-repositories*))) diff --git a/src/main/phabricator/package.lisp b/src/main/phabricator/package.lisp index 9606fc1..37add5a 100644 --- a/src/main/phabricator/package.lisp +++ b/src/main/phabricator/package.lisp @@ -1,6 +1,6 @@ (defpackage #:forgerie-phabricator (:use :cl) (:export - #:*database-password* #:*revisions-to-skip* #:*phabricator-location* - #:*project-assignment-overrides* #:*working-directory* #:*repository-overrides* + #:*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*)) + #:*included-repositories* #:*staging-repository* #:*email-address-sanitizer*))