diff --git a/src/main/core/package.lisp b/src/main/core/package.lisp index 681bc3c..7ce8061 100644 --- a/src/main/core/package.lisp +++ b/src/main/core/package.lisp @@ -1,57 +1,57 @@ (defpackage #:forgerie-core (:use :cl) (:export ; run.lisp #:run ; postmortem.lisp #:postmortem #:system-postmortem ; base.lisp #:*working-directory* #:*continue-processing* #:check-for-stop #:import-forge #:export-forge #:make-file #:file-id #:file-name #:file-mimetype #:file-location #:file-size #:make-commit #:commit-sha #:commit #:commit-parsed-comment #:make-patch #:patch-diff #:patch #:make-branch #:branch-name #:branch-commit #:make-note #:note-text #:note-author #:note-date #:note-id #:note ; user.lisp #:make-user #:user-username #:user-name #:user-emails #:make-email #:email-address #:email-is-primary #:email-is-verified #:user-primary-email #:user-admin #:user-avatar ; project.lisp #:make-project #:project-name #:project-tags ; ticket.lisp #:make-ticket #:ticket-id #:ticket-projects #:ticket-title #:ticket-notes #:ticket-author #:ticket-description #:ticket-date #:ticket-type #:ticket #:ticket-priority #:ticket-assignee #:ticket-confidential #:ticket-linked-tickets #:ticket-subscribers #:ticket-actions #:make-ticket-action #:ticket-action-id #:ticket-action-date #:ticket-action-author #:ticket-action-type #:ticket-action-newvalue #:ticket-action ; vc-repository.lisp #:make-vc-repository #:vc-repository-name #:vc-repository-slug #:vc-repository-primary-projects #:vc-repository-projects - #:vc-repository-git-location #:vc-repository-commits #:vc-repository-access-policy #:vc-repository-archived + #:vc-repository-git-location #:vc-repository-commits #:vc-repository-access-policy #:vc-repository-archived #:vc-repository-default-branch-name ; snippet.lisp #:make-snippet #:snippet-id #:snippet-title #:snippet-files #:snippet-notes #:snippet-author #:snippet-date #:snippet-private #:snippet ; merge-request.lisp #:make-merge-request #:merge-request-id #:merge-request-vc-repository #:merge-request-title #:merge-request-description #:merge-request-source-branch #:merge-request-target-branch #:merge-request-changes #:merge-request-patch #:merge-request-type #:merge-request-notes #:merge-request-author #:merge-request-date #:merge-request-actions #:merge-request #:make-merge-request-change #:merge-request-change-change #:merge-request-change-comments #:make-merge-request-change-comment #:merge-request-change-comment-new-line #:merge-request-change-comment-old-line #:merge-request-change-comment-text #:merge-request-change-comment-replies #:merge-request-change-comment-author #:merge-request-change-comment-file #:merge-request-change-comment-date #:merge-request-other-change-comments #:make-merge-request-action #:merge-request-action #:merge-request-action-id #:merge-request-action-author #:merge-request-action-date #:merge-request-action-type ; errors.lisp #:add-mapping-error #:*log-mapping-errors* #:display-mapping-error ; utils.lisp #:vc-repositories-with-primary-project #:git-cmd #:*debug* #:to-iso-8601)) diff --git a/src/main/core/vc-repository.lisp b/src/main/core/vc-repository.lisp index 62c7c32..af48cc9 100644 --- a/src/main/core/vc-repository.lisp +++ b/src/main/core/vc-repository.lisp @@ -1,28 +1,31 @@ (in-package #:forgerie-core) ; This object will eventually have things like commits, for which comments ; can get attached to, as well as branches and tags and whatnot. ; ; Also the code location.... that seems important. (defstruct vc-repository name ; Quite often, the slug will become the name slug ; Things like tickets in primary projects get added to the workspace ; in a single project per repository forget (like github) ; ; There's no restriction in core about uniqueness, or number of primary ; projects, and that's left open to the forgerie for a given forge to ; declare. primary-projects git-location projects ; repository access policy - one of :public, :internal, :private access-policy ; whether the repository is archived or not archived + + ; the repository's default branch name + default-branch-name commits) diff --git a/src/main/gitlab/export.lisp b/src/main/gitlab/export.lisp index 9a5ee73..a36eb71 100644 --- a/src/main/gitlab/export.lisp +++ b/src/main/gitlab/export.lisp @@ -1,1354 +1,1357 @@ (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-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:~%~{ * ~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-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 (mapped-item-id (find-mapped-item :group 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 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 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))))) (defmethod forgerie-core:export-forge ((forge (eql :gitlab)) data) (setf *working-directory* (format nil "~Agitlab/" forgerie-core:*working-directory*)) (forgerie-core:check-for-stop) (ensure-directories-exist *working-directory*) (when *single-project* (remove-single-project)) (create-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 (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-project-archived-status vc-repositories) (mapcar #'update-user-admin-status (validate-users (getf data :users))))) (defun add-commit-comments (vc-repository) (single-project-check (forgerie-core:vc-repository-name vc-repository) (let ((project (find-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 (mapped-item-id (find-mapped-item :group 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 "~A~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") (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 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-event-date (obj-type obj-id new-date &key extra-filter new-author) (let ((find-ev-command (format nil "Event.where(:target => ~A, :target_type => '~A').where(\"created_at > ?\", action_time)~@[~A~].order(:created_at => 'DESC').first" obj-id obj-type extra-filter))) (rails-commands-with-recovery `( ,(format nil "action_time = Time.parse(\"~A\")" (to-iso-8601 new-date)) ,(rails-wait-for "ev" find-ev-command) ,@(when new-author (list (format nil "ev.author_id = ~A" new-author))) "ev.created_at = action_time" "ev.updated_at = action_time" "ev.save")))) (defun update-updated-at (obj-type obj-id new-date &key metrics created-at latest-closed-at) (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) "obj.updated_at = action_time" ,@(when created-at '("obj.created_at = action_time")) ,@(when metrics `("obj.metrics.updated_at = action_time" ,@(when created-at '("obj.metrics.created_at = action_time")) ,@(when latest-closed-at '("obj.metrics.latest_closed_at = action_time")) "obj.metrics.save")) "obj.save"))) (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) ("created_at" . ,(to-iso-8601 (forgerie-core:note-date note)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:note-author note)))))) (update-event-date "Note" (getf created-note :id) (forgerie-core:note-date note)) 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 (pathname (format nil "~A~A" *file-transfer-temporary-dir* (forgerie-core:file-name file))))) (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 format-labels-for-post (issue-labels) (format nil "~{~A~^,~}" (remove-if (lambda (label) (find label '("state:open" "state:resolved") :test #'string=)) issue-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)) `(("updated_at" . ,action-date-str) ,@ticket-changes) :sudo author-username) (when update-event (update-event-date "Issue" (getf gl-ticket :id) (forgerie-core:ticket-action-date action)))))) (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~]]" assignee-id)))))) (: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 (project-for-ticket ticket vc-repositories) (when-unmapped (:ticket-completed (forgerie-core:ticket-id ticket)) (let* ((project (project-for-ticket ticket vc-repositories)) (project-id (getf project :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)) ("created_at" . ,(to-iso-8601 (forgerie-core:ticket-date ticket)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:ticket-author ticket)))))) (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-updated-at "Issue" (getf gl-ticket :id) (forgerie-core:ticket-date ticket) :metrics t :created-at t) (update-event-date "Issue" (getf gl-ticket :id) (forgerie-core:ticket-date ticket)) (mapc (lambda (u) (post-request (format nil "projects/~A/issues/~A/subscribe" (getf gl-ticket :project_id) (getf gl-ticket :iid)) nil :sudo (forgerie-core:user-username (ensure-user-created u)))) (forgerie-core:ticket-subscribers ticket)) (update-mapping (:ticket (forgerie-core:ticket-id ticket)) gl-ticket))) (when (and *notes-mode* (not (find-mapped-item :ticket-completed (forgerie-core:ticket-id ticket)))) (let ((gl-ticket (get-request (format nil "projects/~A/issues/~A" project-id (forgerie-core:ticket-id ticket))))) (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) (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) (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 (progn (unless (getf user-on-gitlab :is_admin) (set-gitlab-admin-status (getf user-on-gitlab :id) t)) 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))) ; 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") ("skip_confirmation" . ,(email-verified-to-string (forgerie-core:user-primary-email user))) ("username" . ,(forgerie-core:user-username user)) ,@(when avatar-filepath-with-mimetype `(("avatar" . ,(pathname avatar-filepath-with-mimetype))))))))) (mapcar (lambda (email) (post-request (format nil "/users/~A/emails" (getf gl-user :id)) `(("email" . ,(forgerie-core:email-address email)) ("skip_confirmation" . ,(email-verified-to-string email))))) (remove-if #'forgerie-core:email-is-primary (forgerie-core:user-emails user))) gl-user))))) (defun set-gitlab-admin-status (gl-user-id should-be-admin) (put-request (format nil "/users/~A" gl-user-id) `(("admin" . ,(if should-be-admin "true" "false"))))) (defun update-user-admin-status (user &optional override) (let ((should-be-admin (or override (forgerie-core:user-admin user))) (forgerie-username (forgerie-core:user-username user))) (when forgerie-core:*debug* (format t "Requesting is_admin:~A for user ~A~%" should-be-admin forgerie-username)) (when (find-mapped-item :user forgerie-username) (let ((gl-user (retrieve-mapping :user forgerie-username))) (set-gitlab-admin-status (getf gl-user :id) should-be-admin))))) (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) (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) ".")) (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) ("created_at" . ,(to-iso-8601 (forgerie-core:merge-request-change-comment-date comment)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:merge-request-change-comment-author comment)))))) (when (first (getf discussion :notes)) (update-event-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-date 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)))) (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) ("created_at" . ,(to-iso-8601 (forgerie-core:merge-request-change-comment-date comment)))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:merge-request-change-comment-author comment)))))) (update-event-date "DiffNote" (getf diff-note :id) (forgerie-core:merge-request-change-comment-date 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 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-event (&key new-author) (update-event-date "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-action-date action) :new-author new-author)) (update-last-mr-rse () (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)) "rse = mr.resource_state_events[-1]" "rse.created_at = action_time" "rse.save"))) (update-mr-updated-at (&key latest-closed-at) (update-updated-at "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-action-date action) :metrics t :latest-closed-at latest-closed-at)) (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)) "approval = mr.approvals.order(:created_at => 'DESC').first" "approval.created_at = action_time" "approval.updated_at = action_time" (format nil "approval.user_id = ~A" user-id) "approval.save"))) (update-last-mr-system-note (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)) (rails-wait-for "note" "mr.notes.where(:system => true).order(:created_at => 'DESC').first") "note.created_at = action_time" "note.updated_at = action_time" (format nil "note.author_id = ~A" user-id) "note.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 (getf (retrieve-mapping :user action-username) :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")) :sudo action-username) (update-last-mr-event) (update-last-mr-rse) (update-mr-updated-at :latest-closed-at 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")) :sudo action-username) (update-last-mr-event) (update-last-mr-rse) (update-mr-updated-at :latest-closed-at nil) (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-last-mr-event :new-author action-user-id) (update-last-mr-approval action-user-id) (update-last-mr-system-note action-user-id)))) (:reject (write-action-note) (let ((post-result (handler-case (post-request (format nil "/projects/~A/merge_requests/~A/unapprove" (getf gl-mr :project_id) (getf gl-mr :iid)) nil :sudo action-username) (http-error (e) (cond ((= 404 (http-error-code e)) ;; merge request wasn't approved yet, ignore (when forgerie-core:*debug* (format t "Failed to unapprove MR D~A: ~A" (forgerie-core:merge-request-id forgerie-mr) e)) nil) ((= 403 (http-error-code e)) ;; merge request wasn't approved yet, ignore (when forgerie-core:*debug* (format t "Failed to unapprove MR D~A: ~A" (forgerie-core:merge-request-id forgerie-mr) e)) nil) (t (error e))))))) (when post-result (update-last-mr-event))))))) (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) (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/= "master" (forgerie-core:branch-name (forgerie-core:merge-request-target-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))) :sudo (forgerie-core:user-username (ensure-user-created (forgerie-core:merge-request-author mr)))))) (update-event-date "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-date mr)) (update-updated-at "MergeRequest" (getf gl-mr :id) (forgerie-core:merge-request-date mr) :created-at t :metrics 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)) (git-cmd project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))) (git-cmd project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr)))) (update-mapping (:merge-request-completed (forgerie-core:merge-request-id mr))))))))) (defun create-snippet (snippet) (single-project-check (getf *default-project* :name) (when (default-project) (when-unmapped (:snippet-completed (forgerie-core:snippet-id snippet)) (when (/= 1 (length (forgerie-core:snippet-files snippet))) (error "Can only export snippets with exactly one file for now")) (let ((default-project (default-project)) (file (first (forgerie-core:snippet-files snippet)))) (if (zerop (forgerie-core:file-size file)) (forgerie-core:add-mapping-error :gitlab-snippet-empty (forgerie-core:snippet-id snippet) (format nil "Skipping snippet ~A because empty content" (forgerie-core:snippet-id snippet))) (progn (when-unmapped (:snippet (forgerie-core:snippet-id snippet)) (handler-case (update-mapping (:snippet (forgerie-core:snippet-id snippet)) (let ((content (with-open-file (str (forgerie-core:file-location file) :element-type 'unsigned-byte) (let ((seq (make-sequence 'vector (file-length str)))) (read-sequence seq str) (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")) (update-mapping (:snippet-completed (forgerie-core:snippet-id snippet)) gl-snippet)))))))))) diff --git a/src/main/phabricator/import.lisp b/src/main/phabricator/import.lisp index a61daca..c971a69 100644 --- a/src/main/phabricator/import.lisp +++ b/src/main/phabricator/import.lisp @@ -1,1174 +1,1187 @@ (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 isverified) (getf-convenience file id storageengine storageformat storagehandle name location mimetype bytesize phid) (getf-convenience file-storageblob data) (getf-convenience paste id phid title filephid file comments author authorphid datecreated spacephid) (getf-convenience paste-comment id author authorphid content datecreated) (getf-convenience project id phid icon name tags) (getf-convenience project-slug slug) -(getf-convenience repository id phid repositoryslug name localpath projects primary-projects commits spacephid viewpolicy archived) +(getf-convenience repository id phid repositoryslug name localpath projects primary-projects commits spacephid viewpolicy archived defaultbranch) (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 actions) (getf-convenience task-comment id author authorphid content datecreated) (getf-convenience task-action id author authorphid datecreated transactiontype newvalue) (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 actions) (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) (getf-convenience differential-action id author authorphid newvalue datecreated) (defvar *query-cache* nil) (defun purge-query-cache () "Allow purging query the *query-cache* variable (for debug purposes)." (setf *query-cache* nil)) (defun query (query) (when (not (assoc query *query-cache* :test #'string=)) (when forgerie-core:*debug* (format t "~S~%" query)) (setf *query-cache* (cons (cons query (let* ((result (car (cl-mysql:query query))) (rows (car result)) (definitions (cadr result))) (mapcar (lambda (row) (apply #'append (mapcar (lambda (col def) (list (intern (string-upcase (car def)) :keyword) col)) row definitions))) rows))) *query-cache*))) (cdr (assoc query *query-cache* :test #'string=))) ; https://github.com/hackinghat/cl-mysql/blob/3fbf6e1421484f64c5bcf2ff3c4b96c6f0414f09/pool.lisp#L283 (defun initialize () (when (not cl-mysql-system:*last-database*) (if *database-host* (cl-mysql:connect :host *database-host* :port *database-port* :user *database-username* :password *database-password* ) (cl-mysql:connect :user *database-username* :password *database-password*)) (cl-mysql:query "set names 'utf8mb4'"))) (defun utf-8-bytes-to-string (bytes-list) (trivial-utf-8:utf-8-bytes-to-string (or bytes-list #()))) (defun sanitize-address (address) (if *email-address-sanitizer* (funcall *email-address-sanitizer* address) 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 fill-out-task-action (action) (let* ((newvalue (utf-8-bytes-to-string (task-action-newvalue action))) (parsed-newvalue (first (jsown:parse (format nil "[~A]" newvalue))))) (append (list :newvalue parsed-newvalue) action (list :author (get-user (task-action-authorphid action)))))) (defun get-task-actions (task) (mapcar #'fill-out-task-action (query (format nil "select id, authorphid, datecreated, case when transactiontype = 'core:subscribers' then 'subscribers' else transactiontype end as transactiontype, newvalue from phabricator_maniphest.maniphest_transaction where objectphid = '~A' and transactiontype in ( 'title', 'description', 'priority', 'status', 'reassign', 'subscribers', 'mergedinto', 'core:subscribers') order by datecreated" (task-phid task))))) (defun annotate-task-action (action) (let ((type (task-action-transactiontype action)) (newvalue (task-action-newvalue action))) (cond ((string= type "reassign") (if newvalue (append (list :newvalue (get-user newvalue)) action) action)) ((string= type "subscribers") (append (list :newvalue (mapcar #'get-user newvalue)) action)) ((string= type "mergedinto") (append (list :newvalue (get-task newvalue :shallow t)) action)) (t action)))) (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) :actions (mapcar #'annotate-task-action (get-task-actions 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-query (&optional filter) (query - (format nil "select id, phid, repositoryslug, name, localpath, spacephid, viewpolicy, - (details like '%\"tracking-enabled\":\"inactive\"%' - or details like '%\"tracking-enabled\":false%') - as archived from phabricator_repository.repository~@[ where ~A~]" filter))) + (format nil + "select id, phid, repositoryslug, name, localpath, spacephid, viewpolicy, + coalesce(json_unquote(json_extract(details, '$.\"default-branch\"')), '') as defaultbranch, + coalesce(json_unquote(json_extract(details, '$.\"tracking-enabled\"')), 'true') in ('inactive', 'false') as archived + from phabricator_repository.repository~@[ where ~A~]" filter))) (defun get-repository (phid) (attach-projects-to-repository (first (get-repository-query (format nil "phid = '~A'" phid))))) (defun get-repository-by-slug (slug) (attach-projects-to-repository (first (get-repository-query (format nil "repositoryslug = '~A'" slug))))) (defun get-repository-by-id (id) (attach-projects-to-repository (first (get-repository-query (format nil "id = '~A'" id))))) (defun get-repositories () (let ((repositories (remove-if (lambda (repository) (and *included-repositories* (not (find (repository-repositoryslug repository) *included-repositories* :test #'string=)))) (get-repository-query "repositoryslug is not null")))) (mapcar #'annotate-repository-commits (mapcar #'attach-projects-to-repository (remove-if (lambda (repo) (eql :skip (getf (find (repository-id repo) *repository-overrides* :key (lambda (override) (getf override :key))) :action))) repositories))))) (defun db-file (file-phid) (first (query (format nil "select id, phid, name, storageEngine, storageFormat, storageHandle, mimetype, bytesize from phabricator_file.file where phid = '~A'" file-phid)))) (defun put-file-on-disk (out file) (cond ((and (string= "blob" (file-storageengine file)) (string= "raw" (file-storageformat file))) (write-sequence (file-storageblob-data (first (query (format nil "select data from phabricator_file.file_storageblob where id = '~A';" (file-storagehandle file))))) out)) ((and (string= "local-disk" (file-storageengine file)) (string= "raw" (file-storageformat file))) (with-open-file (str (format nil "~A/~A" *storage-location* (file-storagehandle file)) :element-type 'unsigned-byte) (let ((data (make-array (file-bytesize file)))) (read-sequence data str) (write-sequence data out)))) ((string= "chunks" (file-storageengine file)) (mapcar (lambda (chunk) (put-file-on-disk out (db-file (getf chunk :datafilephid))) (force-output out)) (query (format nil "select dataFilePHID from phabricator_file.file_chunk where chunkhandle = '~A' order by byteStart" (file-storagehandle file))))) (t (error "Don't know how to handle files of with engine,format,mimetype of ~A,~A,~A encounted on ~A" (file-storageengine file) (file-storageformat file) (file-mimetype file) (file-phid file))))) (defun get-file (file-phid) (let* ((file (db-file file-phid)) (dir (format nil "~A/files/~A/" *working-directory* (subseq file-phid (- (length file-phid) 3)))) (location (format nil "~A~A" dir file-phid))) (when (not (probe-file location)) (ensure-directories-exist dir) (with-open-file (out location :direction :output :element-type 'unsigned-byte) (put-file-on-disk out file))) (append file (list :location location)))) (defun get-captured-files () (mapcar #'get-file (mapcar (lambda (file-id) (getf (first (query (format nil "select phid from phabricator_file.file where id = ~A" file-id))) :phid)) (with-open-file (str (format nil "~A/everything/captured-files" *working-directory*)) (remove-duplicates (loop :for obj := (read str nil) :while obj :collect obj) :test #'string=))))) (defun capture-file (id) (with-open-file (str (format nil "~A/everything/captured-files" *working-directory*) :direction :output :if-exists :append :if-does-not-exist :create) (format str "~S~%" id))) (defun add-author-to-paste-comment (comment) (append comment (list :author (get-user (paste-comment-authorphid comment))))) (defun get-paste-comments (paste) (mapcar #'add-author-to-paste-comment (query (format nil "select ptc.id, ptc.authorphid, pt.datecreated, ptc.content from phabricator_paste.paste_transaction pt left join phabricator_paste.paste_transaction_comment ptc on ptc.phid = pt.commentphid where commentphid is not null and ptc.isdeleted = 0 and objectphid = '~A' and transactiontype = 'core:comment' order by pt.datecreated" (paste-phid paste))))) (defun get-pastes () (mapcar (lambda (paste) (append paste (list :author (get-user (paste-authorphid paste)) :comments (get-paste-comments paste)))) (remove nil (mapcar (lambda (paste) (let ((file (get-file (paste-filephid paste)))) (when file (append (list :file file) paste)))) (remove-if (lambda (paste) (find (paste-id paste) *pastes-to-skip*)) (query "select id, title, phid, filePHID, datecreated, authorPHID, spacePHID from phabricator_paste.paste")))))) (defun get-commit (phid &optional (with-parents t)) (let ((commit (first (query (format nil "select id, repositoryid, commitidentifier from phabricator_repository.repository_commit where phid = '~A'" phid))))) (append commit (list :parents (if with-parents (mapcar (lambda (parent-phid) (get-commit parent-phid nil)) (mapcar #'repository-commit-phid (query (format nil "select rc.phid from phabricator_repository.repository_parents rp join phabricator_repository.repository_commit rc on rp.parentcommitid = rc.id where childcommitid = '~A'" (repository-commit-id commit))))) :unfetched))))) (defun order-related-commits (commits) (when (find-if (lambda (commit) (< 1 (length (repository-commit-parents commit)))) commits) (error "There's a merge commit in the differential commit list?! Investigate further")) (cond ((not commits) nil) ((= 1 (length commits)) commits) (t (let* ((parents (apply #'append (mapcar #'repository-commit-parents commits))) (non-parent-commits (remove-if (lambda (commit) (find (repository-commit-commitidentifier commit) parents :key #'repository-commit-commitidentifier :test #'string=)) commits))) (when (< 1 (length non-parent-commits)) (format t "~S~%" non-parent-commits) (error "There's multiple commits that are not a parent in the set, meaning this commit chain is weird")) (cons (car non-parent-commits) (order-related-commits (remove (car non-parent-commits) commits))))))) (defun get-commits-from-db (revision) (let ((repository (get-repository (differential-revision-repositoryphid revision)))) (reverse (order-related-commits (remove-if (lambda (commit) (or (not (eql (repository-commit-repositoryid commit) (repository-id repository))) ; Is this commit reachable? (not (zerop (forgerie-core:git-cmd (repository-localpath repository) "cat-file" (list "-t" (repository-commit-commitidentifier commit))))) (string= (format nil "undefined~%") (nth-value 1 (forgerie-core:git-cmd (repository-localpath repository) "name-rev" (list "--name-only" (repository-commit-commitidentifier commit))))) ; Remove merge commits (< 1 (length (repository-commit-parents commit))))) (mapcar #'get-commit (mapcar #'edge-dst ; type of 31 is the same as DifferentialRevisionHasCommitEdgeType (query (format nil "select dst from phabricator_differential.edge where src = '~A' and type = 31" (differential-revision-phid revision)))))))))) (defun get-details (repository sha) (with-output-to-string (out) (sb-ext:run-program (asdf:system-relative-pathname :forgerie "bin/getdetails.sh") (list sha (repository-localpath repository)) :wait t :output out))) (defun get-shas-and-details (repository) (forgerie-core:check-for-stop) (cached "shas-and-details" (repository-phid repository) (mapcar (lambda (sha) (list sha (get-details repository sha))) (cl-ppcre:split "\\n" (nth-value 1 (forgerie-core:git-cmd (repository-localpath repository) "log" (list "--all" "--pretty=%H"))))))) (defun get-commits-from-staging (revision) (let* ((staging-repository (get-repository *staging-repository*)) (repository (get-repository (differential-revision-repositoryphid revision))) (latest-diff (first (query (format nil "select id from phabricator_differential.differential_diff where revisionid = '~A' order by id desc limit 1" (differential-revision-id revision))))) (all-shas-and-details (get-shas-and-details repository))) (labels ((build-commit-chain (diff-id &optional (n 0)) (when (> n 20) (error "We have failed to find a matching commit in the previous 20")) (let* ((diff-details (get-details staging-repository (format nil "phabricator/diff/~A~~~A" diff-id n))) (repo-details (find diff-details all-shas-and-details :test #'string= :key #'cadr))) (if repo-details (list (list :commitidentifier (car repo-details) :repository repository)) (cons (list :patch (nth-value 1 (forgerie-core:git-cmd (repository-localpath staging-repository) "format-patch" (list "-k" "-1" "--stdout" (format nil "phabricator/diff/~A~~~A" diff-id n))))) (build-commit-chain diff-id (1+ n))))))) (let ((commit-chain (reverse (build-commit-chain (differential-diff-id latest-diff))))) (cons (append (second commit-chain) (list :parents (list (first commit-chain)))) (cddr commit-chain)))))) (defun build-raw-commit (revision) (let* ((repository (get-repository (differential-revision-repositoryphid revision))) (user (get-user (differential-revision-authorphid revision))) (path (format nil "~A/~A/" *working-directory* (repository-repositoryslug repository))) (raw-diff (dex:get (format nil "~A/D~A?download=true" *phabricator-location* (differential-revision-id revision))))) (when (not (probe-file path)) (ensure-directories-exist path) (forgerie-core:git-cmd path "clone" (list (repository-localpath repository) "."))) (labels ((sha-applicable (sha) (forgerie-core:git-cmd path "checkout" (list sha)) (zerop (with-input-from-string (in raw-diff) (forgerie-core:git-cmd path "apply" (list "-") :input in :error nil)))) (find-parent-sha (&optional (shas (mapcar #'car (get-shas-and-details repository)))) (cond ((not shas) (with-open-file (debug-file "~/diff.patch" :direction :output :if-exists :supersede) (princ raw-diff debug-file)) (error "Couldn't find a sha for which this could be applied")) ((sha-applicable (car shas)) (car shas)) (t (find-parent-sha (cdr shas)))))) (let* ((rev-date (unix-to-universal-time (differential-revision-datecreated revision))) (end-date (+ rev-date (* 7 24 3600))) (applicable-shas (cl-ppcre:split "\\n" (nth-value 1 (forgerie-core:git-cmd path "log" (list "--pretty=%H" "--all" "--until" (forgerie-core:to-iso-8601 end-date) "-n" "50"))))) (parent-commit-sha (find-parent-sha applicable-shas))) (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 add-author-to-differential-action (action) (append action (list :author (get-user (differential-action-authorphid action))))) (defun get-diff-actions (rev) (mapcar #'add-author-to-differential-action (query (format nil "select id, authorphid, datecreated, case when transactionType in ('differential:action', 'differential.revision.status') then substring(newvalue from 2 for length(newvalue)-2) else substring(transactionType from 23) end as newvalue from phabricator_differential.differential_transaction where objectphid = '~A' and transactiontype in ( 'differential:action', 'differential.revision.abandon', 'differential.revision.close', 'differential.revision.status' ) order by datecreated" (differential-revision-phid rev))))) (defun get-revision-inline-comments (rev) (let* ((phid (differential-revision-phid rev)) (comments (query (format nil "select * from phabricator_differential.differential_transaction_comment where revisionphid = '~A' and isdeleted = 0 and changesetid is not null" phid)))) (mapcar (lambda (comment) (append comment (list :author (get-user (differential-transaction-comment-authorphid comment)) :diff (car (query (format nil "select diff.*, changeset.filename from phabricator_differential.differential_diff diff join phabricator_differential.differential_changeset changeset on changeset.diffid = diff.id where changeset.id = ~A" (differential-transaction-comment-changesetid comment))))))) comments))) (defun attach-inline-comments-to-commits (commits inline-comments) (flet ((comment-attached-to-commit (comment commit) (find (differential-diff-sourcecontrolbaserevision (differential-transaction-comment-diff comment)) (mapcar #'repository-commit-commitidentifier (repository-commit-parents commit)) :test #'string=))) (let ((attached-comments (remove-if (lambda (comment) (notany (lambda (commit) (comment-attached-to-commit comment commit)) commits)) inline-comments)) (unattached-comments (remove-if-not (lambda (comment) (notany (lambda (commit) (comment-attached-to-commit comment commit)) commits)) inline-comments))) (values (mapcar (lambda (commit) (setf (getf commit :comments) (remove-if-not (lambda (comment) (comment-attached-to-commit comment commit)) attached-comments)) commit) commits) unattached-comments)))) (defun thread-inline-comments (comments) (labels ((thread-comment (comment-to-thread comments) (when comments (mapcar (lambda (comment) (if (string= (differential-transaction-comment-replytocommentphid comment-to-thread) (differential-transaction-comment-phid comment)) (progn (setf (getf comment :replies) (append (differential-transaction-comment-replies comment) (list comment-to-thread))) comment) (progn (setf (getf comment :replies) (thread-comment comment-to-thread (differential-transaction-comment-replies comment))) comment))) comments)))) (let ((comment-to-thread (find-if #'differential-transaction-comment-replytocommentphid comments))) (if (not comment-to-thread) comments (thread-inline-comments (thread-comment comment-to-thread (remove comment-to-thread comments :test #'equalp))))))) (defun get-revision-commits (rev) (let ((inline-comments (thread-inline-comments (get-revision-inline-comments rev))) (commits (cached "revision_commits" (differential-revision-id rev) (or (get-commits-from-db rev) (when *staging-repository* (handler-case (get-commits-from-staging rev) (error (e) (format t "Failed to get commit from staging due to error ~A, falling back.~%" e)))) (build-raw-commit rev))))) (attach-inline-comments-to-commits commits inline-comments))) (defun annotate-revision (rev) (forgerie-core:check-for-stop) (when forgerie-core:*debug* (format t "---------------~%Loading revision ~A~%~%~%" (differential-revision-id rev))) (let ((repository (get-repository (differential-revision-repositoryphid rev)))) (when (or (not *included-repositories*) (find (repository-repositoryslug repository) *included-repositories* :test #'string=)) (handler-case (cached "revisions" (differential-revision-id rev) (append rev (list :author (get-user (differential-revision-authorphid rev))) (list :comments (get-revision-comments rev)) (list :actions (get-diff-actions 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"))))) (defvar *comment-regexes* (list (cons :h1 (cl-ppcre:create-scanner "(?:^|\\n)= +(.*?)[ =]*\\n")) (cons :h2 (cl-ppcre:create-scanner "(?:^|\\n)== +(.*?)[ =]*\\n")) (cons :h3 (cl-ppcre:create-scanner "(?:^|\\n)=== +(.*?)[ =]*\\n")) (cons :h4 (cl-ppcre:create-scanner "(?:^|\\n)==== +(.*?)[ =]*\\n")) (cons :h5 (cl-ppcre:create-scanner "(?:^|\\n)===== +(.*?)[ =]*\\n")) (cons :link (cl-ppcre:create-scanner "\\[\\[ *([^|\\n]*?) *\\| *([^\\]\\n]*?) *\\]\\]")) (cons :file (cl-ppcre:create-scanner "\{F(\\d+)\}")) (cons :ticket (cl-ppcre:create-scanner "\\bT([1-9]\\d{0,4})(#\\d+)?\\b")) (cons :snippet (cl-ppcre:create-scanner "\\bP([1-9]\\d{0,4})(#\\d+)?\\b")) (cons :merge-request (cl-ppcre:create-scanner "\\bD([1-9]\\d{0,4})(#\\d+)?\\b")))) (defun parse-comment (comment) (let ; This is an oddity in how phabricator represents this part of markdown, and thus it's converted ; to actual markdown (checkbox list items need to be prefaced by a list element like -) ((comment (labels ((list-item-prefix (match m1 m2) (format nil "~A- [~A]" m1 (if (string= m2 "") " " m2)))) (cl-ppcre:regex-replace-all "(?m)^( *)(?:- )?\\[(.?)\\]" comment #'list-item-prefix :simple-calls t)))) (labels ((first-instance-of (type &key with-aftercheck (comment comment)) (multiple-value-bind (start end match-starts match-ends) (cl-ppcre:scan (cdr (assoc type *comment-regexes*)) 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 type :comment (subseq comment end))) ((and with-aftercheck (cl-ppcre:scan "[\\d\\w]" (subseq comment end (1+ end)))) (first-instance-of 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 (mapcar #'first-instance-of (mapcar #'car *comment-regexes*))) #'< :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 (utf-8-bytes-to-string (differential-diff-filename (differential-transaction-comment-diff comment))) :text (parse-comment (utf-8-bytes-to-string (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 "DiffNote~A" (differential-comment-id comment)) :text (parse-comment (utf-8-bytes-to-string (differential-comment-content comment))) :author (convert-user-to-core (differential-comment-author comment)) :date (unix-to-universal-time (differential-comment-datecreated comment)))) (defun convert-differential-action-newvalue-to-core (newvalue) (cond ((string= newvalue "close") :close) ((string= newvalue "abandon") :abandon) ((string= newvalue "abandoned") :abandon) ((string= newvalue "accept") :accept) ((string= newvalue "accepted") :accept) ((string= newvalue "commit") :close) ((string= newvalue "committed") :close) ((string= newvalue "needs-review") :ready) ((string= newvalue "needs-revision") :reject) ((string= newvalue "reject") :reject) ((string= newvalue "rejected") :reject) (t (error "unknown differential action ~A" newvalue)))) (defun convert-differential-action-to-core (action) (forgerie-core:make-merge-request-action :id (format nil "DiffAction~A" (differential-action-id action)) :author (convert-user-to-core (differential-action-author action)) :date (unix-to-universal-time (differential-action-datecreated action)) :type (convert-differential-action-newvalue-to-core (differential-action-newvalue action)))) (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)))))) + (t (error "Unknown revision type: ~A" (differential-revision-status revision-def))))) + (core-repository (convert-repository-to-core (differential-revision-repository 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" (utf-8-bytes-to-string (differential-revision-summary revision-def)) (if (differential-revision-testplan revision-def) (format nil "~%~%== Test Plan ==~%~%~A" (utf-8-bytes-to-string (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)) + :vc-repository core-repository :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))) + ; Defaults to the repository's default branch + (if (eql :open type) + (forgerie-core:vc-repository-default-branch-name core-repository) + (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)) :actions (mapcar #'convert-differential-action-to-core (differential-revision-actions revision-def))))) (defun convert-access-policy-to-core (repository-def) (let ((viewpolicy (repository-viewpolicy repository-def))) (cond ((find (repository-spacephid repository-def) *confidential-space-phids* :test #'string=) :private) ((str:starts-with? "PHID-USER-" viewpolicy) :private) ((str:starts-with? "PHID-PROJ-" viewpolicy) :private) ((str:starts-with? "PHID-PLCY-" viewpolicy) :private) ((string= viewpolicy "users") :internal) ((string= viewpolicy "public") :public) (t (error "Could not figure out access policy for repository ~A" repository-def))))) +(defun convert-branchname-to-core (repository-def) + (let + ((branchname (repository-defaultbranch repository-def))) + (if + (or (not branchname) (string= "" branchname)) + "master" + branchname))) + (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) :access-policy (convert-access-policy-to-core repository-def) :archived (= 1 (repository-archived repository-def)) + :default-branch-name (convert-branchname-to-core 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) :is-verified (eql (email-isverified 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 "TaskNote~A" (task-comment-id comment)) :text (parse-comment (utf-8-bytes-to-string (task-comment-content comment))) :author (convert-user-to-core (task-comment-author comment)) :date (unix-to-universal-time (task-comment-datecreated comment)))) (defun task-status-to-type (status) (cond ((find status (list "open" "wip") :test #'string=) :open) ((find status (list "duplicate" "invalid" "resolved" "spite" "wontfix") :test #'string=) :closed) (t (error "Unknown task status: ~A" status)))) (defun task-priority-to-string (priority) (case priority (100 "UnbreakNow!") (90 "Triage") (80 "High") (50 "Normal") (25 "Low") (0 "Wishlist") (otherwise (error "Unknown task priority: ~A" priority)))) (defun convert-task-action-to-core (action) (multiple-value-bind (type newvalue) (let* ((action-type (task-action-transactiontype action)) (newvalue (task-action-newvalue action))) (cond ((string= action-type "status") (values (task-status-to-type newvalue) newvalue)) ((string= action-type "priority") (values :priority (task-priority-to-string (typecase newvalue (integer newvalue) (t (parse-integer newvalue)))))) ((string= action-type "reassign") (values :reassign (if newvalue (convert-user-to-core newvalue)))) ((string= action-type "subscribers") (values :subscribers (mapcar #'convert-user-to-core newvalue))) ((string= action-type "description") (values :description (parse-comment newvalue))) ((string= action-type "mergedinto") (values :mergedinto (convert-task-to-core newvalue))) (t (values (intern (string-upcase action-type) :keyword) newvalue)))) (forgerie-core:make-ticket-action :id (format nil "TaskAction~A" (task-action-id action)) :author (convert-user-to-core (task-action-author action)) :date (unix-to-universal-time (task-action-datecreated action)) :type type :newvalue newvalue))) (defun convert-task-to-core (task-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 (utf-8-bytes-to-string (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 (task-priority-to-string (task-priority task-def)) :type (task-status-to-type (task-status task-def)) :notes (mapcar #'convert-task-comment-to-core (task-comments task-def)) :actions (mapcar #'convert-task-action-to-core (task-actions task-def)))) (defun convert-paste-comment-to-core (comment) (forgerie-core:make-note :id (format nil "PasteNote~A" (paste-comment-id comment)) :text (parse-comment (utf-8-bytes-to-string (paste-comment-content comment))) :author (convert-user-to-core (paste-comment-author comment)) :date (unix-to-universal-time (paste-comment-datecreated comment)))) (defun convert-file-to-core (file-def) (forgerie-core:make-file :id (file-id file-def) :name (file-name file-def) :location (file-location file-def) :size (file-bytesize file-def) :mimetype (file-mimetype file-def))) (defun convert-paste-to-core (paste-def) (forgerie-core:make-snippet :id (paste-id paste-def) :date (unix-to-universal-time (paste-datecreated paste-def)) :title (paste-title paste-def) :files (list (convert-file-to-core (paste-file paste-def))) :author (convert-user-to-core (paste-author paste-def)) :notes (mapcar #'convert-paste-comment-to-core (paste-comments paste-def)) :private (not (not (find (paste-spacephid paste-def) *confidential-space-phids* :test #'string=))))) (defmethod forgerie-core:import-forge ((forge (eql :phabricator))) (setf *working-directory* (format nil "~Aphabricator" forgerie-core:*working-directory*)) (let ((revoke-cache (and *included-repositories* (not (equal *included-repositories* (cached "everything" "included-repositories" nil)))))) (cached "everything" "included-repositories" *included-repositories* t) (list :users (get-objects revoke-cache :type "users" :import-fn #'get-users :convert-fn #'convert-user-to-core) :projects (get-objects revoke-cache :type "projects" :import-fn #'get-projects :convert-fn #'convert-project-to-core) :vc-repositories (get-objects revoke-cache :type "repositories" :import-fn #'get-repositories :convert-fn #'convert-repository-to-core) :snippets (get-objects revoke-cache :type "snippets" :import-fn #'get-pastes :convert-fn #'convert-paste-to-core) :merge-requests (get-objects revoke-cache :type "merge-requests" :import-fn #'get-revisions :convert-fn #'convert-revision-to-core) :tickets (get-objects revoke-cache :type "tickets" :import-fn #'get-tasks :convert-fn #'convert-task-to-core) :files (get-objects revoke-cache :type "files" :import-fn #'get-captured-files :convert-fn #'convert-file-to-core)))) (defun get-objects (revoke-cache &key type import-fn convert-fn (cache-name "everything")) "Get TYPE converted (with CONVERT-FN) objects using GETTER-FN. When REVOKE-CACHE, this fetches data directly from phabricator and update the CACHE-NAME' cache." (setf *working-directory* (format nil "~Aphabricator" forgerie-core:*working-directory*)) (initialize) (cached cache-name type (mapcar (lambda (o) (funcall convert-fn o)) (funcall import-fn)) revoke-cache))