Commit c52e731e authored by Eric Timmons's avatar Eric Timmons
Browse files

First commit

parents
Copyright 2020 Eric Timmons
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#+TITLE: Quicklisp -> CLPI Converter
#+AUTHOR: clpm-devel@common-lisp.net
This project converts project metadata from Quicklisp's format into CLPI's
format.
;;;; QL-CLPI System Definition
;;;;
;;;; This software is part of QL-CLPI. See README.org for more information. See
;;;; LICENSE for license information.
#-:asdf3.2
(error "Requires ASDF >=3.2")
;; Not necessary, but easier to have when using SLIME.
(in-package :asdf-user)
(defsystem #:ql-clpi
:version "0.0.1"
:description "A library to convert Quicklisp metadata to CLPI metadata."
:license "BSD-2-Clause"
:pathname "src/"
:class :package-inferred-system
:depends-on (#:ql-clpi/ql-clpi))
;;;; Script to convert a QL distribution to a file based CLPI index.
;;;;
;;;; This software is part of QL-CLPI. See README.org for more information. See
;;;; LICENSE for license information.
(in-package #:cl-user)
(require :asdf)
(asdf:load-system :ql-clpi)
(asdf:load-system :clpm-multi-http-client/drakma)
(uiop:define-package #:ql-clpm-scripts/convert-ql-dist
(:use #:cl
#:ql-clpi
#:ql-clpi/ql-dist
#:ql-clpi/ql-to-clpi))
(in-package #:ql-clpm-scripts/convert-ql-dist)
(defun sync-ql-dist-to-file-index (ql-dist-uri ql-cache-dir clpi-dir
&key http-client
appendable-p)
(let ((ql-dist (make-instance 'ql-dist
:uri ql-dist-uri
:cache-pathname ql-cache-dir
:http-client http-client))
(index (make-instance 'clpi:file-index
:root clpi-dir)))
(ql-dist-to-clpi ql-dist index :appendable-p appendable-p)
index))
(defun run ()
(clpi:index-save
(sync-ql-dist-to-file-index "https://beta.quicklisp.org/dist/quicklisp.txt"
"/tmp/clpi/ql/"
"/tmp/clpi/file/"
:http-client
(make-instance 'clpm-multi-http-client/drakma:drakma-client)
:appendable-p t)))
(run)
;;;; QL-CLPI
;;;;
;;;; This software is part of QL-CLPI. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:ql-clpi/ql-clpi
(:nicknames #:ql-clpi)
(:use #:cl
#:alexandria
#:ql-clpi/ql-dist
#:ql-clpi/ql-to-clpi)
(:import-from #:alexandria)
(:import-from #:clpi)
(:export #:ql-dist
#:ql-dist-to-clpi
#:project-version-aliases))
(in-package #:ql-clpi/ql-clpi)
(defun project-version-aliases (project version)
"Given a PROJECT and a VERSION, return all aliases of that version string."
(let ((alias-alist (clpi:metadata-value project :ql/version-aliases)))
(assoc-value alias-alist version :test 'equal)))
;;;; Quicklisp Distribution Representation
;;;;
;;;; This software is part of QL-CLPI. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:ql-clpi/ql-dist
(:use #:cl
#:alexandria
#:anaphora
#:clpm-multi-http-client
#:split-sequence)
(:import-from #:puri)
(:export #:ql-dist-version-release
#:ql-dist-version-release-map
#:ql-dist-version-system-by-name-map
#:ql-dist-version-system-by-project-map
#:ql-dist-version-version
#:ql-release-file-md5
#:ql-release-prefix
#:ql-release-size
#:ql-release-system-files
#:ql-release-uri
#:ql-dist
#:ql-dist-version
#:ql-dist-versions
#:ql-system-dependencies
#:ql-system-project
#:ql-system-system-file
#:ql-system-system-name))
(in-package #:ql-clpi/ql-dist)
(defclass ql-dist ()
((http-client
:initarg :http-client
:documentation
"Optional. Specify an HTTP client to use when interacting with this
distribution. If a function, it will be called with one argument. If unbound,
will fallback to *DEFAULT-HTTP-CLIENT*.")
(uri
:accessor ql-dist-uri)
(force-https
:initarg :force-https
:initform nil
:accessor ql-dist-force-https)
(cache-pathname
:initarg :cache-pathname
:initform (error "A cache pathname must be provided")
:accessor ql-dist-cache-pathname)
(versions-uri
:accessor ql-dist-versions-uri)
(version-uris-map
:reader ql-dist-version-uris-map)
(dist-version-cache
:initform (make-hash-table :test 'equal)
:reader ql-dist-version-cache))
(:documentation
"Represents a Quicklisp distribution."))
(defun ql-dist-http-client (ql-dist)
(if (slot-boundp ql-dist 'http-client)
(let ((client (slot-value ql-dist 'http-client)))
(cond
((functionp client)
(funcall client))
(client
client)
(t
*default-http-client*)))
*default-http-client*))
(defmethod initialize-instance :after ((dist ql-dist) &rest initargs
&key
uri
force-https
cache-pathname
&allow-other-keys)
(declare (ignore initargs))
(let ((uri uri))
(if (puri:uri-p uri)
(setf uri (puri:copy-uri uri))
(setf uri (puri:parse-uri uri)))
;; If the URI is already https, set force https to be T
(when (eql (puri:uri-scheme uri) :https)
(setf force-https t)
(setf (ql-dist-force-https dist) force-https))
;; If the scheme is not already https, set it to https if necessary.
(ecase force-https
(nil)
(t
(setf (puri:uri-scheme uri) :https)))
;; Compute the versions uri
(let* ((path (puri:uri-path uri))
(file-name (pathname-name path)))
(setf (ql-dist-versions-uri dist)
(puri:merge-uris (namestring
(merge-pathnames (concatenate 'string file-name "-versions")
path))
uri)))
(unless (uiop:directory-pathname-p cache-pathname)
(error "cache pathname must name a directory"))
(ensure-directories-exist cache-pathname)
(setf (ql-dist-uri dist) uri)))
(defmethod slot-unbound (class (dist ql-dist) (slot-name (eql 'version-uris-map)))
;; Fetch the versions file and parse it.
(let ((versions-pathname (merge-pathnames "versions.txt"
(ql-dist-cache-pathname dist))))
(http-client-ensure-file-fetched (ql-dist-http-client dist)
versions-pathname
(ql-dist-versions-uri dist))
(let ((ht (make-hash-table :test 'equal)))
(with-open-file (s versions-pathname)
(loop
(let ((line (read-line s nil :eof)))
(when (or (eql line :eof) (equal line ""))
(return))
(destructuring-bind (version uri)
(split-sequence #\Space line)
(setf uri (puri:parse-uri uri))
(when (ql-dist-force-https dist)
(setf (puri:uri-scheme uri) :https))
(setf (gethash version ht) uri)))))
(setf (slot-value dist 'version-uris-map) ht))))
(defun ql-dist-versions (dist)
(sort (hash-table-keys (ql-dist-version-uris-map dist))
#'string<))
(defun ql-dist-version (dist version)
(ensure-gethash version (ql-dist-version-cache dist)
(let ((uri (gethash version (ql-dist-version-uris-map dist))))
(unless uri
(error "No such version"))
(make-instance 'ql-dist-version
:dist dist
:version version
:uri uri))))
(defmacro do-dist-versions ((binding dist) &body body)
(with-gensyms (v)
(once-only (dist)
`(dolist (,v (ql-dist-versions ,dist))
(let ((,binding (ql-dist-version ,dist ,v)))
,@body)))))
(defclass ql-dist-version ()
((dist
:initarg :dist
:reader ql-dist-version-dist)
(version
:initarg :version
:reader ql-dist-version-version)
(uri
:initarg :uri
:reader ql-dist-version-uri)
(system-index-uri
:reader ql-dist-version-system-index-uri)
(release-index-uri
:reader ql-dist-version-release-index-uri)
(release-map
:reader ql-dist-version-release-map)
(system-by-name-map
:reader ql-dist-version-system-by-name-map)
(system-by-project-map
:reader ql-dist-version-system-by-project-map)))
(defun ql-dist-version-pathname (dist-version file)
(merge-pathnames file
(uiop:ensure-directory-pathname
(merge-pathnames (ql-dist-version-version dist-version)
(ql-dist-cache-pathname
(ql-dist-version-dist dist-version))))))
(defun parse-distinfo-line (line)
"Parse a single line of a distinfo.txt file."
(let* ((colon-pos (position #\: line))
(property (make-keyword (uiop:standard-case-symbol-name
(subseq line 0 colon-pos))))
(value (subseq line (+ 2 colon-pos))))
(list property value)))
(defun parse-distinfo (distinfo-pathname)
"Given a distinfo.txt pathname, return a plist of its contents."
(let* ((contents (read-file-into-string distinfo-pathname))
(lines (split-sequence #\Newline contents :remove-empty-subseqs t)))
(mapcan #'parse-distinfo-line lines)))
(defun populate-ql-dist-version! (dist-version)
(let ((distinfo-pathname (ql-dist-version-pathname dist-version "distinfo.txt"))
(dist (ql-dist-version-dist dist-version)))
(http-client-ensure-file-fetched (ql-dist-http-client dist)
distinfo-pathname
(ql-dist-version-uri dist-version)
:hint :immutable)
(let ((plist (parse-distinfo distinfo-pathname)))
(let ((system-index-uri (puri:parse-uri (getf plist :system-index-url)))
(release-index-uri (puri:parse-uri (getf plist :release-index-url))))
(when (ql-dist-force-https (ql-dist-version-dist dist-version))
(setf (puri:uri-scheme system-index-uri) :https
(puri:uri-scheme release-index-uri) :https))
(setf (slot-value dist-version 'system-index-uri) system-index-uri
(slot-value dist-version 'release-index-uri) release-index-uri))))
dist-version)
(defmethod slot-unbound (class (dist-version ql-dist-version) (slot-name (eql 'system-index-uri)))
(populate-ql-dist-version! dist-version)
(ql-dist-version-system-index-uri dist-version))
(defmethod slot-unbound (class (dist-version ql-dist-version) (slot-name (eql 'release-index-uri)))
(populate-ql-dist-version! dist-version)
(ql-dist-version-release-index-uri dist-version))
(defun populate-ql-dist-version-releases! (dist-version)
(let ((ht (make-hash-table :test 'equal))
(releases-pathname (ql-dist-version-pathname dist-version "releases.txt"))
(dist (ql-dist-version-dist dist-version)))
(http-client-ensure-file-fetched (ql-dist-http-client dist)
releases-pathname
(ql-dist-version-release-index-uri dist-version)
:hint :immutable)
(with-open-file (s releases-pathname)
(loop
(let ((line (read-line s nil :eof)))
(when (eql line :eof)
(return))
;; Skip empty lines and comments
(unless (or (equal line "")
(equal (aref line 0) #\#))
(destructuring-bind (project uri size file-md5 content-sha1 prefix &rest system-files)
(split-sequence #\Space line)
(setf uri (puri:parse-uri uri))
(when (ql-dist-force-https (ql-dist-version-dist dist-version))
(setf (puri:uri-scheme uri) :https))
(setf size (parse-integer size))
(setf (gethash project ht)
(make-instance 'ql-release
:dist-version dist-version
:project project
:uri uri
:size size
:file-md5 file-md5
:content-sha1 content-sha1
:prefix prefix
:system-files system-files)))))))
(setf (slot-value dist-version 'release-map) ht)))
(defmethod slot-unbound (class (dist-version ql-dist-version) (slot-name (eql 'release-map)))
(populate-ql-dist-version-releases! dist-version)
(slot-value dist-version 'release-map))
(defmethod populate-ql-dist-version-systems! (dist-version)
(let ((ht-by-system-name (make-hash-table :test 'equal))
(ht-by-project (make-hash-table :test 'equal))
(systems-pathname (ql-dist-version-pathname dist-version "systems.txt"))
(dist (ql-dist-version-dist dist-version)))
(http-client-ensure-file-fetched (ql-dist-http-client dist)
systems-pathname
(ql-dist-version-system-index-uri dist-version)
:hint :immutable)
(with-open-file (s systems-pathname)
(loop
(let ((line (read-line s nil :eof)))
(when (eql line :eof)
(return))
;; Skip empty lines and comments
(unless (or (equal line "")
(equal (aref line 0) #\#))
(destructuring-bind (project system-file system-name &rest dependencies)
(split-sequence #\Space line)
(let ((system (make-instance 'ql-system
:dist-version dist-version
:project project
:system-file system-file
:system-name system-name
:dependencies dependencies)))
(setf (gethash system-name ht-by-system-name) system)
(push system (gethash project ht-by-project))))))))
(setf (slot-value dist-version 'system-by-name-map) ht-by-system-name
(slot-value dist-version 'system-by-project-map) ht-by-project)))
(defmethod slot-unbound (class (dist-version ql-dist-version) (slot-name (eql 'system-by-name-map)))
(populate-ql-dist-version-systems! dist-version)
(slot-value dist-version 'system-by-name-map))
(defmethod slot-unbound (class (dist-version ql-dist-version) (slot-name (eql 'system-by-project-map)))
(populate-ql-dist-version-systems! dist-version)
(slot-value dist-version 'system-by-project-map))
(defun ql-dist-version-release (dist-version project-name
&optional (missing-error-p t) missing-value)
(or (gethash project-name (ql-dist-version-release-map dist-version))
(and missing-error-p (error "project missing"))
missing-value))
(defclass ql-release ()
((dist-version
:initarg :dist-version
:reader ql-release-dist-version)
(project
:initarg :project
:reader ql-release-project)
(uri
:initarg :uri
:reader ql-release-uri)
(size
:initarg :size
:reader ql-release-size)
(file-md5
:initarg :file-md5
:reader ql-release-file-md5)
(content-sha1
:initarg :content-sha1
:reader ql-release-content-sha1)
(prefix
:initarg :prefix
:reader ql-release-prefix)
(system-files
:initarg :system-files
:reader ql-release-system-files)))
(defclass ql-system ()
((dist-version
:initarg :dist-version
:reader ql-system-dist-version)
(project
:initarg :project
:reader ql-system-project)
(system-file
:initarg :system-file
:reader ql-system-system-file)
(system-name
:initarg :system-name
:reader ql-system-system-name)
(dependencies
:initarg :dependencies
:reader ql-system-dependencies)))
;;;; Quicklisp Distribution Representation
;;;;
;;;; This software is part of QL-CLPI. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:ql-clpi/ql-to-clpi
(:use #:cl
#:alexandria
#:anaphora
#:ql-clpi/ql-dist)
(:import-from #:clpi)
(:import-from #:puri)
(:export #:ql-dist-to-clpi))
(in-package #:ql-clpi/ql-to-clpi)
(defvar *appendable-p*)
(defun max-element (list predicate)
(loop
:with result := (first list)
:for el :in (rest list)
:when (funcall predicate el result)
:do
(setf result el)
:finally
(return result)))
(defun latest-release-of-project (project)
(let ((latest-version (max-element (clpi:project-versions project) #'string>)))
(when latest-version
(clpi:project-release project latest-version))))
(defun find-or-make-project (index project-name)
(or (clpi:index-project index project-name nil)
(let ((project (make-instance (clpi:index-project-class index)
:index index
:name project-name
:version-scheme :date)))
(when *appendable-p*
(setf (clpi:project-releases-object-version project) 0))
(clpi:index-add-project index project)
project)))
(defun find-or-make-system (index system-name)
(or (clpi:index-system index system-name nil)
(let ((system (make-instance (clpi:index-system-class index)
:index index
:name system-name)))
(clpi:index-add-system index system)
system)))
(defun ql-version-to-clpi (ql-dist version index)
(let* ((dv (ql-dist-version ql-dist version))
(release-map (ql-dist-version-release-map dv))
(system-by-project-map (ql-dist-version-system-by-project-map dv)))
(maphash (lambda (project-name ql-release)
(let* ((uri-string (puri:render-uri (ql-release-uri ql-release) nil))
(project (find-or-make-project index project-name))
(previous-release (latest-release-of-project project))
new-release
(system-file-ht (make-hash-table :test 'equal)))
(labels ((get-system-file-pathname (name)
;; This madness is becuase releases.txt and
;; systems.txt give different strings for the system
;; files...
(aprog1 (find-if (lambda (pn)
(equal (pathname-name pn)
name))
(ql-release-system-files ql-release))
(unless it
(error "Unable to determine system file path for system"))))
(make-or-get-system-file (pathname-name)
(let ((enough-namestring (get-system-file-pathname pathname-name)))
(ensure-gethash enough-namestring system-file-ht
(make-instance (clpi:index-system-file-class index)
:release new-release
:enough-namestring enough-namestring)))))
(when (or (null previous-release)
(not (equal (ql-release-file-md5 ql-release)
(clpi:release-md5 previous-release))))
;; This is a release we haven't seen before. Make a new
;; release object.
(setf new-release
(make-instance (clpi:project-release-class project)
:project project
:version version
:archive-type :tar.gz
:system-files (ql-release-system-files ql-release)
:url uri-string
:size (ql-release-size ql-release)
:md5 (ql-release-file-md5 ql-release)))
;; Create all the system files.
(dolist (ql-system (gethash project-name system-by-project-map))
(let* ((system (find-or-make-system index (ql-system-system-name ql-system)))
(system-file (make-or-get-system-file (ql-system-system-file ql-system)))
(system-release
(make-instance (clpi:index-system-release-class index)
:name (ql-system-system-name ql-system)
:system-file system-file
:dependencies (ql-system-dependencies ql-system))))
(clpi:system-add-system-release system system-release)
(setf (clpi:metadata-value system :primary-project)
(clpi:project-name project))
(clpi:system-file-add-system-release system-file system-release)))
;; Add the system files to the release.
(dolist (new-system-file (hash-table-values system-file-ht))
(clpi:release-add-system-file new-release new-system-file))
;; Add the release to the project.
(clpi:project-add-release project new-release)))
(when (and previous-release
(equal (ql-release-file-md5 ql-release)
(clpi:release-md5 previous-release)))
;; This release exists already from a previous dist. Add an
;; alias to the project.
(push version
(assoc-value (clpi:metadata-value project :ql/version-aliases)
(clpi:release-version previous-release) :test 'equal)))))
release-map)))
(defun ql-dist-to-clpi (ql-dist index &key appendable-p)
(let ((*appendable-p* appendable-p)
(latest-version-synced (clpi:metadata-value index :ql/latest-version-synced nil))
(versions (ql-dist-versions ql-dist))
(modified-p nil))
(dolist (version versions)
(unless (or
;;(string>= version "2017-01-01")
(and latest-version-synced
(string<= version latest-version-synced)))
(format t "Syncing ~S ~S version~%" latest-version-synced version)
(ql-version-to-clpi ql-dist version index)
(setf modified-p t)
(setf (clpi:metadata-value index :ql/latest-version-synced) version)))
modified-p))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment