Page MenuHomeSoftware Heritage
Files F9696657

No OneTemporary
Actions

View Options

diff --git a/src/main/core/merge-request.lisp b/src/main/core/merge-request.lisp
index f33bae8..caf5f67 100644
--- a/src/main/core/merge-request.lisp
+++ b/src/main/core/merge-request.lisp
@@ -1,43 +1,52 @@
(in-package #:forgerie-core)
(defstruct merge-request-change
; A change can be a <commit> or a <patch> (from base)
change
; A list of merge-request-change-comment, though there may be nested comments
comments)
; For comments that are in the changes for the PRs
(defstruct merge-request-change-comment
- line
+ ; list of two items, the start and ending lines post change
+ new-line
+ ; list of two items, the start and ending lines pre change
+ old-line
text
file
author
date
; Replies are of type merge-request-change-comment, though the line number
; doesn't matter
replies)
(defstruct merge-request
id
vc-repository
title
description
date
author
; The type can be one of:
; - :open
; - :closed
type
; These branches may not currently exist, which is why we also need to
; know what commits were involved in the merge request. That way we can
; recreate the data as it existed when the merge request happened.
source-branch ; the base of the merge request
target-branch ; the branch holding the changes for the merge
; Changes is a list of things to be applied. Each is of the type merge-request-change
changes
+ ; Change comments here differ from change comments on the changes, as those
+ ; are attached to commits, and they differ from the notes here, as they are
+ ; comments that go on the files, with locations and replies, rather than general
+ ; notes added to the merge request as a whole
+ other-change-comments
+
; All the comments
notes)
diff --git a/src/main/core/package.lisp b/src/main/core/package.lisp
index ab655dc..6681613 100644
--- a/src/main/core/package.lisp
+++ b/src/main/core/package.lisp
@@ -1,51 +1,51 @@
(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
; user.lisp
#:make-user #:user-username #:user-name #:user-emails #:make-email #:email-address #:email-is-primary #: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
; 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
; snippet.lisp
#:make-snippet #:snippet-id #:snippet-title #:snippet-files #:snippet-notes #:snippet-author #: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
#:make-merge-request-change #:merge-request-change-change #:merge-request-change-comments
- #:make-merge-request-change-comment #:merge-request-change-comment-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
+ #: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
; errors.lisp
#:add-mapping-error #:*log-mapping-errors* #:display-mapping-error
; utils.lisp
#:vc-repositories-with-primary-project #:git-cmd #:*debug*))
diff --git a/src/main/gitlab/export.lisp b/src/main/gitlab/export.lisp
index 48e7d2f..e7ebbaf 100644
--- a/src/main/gitlab/export.lisp
+++ b/src/main/gitlab/export.lisp
@@ -1,737 +1,740 @@
(in-package #:forgerie-gitlab)
(define-condition unknown-note-mapping
nil
((mapping :initarg :mapping :reader unknown-note-mapping-mapping)))
(defvar *note-mapping-skips* nil)
(defvar *notes-mode* nil)
(defvar *files-to-upload* nil)
(defun validate-vc-repositories (vc-repositories projects)
(let
((valid-projects
(mapcar
(lambda (proj)
(let
((repos-for-proj (forgerie-core:vc-repositories-with-primary-project proj vc-repositories)))
(cond
((< 1 (length repos-for-proj))
(forgerie-core:add-mapping-error
:gitlab-project-primary-in-multiple
(forgerie-core:project-name proj)
(format nil
"Project ~A is the primary project in multiple repositories, and those repositories won't be included:~%~{ * ~A~%~}"
(forgerie-core:project-name proj)
(mapcar #'forgerie-core:vc-repository-name repos-for-proj)))
nil)
(proj))))
projects)))
(remove
nil
(mapcar
(lambda (vcr)
(cond
((cl-ppcre:scan "[,()/+]" (forgerie-core:vc-repository-name vcr))
(forgerie-core:add-mapping-error
:gitlab-repository-has-illegal-name
(forgerie-core:vc-repository-name vcr)
(format nil "VC Repository '~A' has an illegal name due to an illegal character, one of: ',()/+'." (forgerie-core:vc-repository-name vcr))))
((cl-ppcre:scan "^ " (forgerie-core:vc-repository-name vcr))
(forgerie-core:add-mapping-error
:gitlab-repository-has-illegal-name
(forgerie-core:vc-repository-name vcr)
(format nil "VC Repository '~A' has an illegal name due to starting with a space." (forgerie-core:vc-repository-name vcr))))
((not (forgerie-core:vc-repository-primary-projects vcr))
(forgerie-core:add-mapping-error
:gitlab-repository-has-no-projects
(forgerie-core:vc-repository-name vcr)
(format nil "VC Repository '~A' has no primary projects.~%" (forgerie-core:vc-repository-name vcr)))
vcr)
((not
(remove-if-not
(lambda (proj) (find proj valid-projects :test #'equalp))
(forgerie-core:vc-repository-primary-projects vcr)))
nil)
(vcr)))
vc-repositories))))
(defun validate-users (users)
(remove nil
(mapcar
(lambda (user)
(cond
((< (length (forgerie-core:user-username user)) 2)
(forgerie-core:add-mapping-error
:gitlab-username-too-short
(forgerie-core:user-username user)
(format nil "User '~A' (~{~A~^,~}) has too short of a username."
(forgerie-core:user-username user)
(mapcar #'forgerie-core:email-address (forgerie-core:user-emails user)))))
(user)))
users)))
(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:merge-request-vc-repository mr) vc-repositories :test #'equalp))
(forgerie-core:add-mapping-error
:gitlab-merge-request-not-assignable
(forgerie-core:merge-request-id mr)
(format nil "Merge Request with title ~A is not assignable to a repository~%" (forgerie-core:merge-request-title mr)))
mr))
merge-requests)))
; We only cache this in memory, and not on disk, because we most likely want
; updated information any time a run is fresh.
(defvar *projects-by-name* nil)
(defvar *projects-by-id* nil)
(defun find-project-by-name (name)
(when (not (assoc name *projects-by-name* :test #'string=))
(let
((project
(find
name
(get-request "projects" :parameters `(("search" . ,name)))
:test #'string=
:key (lambda (gl-project) (getf gl-project :name)))))
(setf *projects-by-name* (cons (cons name project) *projects-by-name*))
(setf *projects-by-id* (cons (cons (getf project :id) project) *projects-by-id*))))
(cdr (assoc name *projects-by-name* :test #'string=)))
(defun find-project-by-id (id)
(when (not (assoc id *projects-by-id*))
(let
((project (get-request (format nil "projects/~A" id))))
(setf *projects-by-id* (cons (cons (getf project :id) project) *projects-by-id*))))
(cdr (assoc id *projects-by-id*)))
(defun default-project ()
(find-project-by-name (getf *default-project* :name)))
(defun create-default-project ()
(when-unmapped-with-update (:project :default-project)
(post-request
"projects"
(append
(when *default-group*
(list
(cons
"namespace_id"
(princ-to-string (getf (first (get-request "namespaces" :parameters `(("search" . ,(getf *default-group* :name))))) :id)))))
`(("name" . ,(getf *default-project* :name))
("issues_access_level" . "enabled")
("snippets_access_level" . "enabled")
("path" . ,(getf *default-project* :path)))))))
(defun default-group ()
(when *default-group*
(get-request
"groups"
:parameters `(("search" . ,(getf *default-group* :name))))))
(defun create-default-group ()
(when *default-group*
(when-unmapped-with-update (:group :default-group)
(post-request
"groups"
`(("name" . ,(getf *default-group* :name))
("path" . ,(getf *default-group* :path)))))))
(defun add-ssh-key ()
(let
((key-name "Forgerie Export Key"))
(when-unmapped-with-update (:forgerie-key :main-key)
(post-request
"user/keys"
`(("title" . ,key-name)
("key" . ,*ssh-public-key*))))))
(defun project-for-ticket (ticket vc-repositories)
(let
((vc-repos (ticket-assignable-vc-repositories ticket vc-repositories)))
(if vc-repos
(find-project-by-name (forgerie-core:vc-repository-name (car vc-repos)))
(default-project))))
(defun remove-single-project ()
(when *single-project*
(let
((project (find-project-by-name *single-project*)))
(when project
(cl-fad:delete-directory-and-files
(format nil "~A~A/" *working-directory* (getf project :path))
:if-does-not-exist :ignore)
(delete-request (format nil "/projects/~A" (getf project :id)))
(setf *projects-by-name* nil)
; Gitlab returns immediately even though the project is being deleted....
(sleep 60)))))
(defmethod forgerie-core:export-forge ((forge (eql :gitlab)) data)
(forgerie-core:check-for-stop)
(ensure-directories-exist *working-directory*)
(when *single-project* (remove-single-project))
(create-default-group)
(create-default-project)
(add-ssh-key)
(let*
((*note-mapping-skips* nil)
(*notes-mode* nil)
(*files-to-upload* (getf data :files))
(vc-repositories (validate-vc-repositories (getf data :vc-repositories) (getf data :projects)))
(tickets (remove-if-not #'identity (validate-tickets (getf data :tickets) vc-repositories)))
(merge-requests (validate-merge-requests (getf data :merge-requests) vc-repositories)))
(mapcar #'create-user (validate-users (getf data :users)))
(mapcar #'create-project vc-repositories)
(loop
:with moved-forward := t
:with completed := nil
:with first-error := nil
:with number-of-errors := 0
:while moved-forward
:do
(flet
((map-with-note-mapping-catch (fn collection)
(mapcar
(lambda (item)
(let
((item-info
(list
(type-of item)
(typecase item
(forgerie-core:ticket (forgerie-core:ticket-id item))
(forgerie-core:merge-request (forgerie-core:merge-request-id item))
(forgerie-core:snippet (forgerie-core:snippet-id item))))))
(when (not (find item completed :test #'equalp))
(handler-case
(progn
(funcall fn item)
(setf moved-forward t)
(setf completed (cons item completed)))
(unknown-note-mapping (e)
(incf number-of-errors)
(when (not first-error) (setf first-error (unknown-note-mapping-mapping e))))))))
collection)))
(setf moved-forward nil)
(setf first-error nil)
(setf number-of-errors 0)
(map-with-note-mapping-catch (lambda (ticket) (create-ticket ticket vc-repositories)) tickets)
(map-with-note-mapping-catch #'create-snippet (getf data :snippets))
(map-with-note-mapping-catch #'create-merge-request merge-requests)
(when (and (not first-error) (not *notes-mode*))
(setf *notes-mode* t)
(setf completed nil)
(setf moved-forward t))
(when (and (not moved-forward) first-error)
(when forgerie-core:*debug* (format t "We failed to move forward...., so skipping item ~A~%" first-error))
(setf moved-forward t)
(push first-error *note-mapping-skips*))))
(mapcar (lambda (ticket) (create-ticket-links ticket vc-repositories)) tickets)
(mapcar #'add-commit-comments vc-repositories)
(mapcar #'update-user-admin-status (validate-users (getf data :users)))))
(defun add-commit-comments (vc-repository)
(single-project-check (forgerie-core:vc-repository-name vc-repository)
(let
((project (find-project-by-name (forgerie-core:vc-repository-name vc-repository))))
(mapcar
(lambda (commit)
(let*
((comment (forgerie-core:commit-parsed-comment commit))
(mappings
(remove-if-not
(lambda (item)
(and
(listp item)
(find (car item) (list :ticket :merge-request :snippet))
(find-mapped-item (car item) (parse-integer (cadr item)))))
comment))
(body
(when mappings
(format nil "Commit comment has updated locations:~%~%~{* ~A is now ~A~%~}"
(apply #'append
(mapcar
(lambda (item)
(let
((mi (find-mapped-item (car item) (parse-integer (cadr item))))
(c
(cond
((eql :ticket (car item)) "#")
((eql :merge-request (car item)) "!")
((eql :snippet (car item)) "$"))))
(list
(caddr item)
(if (equal (getf project :id) (mapped-item-project-id mi))
(format nil "~A~A" c (or (mapped-item-iid mi) (mapped-item-id mi)))
(let
((other-project (find-project-by-id (mapped-item-project-id mi))))
(format nil "~A~A~A" (getf other-project :path) c (or (mapped-item-iid mi) (mapped-item-id mi))))))))
mappings))))))
(when body
(post-request
(format nil "/projects/~A/repository/commits/~A/discussions" (getf project :id) (forgerie-core:commit-sha commit))
`(("body" . ,body))))))
(forgerie-core:vc-repository-commits vc-repository)))))
; Projects are created from vc repositories, since they are linked in gitlab.
; Some of the underlying information comes from core:projects that are
; the primary projects of the vc-repository
(defun create-project (vc-repository)
(single-project-check (forgerie-core:vc-repository-name vc-repository)
(when-unmapped (:project (forgerie-core:vc-repository-slug vc-repository))
(let*
((tags
(remove-duplicates
(apply #'append
(mapcar #'forgerie-core:project-tags (forgerie-core:vc-repository-projects vc-repository)))
:test #'string=))
(gl-project
(post-request
"projects"
(append
(when *default-group*
(list
(cons
"namespace_id"
(princ-to-string (getf (first (get-request "namespaces" :parameters `(("search" . ,(getf *default-group* :name))))) :id)))))
`(("name" . ,(forgerie-core:vc-repository-name vc-repository))
("path" . ,(forgerie-core:vc-repository-slug vc-repository))
("tag_list" . ,(format nil "~{~A~^,~}" tags))
("issues_access_level" . "enabled")
("merge_requests_access_level" . "enabled")))))
(working-path (format nil "~A~A/" *working-directory* (getf gl-project :path))))
(when
(getf gl-project :empty_repo)
(ensure-directories-exist working-path)
(git-cmd gl-project "clone" "--mirror" (forgerie-core:vc-repository-git-location vc-repository) ".")
(git-cmd gl-project "remote" "add" "gitlab" (getf gl-project :ssh_url_to_repo))
(git-cmd gl-project "push" "gitlab" "--all")
(git-cmd gl-project "push" "gitlab" "--tags")
(uiop/filesystem:delete-directory-tree (pathname working-path) :validate t)
(update-mapping (:project (forgerie-core:vc-repository-slug vc-repository)) gl-project))))))
(defun process-note-text (note-text project-id)
(format nil "~{~A~}"
(mapcar
(lambda (item)
(flet
((mapped-item-p (item type) (and (eql type (car item)) (find-mapped-item type (parse-integer (cadr item)))))
(handle-mapped-item (item type c)
(let
((mi (find-mapped-item type (parse-integer (cadr item)))))
(if (equal project-id (mapped-item-project-id mi))
(format nil "~A~A" c (or (mapped-item-iid mi) (mapped-item-id mi)))
(let
((other-project (find-project-by-id (mapped-item-project-id mi))))
(format nil "~A~A~A" (getf other-project :path) c (or (mapped-item-iid mi) (mapped-item-id mi)))))))
(handle-file (file-id)
(let
((file-response (create-file file-id project-id)))
(getf file-response :markdown))))
(cond
((stringp item) item)
((eql (car item) :file) (handle-file (cadr item)))
((eql (car item) :h1) (format nil "~%# ~A~%" (cadr item)))
((eql (car item) :h2) (format nil "~%## ~A~%" (cadr item)))
((eql (car item) :h3) (format nil "~%### ~A~%" (cadr item)))
((eql (car item) :h4) (format nil "~%#### ~A~%" (cadr item)))
((eql (car item) :h5) (format nil "~%##### ~A~%" (cadr item)))
((eql (car item) :link) (format nil "[~A](~A)" (cadr (cadr item)) (car (cadr item))))
((mapped-item-p item :ticket) (handle-mapped-item item :ticket "#"))
((mapped-item-p item :merge-request) (handle-mapped-item item :merge-request "!"))
((mapped-item-p item :snippet) (handle-mapped-item item :snippet "$"))
((find item *note-mapping-skips* :test #'equalp)
(caddr item))
(*notes-mode* (caddr item))
(t (error (make-instance 'unknown-note-mapping :mapping item))))))
note-text)))
(defun create-note (project-id item-type item-id note)
(when *notes-mode*
(let
((note-text (process-note-text (forgerie-core:note-text note) project-id)))
(when
(not (cl-ppcre:scan "^\\s*$" note-text))
(when-unmapped-with-update (:note (forgerie-core:note-id note))
(post-request
(format nil "/~A~A/~A/notes"
(if project-id (format nil "projects/~A/" project-id) "") item-type item-id)
`(("body" . ,note-text)
("created_at" . ,(to-iso-8601 (forgerie-core:note-date note))))
:sudo (forgerie-core:user-username (forgerie-core:note-author note))))))))
(defun create-file (file-id project-id)
(let
((file (find (parse-integer file-id) *files-to-upload* :key #'forgerie-core:file-id)))
(when (not file)
(error (format nil "Couldn't find file to upload with id ~S" (parse-integer file-id))))
(when-unmapped (:file-upoaded (forgerie-core:file-id file))
(update-file-mapping (:file-upoaded (forgerie-core:file-id file))
(with-open-file (str (forgerie-core:file-location file) :element-type 'unsigned-byte)
(post-request
(format nil "projects/~A/uploads" project-id)
`(("file" . ,(list str :filename (drakma:url-encode (forgerie-core:file-name file) :utf-8))))))))
(retrieve-mapping :file-upoaded (forgerie-core:file-id file))))
(defun note-mapped (note)
(find-mapped-item :find-mapped-item (forgerie-core:note-id note)))
(defun create-ticket (ticket vc-repositories)
(single-project-check
(let
((vc-repos (ticket-assignable-vc-repositories ticket vc-repositories)))
(if vc-repos (forgerie-core:vc-repository-name (car vc-repos)) (getf *default-project* :name)))
(when-unmapped (:ticket-completed (forgerie-core:ticket-id ticket))
(let
((project-id (getf (project-for-ticket ticket vc-repositories) :id)))
(when-unmapped (:ticket (forgerie-core:ticket-id ticket))
(let
((gl-ticket
(post-request
(format nil "projects/~A/issues" project-id)
`(("iid" . ,(prin1-to-string (forgerie-core:ticket-id ticket)))
("title" . ,(forgerie-core:ticket-title ticket))
("labels" .
,(format nil "~{~A~^,~}"
(cons
(format nil "priority:~A" (forgerie-core:ticket-priority ticket))
(mapcar #'forgerie-core:project-name (forgerie-core:ticket-projects ticket)))))
,@(when (forgerie-core:ticket-assignee ticket)
(list (cons "assignee_id" (princ-to-string (getf (retrieve-mapping :user (forgerie-core:user-username (forgerie-core:ticket-assignee ticket))) :id)))))
("confidential" . ,(if (forgerie-core:ticket-confidential ticket) "true" "false"))
("description" . ,(process-note-text (forgerie-core:ticket-description ticket) project-id))
("created_at" . ,(to-iso-8601 (forgerie-core:ticket-date ticket))))
:sudo (forgerie-core:user-username (forgerie-core:ticket-author ticket)))))
(mapcar
(lambda (u)
(post-request
(format nil "projects/~A/issues/~A/subscribe" (getf gl-ticket :project_id) (getf gl-ticket :iid))
nil
:sudo (forgerie-core:user-username u)))
(forgerie-core:ticket-subscribers ticket))
(update-mapping (:ticket (forgerie-core:ticket-id ticket)) gl-ticket)))
(when
(and
*notes-mode*
(notevery #'identity (mapcar #'note-mapped (forgerie-core:ticket-notes ticket))))
(let
((gl-ticket (get-request (format nil "projects/~A/issues/~A" project-id (forgerie-core:ticket-id ticket)))))
(mapcar
(lambda (note)
(create-note (getf gl-ticket :project_id) "issues" (getf gl-ticket :iid) note))
(forgerie-core:ticket-notes ticket))
(when (eql :closed (forgerie-core:ticket-type ticket))
(put-request
(format nil "projects/~A/issues/~A" project-id (getf gl-ticket :iid))
'(("state_event" . "close"))))
(update-mapping (:ticket-completed (forgerie-core:ticket-id ticket)))))))))
(defun create-ticket-links (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)))
(let
((gl-ticket (retrieve-mapping :ticket (forgerie-core:ticket-id ticket))))
(mapcar
(lambda (linked-ticket)
(let
((gl-linked-ticket (ignore-errors (retrieve-mapping :ticket (forgerie-core:ticket-id linked-ticket)))))
(if (not gl-linked-ticket)
(forgerie-core:add-mapping-error
:linked-ticket-not-found
(forgerie-core:ticket-id linked-ticket)
(format nil "Link was between ~A and ~A" (forgerie-core:ticket-id ticket) (forgerie-core:ticket-id linked-ticket)))
(post-request
(format nil "projects/~A/issues/~A/links" (getf gl-ticket :project_id) (getf gl-ticket :iid))
`(("target_project_id" . ,(princ-to-string (getf gl-linked-ticket :project_id)))
("target_issue_iid" . ,(princ-to-string (getf gl-linked-ticket :iid))))))))
(forgerie-core:ticket-linked-tickets ticket)))))
(defun create-user (user)
(when-unmapped-with-update (:user (forgerie-core:user-username user))
(let*
((avatar (forgerie-core:user-avatar user))
(avatar
(when avatar
(if (> (* 1024 200) (forgerie-core:file-size avatar))
avatar
(progn
(forgerie-core:add-mapping-error
:user-avatar-too-big
(forgerie-core:user-username user)
(format nil "User ~A's avatar is ~A, which is bigger than the allowed 200k" (forgerie-core:user-username user) (forgerie-core:file-size avatar)))))))
(avatar-filename
(when avatar
(if
(find-if
(lambda (ext) (cl-ppcre:scan (format nil "~A$" ext) (forgerie-core:file-name avatar)))
(list "png" "jpg" "jpeg" "gif" "bmp" "tiff" "ico" "webp"))
(forgerie-core:file-name avatar)
(format nil "~A.~A" (forgerie-core:file-name avatar)
(cond
((cl-ppcre:scan "^image/" (forgerie-core:file-mimetype avatar)) (subseq (forgerie-core:file-mimetype avatar) 6))
(t (error (format nil "Don't know profile mimetype ~A" (forgerie-core:file-mimetype avatar)))))))))
(gl-user
(with-open-file (str (if avatar (forgerie-core:file-location avatar) "/dev/null") :element-type 'unsigned-byte)
(post-request
"users"
`(("name" . ,(forgerie-core:user-name user))
("email" . ,(forgerie-core:email-address (forgerie-core:user-primary-email user)))
; Everyone must be an admin to make some of the other import things work correctly
; and then admin must be removed after
("admin" . "true")
("reset_password" . "true")
("username" . ,(forgerie-core:user-username user))
,@(when avatar
(list (cons "avatar" (list str :content-type (forgerie-core:file-mimetype avatar) :filename (drakma:url-encode avatar-filename :utf-8))))))))))
(mapcar
(lambda (email)
(post-request (format nil "/users/~A/emails" (getf gl-user :id))
`(("email" . ,(forgerie-core:email-address email)))))
(remove-if #'forgerie-core:email-is-primary (forgerie-core:user-emails user)))
gl-user)))
(defun update-user-admin-status (user)
(when-unmapped (:user-admin-set (forgerie-core:user-username user))
(let
((gl-user (retrieve-mapping :user (forgerie-core:user-username user))))
(put-request
(format nil "/users/~A" (getf gl-user :id))
`(("admin" . ,(if (forgerie-core:user-admin user) "true" "false")))))
(update-mapping (:user-admin-set (forgerie-core:user-username user)))))
(defun create-local-checkout (project)
(when (not (probe-file (format nil "~A~A" *working-directory* (getf project :path))))
(ensure-directories-exist (format nil "~A~A/" *working-directory* (getf project :path)))
(git-cmd project "clone" "-o" "gitlab" (getf project :ssh_url_to_repo) ".")))
(defun create-change-comments (gl-mr change)
(let*
((versions (get-request (format nil "/projects/~A/merge_requests/~A/versions" (getf gl-mr :project_id) (getf gl-mr :iid))))
; This may not work! We may have to figure out how to correlate version with this commit
(version-for-change (car versions)))
(mapcar
(lambda (comment)
(let
((note-text (process-note-text (forgerie-core:merge-request-change-comment-text comment) (getf gl-mr :project_id))))
(when
(and note-text (not (zerop (length note-text))))
(handler-case
(let
((discussion
(post-request
(format nil "/projects/~A/merge_requests/~A/discussions" (getf gl-mr :project_id) (getf gl-mr :iid))
`(("position[position_type]" . "text")
("position[base_sha]" . ,(getf version-for-change :base_commit_sha))
("position[head_sha]" . ,(getf version-for-change :head_commit_sha))
("position[start_sha]" . ,(getf version-for-change :start_commit_sha))
;("position[line_range][start][line_code]" . "40606d8fa72800ddf68b5f2cf2b0b30e1d2de8e2_224_131")
;("position[line_range][start][type]" . "new")
;("position[line_range][start][new_line]" . "131")
;("position[line_range][end][line_code]" . "40606d8fa72800ddf68b5f2cf2b0b30e1d2de8e2_224_134")
;("position[line_range][end][type]" . "new")
;("position[line_range][end][new_line]" . "134")
- ("position[new_line]" . ,(princ-to-string (forgerie-core:merge-request-change-comment-line comment)))
+ ,@(when (forgerie-core:merge-request-change-comment-new-line comment)
+ (list (cons "position[new_line]" (princ-to-string (cadr (forgerie-core:merge-request-change-comment-new-line comment))))))
+ ,@(when (forgerie-core:merge-request-change-comment-old-line comment)
+ (list (cons "position[old_line]" (princ-to-string (cadr (forgerie-core:merge-request-change-comment-new-line comment))))))
("position[old_path]" . ,(forgerie-core:merge-request-change-comment-file comment))
("position[new_path]" . ,(forgerie-core:merge-request-change-comment-file comment))
("body" . ,note-text)
("created_at" . ,(to-iso-8601 (forgerie-core:merge-request-change-comment-date comment))))
:sudo (forgerie-core:user-username (forgerie-core:merge-request-change-comment-author comment)))))
(mapcar
(lambda (comment)
(let
((note-text (process-note-text (forgerie-core:merge-request-change-comment-text comment) (getf gl-mr :project_id))))
(when
(and note-text (not (zerop (length note-text))))
(post-request
(format nil "/projects/~A/merge_requests/~A/discussions/~A/notes" (getf gl-mr :project_id) (getf gl-mr :iid) (getf discussion :id))
`(("body" . ,note-text)
("created_at" . ,(to-iso-8601 (forgerie-core:merge-request-change-comment-date comment))))
:sudo (forgerie-core:user-username (forgerie-core:merge-request-change-comment-author comment))))))
(forgerie-core:merge-request-change-comment-replies comment)))
(http-error (e)
(cond
((= 400 (http-error-code e))
- (format *standard-output* "400 error in create-change-comments: ~A~%" (http-error-resp e)))
+ (format t "400 error in create-change-comments: ~A~%" (http-error-resp e)))
((= 500 (http-error-code e))
- (format *standard-output* "500 error in create-change-comments: ~A~%" (http-error-resp e)))
+ (format t "500 error in create-change-comments: ~A~%" (http-error-resp e)))
(t (error e))))))))
(forgerie-core:merge-request-change-comments change))))
(defun create-merge-request (mr)
(single-project-check
(forgerie-core:vc-repository-name (forgerie-core:merge-request-vc-repository mr))
(when-unmapped (:merge-request-completed (forgerie-core:merge-request-id mr))
(let*
((project-name
(forgerie-core:vc-repository-name
(forgerie-core:merge-request-vc-repository
mr)))
(project (find-project-by-name project-name)))
(when-unmapped (:merge-request (forgerie-core:merge-request-id mr))
(when (not project)
(error "Could not find project with name: ~A" project-name))
(create-local-checkout project)
; We do this first, because if this errors, we want to bomb out first without doing the work
; to create all the branches and whatnot. The other option would be to add a mapping for
; the git work we need to do, but this seemed more elegant.
(process-note-text (forgerie-core:merge-request-description mr) (getf project :id))
(when
(not
(zerop
(git-cmd-code project "show-ref" "--verify" "--quiet"
(format nil "refs/heads/~A" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))))))
(git-cmd project "branch"
(forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr))
(forgerie-core:commit-sha (forgerie-core:branch-commit (forgerie-core:merge-request-source-branch mr)))))
(when
(not
(zerop
(git-cmd-code project "show-ref" "--verify" "--quiet"
(format nil "refs/heads/~A" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr))))))
(git-cmd project "branch"
(forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr))
(forgerie-core:commit-sha (forgerie-core:branch-commit (forgerie-core:merge-request-source-branch mr)))))
(git-cmd project "checkout"
(forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr)))
(mapcar
(lambda (change)
(let
((commit (forgerie-core:merge-request-change-change change)))
(typecase commit
(forgerie-core:commit (git-cmd project "merge" (forgerie-core:commit-sha commit)))
(forgerie-core:patch
(let
((patch-file (format nil "~A/working.patch" *working-directory*)))
(with-open-file (str patch-file :direction :output :if-exists :supersede :if-does-not-exist :create)
(princ (forgerie-core:patch-diff commit) str))
(git-cmd project "am" patch-file)
(delete-file patch-file))))))
(forgerie-core:merge-request-changes mr))
(git-cmd project "push" "gitlab" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr)))
(git-cmd project "push" "gitlab" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr)))
(update-mapping (:merge-request (forgerie-core:merge-request-id mr))
(post-request
(format nil "projects/~A/merge_requests" (getf project :id))
`(("source_branch" . ,(forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr)))
("target_branch" . ,(forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr)))
("description" . ,(process-note-text (append (forgerie-core:merge-request-description mr) (list (merge-request-suffix mr))) (getf project :id)))
("title" . ,(forgerie-core:merge-request-title mr)))
:sudo (forgerie-core:user-username (forgerie-core:merge-request-author mr)))))
(when *notes-mode*
(let
((gl-mr (retrieve-mapping :merge-request (forgerie-core:merge-request-id mr))))
(rails-command (format nil "mr = MergeRequest.find(~A)" (getf gl-mr :id)))
(rails-command (format nil "mr.created_at = Time.parse(\"~A\")" (to-iso-8601 (forgerie-core:merge-request-date mr))))
(rails-command "mr.save")
(mapcar
(lambda (note) (create-note (getf gl-mr :project_id) "merge_requests" (getf gl-mr :iid) note))
(forgerie-core:merge-request-notes mr))
(mapcar
(lambda (change)
(create-change-comments gl-mr change))
(forgerie-core:merge-request-changes mr))
(when (eql :closed (forgerie-core:merge-request-type mr))
(put-request
(format nil "projects/~A/merge_requests/~A" (getf project :id) (getf gl-mr :iid))
'(("state_event" . "close")))
(git-cmd project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-source-branch mr)))
(git-cmd project "push" "gitlab" "--delete" (forgerie-core:branch-name (forgerie-core:merge-request-target-branch mr))))
(update-mapping (:merge-request-completed (forgerie-core:merge-request-id mr)))))))))
(defun create-snippet (snippet)
(single-project-check (getf *default-project* :name)
(when-unmapped (:snippet-completed (forgerie-core:snippet-id snippet))
(when
(/= 1 (length (forgerie-core:snippet-files snippet)))
(error "Can only export snippets with exactly one file for now"))
(let
((default-project (default-project))
(file (first (forgerie-core:snippet-files snippet))))
(if
(zerop (forgerie-core:file-size file))
(forgerie-core:add-mapping-error
:gitlab-snippet-empty
(forgerie-core:snippet-id snippet)
(format nil "Skipping snippet ~A because empty content" (forgerie-core:snippet-id snippet)))
(progn
(when-unmapped (:snippet (forgerie-core:snippet-id snippet))
(handler-case
(update-mapping (:snippet (forgerie-core:snippet-id snippet))
(with-open-file (str (forgerie-core:file-location file))
(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" . ,str)
("visibility" . "public")
("file_name" . ,(forgerie-core:file-name file))))))
(error (e)
(forgerie-core:add-mapping-error
:gitlab-snippet-error
(forgerie-core:snippet-id snippet)
(format nil "Failed to create snippet with title ~A, due to error ~A" (forgerie-core:snippet-title snippet) e)))))
(when *notes-mode*
(let
((gl-snippet (retrieve-mapping :snippet (forgerie-core:snippet-id snippet))))
(list
gl-snippet
(mapcar
(lambda (note) (create-note (getf default-project :id) "snippets" (getf gl-snippet :id) note))
(forgerie-core:snippet-notes snippet)))
(rails-command (format nil "s = Snippet.find(~A)" (getf gl-snippet :id)))
(rails-command (format nil "u = User.find_by_username(\"~A\")" (forgerie-core:user-username (forgerie-core:snippet-author snippet))))
(rails-command "s.author = u")
(rails-command "s.save")
(update-mapping (:snippet-completed (forgerie-core:snippet-id snippet)) gl-snippet)))))))))
diff --git a/src/main/phabricator/import.lisp b/src/main/phabricator/import.lisp
index e0af668..5b0ac3f 100644
--- a/src/main/phabricator/import.lisp
+++ b/src/main/phabricator/import.lisp
@@ -1,919 +1,947 @@
(in-package #:forgerie-phabricator)
; This is really a stepping stone to more structured data, but nice
; while what we're getting out of the database and whatnot is more fluid.
(defmacro getf-convenience (type &rest fields)
`(progn
,@(mapcar
(lambda (field)
`(defun ,(intern (format nil "~A-~A" type field)) (o)
(getf o ,(intern (symbol-name field) :keyword))))
fields)))
(getf-convenience differential-diff id)
(getf-convenience edge dst)
(getf-convenience email address isprimary)
(getf-convenience file id storageengine storageformat storagehandle name location mimetype bytesize phid)
(getf-convenience file-storageblob data)
(getf-convenience paste id phid title filephid file comments author authorphid)
(getf-convenience paste-comment id author authorphid content datecreated)
(getf-convenience project id phid icon name tags)
(getf-convenience project-slug slug)
(getf-convenience repository id phid repositoryslug name localpath projects primary-projects commits)
(getf-convenience repository-commit id phid repositoryid commitidentifier parents patch comments git-comment)
(getf-convenience task id phid title status projects comments owner author ownerphid authorphid description datecreated priority spacephid linked-tasks subscribers)
(getf-convenience task-comment id author authorphid content datecreated)
(getf-convenience user id username realname phid emails isadmin profileimage profileimagephid)
(getf-convenience differential-revision
- id title summary testplan phid status repository repositoryphid datecreated related-commits author authorphid comments)
+ id title summary testplan phid status repository repositoryphid datecreated related-commits author authorphid comments change-comments
+ activediffphid)
(getf-convenience differential-transaction-comment
phid content changesetid isnewfile linenumber linelength replytocommentphid diff replies author authorphid datecreated)
-(getf-convenience differential-diff sourcecontrolbaserevision filename)
+(getf-convenience differential-diff sourcecontrolbaserevision filename phid)
(getf-convenience differential-comment id author authorphid content datecreated)
(defvar *query-cache* nil)
(defun query (query)
(when (not (assoc query *query-cache* :test #'string=))
(when forgerie-core:*debug* (format t "~S~%" query))
(setf *query-cache*
(cons
(cons
query
(let*
((result (car (cl-mysql:query query)))
(rows (car result))
(definitions (cadr result)))
(mapcar
(lambda (row)
(apply #'append
(mapcar
(lambda (col def)
(list (intern (string-upcase (car def)) :keyword) col))
row definitions)))
rows)))
*query-cache*)))
(cdr (assoc query *query-cache* :test #'string=)))
(defun initialize ()
(cl-mysql:connect :password *database-password*)
(cl-mysql:query "set names 'utf8'"))
; This function is only for development mode. While we have emails
; turned off for gitlab, there's a chance that something screwed up will happen
; so we should make it so the aren't real email addresses
(defun sanitize-address (address)
(format nil "~A@opentechstrategies.com" (cl-ppcre:regex-replace-all "@" address "_")))
(defun user-primary-email (user)
(find 1 (user-emails user) :key #'email-isprimary))
(defun get-emails (user-phid)
(query (format nil "select * from phabricator_user.user_email where userphid = '~A'" user-phid)))
(defun annotate-user (user)
(append
(let
((override (find (user-id user) *user-overrides* :key (lambda (override) (getf override :key)))))
(when (and override (eql :update (getf override :action)))
(getf override :data)))
user
(list :profileimage (when (user-profileimagephid user) (get-file (user-profileimagephid user))))
(list :emails (get-emails (user-phid user)))))
(defun get-user (phid)
(annotate-user
(first
(query (format nil "select id, username, realName, phid, isadmin, profileimagephid from phabricator_user.user where phid = '~A'" phid)))))
(defun get-users ()
(mapcar #'annotate-user
(query "select id, username, realName, phid, isadmin, profileimagephid from phabricator_user.user")))
(defun fill-out-project (proj)
(append
(list
:tags
(mapcar #'project-slug-slug
(query (format nil "select slug from phabricator_project.project_slug where projectphid = '~A'" (project-phid proj)))))
proj))
(defun get-project (id &optional (key "phid"))
(fill-out-project
(first
(query
(format nil "select id, phid, color, name, icon from phabricator_project.project where ~A = '~A'" key id)))))
(defun get-projects ()
(mapcar #'fill-out-project (query "select id, phid, color, name, icon from phabricator_project.project")))
(defun add-author-to-task-comment (comment)
(append
comment
(list :author (get-user (task-comment-authorphid comment)))))
(defun get-task-comments (task)
(mapcar
#'add-author-to-task-comment
(query
(format nil
"select
mtc.id, mtc.authorphid, mt.datecreated, mtc.content
from phabricator_maniphest.maniphest_transaction mt
left join phabricator_maniphest.maniphest_transaction_comment mtc on mtc.phid = mt.commentphid
where commentphid is not null and
mtc.isdeleted = 0 and
objectphid = '~A' and
transactiontype = 'core:comment' order by mt.datecreated"
(task-phid task)))))
(defun annotate-task (task)
(append
task
(list
:owner (when (task-ownerphid task) (get-user (task-ownerphid task)))
:author (when (task-authorphid task) (get-user (task-authorphid task)))
:comments (get-task-comments task))
(list
:subscribers
(mapcar
(lambda (phid) (get-user phid))
(mapcar #'edge-dst
(query
(format nil
"select dst from phabricator_maniphest.edge where src = '~A' and type = 21"
(task-phid task))))))
(list
:linked-tasks
(mapcar
(lambda (phid) (get-task phid :shallow t))
(mapcar #'edge-dst
(query
(format nil
"select dst from phabricator_maniphest.edge where src = '~A' and type = 3"
(task-phid task))))))
(list
:projects
(mapcar #'get-project
(mapcar #'edge-dst
(query
(format nil
"select dst from phabricator_maniphest.edge where src = '~A' and dst like 'PHID-PROJ%'"
(task-phid task))))))))
(defun get-task (phid &key shallow)
(let
((task (first (query (format nil "select * from phabricator_maniphest.maniphest_task where phid = '~A'" phid)))))
(if shallow task (annotate-task task))))
(defun get-tasks ()
(mapcar #'annotate-task
(query "select * from phabricator_maniphest.maniphest_task")))
(defun attach-projects-to-repository (repo)
(let
((associated-projects
(mapcar #'get-project
(mapcar #'edge-dst
(query
(format nil
"select * from phabricator_repository.edge where src = '~A' and dst like 'PHID-PROJ%'"
(repository-phid repo)))))))
(append
(let
((override (find (repository-id repo) *repository-overrides* :key (lambda (override) (getf override :key)))))
(when (and override (eql :update (getf override :action)))
(getf override :data)))
repo
(list :primary-projects
(append
(mapcar
(lambda (override) (get-project (getf override :key) "id"))
(remove-if-not
(lambda (override)
(and
(repository-repositoryslug repo)
(string= (repository-repositoryslug repo) (getf override :repository))))
*project-assignment-overrides*))
(remove
nil
(mapcar
(lambda (project)
(when
(and
(string= "folder" (project-icon project))
; We remove projects that have override defs, because we add them back in later
(not (find (project-id project) *project-assignment-overrides* :key (lambda (override) (getf override :key)))))
project))
associated-projects))))
(list :projects associated-projects))))
(defun annotate-repository-commits (repo)
(append
(list
:commits
(cached "repository-commits" (repository-phid repo)
(mapcar
(lambda (sha)
(list
:commitidentifier sha
:git-comment
(nth-value 1
(forgerie-core:git-cmd
(repository-localpath repo)
"log"
(list "--format=%B" "-n" "1" sha)))))
(mapcar #'car (get-shas-and-details repo)))))
repo))
(defun get-repository (phid)
(attach-projects-to-repository
(first
(query
(format nil
"select id, phid, repositoryslug, name, localpath from phabricator_repository.repository where phid = '~A'"
phid)))))
(defun get-repository-by-slug (slug)
(attach-projects-to-repository
(first
(query
(format nil
"select id, phid, repositoryslug, name, localpath from phabricator_repository.repository where repositoryslug = '~A'"
slug)))))
(defun get-repositories ()
(let
((repositories (query "select id, phid, repositoryslug, name, localpath from phabricator_repository.repository where repositoryslug is not null")))
(mapcar #'annotate-repository-commits
(mapcar #'attach-projects-to-repository
(remove-if
(lambda (repo)
(eql :skip
(getf
(find (repository-id repo) *repository-overrides* :key (lambda (override) (getf override :key)))
:action)))
repositories)))))
(defun db-file (file-phid)
(first
(query
(format nil "select id, phid, name, storageEngine, storageFormat, storageHandle, mimetype, bytesize from phabricator_file.file where phid = '~A'"
file-phid))))
(defun put-file-on-disk (out file)
(cond
((and (string= "blob" (file-storageengine file)) (string= "raw" (file-storageformat file)))
(write-sequence
(file-storageblob-data
(first
(query
(format nil "select data from phabricator_file.file_storageblob where id = '~A';"
(file-storagehandle file)))))
out))
((and
(string= "local-disk" (file-storageengine file))
(string= "raw" (file-storageformat file)))
(with-open-file (str (format nil "~A/~A" *storage-location* (file-storagehandle file)) :element-type 'unsigned-byte)
(let
((data (make-array (file-bytesize file))))
(read-sequence data str)
(write-sequence data out))))
((string= "chunks" (file-storageengine file))
(mapcar
(lambda (chunk)
(put-file-on-disk out (db-file (getf chunk :datafilephid)))
(force-output out))
(query
(format nil "select dataFilePHID from phabricator_file.file_chunk where chunkhandle = '~A' order by byteStart" (file-storagehandle file)))))
(t
(error
"Don't know how to handle files of with engine,format,mimetype of ~A,~A,~A encounted on ~A"
(file-storageengine file)
(file-storageformat file)
(file-mimetype file)
(file-phid file)))))
(defun get-file (file-phid)
(let*
((file (db-file file-phid))
(dir (format nil "~A/files/~A/" *working-directory* (subseq file-phid (- (length file-phid) 3))))
(location (format nil "~A~A" dir file-phid)))
(when (not (probe-file location))
(ensure-directories-exist dir)
(with-open-file (out location :direction :output :element-type 'unsigned-byte)
(put-file-on-disk out file)))
(append file (list :location location))))
(defvar *captured-files* nil)
(defun capture-file (id)
(setf
*captured-files*
(remove-duplicates
(cons id *captured-files*)
:test #'string=)))
(defun get-captured-files ()
(mapcar
#'get-file
(mapcar
(lambda (file-id)
(getf (first (query (format nil "select phid from phabricator_file.file where id = ~A" file-id))) :phid))
(cached "everything" "captured-files" *captured-files*))))
(defun add-author-to-paste-comment (comment)
(append
comment
(list :author (get-user (paste-comment-authorphid comment)))))
(defun get-paste-comments (paste)
(mapcar
#'add-author-to-paste-comment
(query
(format nil
"select
ptc.id, ptc.authorphid, pt.datecreated, ptc.content
from phabricator_paste.paste_transaction pt
left join phabricator_paste.paste_transaction_comment ptc on ptc.phid = pt.commentphid
where commentphid is not null and
ptc.isdeleted = 0 and
objectphid = '~A' and
transactiontype = 'core:comment' order by pt.datecreated"
(paste-phid paste)))))
(defun get-pastes ()
(mapcar
(lambda (paste)
(append paste
(list
:author (get-user (paste-authorphid paste))
:comments (get-paste-comments paste))))
(remove
nil
(mapcar
(lambda (paste)
(let
((file (get-file (paste-filephid paste))))
(when file (append (list :file file) paste))))
(remove-if
(lambda (paste) (find (paste-id paste) *pastes-to-skip*))
(query "select id, title, phid, filePHID, authorPHID from phabricator_paste.paste"))))))
(defun get-commit (phid &optional (with-parents t))
(let
((commit
(first
(query
(format nil
"select id, repositoryid, commitidentifier from phabricator_repository.repository_commit where phid = '~A'"
phid)))))
(append
commit
(list :parents
(if with-parents
(mapcar
(lambda (parent-phid) (get-commit parent-phid nil))
(mapcar #'repository-commit-phid
(query
(format nil
"select rc.phid
from phabricator_repository.repository_parents rp
join phabricator_repository.repository_commit rc on rp.parentcommitid = rc.id
where childcommitid = '~A'"
(repository-commit-id commit)))))
:unfetched)))))
(defun order-related-commits (commits)
(when (find-if (lambda (commit) (< 1 (length (repository-commit-parents commit)))) commits)
(error "There's a merge commit in the differential commit list?! Investigate further"))
(cond
((not commits) nil)
((= 1 (length commits)) commits)
(t
(let*
((parents (apply #'append (mapcar #'repository-commit-parents commits)))
(non-parent-commits
(remove-if
(lambda (commit)
(find (repository-commit-commitidentifier commit) parents :key #'repository-commit-commitidentifier :test #'string=))
commits)))
(when (< 1 (length non-parent-commits))
(format t "~S~%" non-parent-commits)
(error "There's multiple commits that are not a parent in the set, meaning this commit chain is weird"))
(cons
(car non-parent-commits)
(order-related-commits (remove (car non-parent-commits) commits)))))))
(defun get-commits-from-db (revision)
(let
((repository (get-repository (differential-revision-repositoryphid revision))))
(reverse
(order-related-commits
(remove-if
(lambda (commit)
(or
(not (eql (repository-commit-repositoryid commit) (repository-id repository)))
; Is this commit reachable?
(not
(zerop
(forgerie-core:git-cmd
(repository-localpath repository)
"cat-file"
(list "-t" (repository-commit-commitidentifier commit)))))
(string=
(format nil "undefined~%")
(nth-value 1
(forgerie-core:git-cmd
(repository-localpath repository)
"name-rev"
(list
"--name-only"
(repository-commit-commitidentifier commit)))))
; Remove merge commits
(< 1 (length (repository-commit-parents commit)))))
(mapcar #'get-commit
(mapcar #'edge-dst
; type of 31 is the same as DifferentialRevisionHasCommitEdgeType
(query (format nil "select dst from phabricator_differential.edge where src = '~A' and type = 31"
(differential-revision-phid revision))))))))))
(defun get-details (repository sha)
(with-output-to-string (out)
(sb-ext:run-program (asdf:system-relative-pathname :forgerie "bin/getdetails.sh")
(list sha (repository-localpath repository))
:wait t
:output out)))
(defun get-shas-and-details (repository)
(forgerie-core:check-for-stop)
(cached
"shas-and-details"
(repository-phid repository)
(mapcar
(lambda (sha) (list sha (get-details repository sha)))
(cl-ppcre:split
"\\n"
(nth-value 1
(forgerie-core:git-cmd
(repository-localpath repository)
"log"
(list
"--all"
"--pretty=%H")))))))
(defun get-commits-from-staging (revision)
(let*
((staging-repository (get-repository "PHID-REPO-cuxcaqw5u7vepi4b4bpg"))
(repository (get-repository (differential-revision-repositoryphid revision)))
(latest-diff
(first
(query
(format nil "select id from phabricator_differential.differential_diff where revisionid = '~A' order by id desc limit 1"
(differential-revision-id revision)))))
(all-shas-and-details (get-shas-and-details repository)))
(labels
((build-commit-chain (diff-id &optional (n 0))
(when
(> n 20)
(error "We have failed to find a matching commit in the previous 20"))
(let*
((diff-details (get-details staging-repository (format nil "phabricator/diff/~A~~~A" diff-id n)))
(repo-details (find diff-details all-shas-and-details :test #'string= :key #'cadr)))
(if repo-details
(list (list :commitidentifier (car repo-details) :repository repository))
(cons
(list
:patch
(nth-value 1
(forgerie-core:git-cmd
(repository-localpath staging-repository)
"format-patch"
(list "-k" "-1" "--stdout" (format nil "phabricator/diff/~A~~~A" diff-id n)))))
(build-commit-chain diff-id (1+ n)))))))
(let
((commit-chain (reverse (build-commit-chain (differential-diff-id latest-diff)))))
(cons
(append
(second commit-chain)
(list :parents (list (first commit-chain))))
(cddr commit-chain))))))
(defun build-raw-commit (revision)
(let*
((repository (get-repository (differential-revision-repositoryphid revision)))
(user (get-user (differential-revision-authorphid revision)))
(path (format nil "~A/~A/" *working-directory* (repository-repositoryslug repository)))
(raw-diff
(drakma:http-request
(format nil
"~A/D~A?download=true"
*phabricator-location*
(differential-revision-id revision)))))
(when (not (probe-file path))
(ensure-directories-exist path)
(forgerie-core:git-cmd path "clone" (list (repository-localpath repository) ".")))
(labels
((sha-applicable (sha)
(forgerie-core:git-cmd path "checkout" (list sha))
(zerop
(with-input-from-string (in raw-diff)
(forgerie-core:git-cmd path "apply" (list "-") :input in :error nil))))
(find-parent-sha (&optional (shas (mapcar #'car (get-shas-and-details repository))))
(cond
((not shas)
(with-open-file (debug-file "~/diff.patch" :direction :output :if-exists :supersede)
(princ raw-diff debug-file))
(error "Couldn't find a sha for which this could be applied"))
((sha-applicable (car shas)) (car shas))
(t (find-parent-sha (cdr shas))))))
(let
((parent-commit-sha (find-parent-sha)))
(forgerie-core:git-cmd path "add" (list "."))
(forgerie-core:git-cmd path "commit"
(list
"--author"
(format nil "~A <~A>" (user-realname user) (email-address (user-primary-email user)))
"-m"
(format nil "Generated commit for differential D~A" (differential-revision-id revision))))
(list
(list
:repositoryid (repository-id repository)
:patch
(nth-value 1
(forgerie-core:git-cmd path "format-patch"
(list
"-k"
"-1"
"--stdout")))
:parents
(list
(list
:repositoryid (repository-id repository)
:commitidentifier parent-commit-sha))))))))
(defun add-author-to-differential-comment (comment)
(append
comment
(list :author (get-user (differential-comment-authorphid comment)))))
(defun get-revision-comments (rev)
(mapcar
#'add-author-to-differential-comment
(query
(format nil
"select
rtc.id, rtc.authorphid, rt.datecreated, rtc.content
from phabricator_differential.differential_transaction rt
left join phabricator_differential.differential_transaction_comment rtc on rtc.phid = rt.commentphid
where commentphid is not null and
rtc.isdeleted = 0 and
objectphid = '~A' and
transactiontype = 'core:comment' order by rt.datecreated"
(differential-revision-phid rev)))))
(defun get-revision-inline-comments (rev)
(let*
((phid (differential-revision-phid rev))
(comments
(query
(format nil
"select * from phabricator_differential.differential_transaction_comment where revisionphid = '~A' and isdeleted = 0 and changesetid is not null" phid))))
(mapcar
(lambda (comment)
(append
comment
(list
:author
(get-user (differential-transaction-comment-authorphid comment))
:diff
(car
(query
(format nil
"select diff.*, changeset.filename from phabricator_differential.differential_diff diff join phabricator_differential.differential_changeset changeset on changeset.diffid = diff.id where changeset.id = ~A" (differential-transaction-comment-changesetid comment)))))))
comments)))
(defun attach-inline-comments-to-commits (commits inline-comments)
(flet
((comment-attached-to-commit (comment commit)
(find
(differential-diff-sourcecontrolbaserevision
(differential-transaction-comment-diff comment))
(mapcar #'repository-commit-commitidentifier (repository-commit-parents commit))
:test #'string=)))
- (cond
- ((some
- (lambda (comment) (/= (differential-transaction-comment-isnewfile comment) 1))
- inline-comments)
- (error "Ran into a transaction comment where it's not a new file, can't handle."))
-; ((find-if
-; (lambda (comment)
-; (notany
-; (lambda (commit) (comment-attached-to-commit comment commit))
-; commits))
-; inline-comments)
-; (error "Inline comment does not have a commit it goes with, can't handle"))
- (t
+ (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))
- inline-comments))
+ attached-comments))
commit)
- commits)))))
+ 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 (get-revision-inline-comments rev))
+ ((inline-comments (thread-inline-comments (get-revision-inline-comments rev)))
(commits
(cached
"revision_commits"
(differential-revision-id rev)
(or
(get-commits-from-db rev)
(handler-case
(get-commits-from-staging rev)
(error (e) (format t "Failed to get commit from staging due to error ~A, falling back.~%" e)))
(build-raw-commit rev)))))
(attach-inline-comments-to-commits
commits
- (thread-inline-comments inline-comments))))
+ inline-comments)))
+
+(defun annotate-revision (rev)
+ (forgerie-core:check-for-stop)
+ (when forgerie-core:*debug*
+ (format t "---------------~%Loading revision ~A~%~%~%" (differential-revision-id rev)))
+ (let
+ ((repository (get-repository (differential-revision-repositoryphid rev))))
+ (handler-case
+ (cached
+ "revisions"
+ (differential-revision-id rev)
+ (append
+ rev
+ (list :author (get-user (differential-revision-authorphid rev)))
+ (list :comments (get-revision-comments rev))
+ (multiple-value-bind (commits unattached-comments) (get-revision-commits rev)
+ (let
+ ((comments-to-attach
+ (remove-if-not
+ (lambda (comment)
+ (string= (differential-diff-phid (differential-transaction-comment-diff comment)) (differential-revision-activediffphid rev)))
+ unattached-comments)))
+ (list :change-comments comments-to-attach :related-commits commits)))
+ (list :repository repository)))
+ (error (e) (format t "Failed to handle revision ~A, due to error ~A, skipping.~%" (differential-revision-id rev) e)))))
+
+(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
- (lambda (rev)
- (when forgerie-core:*debug*
- (format t "---------------~%Loading revision ~A~%~%~%" (differential-revision-id rev)))
- (let
- ((repository (get-repository (differential-revision-repositoryphid rev))))
- (handler-case
- (cached
- "revisions"
- (differential-revision-id rev)
- (append
- rev
- (list :author (get-user (differential-revision-authorphid rev)))
- (list :comments (get-revision-comments rev))
- (list :related-commits (get-revision-commits rev))
- (list :repository repository)))
- (error (e) (format t "Failed to handle revision ~A, due to error ~A, skipping.~%" (differential-revision-id rev) e)))))
+ (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 from phabricator_differential.differential_revision")))))
+ (query "select id, title, summary, testplan, phid, status, repositoryphid, datecreated, authorphid, activediffphid from phabricator_differential.differential_revision")))))
(defun parse-comment (comment)
(labels
((first-instance-of (regex type &key with-aftercheck (comment comment))
(multiple-value-bind (start end match-starts match-ends) (cl-ppcre:scan regex comment)
(cond
((not start) nil)
((eql type :link)
(list start end type
(list
(subseq comment (aref match-starts 0) (aref match-ends 0))
(subseq comment (aref match-starts 1) (aref match-ends 1)))
(subseq comment start end)))
((or (zerop start) (= end (length comment)))
(list start end type (subseq comment (aref match-starts 0) (aref match-ends 0)) (subseq comment start end)))
((and with-aftercheck (cl-ppcre:scan "[\\d\\w]" (subseq comment (1- start) start)))
(first-instance-of regex type :comment (subseq comment end)))
((and with-aftercheck (cl-ppcre:scan "[\\d\\w]" (subseq comment end (1+ end))))
(first-instance-of regex type :comment (subseq comment end)))
(t
(list start end type (subseq comment (aref match-starts 0) (aref match-ends 0)) (subseq comment start end)))))))
(let*
((first-instance
(car
(sort
(remove-if-not #'identity
(list
(first-instance-of "\\n= ([^\\n]*) =\\n" :h1)
(first-instance-of "\\n== ([^\\n]*) ==\\n" :h2)
(first-instance-of "\\n=== ([^\\n]*) ===\\n" :h3)
(first-instance-of "\\n==== ([^\\n]*) ====\\n" :h4)
(first-instance-of "\\n===== ([^\\n]*) =====\\n" :h5)
(first-instance-of "\\[\\[ *([^| ]*) *\\| *([^\\]]*) *\\]\\]" :link)
(first-instance-of "\{F(\\d+)\}" :file)
(first-instance-of "T(\\d+)(#\\d+)?" :ticket)
(first-instance-of "P(\\d+)(#\\d+)?" :snippet)
(first-instance-of "D(\\d+)(#\\d+)?" :merge-request)))
#'<
:key #'car))))
(when
(and first-instance (equal :file (third first-instance)))
(capture-file (fourth first-instance)))
(cond
((zerop (length comment)) nil)
((not first-instance) (list comment))
(t
(append
(when (not (zerop (car first-instance))) (list (subseq comment 0 (car first-instance))))
(list (cddr first-instance))
(parse-comment (subseq comment (cadr first-instance)))))))))
(defun convert-commit-to-core (commit)
(cond
((repository-commit-commitidentifier commit)
(forgerie-core:make-commit
:sha (repository-commit-commitidentifier commit)
:parsed-comment
(when (repository-commit-git-comment commit)
(parse-comment (repository-commit-git-comment commit)))))
((repository-commit-patch commit)
(forgerie-core:make-patch :diff (repository-commit-patch commit)))))
+(defun convert-change-comment-to-core (comment)
+ (forgerie-core:make-merge-request-change-comment
+ :old-line
+ (when (zerop (differential-transaction-comment-isnewfile comment))
+ (list
+ (differential-transaction-comment-linenumber comment)
+ (+ (differential-transaction-comment-linenumber comment) (differential-transaction-comment-linelength comment))))
+ :new-line
+ (when (not (zerop (differential-transaction-comment-isnewfile comment)))
+ (list
+ (differential-transaction-comment-linenumber comment)
+ (+ (differential-transaction-comment-linenumber comment) (differential-transaction-comment-linelength comment))))
+ :date (unix-to-universal-time (differential-transaction-comment-datecreated comment))
+ :file (map 'string #'code-char (differential-diff-filename (differential-transaction-comment-diff comment)))
+ :text (parse-comment (map 'string #'code-char (differential-transaction-comment-content comment)))
+ :author (convert-user-to-core (differential-transaction-comment-author comment))
+ :replies (mapcar #'convert-change-comment-to-core (differential-transaction-comment-replies comment))))
+
(defun convert-change-to-core (commit)
- (labels
- ((convert-comment-to-core (comment)
- (forgerie-core:make-merge-request-change-comment
- :line (differential-transaction-comment-linenumber comment)
- :date (unix-to-universal-time (differential-transaction-comment-datecreated comment))
- :file (map 'string #'code-char (differential-diff-filename (differential-transaction-comment-diff comment)))
- :text (parse-comment (map 'string #'code-char (differential-transaction-comment-content comment)))
- :author (convert-user-to-core (differential-transaction-comment-author comment))
- :replies (mapcar #'convert-comment-to-core (differential-transaction-comment-replies comment)))))
- (forgerie-core:make-merge-request-change
- :change (convert-commit-to-core commit)
- :comments (mapcar #'convert-comment-to-core (repository-commit-comments commit)))))
+ (forgerie-core:make-merge-request-change
+ :change (convert-commit-to-core commit)
+ :comments (mapcar #'convert-change-comment-to-core (repository-commit-comments commit))))
(defun convert-differential-comment-to-core (comment)
(forgerie-core:make-note
:id (format nil "D~A" (differential-comment-id comment))
:text (parse-comment (map 'string #'code-char (differential-comment-content comment)))
:author (convert-user-to-core (differential-comment-author comment))
:date (unix-to-universal-time (differential-comment-datecreated comment))))
(defun convert-revision-to-core (revision-def)
(let
((type
(cond
((find (differential-revision-status revision-def) (list "published" "abandoned") :test #'string=)
:closed)
((find (differential-revision-status revision-def) (list "changes-planned" "needs-review" "needs-revision" "accepted" "draft") :test #'string=)
:open)
(t (error "Unknown revision type: ~A" (differential-revision-status revision-def))))))
(forgerie-core:make-merge-request
:id (differential-revision-id revision-def)
:title (differential-revision-title revision-def)
:description
(parse-comment
(format nil "~A~A"
(map 'string #'code-char (differential-revision-summary revision-def))
(if (differential-revision-testplan revision-def)
(format nil "~%~%== Test Plan ==~%~%~A" (map 'string #'code-char (differential-revision-testplan revision-def)))
"")))
:author (convert-user-to-core (differential-revision-author revision-def))
:vc-repository (convert-repository-to-core (differential-revision-repository revision-def))
:date (unix-to-universal-time (differential-revision-datecreated revision-def))
:type type
:target-branch
(forgerie-core:make-branch
:name
; Defaults to master, but that may be wrong after more investigation
(if (eql :open type) "master" (format nil "generated-differential-D~A-target" (differential-revision-id revision-def)))
:commit (convert-commit-to-core (car (repository-commit-parents (car (differential-revision-related-commits revision-def))))))
:source-branch
(forgerie-core:make-branch
:name (format nil "generated-differential-D~A-source" (differential-revision-id revision-def))
:commit (convert-commit-to-core (car (repository-commit-parents (car (differential-revision-related-commits revision-def))))))
:changes (mapcar #'convert-change-to-core (differential-revision-related-commits revision-def))
+ :other-change-comments (mapcar #'convert-change-comment-to-core (differential-revision-change-comments revision-def))
:notes (mapcar #'convert-differential-comment-to-core (differential-revision-comments revision-def)))))
(defun convert-repository-to-core (repository-def)
(forgerie-core:make-vc-repository
:name (repository-name repository-def)
:slug (repository-repositoryslug repository-def)
:projects (mapcar #'convert-project-to-core (repository-projects repository-def))
:primary-projects (mapcar #'convert-project-to-core (repository-primary-projects repository-def))
:git-location (repository-localpath repository-def)
:commits (mapcar #'convert-commit-to-core (repository-commits repository-def))))
(defun convert-project-to-core (project-def)
(forgerie-core:make-project
:tags (project-tags project-def)
:name (project-name project-def)))
(defun convert-email-to-core (email-def)
(forgerie-core:make-email
:address (sanitize-address (email-address email-def))
:is-primary (eql (email-isprimary email-def) 1)))
(defun convert-user-to-core (user-def)
(when user-def
(forgerie-core:make-user
:username (user-username user-def)
:name (user-realname user-def)
:admin (equal (user-isadmin user-def) 1)
:emails (mapcar #'convert-email-to-core (user-emails user-def))
:avatar (when (user-profileimage user-def) (convert-file-to-core (user-profileimage user-def))))))
(defun convert-task-comment-to-core (comment)
(forgerie-core:make-note
:id (format nil "T~A" (task-comment-id comment))
:text (parse-comment (map 'string #'code-char (task-comment-content comment)))
:author (convert-user-to-core (task-comment-author comment))
:date (unix-to-universal-time (task-comment-datecreated comment))))
(defun convert-task-to-core (task-def)
(let
((type
(cond
((find (task-status task-def) (list "open" "wip") :test #'string=)
:open)
((find (task-status task-def) (list "duplicate" "invalid" "resolved" "spite" "wontfix") :test #'string=)
:closed)
(t (error "Unknown revision type: ~A" (differential-revision-status revision-def))))))
(forgerie-core:make-ticket
:id (task-id task-def)
:title (task-title task-def)
:author (convert-user-to-core (task-author task-def))
:assignee (convert-user-to-core (task-owner task-def))
:description (parse-comment (map 'string #'code-char (task-description task-def)))
:projects (mapcar #'convert-project-to-core (task-projects task-def))
:date (unix-to-universal-time (task-datecreated task-def))
:confidential (not (not (find (task-spacephid task-def) *confidential-space-phids* :test #'string=)))
:linked-tickets (mapcar #'convert-task-to-core (task-linked-tasks task-def))
:subscribers (mapcar #'convert-user-to-core (task-subscribers task-def))
:priority
(case (task-priority task-def)
(100 "Unbreak!")
(90 "Triage")
(80 "High")
(50 "Normal")
(25 "Low")
(0 "Wish"))
:type type
:notes (mapcar #'convert-task-comment-to-core (task-comments task-def)))))
(defun convert-paste-comment-to-core (comment)
(forgerie-core:make-note
:id (format nil "P~A" (paste-comment-id comment))
:text (parse-comment (map 'string #'code-char (paste-comment-content comment)))
:author (convert-user-to-core (paste-comment-author comment))
:date (unix-to-universal-time (paste-comment-datecreated comment))))
(defun convert-file-to-core (file-def)
(forgerie-core:make-file
:id (file-id file-def)
:name (file-name file-def)
:location (file-location file-def)
:size (file-bytesize file-def)
:mimetype (file-mimetype file-def)))
(defun convert-paste-to-core (paste-def)
(forgerie-core:make-snippet
:id (paste-id paste-def)
:title (paste-title paste-def)
:files (list (convert-file-to-core (paste-file paste-def)))
:author (convert-user-to-core (paste-author paste-def))
:notes (mapcar #'convert-paste-comment-to-core (paste-comments paste-def))))
(defmethod forgerie-core:import-forge ((forge (eql :phabricator)))
(initialize)
(list
:users (cached "everything" "users" (mapcar #'convert-user-to-core (get-users)))
:projects (cached "everything" "projects" (mapcar #'convert-project-to-core (get-projects)))
:vc-repositories (cached "everything" "repositories" (mapcar #'convert-repository-to-core (get-repositories)))
:snippets (cached "everything" "snippets" (mapcar #'convert-paste-to-core (get-pastes)))
:merge-requests (cached "everything" "merge-requests" (mapcar #'convert-revision-to-core (get-revisions)))
:tickets (cached "everything" "tickets" (mapcar #'convert-task-to-core (get-tasks)))
:files (cached "everything" "files" (mapcar #'convert-file-to-core (get-captured-files)))))

File Metadata

Mime Type
text/x-diff
Expires
Mon, Aug 18, 8:54 PM (1 d, 1 h)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
3317813

Event Timeline

About · Developer information · Legal