diff --git a/src/main/gitlab/base.lisp b/src/main/gitlab/base.lisp index 0251919..12f6ea8 100644 --- a/src/main/gitlab/base.lisp +++ b/src/main/gitlab/base.lisp @@ -1,111 +1,114 @@ (in-package #:forgerie-gitlab) (defvar *server-address* nil "The fully qualitifed server address for the gitlab instance, including the scheme to use, e.g. https://gitlab.yourdomain.tld") (defvar *private-token* nil "The private token with which to access the gitlab instance. Needs to be set up either from within gitlab, or via a script that uses the rails console directory") (defvar *default-project* nil "A plist of the form '(:name NAME :slug SLUG :disable-tickets DISABLE) for the default project in which things like snippets, tickets that can't be assigned to a project, and other misc items go. NAME is the proper name of the project, with SLUG being the url slug to access it. If DISABLE is set to T, then tickets that can't be assigned to a project will not be assigned to this default project.") (defvar *ssh-public-key* nil "The public key that should be installed for the running user so that git commands work correctly.") (defvar *default-group* nil "A plist of the form '(:name NAME :path SLUG) that defines the group in which all created projects will be placed. NAME is the proper name for the group, while SLUG is the url slug. If NIL, the projects will all be created at the top level.") +(defvar *create-labels-in-default-group* t + "Whether to create all issue labels in the default group rather than in the individual projects") + (defvar *group-structure* nil "A list of plists of the form '(:name NAME :path SLUG :parent SLUG) that define the base structure of groups configured in the gitlab instance") ; For development only. Will limit all exporting to things having ; to do with the project with the name provided. (defvar *single-project* nil) ; The default rails-command to execute the rails console. (defvar *rails-command* "/usr/bin/ssh" "The rails command to execute, by default this uses ssh. But one could use kubectl or docker instead.") ; The required args for the *rails-command*. (defvar *rails-command-args* nil "By default, using ssh, a tuple of the form '(HOST COMMAND) that informs the gitlab forgerie how to run rails commands over ssh. It will always use SSH, even if set up to run on localhost, so keys must be installed to ssh to localhost. When overriden to another command like kubectl, a list '(COMMAND) for the necessary extra args that the command requires to run. When using ssh, an example for a server using docker might be: '(\"ssh.gitlab.yourdomain.tld\" \"docker exec -i gitlab /opt/gitlab/bin/gitlab-rails c\") A useful thing to do is to run ssh on the server for non git purposes on port 2222, and then set up your .ssh/config to have the following: Host ssh.gitlab.yourdomain.tld User Port 2222 IdentityFile ~/.ssh/your_identity_file When using kube, an example might be: '(\"exec -ti -n gitlab-system deployment/gitlab-toolbox -- /srv/gitlab/bin/rails console\") ") (defvar *merge-request-suffix* nil "A function that takes an argument of a forgerie-core:merge-request and returns a string that will be appended to the description of created merge requests. Useful to create backlinks to the previous system, or addition migration information") (defvar *ticket-suffix* nil "A function that takes an argument of a forgerie-core:ticket and returns a string that will be appended to the description of created tickets (issues). Useful to create backlinks to the previous system, or addition migration information") (defvar *snippet-suffix* nil "A function that takes an argument of a forgerie-core:snippet and returns a string that will be appended to the description of created snippets (pastes). Useful to create backlinks to the previous system, or addition migration information") (defvar *fallback-file-text* nil "A function that takes a forgerie-core:file, and returns the (markdown) text that will be output when the file was too large to be uploaded. Useful to create a link to the previous system on files that are not migrated yet") (defvar *fallback-mapped-item-text* nil "A function that takes an argument of a mapped item reference (as can be found in notes), and returns the (markdown) text that will be output when the mapped item is not found. Useful to create a link to the previous system on references that are not migrated yet") (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.") (defvar *always-migrate-users* nil "A list of usernames of users that should always be migrated, even when only migrating active users. Useful to give all of your known contributors an account at once, even on a partial migration.") (defvar *write-completed-mappings* '(:merge-request :ticket :snippet) "Write the mappings for the given object types to prevent migrating further actions. Allows incremental migrations of some types of objects.") diff --git a/src/main/gitlab/export.lisp b/src/main/gitlab/export.lisp index cf126f0..82fedc9 100644 --- a/src/main/gitlab/export.lisp +++ b/src/main/gitlab/export.lisp @@ -1,1417 +1,1436 @@ (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) (defvar *migration-user-id* 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-commits vcr)) (forgerie-core:add-mapping-error :source-repository-has-no-commits (forgerie-core:vc-repository-name vcr) (format nil "Source Repository '~A' has no commits.~%" (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))) ;; include repository anyway 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, assigning to default:~%~{ * ~A~%~}" (forgerie-core:ticket-id ticket) (mapcar #'forgerie-core:vc-repository-name vc-repos))) ticket) (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-slug* nil) (defvar *projects-by-name* nil) (defvar *projects-by-id* nil) (defun find-gitlab-project (repo) (let ((slug (forgerie-core:vc-repository-slug repo))) (when (not (assoc slug *projects-by-slug* :test #'string=)) (let* ((namespace-path (namespace-for-repo repo)) (namespace-id (cond (namespace-path (get-namespace-id namespace-path)) (*default-group* (mapped-item-id (find-mapped-item :group :default-group))))) (project-path (format nil "~A/~A" (or namespace-path (getf *default-group* :path)) slug)) (project (handler-case (get-request (format nil "projects/~A" (quri:url-encode project-path))) (http-error (e) nil)))) (setf *projects-by-slug* (cons (cons slug project) *projects-by-slug*)) (setf *projects-by-name* (cons (cons (getf project :name) project) *projects-by-name*)) (setf *projects-by-id* (cons (cons (getf project :id) project) *projects-by-id*)))) (cdr (assoc slug *projects-by-slug* :test #'string=)))) (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-slug* (cons (cons (getf project :slug) project) *projects-by-slug*)) (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-slug* (cons (cons (getf project :slug) project) *projects-by-slug*)) (setf *projects-by-id* (cons (cons (getf project :id) project) *projects-by-id*)))) (cdr (assoc id *projects-by-id*))) (defun default-project () (when *default-project* (find-project-by-name (getf *default-project* :name)))) (defun create-default-project () (when *default-project* (when-unmapped-with-update (:project :default-project) (let ((project-on-gitlab (handler-case (get-request (format nil "projects/~A" (quri:url-encode (format nil "~A/~A" (getf *default-group* :path) (getf *default-project* :path))))) (http-error (e) nil)))) (or project-on-gitlab (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") ("auto_devops_enabled" . "false") ("wiki_access_level" . "disabled") ("requirements_access_level" . "disabled") ("pages_access_level" . "disabled") ("packages_enabled" . "false") ("operations_access_level" . "disabled") ("container_registry_access_level" . "disabled") ("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) (let ((group-on-gitlab (handler-case (get-request (format nil "groups/~A" (quri:url-encode (getf *default-group* :path)))) (http-error (e) nil)))) (or group-on-gitlab (post-request "groups" `(("name" . ,(getf *default-group* :name)) ("path" . ,(getf *default-group* :path)) ("visibility" . "public")))))))) (defun create-groups () (when *group-structure* (mapcar (lambda (group) (let* ((parent-group-id (if (getf group :parent) (mapped-item-id (find-mapped-item :group (getf group :parent))))) (full-path (if (getf group :parent) (concatenate 'string (getf group :parent) "/" (getf group :path)) (getf group :path)))) (when-unmapped-with-update (:group full-path) (let ((group-on-gitlab (handler-case (get-request (format nil "groups/~A" (quri:url-encode full-path))) (http-error (e) nil)))) (or group-on-gitlab (post-request "groups" `(("name" . ,(getf group :name)) ("path" . ,(getf group :path)) ("parent_id" . ,parent-group-id) ;; This works fine even if parent-group-id is nil ("visibility" . "public")))))))) *group-structure*))) (defun get-namespace-id (namespace-path) (let ((mapped-item (find-mapped-item :group namespace-path))) (if mapped-item (mapped-item-id mapped-item) (getf (first (get-request "namespaces" :parameters `(("search" . ,namespace-path)))) :id)))) (defun get-migration-user-id () (setf *migration-user-id* (getf (get-request "user") :id))) (defun normalize-pubkey (pubkeystr) "Compare ssh keys using algo and hash (first two words), ignoring key title" (let ((split (uiop:split-string pubkeystr))) (uiop:reduce/strcat (subseq split 0 2)))) (defun gitlab-key-matches (key) (string= (normalize-pubkey *ssh-public-key*) (normalize-pubkey (getf key :key)))) (defun add-ssh-key () (when-unmapped-with-update (:forgerie-key :main-key) (let* ((key-name (format nil "Forgerie Export Key ~a" (local-time:now))) (known-keys (get-request "user/keys")) (key-found (find-if #'gitlab-key-matches known-keys))) (if key-found key-found (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 (and vc-repos (= 1 (length vc-repos))) (find-gitlab-project (car vc-repos)) (when (not (getf *default-project* :disable-tickets)) (default-project))))) (defun remove-single-project () (when *single-project* (let ((project (find-project-by-name *single-project*))) (when project (cl-fad:delete-directory-and-files (format nil "~A~A/" *working-directory* (getf project :path)) :if-does-not-exist :ignore) (delete-request (format nil "/projects/~A" (getf project :id))) (setf *projects-by-name* nil) ; Gitlab returns immediately even though the project is being deleted.... (sleep 60))))) (defun user-must-be-migrated (user) (if *limit-to-active-users* (or ; migrate admins (forgerie-core:user-admin user) ; migrate users that we've forced the migration of (find (forgerie-core:user-username user) *always-migrate-users* :test #'string=)) t)) (defmethod forgerie-core:export-forge ((forge (eql :gitlab)) data) (setf *working-directory* (format nil "~Agitlab/" forgerie-core:*working-directory*)) (forgerie-core:check-for-stop) (ensure-directories-exist *working-directory*) (get-migration-user-id) (when *single-project* (remove-single-project)) (create-groups) (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 #'create-user (remove-if-not #'user-must-be-migrated (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-project-archived-status vc-repositories))) (defun add-commit-comments (vc-repository) (single-project-check (forgerie-core:vc-repository-name vc-repository) (let ((project (find-gitlab-project vc-repository))) (mapc (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 "Some references in the commit message have been migrated:~%~%~{* ~A is now ~A~%~}" (apply #'append (mapcar (lambda (item) (list (caddr item) (mapped-item-reference (getf project :id) item))) 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/comments" (getf project :id) (forgerie-core:commit-sha commit)) `(("note" . ,body))) ;; Update date for the note generated above (rails-commands-with-recovery (list (rails-wait-for "n" (format nil "Note.where(:noteable_type => 'Commit', :commit_id => '~A', :project_id => ~A).order(:created_at => 'DESC').first" (forgerie-core:commit-sha commit) (getf project :id))) "n.created_at = n.commit.date" "n.updated_at = n.commit.date" "n.save" (rails-wait-for "ev" "Event.find_by(:target_type => 'Note', :target_id => n.id)") "ev.created_at = n.commit.date" "ev.updated_at = n.commit.date" "ev.save")) ;; update backlinks to the previous note (mapc (lambda (item) (let ((mi (find-mapped-item (car item) (parse-integer (cadr item)))) (noteable-type (cond ((eql :snippet (car item)) nil) ; Snippets don't get back-links ((eql :ticket (car item)) "Issue") ((eql :merge-request (car item)) "MergeRequest")))) (when noteable-type (rails-commands-with-recovery (list (format nil "commit_date = Time.parse('~A')" (getf commit-in-gitlab :authored_date)) (rails-wait-for "n" (format nil "Note.where(:noteable_type => '~A', :noteable_id => ~A, :system => true).where('note like ?', 'mentioned in commit %~A').order(:created_at => 'DESC').first" noteable-type (mapped-item-id mi) (forgerie-core:commit-sha commit))) "n.created_at = commit_date" "n.updated_at = commit_date" "n.save"))))) mappings) (update-mapping (:commit-comment (forgerie-core:commit-sha commit)))))))) (forgerie-core:vc-repository-commits vc-repository))))) (defun repo-access-policy-to-string (vc-repository) (ccase (forgerie-core:vc-repository-access-policy vc-repository) (:public "public") (:private "private") (:internal "internal"))) ; 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=)) (namespace-path (namespace-for-repo vc-repository)) (namespace-id (cond (namespace-path (get-namespace-id namespace-path)) (*default-group* (mapped-item-id (find-mapped-item :group :default-group))))) (gl-project-path (format nil "~A/~A" (or namespace-path (getf *default-group* :path)) (forgerie-core:vc-repository-slug vc-repository))) (gl-project-get (handler-case (get-request (format nil "projects/~A" (quri:url-encode gl-project-path))) (http-error (e) nil))) (gl-project (or gl-project-get (post-request "projects" `(("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" . ,(repo-access-policy-to-string vc-repository)) ("merge_requests_access_level" . "enabled") ("auto_devops_enabled" . "false") ("wiki_access_level" . "disabled") ("requirements_access_level" . "disabled") ("pages_access_level" . "disabled") ("packages_enabled" . "false") ("operations_access_level" . "disabled") ("container_registry_access_level" . "disabled") ("namespace_id" . ,namespace-id))))) (working-path (format nil "~Alocal-checkouts/~A/" *working-directory* (getf gl-project :path)))) (when (getf gl-project :empty_repo) (when (not (probe-file working-path)) (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 "remote" "set-url" "gitlab" (getf gl-project :ssh_url_to_repo)) (git-cmd gl-project "push" "gitlab" "--all" "-f") (git-cmd gl-project "push" "gitlab" "--tags" "-f") (uiop/filesystem:delete-directory-tree (pathname working-path) :validate t) (update-mapping (:project (forgerie-core:vc-repository-slug vc-repository)) gl-project)))))) (defun update-project-archived-status (vc-repository) (single-project-check (forgerie-core:vc-repository-name vc-repository) (when (forgerie-core:vc-repository-archived vc-repository) (when-unmapped-with-update (:project-archived (forgerie-core:vc-repository-slug vc-repository)) (let ((gl-project (find-mapped-item :project (forgerie-core:vc-repository-slug vc-repository)))) (post-request (format nil "projects/~A/archive" (mapped-item-id gl-project)) nil)))))) (defun update-object-author-date (obj-type obj-id author new-date &key author-field update-created-at update-updated-at update-closed-at update-event update-label-events update-resource-state-events update-metrics-created-at update-metrics-updated-at update-metrics-latest-closed-at update-system-notes) (let* ((find-ev-command (format nil "Event.where(:target => ~A, :target_type => '~A').where('created_at > ?', action_time).order(:created_at => 'DESC').first" obj-id obj-type)) (author-username (forgerie-core:user-username (ensure-user-created author))) (author-id (if author-username (getf (retrieve-mapping :user author-username) :id) *migration-user-id*)) (author-field (if update-created-at "author_id" "updated_by_id"))) (rails-commands-with-recovery `( ,(format nil "action_time = Time.parse('~A')" (to-iso-8601 new-date)) ,(format nil "obj = ~A.find(~A)" obj-type obj-id) ,(format nil "author_id = ~A" author-id) ,(format nil "migration_user_id = ~A" *migration-user-id*) ,@(when update-created-at '("obj.created_at = action_time")) ,@(when update-updated-at '("obj.updated_at = action_time")) ,@(when update-closed-at '("obj.closed_at = action_time")) ,@(when author-field (list (format nil "obj.~A = author_id" author-field))) ,@(when (or update-metrics-created-at update-metrics-updated-at update-metrics-latest-closed-at) `(,@(when update-metrics-updated-at '("obj.metrics.updated_at = action_time")) ,@(when update-metrics-created-at '("obj.metrics.created_at = action_time")) ,@(when update-metrics-latest-closed-at '("obj.metrics.latest_closed_at = action_time")) "obj.metrics.save")) ,@(when update-label-events '("obj.resource_label_events.where('created_at > ?', action_time).update(created_at: action_time, user_id: author_id)")) ,@(when update-system-notes (list (format nil "obj.notes.where(system: true, author_id: ~A).where('created_at > ?', action_time).update(created_at: action_time, updated_at: action_time, author_id: ~A)" *migration-user-id* author-id))) ,@(when update-event `(,(rails-wait-for "ev" find-ev-command) ,(format nil "ev.author_id = ~A" author-id) "ev.created_at = action_time" "ev.updated_at = action_time" "ev.save")) ,@(when update-resource-state-events '("obj.resource_state_events.where('created_at > ?', action_time).update(user_id: author_id, created_at: action_time)")) "obj.save")))) (defun subscribe-users-to-object (obj-type obj-id users) (let ((filtered-users (remove-if (lambda (u) (not (forgerie-core:user-username u))) users))) (when filtered-users (rails-commands-with-recovery (cons (format nil "obj = ~A.find(~A)" obj-type obj-id) (mapcar (lambda (u) (format nil "obj.subscribe(User.find_by_username('~A'))" (forgerie-core:user-username (ensure-user-created u)))) filtered-users)))))) (defun mapped-item-reference (project-id item) (let* ((type (car item)) (c (ccase type (:snippet "$") (:ticket "#") (:merge-request "!"))) (original-id (parse-integer (cadr item))) (mi (find-mapped-item type original-id))) (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_with_namespace) c (or (mapped-item-iid mi) (mapped-item-id mi))))))) (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-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) (mapped-item-reference project-id item)) ((mapped-item-p item :merge-request) (mapped-item-reference project-id item)) ((mapped-item-p item :snippet) (mapped-item-reference project-id item)) ((find item *note-mapping-skips* :test #'equalp) (fallback-mapped-item-text item)) (*notes-mode* (fallback-mapped-item-text 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)) (let ((created-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))))) (update-object-author-date "Note" (getf created-note :id) (forgerie-core:note-author note) (forgerie-core:note-date note) :author-field "author" :update-created-at t :update-updated-at t :update-event t) created-note)))))) (defvar *file-transfer-temporary-dir* nil) (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-uploaded (forgerie-core:file-id file)) (update-file-mapping (:file-uploaded (forgerie-core:file-id file)) (progn (unless *file-transfer-temporary-dir* (setf *file-transfer-temporary-dir* (format nil "~A_file-upload-tmp/" forgerie-core:*working-directory*)) (ensure-directories-exist *file-transfer-temporary-dir*)) (let ((link-path (merge-pathnames (sb-ext:parse-native-namestring (forgerie-core:file-name file)) *file-transfer-temporary-dir*))) (unwind-protect (progn (sb-posix:symlink (pathname (forgerie-core:file-location file)) link-path) (handler-case (post-request (format nil "projects/~A/uploads" project-id) `(("file" . ,link-path))) (http-error (e) (cond ((= 413 (http-error-code e)) `(:markdown ,(fallback-file-text file))) (t (error e)))))) (ignore-errors (delete-file link-path))))))) (retrieve-mapping :file-uploaded (forgerie-core:file-id file)))) +(defun create-label-in-default-group (label) + (when *default-group* + (when-unmapped-with-update (:default-group-label label) + (handler-case + (post-request + (format nil "groups/~A/labels" (quri:url-encode (getf *default-group* :path))) + `(("name" . ,label) + ("color" . "azure"))) + (http-error (e) + (cond + ((= 409 (http-error-code e)) + (get-request + (format nil "groups/~A/labels/~A" (quri:url-encode (getf *default-group* :path)) (quri:url-encode label)))) + (t (error e)))))))) + (defun format-labels-for-post (issue-labels) - (format nil "~{~A~^,~}" - (remove-if - (lambda (label) - (find label '("state:open" "state:resolved") :test #'string=)) - issue-labels))) + (let + ((filtered-labels + (remove-if + (lambda (label) + (find label '("state:open" "state:resolved") :test #'string=)) + issue-labels))) + (when *create-labels-in-default-group* + (mapc #'create-label-in-default-group filtered-labels)) + (format nil "~{~A~^,~}" filtered-labels))) (defvar *ticket-labels-map* nil) (defvar *ticket-state-map* nil) (defun create-ticket-action (gl-ticket vc-ticket action) (when-unmapped (:ticket-action (forgerie-core:ticket-action-id action)) (let* ((action-type (forgerie-core:ticket-action-type action)) (new-value (forgerie-core:ticket-action-newvalue action)) (author-username (forgerie-core:user-username (ensure-user-created (forgerie-core:ticket-action-author action)))) (action-date-str (to-iso-8601 (forgerie-core:ticket-action-date action))) (ticket-map-id (getf gl-ticket :id)) (known-state (or (cdr (assoc ticket-map-id *ticket-state-map*)) (getf gl-ticket :state))) (known-labels (or (cdr (assoc ticket-map-id *ticket-labels-map*)) (getf gl-ticket :labels)))) (labels ((changes-add-label (label &optional (filter-fn (lambda (l) nil))) (let ((new-labels (cons label (remove-if filter-fn known-labels)))) (setf *ticket-labels-map* (acons ticket-map-id new-labels *ticket-labels-map*)) `("labels" . ,(format-labels-for-post new-labels)))) (changes-for-close (&key (state "resolved")) `(,(changes-add-label (format nil "state:~A" state) (lambda (label) (str:starts-with? "state:" label))) ,@(when (string= known-state "opened") (setf *ticket-state-map* (acons ticket-map-id "closed" *ticket-state-map*)) '(("state_event" . "close"))))) (change-ticket (ticket-changes &key update-event) (when ticket-changes (put-request (format nil "projects/~A/issues/~A" (getf gl-ticket :project_id) (getf gl-ticket :iid)) ticket-changes) (update-object-author-date "Issue" (getf gl-ticket :id) (forgerie-core:ticket-action-author action) (forgerie-core:ticket-action-date action) :author-field "updated_by" :update-updated-at t :update-closed-at (find '("state_event" . "close") ticket-changes :test #'equalp) :update-event update-event :update-resource-state-events update-event :update-label-events t :update-system-notes t)))) (case action-type (:open (change-ticket `(,(changes-add-label (format nil "state:~A" new-value) (lambda (label) (str:starts-with? "state:" label))) ,@(when (string= known-state "closed") (setf *ticket-state-map* (acons ticket-map-id "opened" *ticket-state-map*)) '(("state_event" . "reopen")))) :update-event (string= known-state "closed"))) (:closed (change-ticket (changes-for-close :state new-value) :update-event (string= known-state "opened"))) (:mergedinto ;; TODO: add note or ticket link for the ticket we've merged into (change-ticket (changes-for-close :state "duplicate") :update-event (string= known-state "opened"))) (:title (change-ticket `(("title" . ,new-value)))) (:description (change-ticket `(("description" . ,(process-note-text (append new-value (list (ticket-suffix vc-ticket))) (getf gl-ticket :project_id)))))) (:priority (change-ticket (list (changes-add-label (format nil "priority:~A" new-value) (lambda (label) (str:starts-with? "priority:" label)))))) (:reassign (let ((assignee-id (if new-value (getf (retrieve-mapping :user (forgerie-core:user-username (ensure-user-created new-value))) :id)))) (change-ticket `(("assignee_ids" . ,(format nil "~A" (if assignee-id assignee-id 0))))))) (:subscribers) (otherwise (error "Unknown ticket action ~A" action-type))))) (update-mapping (:ticket-action (forgerie-core:ticket-action-id action))))) (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 (or (find-mapped-item :ticket (forgerie-core:ticket-id ticket)) (project-for-ticket ticket vc-repositories)) (when-unmapped (:ticket-completed (forgerie-core:ticket-id ticket)) (let* ((mapped-ticket (find-mapped-item :ticket (forgerie-core:ticket-id ticket))) (project-id (if mapped-ticket (mapped-item-project-id mapped-ticket) (getf (project-for-ticket ticket vc-repositories) :id))) (actions-and-notes (stable-sort (copy-list (append (forgerie-core:ticket-notes ticket) (forgerie-core:ticket-actions ticket))) #'< :key (lambda (action-or-note) (ctypecase action-or-note (forgerie-core:note (forgerie-core:note-date action-or-note)) (forgerie-core:ticket-action (forgerie-core:ticket-action-date action-or-note)))))) (first-description-action (find-if (lambda (action-or-note) (typecase action-or-note (forgerie-core:ticket-action (equalp (forgerie-core:ticket-action-type action-or-note) :description)))) actions-and-notes)) (orig-description (if first-description-action (forgerie-core:ticket-action-newvalue first-description-action) (forgerie-core:ticket-description ticket))) (first-title-action (find-if (lambda (action-or-note) (typecase action-or-note (forgerie-core:ticket-action (equalp (forgerie-core:ticket-action-type action-or-note) :title)))) actions-and-notes)) (orig-title (if first-title-action (forgerie-core:ticket-action-newvalue first-title-action) (forgerie-core:ticket-title ticket)))) (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" . ,orig-title) ("labels" . ,(format-labels-for-post (mapcar #'forgerie-core:project-name (forgerie-core:ticket-projects ticket)))) ("confidential" . ,(if (forgerie-core:ticket-confidential ticket) "true" "false")) ("description" . ,(process-note-text (append orig-description (list (ticket-suffix ticket))) project-id)))))) (when (/= (getf gl-ticket :iid) (forgerie-core:ticket-id ticket)) (forgerie-core:add-mapping-error :ticket-iid-not-set (forgerie-core:ticket-id ticket) (format nil "Ticket iid ignored by gitlab for ~A (~A)" (forgerie-core:ticket-id ticket) (getf (getf gl-ticket :references) :full)))) (update-object-author-date "Issue" (getf gl-ticket :id) (forgerie-core:ticket-author ticket) (forgerie-core:ticket-date ticket) :update-created-at t :update-updated-at t :author-field "author" :update-event t :update-metrics-created-at t :update-metrics-updated-at t :update-label-events t) (subscribe-users-to-object "Issue" (getf gl-ticket :id) (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 (mapped-item-iid (find-mapped-item :ticket (forgerie-core:ticket-id ticket))))))) (mapc (lambda (action-or-note) (typecase action-or-note (forgerie-core:note (create-note (getf gl-ticket :project_id) "issues" (getf gl-ticket :iid) action-or-note)) (forgerie-core:ticket-action (create-ticket-action gl-ticket ticket action-or-note)) (t (error "Unknown type")))) actions-and-notes) (when (find :ticket *write-completed-mappings*) (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))) (let ((post-result (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))))))) (when post-result (rails-commands-with-recovery (apply #'append (cons (list (format nil "l = IssueLink.find_by(:source_id => ~A, :target_id => ~A)" (getf gl-ticket :id) (getf gl-linked-ticket :id)) "date = [l.source.created_at, l.target.created_at].max" "l.created_at = l.updated_at = date" "l.save") (mapcar (lambda (src dest) (list (rails-wait-for "n" (format nil (concatenate 'string "Note.where('note like ?', 'marked this issue as related to %#~A')" ".where(system: true, noteable_id: ~A, noteable_type: 'Issue').take") (getf dest :iid) (getf src :id))) "n.created_at = n.updated_at = date" "n.save")) (list gl-ticket gl-linked-ticket) (list gl-linked-ticket gl-ticket)))))))))) (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 email-verified-to-string (email) (if (forgerie-core:email-is-verified email) "true" "false")) (defun create-user (user) (if (forgerie-core:user-username user) (when-unmapped-with-update (:user (forgerie-core:user-username user)) (let ((user-on-gitlab (first (get-request "users" :parameters `(("username" . ,(forgerie-core:user-username user))))))) (if user-on-gitlab ;; user exists user-on-gitlab ;; create user, handling avatar + emails (let* ((avatar (forgerie-core:user-avatar user)) (avatar (when avatar (if (> (* 1024 200) (forgerie-core:file-size avatar)) avatar (progn (forgerie-core:add-mapping-error :user-avatar-too-big (forgerie-core:user-username user) (format nil "User ~A's avatar is ~A, which is bigger than the allowed 200k" (forgerie-core:user-username user) (forgerie-core:file-size avatar))))))) (avatar-filename (when avatar (if (find-if (lambda (ext) (cl-ppcre:scan (format nil "~A$" ext) (forgerie-core:file-name avatar))) (list "png" "jpg" "jpeg" "gif" "bmp" "tiff" "ico" "webp")) (forgerie-core:file-name avatar) (format nil "~A.~A" (forgerie-core:file-name avatar) (cond ((cl-ppcre:scan "^image/" (forgerie-core:file-mimetype avatar)) (subseq (forgerie-core:file-mimetype avatar) 6)) (t (error (format nil "Don't know profile mimetype ~A" (forgerie-core:file-mimetype avatar))))))))) (avatar-filepath-with-mimetype (when avatar-filename (format nil "~A.~A" (forgerie-core:file-location avatar) (subseq (forgerie-core:file-mimetype avatar) 6)))) (gl-user (progn (when avatar-filepath-with-mimetype (uiop:copy-file (forgerie-core:file-location avatar) avatar-filepath-with-mimetype)) ;; using the new make-request implementation (dexador) does not work ;; so use the previous slower implementation which works (post-request "users" `(("name" . ,(forgerie-core:user-name user)) ("email" . ,(forgerie-core:email-address (forgerie-core:user-primary-email user))) ("reset_password" . "true") ("skip_confirmation" . ,(email-verified-to-string (forgerie-core:user-primary-email user))) ("username" . ,(forgerie-core:user-username user)) ,@(when (forgerie-core:user-admin user) '(("admin" . "true"))) ,@(when avatar-filepath-with-mimetype `(("avatar" . ,(pathname avatar-filepath-with-mimetype))))))))) (mapcar (lambda (email) (post-request (format nil "/users/~A/emails" (getf gl-user :id)) `(("email" . ,(forgerie-core:email-address email)) ("skip_confirmation" . ,(email-verified-to-string email))))) (remove-if #'forgerie-core:email-is-primary (forgerie-core:user-emails user))) gl-user)))))) (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-gitlab-project 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 vc-repository) (let ((working-path (format nil "~Alocal-checkouts/~A" *working-directory* (getf project :path)))) (when (not (probe-file working-path)) (ensure-directories-exist (format nil "~A/" working-path)) (git-cmd project "clone" (forgerie-core:vc-repository-git-location vc-repository) ".") (git-cmd project "remote" "add" "gitlab" (getf project :ssh_url_to_repo)) (git-cmd project "fetch" "gitlab" "refs/heads/generated-differential-*:refs/heads/generated-differential-*") (git-cmd project "fetch" "gitlab") (when (/= 0 (git-cmd-code project "merge-base" "--is-ancestor" "HEAD" (format nil "gitlab/~A" (forgerie-core:vc-repository-default-branch-name vc-repository)))) (error (format nil "~A on phabricator is not ancestor of gitlab; merge needed" (getf project :path)))) (git-cmd project "push" "gitlab" "--tags")) (git-cmd-code project "am" "--abort") (git-cmd project "reset" "--hard" "HEAD") (git-cmd project "clean" "-fdx"))) (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))))) (when (first (getf discussion :notes)) (update-object-author-date "DiffNote" (getf (first (getf discussion :notes)) :id) ;; get the id of the first note in the discussion, created by the previous post-request (forgerie-core:merge-request-change-comment-author comment) (forgerie-core:merge-request-change-comment-date comment) :author-field "author" :update-created-at t :update-updated-at t :update-event t)) (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)))) (let ((diff-note (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))))) (update-object-author-date "DiffNote" (getf diff-note :id) (forgerie-core:merge-request-change-comment-author comment) (forgerie-core:merge-request-change-comment-date comment) :author-field "author" :update-created-at t :update-updated-at t :update-event t))))) (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 merge-request-action-text (action) (ccase (forgerie-core:merge-request-action-type action) (:abandon "abandoned") (:close "merged") (:accept "accepted") (:reject "returned for changes"))) (defvar *mr-state-map* nil) (defun record-mr-action (gl-mr forgerie-mr action) (when-unmapped (:merge-request-action (forgerie-core:merge-request-action-id action)) (flet ((update-last-mr-approval (user-id) (rails-commands-with-recovery (list (format nil "action_time = Time.parse(\"~A\")" (to-iso-8601 (forgerie-core:merge-request-action-date action))) (format nil "mr = MergeRequest.find(~A)" (getf gl-mr :id)) (format nil "approval = mr.approvals.where(user_id: ~A).order(created_at: 'DESC').first" *migration-user-id*) "approval.created_at = action_time" "approval.updated_at = action_time" (format nil "approval.user_id = ~A" user-id) "approval.save"))) (update-mr-state (newstate) (setf *mr-state-map* (acons (getf gl-mr :id) newstate *mr-state-map*))) (get-mr-state () (or (cdr (assoc (getf gl-mr :id) *mr-state-map*)) (getf gl-mr :state))) (write-action-note () (create-note (getf gl-mr :project_id) "merge_requests" (getf gl-mr :iid) (forgerie-core:make-note :id (format nil "NoteFor~A" (forgerie-core:merge-request-action-id action)) :author (forgerie-core:merge-request-action-author action) :date (forgerie-core:merge-request-action-date action) :text (list (format nil "Merge request was ~A" (merge-request-action-text action))))))) (let* ((action-username (forgerie-core:user-username (ensure-user-created (forgerie-core:merge-request-action-author action)))) (action-user-id (if action-username (getf (retrieve-mapping :user action-username) :id) *migration-user-id*))) (case (forgerie-core:merge-request-action-type action) ((:abandon :close) ;; Write a synthetic note explaining why the MR is closed (write-action-note) ;; Close the MR (when (string= (get-mr-state) "opened") (put-request (format nil "/projects/~A/merge_requests/~A" (getf gl-mr :project_id) (getf gl-mr :iid)) '(("state_event" . "close"))) (update-object-author-date "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-action-author action) (forgerie-core:merge-request-action-date action) :update-created-at nil :update-updated-at t :author-field "updated_by" :update-metrics-latest-closed-at t :update-metrics-updated-at t :update-resource-state-events t :update-event t) (update-mr-state "closed"))) (:ready ;; Reopen the MR (when (string= (get-mr-state) "closed") (put-request (format nil "/projects/~A/merge_requests/~A" (getf gl-mr :project_id) (getf gl-mr :iid)) '(("state_event" . "reopen"))) (update-object-author-date "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-action-author action) (forgerie-core:merge-request-action-date action) :update-created-at nil :update-updated-at t :author-field "updated_by" :update-metrics-updated-at t :update-resource-state-events t :update-event t) (update-mr-state "opened"))) (:accept (write-action-note) (let ((post-result (handler-case (post-request (format nil "/projects/~A/merge_requests/~A/approve" (getf gl-mr :project_id) (getf gl-mr :iid)) nil) (http-error (e) (cond ((= 401 (http-error-code e)) nil) ((= 403 (http-error-code e)) nil) (t (error e))))))) (when post-result (update-object-author-date "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-action-author action) (forgerie-core:merge-request-action-date action) :update-system-notes t :update-event t) (update-last-mr-approval action-user-id)))) (:reject (write-action-note) (rails-commands-with-recovery (list (format nil "mr = MergeRequest.find(~A)" (getf gl-mr :id)) (format nil "user = User.find_by_username('~A')" action-username) (format nil "action_time = Time.parse('~A')" (to-iso-8601 (forgerie-core:merge-request-action-date action))) "::MergeRequests::RemoveApprovalService.new(project: mr.project, current_user: user).execute(mr)" "mr.notes.where(system: true, author: user).where('created_at > ?', action_time).update(created_at: action_time, updated_at: action_time)")))))) (update-mapping (:merge-request-action (forgerie-core:merge-request-action-id action))))) (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* ((vc-repo (forgerie-core:merge-request-vc-repository mr)) (project (find-gitlab-project vc-repo))) (when-unmapped (:merge-request (forgerie-core:merge-request-id mr)) (when (not project) (error "Could not find project with slug: ~A" (forgerie-core:vc-repository-slug vc-repo))) (when forgerie-core:*debug* (format t "Processing merge request ~A~%" (forgerie-core:merge-request-id mr))) ; 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)) (create-local-checkout project vc-repo) (git-cmd project "branch" "-f" (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 "switch" "-C" (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)))) (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" "-f" "gitlab" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))) (when (string/= (forgerie-core:vc-repository-default-branch-name vc-repo) (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr))) (git-cmd project "push" "-f" "gitlab" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr)))) (update-mapping (:merge-request (forgerie-core:merge-request-id mr)) (let ((gl-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)))))) (update-object-author-date "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-author mr) (forgerie-core:merge-request-date mr) :author-field "author" :update-created-at t :update-updated-at t :update-event t :update-metrics-created-at t :update-metrics-updated-at t) gl-mr))) (when *notes-mode* (let ((gl-mr (retrieve-mapping :merge-request (forgerie-core:merge-request-id mr))) (actions-and-notes (stable-sort (copy-list (append (forgerie-core:merge-request-notes mr) (forgerie-core:merge-request-actions mr))) #'< :key (lambda (action-or-note) (ctypecase action-or-note (forgerie-core:note (forgerie-core:note-date action-or-note)) (forgerie-core:merge-request-action (forgerie-core:merge-request-action-date action-or-note))))))) (mapc (lambda (change) (create-change-comments gl-mr change)) (forgerie-core:merge-request-changes mr)) (mapc (lambda (action-or-note) (ctypecase action-or-note (forgerie-core:note (create-note (getf gl-mr :project_id) "merge_requests" (getf gl-mr :iid) action-or-note)) (forgerie-core:merge-request-action (record-mr-action gl-mr mr action-or-note)))) actions-and-notes) (when (eql :closed (forgerie-core:merge-request-type mr)) (when-unmapped-with-update (:merge-request-branches-deleted (forgerie-core:merge-request-id mr)) (progn (git-cmd-code project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))) (git-cmd-code project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr))) nil))) (when (find :merge-request *write-completed-mappings*) (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) (trivial-utf-8:utf-8-bytes-to-string 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) ("description" . ,(when *snippet-suffix* (funcall *snippet-suffix* snippet))) ("visibility" . ,(if (forgerie-core:snippet-private snippet) "private" "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-commands-with-recovery (list (format nil "s = Snippet.find(~A)" (getf gl-snippet :id)) (format nil "u = User.find_by_username(\"~A\")" (forgerie-core:user-username (ensure-user-created (forgerie-core:snippet-author snippet)))) (format nil "s.created_at = Time.parse(\"~A\")" (to-iso-8601 (forgerie-core:snippet-date snippet))) "s.author = u" "s.save")) (when (find :snippet *write-completed-mappings*) (update-mapping (:snippet-completed (forgerie-core:snippet-id snippet)) gl-snippet)))))))))))