Skip to content

Commit 7da572a

Browse files
atgreenatgreen
committed
Initial import
0 parents  commit 7da572a

24 files changed

+1370
-0
lines changed

‎.s2i/bin/assemble

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
#!/bin/bash
2+
3+
set -x
4+
5+
/usr/libexec/s2i/assemble
6+
rc=$?
7+
8+
if [ $rc -eq 0 ]; then
9+
10+
ln -s `pwd`/quicklisp/local-projects/quicklisp-mirror/quicklisp-mirror-tool ./quicklisp/local-projects
11+
ln -s `pwd`/quicklisp/local-projects/quicklisp-mirror/sync-quicklisp ./quicklisp/local-projects
12+
export APP_SYSTEM_NAME=sync-quicklisp
13+
export APP_SCRIPT=s.lisp
14+
APP_MEM=4092 /usr/libexec/s2i/run
15+
# Trim the version list
16+
# tail -1 mirror/dist/quicklisp-versions.txt > mirror/dist/quicklisp-versions.txt
17+
export APP_SCRIPT=s2.lisp
18+
APP_MEM=4092 /usr/libexec/s2i/run
19+
rc=$?
20+
ln -s `pwd`/quicklisp/local-projects/archive/quicklisp `pwd`/quicklisp/local-projects/quicklisp-mirror/archive
21+
rm -fr ./quicklisp/local-projects/quicklisp-mirror/quicklisp-mirror-tool
22+
rm -fr ./quicklisp/local-projects/quicklisp-mirror/sync-quicklisp
23+
24+
fi
25+
26+
exit $rc

‎.s2i/environment

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
APP_SYSTEM_NAME=quicklisp-mirror
2+
APP_EVAL="(quicklisp-mirror:start-quicklisp-mirror)"

‎README.md

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
# quicklisp-mirror
2+
3+
This lisp-powered container hosts a complete mirror of the quicklisp
4+
archive, suitable for deployment within kubernetes.
5+
6+
7+

‎mirror/.keep

Whitespace-only changes.

‎mirror/dist/.keep

Whitespace-only changes.

