Initial commit.

Author: fukamachi

.gitignore

@@ -0,0 +1,8 @@
+*.fasl
+*.dx32fsl
+*.dx64fsl
+*.lx32fsl
+*.lx64fsl
+*.x86f
+*~
+.#*

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "modules/quicklisp-projects"]
+	path = modules/quicklisp-projects
+	url = https://github.com/quicklisp/quicklisp-projects

README.markdown

@@ -0,0 +1,17 @@
+# Quickdocs-Updater
+
+## Usage
+
+## Installation
+
+## Author
+
+* Eitaro Fukamachi ([email protected])
+
+## Copyright
+
+Copyright (c) 2015 Eitaro Fukamachi ([email protected])
+
+## License
+
+Licensed under the BSD 2-Clause License.

modules/quicklisp-projects

@@ -0,0 +1,41 @@
+#|
+  This file is a part of quickdocs-updater project.
+  Copyright (c) 2015 Eitaro Fukamachi ([email protected])
+|#
+
+#|
+  Author: Eitaro Fukamachi ([email protected])
+|#
+
+(in-package :cl-user)
+(defpackage quickdocs-updater-asd
+  (:use :cl :asdf))
+(in-package :quickdocs-updater-asd)
+
+(defsystem quickdocs-updater
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "BSD 2-Clause"
+  :depends-on (:quickdocs-extracter
+               :quickdocs-database
+               :cl-ppcre
+               :quri
+               :uiop
+               :alexandria
+               :split-sequence)
+  :components ((:module "src"
+                :components
+                ((:file "quickdocs-updater"))))
+  :description "Updates Quickdocs database"
+  :long-description
+  #.(with-open-file (stream (merge-pathnames
+                             #p"README.markdown"
+                             (or *load-pathname* *compile-file-pathname*))
+                            :if-does-not-exist nil
+                            :direction :input)
+      (when stream
+        (let ((seq (make-array (file-length stream)
+                               :element-type 'character
+                               :fill-pointer t)))
+          (setf (fill-pointer seq) (read-sequence seq stream))
+          seq))))

quickdocs-updater.asd

@@ -0,0 +1,51 @@
+(in-package :cl-user)
+(defpackage quickdocs-updater.extracter
+  (:use :cl)
+  (:export :extract-result-directory
+           :extractedp
+           :run-extract-dist
+           :release-systems-info)
+  (:documentation "Functions for controlling quickdocs-extracter"))
+(in-package :quickdocs-updater.extracter)
+
+(defparameter *extract-result-directory*
+  (asdf:system-relative-pathname :quickdocs-updater #P"dists/"))
+
+(defun extract-result-directory (dist)
+  (merge-pathnames (ql-dist:version dist) *extract-result-directory*))
+
+(defun extract-result-of-release (release)
+  (merge-pathnames (ql-dist:name release) (extract-result-directory (ql-dist:dist release))))
+
+(defun extractedp (dist)
+  (uiop:directory-exists-p (extract-result-directory dist)))
+
+(defun run-extract-dist (dist)
+  (let ((extract-dist-script (asdf:system-relative-pathname #P"scripts/extract-dist" :quickdocs-extracter))
+        (*default-pathname-defaults*
+          (uiop:pathname-parent-directory-pathname *extract-result-directory*)))
+    (uiop:run-program `(,extract-dist-script ,(ql-dist:version dist))
+                      :output *standard-output*
+                      :error-output *error-output*))
+  (extract-result-directory dist))
+
+(defun release-systems-info (release)
+  (check-type release ql-dist:release)
+  (let ((result-file (extract-result-of-release release)))
+    (unless (uiop:file-exists-p result-file)
+      (restart-case
+          (error "Extracted release info of ~S does not exist." (ql-dist:name release))
+        ;; For testing mainly.
+        (extract-now ()
+          :report "Extract it now in the current thread"
+          (return-from release-systems-info
+            (getf (quickdocs-extracter:serialize-release
+                   (ql-dist:name release)
+                   (ql-dist:dist release))
+                  :systems)))))
+    (with-open-file (in result-file)
+      (uiop:with-safe-io-syntax ()
+        (loop with eof = '#:eof
+              for form = (read in nil eof)
+              until (eq form eof)
+              collect form)))))

src/extracter.lisp

@@ -0,0 +1,15 @@
+(in-package :cl-user)
+(defpackage quickdocs-updater
+  (:use :cl)
+  (:import-from :quickdocs-updater.extracter
+                :run-extract-dist))
+(in-package :quickdocs-updater)
+
+(defun update-dist (dist)
+  (check-type dist ql-dist:dist)
+  (run-extract-dist dist)
+  (dolist (release (ql-dist:provided-releases dist))
+    (update-release release)))
+
+(defun update-release (release)
+  (check-type release ql-dist:release))

src/quickdocs-updater.lisp

@@ -0,0 +1,108 @@
+(in-package :cl-user)
+(defpackage quickdocs-updater.release
+  (:use :cl
+        :split-sequence)
+  (:import-from :quickdocs-updater.extracter
+                :extractedp
+                :extract-result-directory
+                :release-systems-info)
+  (:import-from :alexandria
+                :when-let
+                :starts-with-subseq
+                :compose
+                :ignore-some-conditions)
+  (:export :readme-file
+           :release-version
+           :primary-system
+           :project-homepage)
+  (:documentation "Function/method collections for Quicklisp releases."))
+(in-package :quickdocs-updater.release)
+
+(defun readme-file (release)
+  (check-type release ql-dist:release)
+  (assert (ql-dist:installedp release))
+  (find "README"
+        (uiop:directory-files (ql-dist:base-directory release))
+        :key #'pathname-name
+        :test #'string=))
+
+(defun release-version (release)
+  "Return the latest Quicklisp dist version that `release` was updated."
+  (check-type release ql-dist:release)
+  (when-let (match (nth-value 1
+                              (ppcre:scan-to-strings "beta\\.quicklisp\\.org/archive/[^/]+/([^/]+)"
+                                                     (ql-dist:archive-url release))))
+    (aref match 0)))
+
+(defun primary-system (release)
+  (check-type release ql-dist:release)
+  (flet ((remove-cl-prefix (name)
+           (if (starts-with-subseq "cl-" name)
+               (subseq name 3)
+               name)))
+    (let ((project-name (remove-cl-prefix (ql-dist:project-name release)))
+          (provided-systems (ql-dist:provided-systems release)))
+      (or (find project-name
+                provided-systems
+                :key (compose #'remove-cl-prefix #'ql-dist:name)
+                :test #'string=)
+          (first provided-systems)))))
+
+;; NOTE: quicklisp-projects is updated every month and it could be different from the `release' has been included.
+;;   It would be a problem when updating old dists.
+(defun project-source-txt (release)
+  (check-type release ql-dist:release)
+  (merge-pathnames (format nil "~A/source.txt" (ql-dist:name release))
+                   (asdf:system-relative-pathname :quickdocs-database
+                                                  #P"modules/quicklisp-projects/")))
+
+(defun project-source-info (release)
+  (check-type release ql-dist:release)
+  (let ((data (uiop:read-file-string (project-source-txt release))))
+    (destructuring-bind (type source-url)
+        (split-sequence #\Space data :count 2)
+      (values type source-url))))
+
+(defun project-homepage (release)
+  (check-type release ql-dist:release)
+  (let ((systems-info (release-systems-info release)))
+    (or
+     ;; Use if :homepage exists in ASD files
+     (getf (find-if (lambda (info)
+                      (getf info :homepage))
+                    systems-info)
+           :homepage)
+
+     ;; Use the repository URL if it's on some popular services, like GitHub or BitBucket
+     (multiple-value-bind (type source-url)
+         (project-source-info release)
+       (ignore-some-conditions (quri:uri-error)
+         (let* ((uri (quri:uri source-url))
+                (domain (quri:uri-domain uri)))
+           (cond
+             ((string= domain "github.com")
+              (let ((repos-id (ppcre:regex-replace "\\.[^\\.]*$" (quri:uri-path uri) "")))
+                ;; TODO: request website URL to GitHub
+                (concatenate 'string
+                             "https://github.com"
+                             repos-id)))
+             ((string= domain "bitbucket.org")
+              ;; TODO: request website URL to BitBucket
+              source-url)
+             ((string= domain "gitlab.common-lisp.net")
+              (let ((repos-id (ppcre:regex-replace "\\.[^\\.]*$" (quri:uri-path uri) "")))
+                (concatenate 'string
+                             "http://gitlab.common-lisp.net"
+                             repos-id)))
+             ((string= domain "common-lisp.net")
+              (let ((match (ppcre:scan-to-strings "://common-lisp\\.net/project/([^\\/]+)" source-url)))
+                (format nil "http://common-lisp.net/project/~A"
+                        (quri:url-encode
+                         (if match
+                             (aref match 0)
+                             (ql-dist:project-name release))
+                         :encoding :utf-8))))
+             ((or (string= domain "weitz.de")
+                  (string= type "ediware-http"))
+              (format nil "http://weitz.de/~A/"
+                      (quri:url-encode (ql-dist:project-name release) :encoding :utf-8))))))))))