diff --git a/src/main/core/errors.lisp b/src/main/core/errors.lisp index d47e6c8..8353bb3 100644 --- a/src/main/core/errors.lisp +++ b/src/main/core/errors.lisp @@ -1,43 +1,52 @@ (in-package #:forgerie-core) (defvar *log-mapping-errors* t) (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*)) (defun mapping-errors () (or *mapping-errors* - (setf *mapping-errors* (when (probe-file (mapping-errors-file)) (with-open-file (str (mapping-errors-file)) (read str)))))) + (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)))) - (setf - *mapping-errors* - (cons - (make-mapping-error - :error-type error-type - :object-id object-id - :description description) - (mapping-errors))) - (with-open-file (str (mapping-errors-file) :direction :output :if-exists :supersede) - (format str "~S" (mapping-errors)))) - (forgerie-core:check-for-stop)) + (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/gitlab/base.lisp b/src/main/gitlab/base.lisp index ef4372e..bcc2958 100644 --- a/src/main/gitlab/base.lisp +++ b/src/main/gitlab/base.lisp @@ -1,29 +1,37 @@ (in-package #:forgerie-gitlab) (defvar *server-address* nil) (defvar *private-token* nil) (defvar *working-directory* "/tmp/forgerie/gitlab/") ; This is a plist of the form: ; '(:name :slug ) (defvar *default-project* nil) (defvar *ssh-public-key* nil) ; This is of the form ; '(:name :path ) (defvar *default-group* nil) ; For development only. Will limit all exporting to things having ; to do with the project with the name provided. (defvar *single-project* nil) ; The args (host and command are normal) for the ssh command to ; boot the rails console. Sometimes this is localhost. Keys ; have to be set up. (defvar *rails-console-ssh-args* nil) ; A 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) + +; 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) + +; If non nil, will not create the default project. If it's already created, will +; write nothing to it +(defvar *omit-default-project* nil) diff --git a/src/main/gitlab/export.lisp b/src/main/gitlab/export.lisp index 9d24abc..640a119 100644 --- a/src/main/gitlab/export.lisp +++ b/src/main/gitlab/export.lisp @@ -1,780 +1,795 @@ (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-users (users) - (remove nil - (mapcar - (lambda (user) - (cond - ((< (length (forgerie-core:user-username user)) 2) - (forgerie-core:add-mapping-error +(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))) - users))) + (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 () - (find-project-by-name (getf *default-project* :name))) + (when (not *omit-default-project*) + (find-project-by-name (getf *default-project* :name)))) (defun create-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") - ("path" . ,(getf *default-project* :path))))))) + (when (not *omit-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") + ("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))))))) (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 #'create-user (validate-users (getf data :users))) + (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))) (add-users-to-projects vc-repositories (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)) (post-request (format nil "/projects/~A/repository/commits/~A/discussions" (getf project :id) (forgerie-core:commit-sha commit)) `(("body" . ,body))) (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") ("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 (forgerie-core:note-author 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 note-mapped (note) (find-mapped-item :find-mapped-item (forgerie-core:note-id note))) (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-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)) + (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 (forgerie-core:ticket-description 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* + (notevery #'identity (mapcar #'note-mapped (forgerie-core:ticket-notes 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 (forgerie-core:ticket-assignee ticket))) :id))))) - ("confidential" . ,(if (forgerie-core:ticket-confidential ticket) "true" "false")) - ("description" . ,(process-note-text (forgerie-core:ticket-description ticket) project-id)) - ("created_at" . ,(to-iso-8601 (forgerie-core:ticket-date ticket)))) - :sudo (forgerie-core:user-username (forgerie-core:ticket-author ticket))))) + ((gl-ticket (get-request (format nil "projects/~A/issues/~A" project-id (forgerie-core:ticket-id 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 u))) - (forgerie-core:ticket-subscribers ticket)) - (update-mapping (:ticket (forgerie-core:ticket-id ticket)) gl-ticket))) - (when - (and - *notes-mode* - (notevery #'identity (mapcar #'note-mapped (forgerie-core:ticket-notes 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))))))))) + (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-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)))))) + (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) - (when-unmapped (:user-admin-set (forgerie-core:user-username 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 (forgerie-core:user-admin user) "true" "false"))))) - (update-mapping (:user-admin-set (forgerie-core:user-username user))))) + `(("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)))) - users))) + (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=)))) - (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))))) + (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 (forgerie-core:merge-request-change-comment-author 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 (forgerie-core:merge-request-change-comment-author 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 (forgerie-core:merge-request-author 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-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 (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))))))))) + (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 83c89a7..20112e6 100644 --- a/src/main/gitlab/package.lisp +++ b/src/main/gitlab/package.lisp @@ -1,2 +1,5 @@ (defpackage #:forgerie-gitlab (:use :cl) - (:export #:*private-token* #:*server-address* #:*default-project* #:*working-directory* #:*ssh-public-key* #:*default-group* #:*single-project* #:*rails-console-ssh-args* #:*merge-request-suffix*)) + (:export + #:*private-token* #:*server-address* #:*default-project* #:*working-directory* #:*ssh-public-key* + #:*default-group* #:*single-project* #:*rails-console-ssh-args* #:*merge-request-suffix* + #:*limit-to-active-users* #:*omit-default-project*)) diff --git a/src/main/gitlab/utils.lisp b/src/main/gitlab/utils.lisp index fcb3b64..7cd1c06 100644 --- a/src/main/gitlab/utils.lisp +++ b/src/main/gitlab/utils.lisp @@ -1,229 +1,239 @@ (in-package #:forgerie-gitlab) (define-condition http-error nil ((code :initarg :code :reader http-error-code) (path :initarg :path :reader http-error-path) (method :initarg :method :reader http-error-method) (parameters :initarg :parameters :reader http-error-parameters) (resp :initarg :resp :reader http-error-resp)) (:report (lambda (condition stream) (format stream "Http error code: ~A, resp: ~A" (http-error-code condition) (http-error-resp condition))))) (defun convert-js-to-plist (jsown) (cond ((not (listp jsown)) jsown) ((eql :obj (car jsown)) (apply #'append (mapcar (lambda (keyword) (list (intern (string-upcase keyword) :keyword) (convert-js-to-plist (jsown:val jsown keyword)))) (jsown:keywords jsown)))) ((listp jsown) (mapcar #'convert-js-to-plist jsown)) (t (error "Don't know how to handle ~S" jsown)))) (defun make-request (path method parameters &key sudo) (let ((parameters (append (when sudo (list (cons "sudo" sudo))) parameters))) (multiple-value-bind (body code headers uri stream must-close reason-phrase) (drakma:http-request (format nil "~A/api/v4/~A" *server-address* path) :method method :parameters parameters :additional-headers (list (cons "PRIVATE-TOKEN" *private-token*))) (when (not (= 304 code)) ; 304s are empty, and can be ignored (let ((resp (convert-js-to-plist (jsown:parse (map 'string #'code-char body))))) (when forgerie-core:*debug* (format t "*****************~%Gitlab request ~A (~A): ~S~%Status Code: ~S~%Response: ~S~%" path method parameters code resp)) (when (not (<= 200 code 299)) (error (make-instance 'http-error :code code :path path :method method :parameters parameters :resp resp ))) resp))))) (defun git-cmd (project cmd &rest args) (forgerie-core:git-cmd (format nil "~A~A" *working-directory* (getf project :path)) cmd args)) (defun git-cmd-code (project cmd &rest args) (forgerie-core:git-cmd (format nil "~A~A" *working-directory* (getf project :path)) cmd args :error nil)) (defun get-request (path &key parameters sudo) (make-request path :get parameters :sudo sudo)) (defun post-request (path parameters &key sudo) (make-request path :post parameters :sudo sudo)) (defun delete-request (path) (make-request path :delete nil)) (defun put-request (path parameters &key sudo) (make-request path :put parameters :sudo sudo)) (defun merge-request-suffix (mr) (if *merge-request-suffix* (funcall *merge-request-suffix* mr) "")) (defun to-iso-8601 (d) (multiple-value-bind (sec min hr date month year) (decode-universal-time d 0) (format nil "~A-~2,,,'0@A-~2,,,'0@AT~2,,,'0@A:~2,,,'0@A:~2,,,'0@AZ" year month date hr min sec))) (defstruct mapped-item type original-id id iid project-id) (defstruct mapped-file type original-id response) (defun mapping-file () (format nil "~A/mapping" *working-directory*)) (defvar *mapping* nil) (defun mapping () (or *mapping* - (setf *mapping* (when (probe-file (mapping-file)) (with-open-file (str (mapping-file)) (read str)))))) + (setf *mapping* + (when + (probe-file (mapping-file)) + (with-open-file (str (mapping-file)) + (loop :for obj := (read str nil) + :while obj + :collect obj)))))) (defun find-mapped-item (type original-id) (find (list type original-id) (mapping) :key (lambda (mi) (typecase mi (mapped-item (list (mapped-item-type mi) (mapped-item-original-id mi))) (mapped-file (list (mapped-file-type mi) (mapped-file-original-id mi))))) :test #'equalp)) (defmacro when-unmapped ((type original-id) &rest body) `(when (not (find-mapped-item ,type ,original-id)) ,@body)) (defmacro when-unmapped-with-update ((type original-id) &rest body) `(when-unmapped (,type ,original-id) (update-mapping (,type ,original-id) ,@body))) (defmacro update-mapping ((type original-id) &rest body) (let ((result (gensym)) - (str (gensym))) - `(let - ((,result ,@body)) - (setf - *mapping* - (cons + (str (gensym)) + (mapped-item (gensym))) + `(let* + ((,result ,@body) + (,mapped-item (make-mapped-item :type ,type :original-id ,original-id :id (getf ,result :id) :iid (getf ,result :iid) - :project-id (getf ,result :project_id)) + :project-id (getf ,result :project_id)))) + (setf + *mapping* + (cons + ,mapped-item (mapping))) - (with-open-file (,str (mapping-file) :direction :output :if-exists :supersede) - (format ,str "~S" (mapping))) + (with-open-file (,str (mapping-file) :direction :output :if-exists :append :if-does-not-exist :create) + (format ,str "~S" ,mapped-item)) (forgerie-core:check-for-stop) ,result))) (defmacro update-file-mapping ((type original-id) &rest body) (let ((result (gensym)) - (str (gensym))) - `(let - ((,result ,@body)) - (setf - *mapping* - (cons + (str (gensym)) + (mapped-item (gensym))) + `(let* + ((,result ,@body) + (,mapped-item (make-mapped-file :type ,type :original-id ,original-id - :response ,result) - (mapping))) - (with-open-file (,str (mapping-file) :direction :output :if-exists :supersede) - (format ,str "~S" (mapping))) + :response ,result))) + (setf + *mapping* + (cons ,mapped-item (mapping))) + (with-open-file (,str (mapping-file) :direction :output :if-exists :append :if-does-not-exist :create) + (format ,str "~S" ,mapped-item)) (forgerie-core:check-for-stop) ,result))) (defun retrieve-mapping (type original-id) (let ((mi (find-mapped-item type original-id))) (when (not mi) (error "Failed to retrieve mapping for ~S" (list type original-id))) (typecase mi (mapped-item (if (mapped-item-project-id mi) (get-request (format nil "projects/~A/~A/~A" (mapped-item-project-id mi) (case (mapped-item-type mi) (:snippet "snippets") (:merge-request "merge_requests") (:ticket "issues")) (or (mapped-item-iid mi) (mapped-item-id mi)))) (get-request (format nil "~A/~A" (case (mapped-item-type mi) (:user "users")) (or (mapped-item-iid mi) (mapped-item-id mi)))))) (mapped-file (mapped-file-response mi))))) ; This is for development, so that we can export only one project ; and all the tickets/prs associated with it. (defmacro single-project-check (name &rest body) `(when (or (not *single-project*) (string= *single-project* ,name)) ,@body)) (defvar *rails-connection* nil) ; Each command needs to be a one liner standalone (defun rails-command (cmd) (when (not *rails-connection*) (setf *rails-connection* (sb-ext:run-program "/usr/bin/ssh" *rails-console-ssh-args* :input :stream :output :stream :wait nil)) (format (sb-ext:process-input *rails-connection*) "0~%" cmd) (force-output (sb-ext:process-input *rails-connection*)) (loop for line = (read-line (sb-ext:process-output *rails-connection*)) do (when forgerie-core:*debug* (format t "Booting: ~A~%" line)) until (string= line "0"))) ; The reason we append a 0 on the end of this, is because irb does some funky ; things, expecting you to be running from a terminal with a tty. So just ; doing a 0 and then checking for that output means we'll A) know when the ; command is done and B) not run into these no tty errors. (format (sb-ext:process-input *rails-connection*) "~A;0~%" cmd) (force-output (sb-ext:process-input *rails-connection*)) (let ((line (read-line (sb-ext:process-output *rails-connection*)))) (loop for line = (read-line (sb-ext:process-output *rails-connection*)) do (when forgerie-core:*debug* (format t "Running: ~A~%" line)) until (string= line "0")))) diff --git a/src/main/phabricator/base.lisp b/src/main/phabricator/base.lisp index ace1e09..4197861 100644 --- a/src/main/phabricator/base.lisp +++ b/src/main/phabricator/base.lisp @@ -1,32 +1,38 @@ (in-package #:forgerie-phabricator) (defvar *database-password* nil) ; This needs to be some http or https that's accessible from forges that are importing. ; Usually you can just link the phabricators repositories directory to some http or https ; that the gitlab instance can access. (defvar *git-location* nil) ; These are differentials that can't be migrated, and need to be handled manually ; if at all. (defvar *revisions-to-skip* nil) ; Pastes that can't be migrated, and will need to be handled manually (defvar *pastes-to-skip* nil) ; This is the http location of the phabricator server (defvar *phabricator-location* nil) ; The local filesystem storage location (defvar *storage-location* nil) (defvar *working-directory* "/tmp/forgerie/phabricator") ; 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) ; List of spaces for tasks that should be marked as confidential (defvar *confidential-space-phids* nil) + +; 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) diff --git a/src/main/phabricator/import.lisp b/src/main/phabricator/import.lisp index 9e91e44..065b5c7 100644 --- a/src/main/phabricator/import.lisp +++ b/src/main/phabricator/import.lisp @@ -1,955 +1,969 @@ (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: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 "_"))) (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 (query "select id, phid, repositoryslug, name, localpath from phabricator_repository.repository where repositoryslug is not null"))) + ((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)))) -(defvar *captured-files* nil) - -(defun capture-file (id) - (setf - *captured-files* - (remove-duplicates - (cons id *captured-files*) - :test #'string=))) - (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)) - (cached "everything" "captured-files" *captured-files*)))) + (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")) (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))) (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)))) - (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))))) + (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) (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))) + :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))) + :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))))) + :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 568088d..3730a04 100644 --- a/src/main/phabricator/package.lisp +++ b/src/main/phabricator/package.lisp @@ -1,2 +1,6 @@ (defpackage #:forgerie-phabricator (:use :cl) - (:export #:*database-password* #:*git-location* #:*revisions-to-skip* #:*phabricator-location* #:*project-assignment-overrides* #:*working-directory* #:*repository-overrides* #:*pastes-to-skip* #:*user-overrides* #:*storage-location* #:*confidential-space-phids*)) + (:export + #:*database-password* #:*git-location* #:*revisions-to-skip* #:*phabricator-location* + #:*project-assignment-overrides* #:*working-directory* #:*repository-overrides* + #:*pastes-to-skip* #:*user-overrides* #:*storage-location* #:*confidential-space-phids* + #:*included-repositories*)) diff --git a/src/main/phabricator/utils.lisp b/src/main/phabricator/utils.lisp index 5fdd94b..0188391 100644 --- a/src/main/phabricator/utils.lisp +++ b/src/main/phabricator/utils.lisp @@ -1,125 +1,125 @@ (in-package #:forgerie-phabricator) (defun generate-override-csv-template (output-file) (let ((projects (get-projects)) (repositories (get-repositories))) (with-open-file (out output-file :direction :output :if-exists :supersede) (cl-csv:write-csv (cons (list "Primary Key" "Project Name" "Icon" "Color" "HashTags" "Repositories" "Repository Name") (append (mapcar (lambda (proj) (let ((associated-repos (remove-if-not (lambda (repo) (find proj (getf repo :primary-projects) :test #'equalp)) repositories))) (list (getf proj :id) (getf proj :name) (getf proj :icon) (getf proj :color) (format nil "~{#~A~^~%~}" (project-tags proj)) (format nil "~{~A~^~%~}" (mapcar (lambda (repo) (getf repo :repositoryslug)) associated-repos)) (if (= 1 (length associated-repos)) (getf (first associated-repos) :name))))) projects) (mapcar (lambda (repo) (list "" "" "" "" "" (getf repo :repositoryslug) (getf repo :name))) (remove nil repositories :test-not #'eql :key (lambda (repo) (getf repo :primary-projects)))))) :stream out)))) (defun generate-task-overide-csv (ouput-file) (labels ((repositories-with-primary-project (project repositories) (remove-if-not (lambda (repo) (find project (repository-primary-projects repo) :test #'equalp)) repositories))) (task-assignable-repositories (task repositories) (when (task-projects task) (remove nil (remove-duplicates (apply #'append (mapcar (lambda (proj) (repositories-with-primary-project proj repositories)) (task-projects task))) :test #'equalp)))) (build-row (task reason) (list (task-id task) (format nil "https://forge.softwareheritage.org/T~A" (task-id task)) (task-title task) (task-status task) (user-username (task-owner task)) (format nil "~{#~A~^%~}" (apply #'append (mapcar (lambda (proj) (project-tags proj)) (task-projects)))))))) (defun validate-tasks () (let ((tasks (get-tasks)) (repositories (get-repositories))) (with-output-to-string (out) (remove nil (cl-csv:write-csv (cons (list "Primary Key" "URL" "Title" "Status" "Assignee" "Tags" "Reason") (remove nil (mapcar (lambda (task) (let ((repos (task-assignable-repositories task repositories))) (cond ((not repos) (format t "Task with id ~A is not assignable to a repository~%" (task-id task))) ((< 1 (length repos)) (format t "Task with id ~A is assignable to multiple repositories:~%~{ * ~A~%~}" (task-id task) (mapcar #'repository-name repos)))))) tasks)))))))) (defun unix-to-universal-time (d) (+ d (encode-universal-time 0 0 0 1 1 1970 0))) (defvar *override-cache* nil) -(defmacro cached (dir id item) +(defmacro cached (dir id item &optional override-cache) (let ((cache-path (gensym)) (obj (gensym))) `(let ((,cache-path (format nil "~A/~A/~A" *working-directory* ,dir ,id))) (ensure-directories-exist ,cache-path) (if - (and (probe-file ,cache-path) (not *override-cache*)) + (and (probe-file ,cache-path) (not ,override-cache) (not *override-cache*)) (with-open-file (str ,cache-path) (read str)) (let ((,obj ,item)) (with-open-file (str ,cache-path :direction :output :if-exists :supersede) (format str "~S" ,obj)) ,obj)))))