‎package.lisp

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: QUICKLISP-MIRROR; Base: 10 -*-
2+
3+
;;; Copyright (C) 2012, 2017, 2018 Anthony Green <[email protected]>
4+
5+
;;; Quicklisp-Mirror is free software; you can redistribute it and/or modify it
6+
;;; under the terms of the GNU General Public License as published by
7+
;;; the Free Software Foundation; either version 3, or (at your
8+
;;; option) any later version.
9+
;;;
10+
;;; Quicklisp-Mirror is distributed in the hope that it will be useful, but
11+
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
12+
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13+
;;; General Public License for more details.
14+
;;;
15+
;;; You should have received a copy of the GNU General Public License
16+
;;; along with quicklisp-mirror; see the file COPYING3. If not see
17+
;;; <http://www.gnu.org/licenses/>.
18+
19+
;;;; package.lisp
20+
21+
(defpackage #:quicklisp-mirror
22+
(:use #:hunchentoot #:cl)
23+
(:shadow #:package)
24+
(:export #:start-quicklisp-mirror #:stop-quicklisp-mirror))
25+
26+
(in-package #:quicklisp-mirror)

‎quicklisp-mirror-tool/.gitignore

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
*.fasl
2+
*.dx32fsl
3+
*.dx64fsl
4+
*.lx32fsl
5+
*.lx64fsl
6+
*.x86f
7+
*~
8+
.#*

‎quicklisp-mirror-tool/LICENSE

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
The MIT License (MIT)
2+
3+
Copyright (c) 2016 David Gu
4+
5+
Permission is hereby granted, free of charge, to any person obtaining a copy
6+
of this software and associated documentation files (the "Software"), to deal
7+
in the Software without restriction, including without limitation the rights
8+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9+
copies of the Software, and to permit persons to whom the Software is
10+
furnished to do so, subject to the following conditions:
11+
12+
The above copyright notice and this permission notice shall be included in all
13+
copies or substantial portions of the Software.
14+
15+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21+
SOFTWARE.

‎quicklisp-mirror-tool/README.markdown

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
# Quicklisp-Mirror-Tool
2+
3+
Quicklisp-Mirror-Tool, helping people building mirror sites for [Quicklisp](http://quicklisp.org), the de-facto Package Manager for Common Lisp.
4+
5+
The documentation is not ready yet and the code may also need to be fixed a little bit, but please wait warmly :)
6+
7+
## Usage
8+
9+
## Installation
10+
11+
## Author
12+
13+
* David Gu ([email protected])
14+
15+
## Copyright
16+
17+
Copyright (c) 2016 David Gu ([email protected])

‎quicklisp-mirror-tool/client.lisp

Lines changed: 256 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,256 @@
1+
;;;; client.lisp
2+
(in-package #:cl-user)
3+
(defpackage #:quicklisp-mirror-tool.client
4+
(:use #:cl
5+
#:ql-mirror.variables
6+
#:ql-mirror.utils
7+
#:ql-mirror.task)
8+
(:nicknames #:ql-mirror.client)
9+
(:export #:*client-directory*
10+
#:client-tasks/fetching*
11+
#:client-tasks/retry-fetching*
12+
#:client-tasks/verifying*
13+
#:client-tasks/retry-verifying*
14+
#:fetch-quicklisp.sexp
15+
#:fetch-quicklisp-versions.sexp
16+
#:initialize/client
17+
#:mirror/client
18+
#:verify/client))
19+
(in-package #:quicklisp-mirror-tool.client)
20+
21+
;;; Global Variables
22+
(defvar *client-directory*
23+
(let ((directory* (uiop:directory-exists-p *web-server-directory-root*)))
24+
(unless directory*
25+
(error "Directory: ~A doesn't exist." *web-server-directory-root*))
26+
(merge-pathnames "client/" (uiop:ensure-absolute-pathname directory*)))
27+
"The directory where all client information files would be put at.")
28+
29+
(defvar *client-tasks/fetching*
30+
(make-tasks-record :name "client-tasks/fetching"
31+
:capacity (+ 2 ;; fetch-quicklisp.sexp + fetch-quicklisp-versions.sexp
32+
;; quicklisp.tar + setup.lisp + asdf.lisp
33+
(* 3 (length *available-client-versions*))))
34+
"Tasks-Record for fetching client files, including 'client-info.sexp', 'quicklisp.tar', 'setup.lisp' and 'asdf.lisp' for each version")
35+
36+
(defvar *client-tasks/retry-fetching*
37+
(make-tasks-record :name "client-tasks/retry-fetching")
38+
"Tasks-Record for retrying fetching broken (during downloading) files .")
39+
40+
(defvar *client-tasks/verifying*
41+
(make-tasks-record :name "client-tasks/verification"
42+
:capacity (* 3 (length *available-client-versions*)))
43+
"Tasks-Record for verifying 'quicklisp.tar', 'setup.lisp' and 'asdf.lisp' for each client version.")
44+
45+
(defvar *client-tasks/retry-verifying*
46+
(make-tasks-record :name "client-tasks/retry-verifying")
47+
"Tasks-Record for retrying verifying broken (checked by md5) files.")
48+
49+
;;; Utilities
50+
(declaim (inline make-dir-by-client-version))
51+
(defun make-dir-by-client-version (version)
52+
"Given a version, e.g. \"2016-02-22\",
53+
then transform it to #P\"/usr/local/var/www/client/2016-02-22/\" and return."
54+
(declare (type simple-string version))
55+
(merge-pathnames (concatenate 'string version "/")
56+
*client-directory*))
57+
58+
#+ignore
59+
(defmacro with-client-info-slots ((&rest slots) client-info &body body)
60+
"An utility macro helps with binding slots of a client info using 'symbol-macrolet'."
61+
(alexandria:with-gensyms (%getf% indicator indicators result)
62+
`(flet ((,%getf% (,indicators)
63+
(loop for ,indicator in ,indicators
64+
for ,result = (getf ,client-info ,indicator) then (getf ,result ,indicator)
65+
finally (return ,result))))
66+
(symbol-macrolet ,(mapcar (lambda (slot)
67+
(cond ((atom slot)
68+
`(,slot (getf ,client-info ,(intern (symbol-name slot) :keyword))))
69+
((consp slot)
70+
`(,(car slot) (,%getf% ',(cadr slot))))))
71+
slots)
72+
,@body))))
73+
74+
(defun modify-client-info-hostname (client-info)
75+
"Modify hostnames for all urls in a client infomation file (e.g. 'client-info.sexp')."
76+
(declare (type cons client-info))
77+
(destructuring-bind (&key subscription-url canonical-client-info-url
78+
client-tar setup asdf
79+
&allow-other-keys)
80+
client-info
81+
(setf (getf client-info :subscription-url) (modify-hostname subscription-url)
82+
(getf client-info :canonical-client-info-url) (modify-hostname canonical-client-info-url)
83+
(getf (getf client-info :client-tar) :url) (modify-hostname (getf client-tar :url))
84+
(getf (getf client-info :setup) :url) (modify-hostname (getf setup :url))
85+
(getf (getf client-info :asdf) :url) (modify-hostname (getf asdf :url)))
86+
(let ((*print-case* :downcase))
87+
(write-to-string client-info))))
88+
89+
(defun collect-required-urls (client-info)
90+
"Collect client-tar, setup and asdf's urls from a 'client-info.sexp'."
91+
(declare (type list client-info))
92+
(destructuring-bind (&key client-tar setup asdf &allow-other-keys)
93+
client-info
94+
(mapcar (lambda (x) (getf x :url))
95+
(list client-tar setup asdf))))
96+
97+
(defun download-tmp-client-info.sexp (version url &key keep)
98+
"Before fetching files, we need a temporary copy of the original 'client-info.sexp' as metadata.
99+
After all tasks are prepared, we will then delete these files.
100+
If 'keep' was given as T, the downloaded file will be kept; delete the file when it's NIL."
101+
(let* ((tmp-dir (uiop:ensure-directory-pathname (format nil "/tmp/~A/" version)))
102+
(tmp-filename (merge-pathnames "client-info.sexp" tmp-dir)))
103+
(if (probe-file tmp-filename)
104+
tmp-filename
105+
(progn
106+
(trivial-download:download url tmp-filename :quiet nil)
107+
(terpri *standard-output*)
108+
(unless keep
109+
(uiop:delete-directory-tree tmp-dir :validate t :if-does-not-exist :ignore))
110+
tmp-filename))))
111+
112+
(declaim (inline delete-tmp-downloaded-client-info))
113+
(defun delete-tmp-downloaded-client-info (file)
114+
"Delete the temporary original 'client-info.sexp' file."
115+
(uiop:delete-directory-tree
116+
(uiop:pathname-directory-pathname file)
117+
:validate t :if-does-not-exist :ignore))
118+
119+
;;; Functions to prepare all tasks
120+
;;; -- Utilities -----------------
121+
(defun fetch-quicklisp.sexp
122+
(&optional (url "http://beta.quicklisp.org/client/quicklisp.sexp"))
123+
"A default client info file should be fetched; its link was given as 'subscription-url'."
124+
(let ((quicklisp.sexp (merge-pathnames "quicklisp.sexp" *client-directory*))
125+
(client-info (read-from-string (drakma:http-request url))))
126+
(with-open-file (out quicklisp.sexp :direction :output
127+
:if-exists :supersede :if-does-not-exist :create)
128+
(write-sequence
129+
(modify-client-info-hostname client-info) out))
130+
(probe-file quicklisp.sexp)))
131+
132+
(defun fetch-quicklisp-versions.sexp
133+
(&optional (url "http://beta.quicklisp.org/client/quicklisp-versions.sexp"))
134+
"A defaut client versions file should be fetched;
135+
its link was defined by appending \"-versions\" to the name of subscription url."
136+
(let ((quicklisp-versions.sexp (merge-pathnames "quicklisp-versions.sexp" *client-directory*))
137+
(sexp (read-from-string (drakma:http-request url))))
138+
(with-open-file (out quicklisp-versions.sexp :direction :output
139+
:if-exists :supersede :if-does-not-exist :create)
140+
(write-sequence
141+
(write-to-string
142+
(dolist (x sexp sexp)
143+
(setf (cdr x) (modify-hostname (cdr x)))))
144+
out))
145+
(probe-file quicklisp-versions.sexp)))
146+
147+
(declaim (inline %prepare-fetching-quicklisp.sexp% %prepare-fetching-quicklisp-veriosn.sexp%))
148+
(defun %prepare-fetching-quicklisp.sexp% ()
149+
"Submit 'fetching quicklisp.sexp' as a task/fetching to *client-tasks/fetching*."
150+
(submit-task
151+
*client-tasks/fetching*
152+
(make-task/fetching "http://beta.quicklisp.org/client/quicklisp.sexp"
153+
(merge-pathnames "quicklisp.sexp" *client-directory*)
154+
:name "FETCHIING QUICKLISP.SEXP [CLIENT]"
155+
:thunk #'fetch-quicklisp.sexp)))
156+
(defun %prepare-fetching-quicklisp-veriosn.sexp% ()
157+
"Submit 'fetching quicklisp-versions.sexp' as a task/fetching to *client-tasks/fetching*."
158+
(submit-task
159+
*client-tasks/fetching*
160+
(make-task/fetching "http://beta.quicklisp.org/client/quicklisp-versions.sexp"
161+
(merge-pathnames "quicklisp-versions.sexp" *client-directory*)
162+
:name "FETCHING QUICKLISP-VERSIONS.SEXP [CLIENT]"
163+
:thunk #'fetch-quicklisp-versions.sexp)))
164+
165+
(defun prepare-fetching (version url &key client-info)
166+
"Given the metadata (version and url of a client), prepare all fetching tasks.
167+
If 'client-info' was given, which should be an original copy, then read required infomation from it;
168+
otherwise, download a temporary copy."
169+
(let ((output-dir (make-dir-by-client-version version)))
170+
(ensure-directories-exist output-dir :verbose t)
171+
(let* ((client-info
172+
(if client-info client-info
173+
(read-from-string (uiop:read-file-string (download-tmp-client-info.sexp version url)))))
174+
(required-urls (collect-required-urls client-info)))
175+
(declare (type list client-info))
176+
(dolist (url required-urls)
177+
(let* ((filename (get-filename-from-url url))
178+
(destination (merge-pathnames filename output-dir)))
179+
(submit-task
180+
*client-tasks/fetching*
181+
(make-task/fetching url destination
182+
:name (format nil "FETCHING ~S for CLIENT[~A]" filename version))))))))
183+
184+
(defun prepare-verifying (version &key client-info)
185+
"Given the metadata (version and url of a client), prepare all verifying tasks.
186+
If 'client-info' was given, which should be an original copy, then read required infomation from it;
187+
otherwise, download a temporary copy and then read from it."
188+
(let* ((dir (uiop:ensure-directory-pathname (merge-pathnames version *client-directory*)))
189+
(client-info
190+
(if client-info client-info
191+
(read-from-string (uiop:read-file-string (merge-pathnames "client-info.sexp" dir)))))
192+
(files (mapcar (lambda (x) (merge-pathnames x dir))
193+
'("quicklisp.tar" "setup.lisp" "asdf.lisp")))
194+
(md5s (mapcar (lambda (x) (getf (getf client-info x) :md5))
195+
'(:client-tar :setup :asdf)))
196+
(urls (mapcar (lambda (x) (getf (getf client-info x) :url))
197+
'(:client-tar :setup :asdf))))
198+
(map nil (lambda (file md5 url)
199+
(submit-task *client-tasks/verifying*
200+
(make-task/verifying :file file :md5 md5 :url url)))
201+
files md5s urls)))
202+
203+
(defun write-new-client-info (version original-client-info)
204+
"After all tasks were prepared and submited, a new client-info where all urls' hostnames have been modified should be written."
205+
(let ((new-client-info
206+
(merge-pathnames "client-info.sexp" (make-dir-by-client-version version))))
207+
(with-open-file (out new-client-info :direction :output
208+
:if-exists :supersede :if-does-not-exist :create)
209+
(write-sequence (modify-client-info-hostname original-client-info) out))))
210+
211+
;;; -- 1st -- Initialization. ------------------------------
212+
(defun initialize/client (&optional (metadata *available-client-versions*))
213+
"Initialize all original client-info.sexp metadata and all fetching and verifying tasks."
214+
(declare (optimize speed (safety 0) (space 0) (debug 0) (compilation-speed 0)))
215+
(ensure-tasks-record-empty!
216+
(*client-tasks/fetching* *client-tasks/retry-fetching* *client-tasks/verifying* *client-tasks/retry-verifying*)
217+
(%prepare-fetching-quicklisp.sexp%)
218+
(%prepare-fetching-quicklisp-veriosn.sexp%)
219+
(dolist (meta metadata (values))
220+
(destructuring-bind (version . url) meta
221+
(format t "PREPARE CLIENT[~A] ......~%" version)
222+
(let* ((file (download-tmp-client-info.sexp version url :keep t))
223+
(info (read-from-string (uiop:read-file-string file))))
224+
(prepare-fetching version url :client-info info)
225+
(prepare-verifying version :client-info info)
226+
(write-new-client-info version info)
227+
(delete-tmp-downloaded-client-info file))))))
228+
229+
;;; -- 2nd -- Fetching all files from Quicklisp -------------------------------------------------
230+
(defun mirror/client
231+
(&key (tasks/fetching *client-tasks/fetching*) (style *processing-style*)
232+
(tasks/retry-fetching *client-tasks/retry-fetching*) (filter #'identity))
233+
"Start mirroring by doing all tasks in *client-tasks/fetching*.
234+
Before this step, you should make sure function 'initialize/client' successfully finished.
235+
After this step, you should inspect whether all tasks finished in *client-tasks/retry-fetching*."
236+
(declare (type tasks-record tasks/fetching tasks/retry-fetching)
237+
(type (member :seq :parallel) style)
238+
(type function filter))
239+
(ensure-tasks-record-empty! (tasks/retry-fetching)
240+
(do-tasks-record tasks/fetching :container tasks/retry-fetching
241+
:filter filter :style style)))
242+
243+
;;; -- 3rd -- Verification ----------------------------------------------------------------------
244+
(defun verify/client
245+
(&key (tasks/verifying *client-tasks/verifying*) (style *processing-style*)
246+
(tasks/retry-verifying *client-tasks/retry-verifying*) (filter #'identity))
247+
"Start verifying by doing all tasks in *client-tasks/verifying.
248+
Before this step, you should make sure either *client-tasks/fetching* or --
249+
*client-tasks/retry-fetching* are finished.
250+
After this step, you should inspect whether all tasks finished in *client-tasks/retry-verifying."
251+
(declare (type tasks-record tasks/verifying tasks/retry-verifying)
252+
(type (member :seq :parallel) style)
253+
(type function filter))
254+
(ensure-tasks-record-empty! (tasks/retry-verifying)
255+
(do-tasks-record tasks/verifying :container tasks/retry-verifying
256+
:filter filter :style style)))

0 commit comments

Comments
 (0)