├── .github └── workflows │ └── ci.yml ├── Dockerfile ├── Makefile ├── README.md ├── html2clwho.asd ├── html2clwho.lisp ├── load-deps.lisp ├── quicklisp.lisp ├── run-tests.sh └── test.lisp /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: 👷 Testing 2 | 3 | on: 4 | push: 5 | 6 | jobs: 7 | test: 8 | runs-on: ubuntu-latest 9 | container: 10 | image: containers.common-lisp.net/cl-docker-images/sbcl:latest 11 | 12 | env: 13 | QUICKLISP_SETUP: /github/home/quicklisp/setup.lisp 14 | 15 | steps: 16 | - uses: actions/checkout@v4 17 | 18 | - name: prepare quicklisp 19 | shell: bash 20 | run: | 21 | install-quicklisp && \ 22 | if [ ! -f ${{ env.QUICKLISP_SETUP }} ]; then \ 23 | echo "Did not find Quicklisp setup file where expected: ${QUICKLISP_SETUP}"; \ 24 | find / -name 'quicklisp' -type d ; \ 25 | fi 26 | 27 | - name: test 28 | shell: bash 29 | run: | 30 | ./run-tests.sh 31 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM clfoundation/sbcl:alpine3.14 as builder 2 | 3 | COPY . /root/common-lisp/ 4 | WORKDIR /root/common-lisp/ 5 | 6 | # https://www.reddit.com/r/Common_Lisp/comments/pdsqbe/installing_quicklisp/ 7 | # https://github.com/yitzchak/common-lisp-jupyter/blob/master/Dockerfile 8 | ENV QUICKLISP_ADD_TO_INIT_FILE=true 9 | RUN sbcl --non-interactive --load quicklisp.lisp \ 10 | --eval "(quicklisp-quickstart:install)" \ 11 | --eval "(ql-util:without-prompting (ql:add-to-init-file))" 12 | 13 | RUN sbcl --eval "(ql:quickload :html2clwho)" \ 14 | --load html2clwho.lisp \ 15 | --eval "(sb-ext:save-lisp-and-die \"core\" :toplevel #'html2clwho::main :executable t)" 16 | 17 | FROM clfoundation/sbcl:alpine3.14 18 | 19 | RUN adduser -D app 20 | USER app 21 | 22 | COPY --from=builder /root/common-lisp/core . 23 | 24 | EXPOSE 3333 25 | 26 | ENTRYPOINT [ "sbcl", "--core", "core" ] 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | serve: 2 | sbcl --eval "(ql:quickload :html2clwho)" \ 3 | --eval "(asdf:load-system :html2clwho)" \ 4 | --eval "(html2clwho::main)" 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # HTML to CL-WHO 2 | 3 | `cl-who` is a common library for HTML rendering in Common Lisp. The main issue is that all the example online are written in HTML... This tool lets you convert HTML to Sexp! 4 | 5 | ## Getting started (without docker) 6 | 1. Clone the repo into `~/common-lisp` (or a path recognized by ASDF) 7 | ``` 8 | git clone https://github.com/albertolerda/html-to-cl-who.git 9 | ``` 10 | 2. Run (inside sbcl) 11 | ``` 12 | (ql:quickload :html2clwho) 13 | (asdf:load-system :html2clwho) 14 | (html2clwho::main) 15 | 16 | ``` 17 | 18 | Now you can open the Browser: [localhost:3333](http://localhost:3333/) 19 | 20 | ## Getting started (with docker) 21 | 1. Clone the repo 22 | ``` 23 | git clone https://github.com/albertolerda/html-to-cl-who.git 24 | ``` 25 | 2. Build the image (sometimes it crashes, just run it again) 26 | ``` 27 | docker build -t html2clwho . 28 | ``` 29 | 3. Run it! 30 | ``` 31 | docker run -p 3333:3333 --rm html2clwho 32 | ``` 33 | 34 | Now you can open the Browser: [localhost:3333](http://localhost:3333/) 35 | 36 | ## More reference 37 | [Youtube Demo](https://www.youtube.com/watch?v=269tBEWzke4&list=PLFdMuo0ICT2C3gOqkDL83bpBhJtsF9e5r) 38 | 39 | More info on asdf: 40 | [ASDF Config](https://asdf.common-lisp.dev/asdf/Configuring-ASDF-to-find-your-systems.html) 41 | [ASDF Loading](https://asdf.common-lisp.dev/asdf/Loading-a-system.html) 42 | 43 | ## Authors 44 | 45 | - [@albertolerda](https://www.github.com/albertolerda) 46 | 47 | ## License 48 | 49 | [MIT](https://choosealicense.com/licenses/mit/) 50 | 51 | -------------------------------------------------------------------------------- /html2clwho.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem "html2clwho" 2 | :description "Convert html to cl-who" 3 | :version "0.0.1" 4 | :author "Alberto Lerda" 5 | :licence "Public Domain" 6 | :depends-on ("plump" "hunchentoot" "cl-who") 7 | :components ((:file "html2clwho")) 8 | :in-order-to ((test-op (test-op "html2clwho/tests")))) 9 | 10 | (asdf:defsystem "html2clwho/tests" 11 | :depends-on ("html2clwho" "fiveam") 12 | :components ((:file "test")) 13 | :perform (test-op (o c) (symbol-call :html2clwho.test :run-tests))) 14 | 15 | 16 | ;; test-op should signal a condition 17 | ;; https://asdf.common-lisp.dev/asdf.html#test_002dop 18 | -------------------------------------------------------------------------------- /html2clwho.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :html2clwho 2 | (:use :cl :plump :hunchentoot :cl-who)) 3 | (in-package :html2clwho) 4 | 5 | (defun build-sexp (str) 6 | (labels 7 | ((iter (root) 8 | (cond 9 | ((text-node-p root) 10 | (let ((txt (string-trim '(#\Space #\Newline #\Backspace #\Tab 11 | #\Linefeed #\Page #\Return #\Rubout) 12 | (render-text root)))) 13 | (if (equal txt "") "" (format nil " \"~A\"" txt)))) 14 | ((comment-p root) 15 | (format nil " #|~A|#" (build-sexp (render-text root)))) 16 | (t 17 | (let ((attrs (attributes root))) 18 | (format nil "~%(:~A~:{ :~A \"~A\"~}~{~A~})" 19 | (tag-name root) 20 | (loop for key being the hash-key of attrs 21 | for value being the hash-value of attrs 22 | collect (list key value)) 23 | (map 'list #'iter (children root)))))))) 24 | (apply #'concatenate (cons 'string 25 | (map 'list #'iter (children 26 | (plump:parse str))))))) 27 | 28 | (defvar *server* (make-instance 'easy-acceptor :port 3333)) 29 | 30 | (defmacro main-layout (title &body body) 31 | `(with-html-output-to-string (*standard-output* nil :prologue t :indent t) 32 | (:html 33 | (:head 34 | (:meta :charset "utf-8") 35 | (:meta :name "viewport" :content "width=device-width, inital-scale=1") 36 | (:title ,title) 37 | (:link :rel "stylesheet" :href "https://cdn.jsdelivr.net/npm/bulma@0.9.4/css/bulma.min.css")) 38 | (:body 39 | (:section :class "section" 40 | (:div :class "container" 41 | ,@body)))))) 42 | 43 | (define-easy-handler (main-page :uri "/") (txt-html) 44 | (let ((txt-html (if txt-html txt-html "")) 45 | (result 46 | (if txt-html 47 | (build-sexp txt-html) 48 | ""))) 49 | (main-layout "Convert" 50 | (:h1 :class "title" "Convert HTML to CL-WHO") 51 | (:p :class "subtitle" "Fill the text are with your HTML") 52 | (:form :action "/" :method "POST" 53 | (:div :class "field" 54 | (:div :class "control" 55 | (:textarea :class "textarea" :name "txt-html" (write-string txt-html)))) 56 | (:div :class "control" 57 | (:input :class "button" :type "submit"))) 58 | (:div :class "container m-1" (:pre (write-string result)))))) 59 | 60 | (defun main () 61 | (start *server*) 62 | (sleep most-positive-fixnum)) 63 | -------------------------------------------------------------------------------- /load-deps.lisp: -------------------------------------------------------------------------------- 1 | (in-package :common-lisp-user) 2 | 3 | (require :asdf) 4 | 5 | (declaim (optimize (speed 3) (space 3) (safety 3))) 6 | 7 | (asdf:load-system "asdf") 8 | 9 | (asdf:initialize-source-registry '(:source-registry (:tree :here) :inherit-configuration)) 10 | 11 | ;;; try to find Quicklisp -- this is a mess because it isn't consistently installed in the 12 | ;;; same location. 13 | (if (uiop:find-package* '#:ql nil) 14 | (format t "~&Quicklisp pre-loaded into image.~%") 15 | (let ((ql-filename (uiop:getenv "QUICKLISP_SETUP")) 16 | loaded) 17 | (if ql-filename 18 | (if (probe-file ql-filename) 19 | (let ((result (load ql-filename :if-does-not-exist nil))) 20 | (when result 21 | (format t "~&Have loaded quicklisp setup file ~a.~%" ql-filename) 22 | (setf loaded t))) 23 | (format t "Quicklisp not installed where expected: ~a~%" ql-filename))) 24 | (unless loaded 25 | (let* ((fallback-name "/root/quicklisp/setup.lisp") 26 | (result (load fallback-name :if-does-not-exist nil))) 27 | (when result 28 | (format t "~&Have loaded quicklisp setup file from /root.~%") 29 | (setf loaded t)))) 30 | (unless loaded 31 | (format t "~&Unable to find quicklisp.~%") 32 | (uiop:quit 1 t)))) 33 | 34 | -------------------------------------------------------------------------------- /quicklisp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 2 | ;;;; This is quicklisp.lisp, the quickstart file for Quicklisp. To use 3 | ;;;; it, start Lisp, then (load "quicklisp.lisp") 4 | ;;;; 5 | ;;;; Quicklisp is beta software and comes with no warranty of any kind. 6 | ;;;; 7 | ;;;; For more information about the Quicklisp beta, see: 8 | ;;;; 9 | ;;;; http://www.quicklisp.org/beta/ 10 | ;;;; 11 | ;;;; If you have any questions or comments about Quicklisp, please 12 | ;;;; contact: 13 | ;;;; 14 | ;;;; Zach Beane 15 | ;;;; 16 | 17 | (cl:in-package #:cl-user) 18 | (cl:defpackage #:qlqs-user 19 | (:use #:cl)) 20 | (cl:in-package #:qlqs-user) 21 | 22 | (defpackage #:qlqs-info 23 | (:export #:*version*)) 24 | 25 | (defvar qlqs-info:*version* "2015-01-28") 26 | 27 | (defpackage #:qlqs-impl 28 | (:use #:cl) 29 | (:export #:*implementation*) 30 | (:export #:definterface 31 | #:defimplementation) 32 | (:export #:lisp 33 | #:abcl 34 | #:allegro 35 | #:ccl 36 | #:clasp 37 | #:clisp 38 | #:cmucl 39 | #:cormanlisp 40 | #:ecl 41 | #:gcl 42 | #:lispworks 43 | #:mkcl 44 | #:scl 45 | #:sbcl)) 46 | 47 | (defpackage #:qlqs-impl-util 48 | (:use #:cl #:qlqs-impl) 49 | (:export #:call-with-quiet-compilation)) 50 | 51 | (defpackage #:qlqs-network 52 | (:use #:cl #:qlqs-impl) 53 | (:export #:open-connection 54 | #:write-octets 55 | #:read-octets 56 | #:close-connection 57 | #:with-connection)) 58 | 59 | (defpackage #:qlqs-progress 60 | (:use #:cl) 61 | (:export #:make-progress-bar 62 | #:start-display 63 | #:update-progress 64 | #:finish-display)) 65 | 66 | (defpackage #:qlqs-http 67 | (:use #:cl #:qlqs-network #:qlqs-progress) 68 | (:export #:fetch 69 | #:*proxy-url* 70 | #:*maximum-redirects* 71 | #:*default-url-defaults*)) 72 | 73 | (defpackage #:qlqs-minitar 74 | (:use #:cl) 75 | (:export #:unpack-tarball)) 76 | 77 | (defpackage #:quicklisp-quickstart 78 | (:use #:cl #:qlqs-impl #:qlqs-impl-util #:qlqs-http #:qlqs-minitar) 79 | (:export #:install 80 | #:help 81 | #:*proxy-url* 82 | #:*asdf-url* 83 | #:*quicklisp-tar-url* 84 | #:*setup-url* 85 | #:*help-message* 86 | #:*after-load-message* 87 | #:*after-initial-setup-message*)) 88 | 89 | 90 | ;;; 91 | ;;; Defining implementation-specific packages and functionality 92 | ;;; 93 | 94 | (in-package #:qlqs-impl) 95 | 96 | (eval-when (:compile-toplevel :load-toplevel :execute) 97 | (defun error-unimplemented (&rest args) 98 | (declare (ignore args)) 99 | (error "Not implemented"))) 100 | 101 | (defmacro neuter-package (name) 102 | `(eval-when (:compile-toplevel :load-toplevel :execute) 103 | (let ((definition (fdefinition 'error-unimplemented))) 104 | (do-external-symbols (symbol ,(string name)) 105 | (unless (fboundp symbol) 106 | (setf (fdefinition symbol) definition)))))) 107 | 108 | (eval-when (:compile-toplevel :load-toplevel :execute) 109 | (defun feature-expression-passes-p (expression) 110 | (cond ((keywordp expression) 111 | (member expression *features*)) 112 | ((consp expression) 113 | (case (first expression) 114 | (or 115 | (some 'feature-expression-passes-p (rest expression))) 116 | (and 117 | (every 'feature-expression-passes-p (rest expression))))) 118 | (t (error "Unrecognized feature expression -- ~S" expression))))) 119 | 120 | 121 | (defmacro define-implementation-package (feature package-name &rest options) 122 | (let* ((output-options '((:use) 123 | (:export #:lisp))) 124 | (prep (cdr (assoc :prep options))) 125 | (class-option (cdr (assoc :class options))) 126 | (class (first class-option)) 127 | (superclasses (rest class-option)) 128 | (import-options '()) 129 | (effectivep (feature-expression-passes-p feature))) 130 | (dolist (option options) 131 | (ecase (first option) 132 | ((:prep :class)) 133 | ((:import-from 134 | :import) 135 | (push option import-options)) 136 | ((:export 137 | :shadow 138 | :intern 139 | :documentation) 140 | (push option output-options)) 141 | ((:reexport-from) 142 | (push (cons :export (cddr option)) output-options) 143 | (push (cons :import-from (cdr option)) import-options)))) 144 | `(eval-when (:compile-toplevel :load-toplevel :execute) 145 | ,@(when effectivep 146 | prep) 147 | (defclass ,class ,superclasses ()) 148 | (defpackage ,package-name ,@output-options 149 | ,@(when effectivep 150 | import-options)) 151 | ,@(when effectivep 152 | `((setf *implementation* (make-instance ',class)))) 153 | ,@(unless effectivep 154 | `((neuter-package ,package-name)))))) 155 | 156 | (defmacro definterface (name lambda-list &body options) 157 | (let* ((forbidden (intersection lambda-list lambda-list-keywords)) 158 | (gf-options (remove :implementation options :key #'first)) 159 | (implementations (set-difference options gf-options))) 160 | (when forbidden 161 | (error "~S not allowed in definterface lambda list" forbidden)) 162 | (flet ((method-option (class body) 163 | `(:method ((*implementation* ,class) ,@lambda-list) 164 | ,@body))) 165 | (let ((generic-name (intern (format nil "%~A" name)))) 166 | `(eval-when (:compile-toplevel :load-toplevel :execute) 167 | (defgeneric ,generic-name (lisp ,@lambda-list) 168 | ,@gf-options 169 | ,@(mapcar (lambda (implementation) 170 | (destructuring-bind (class &rest body) 171 | (rest implementation) 172 | (method-option class body))) 173 | implementations)) 174 | (defun ,name ,lambda-list 175 | (,generic-name *implementation* ,@lambda-list))))))) 176 | 177 | (defmacro defimplementation (name-and-options 178 | lambda-list &body body) 179 | (destructuring-bind (name &key (for t) qualifier) 180 | (if (consp name-and-options) 181 | name-and-options 182 | (list name-and-options)) 183 | (unless for 184 | (error "You must specify an implementation name.")) 185 | (let ((generic-name (find-symbol (format nil "%~A" name)))) 186 | (unless (and generic-name 187 | (fboundp generic-name)) 188 | (error "~S does not name an implementation function" name)) 189 | `(defmethod ,generic-name 190 | ,@(when qualifier (list qualifier)) 191 | ,(list* `(*implementation* ,for) lambda-list) ,@body)))) 192 | 193 | 194 | ;;; Bootstrap implementations 195 | 196 | (defvar *implementation* nil) 197 | (defclass lisp () ()) 198 | 199 | 200 | ;;; Allegro Common Lisp 201 | 202 | (define-implementation-package :allegro #:qlqs-allegro 203 | (:documentation 204 | "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") 205 | (:class allegro) 206 | (:reexport-from #:socket 207 | #:make-socket) 208 | (:reexport-from #:excl 209 | #:read-vector)) 210 | 211 | 212 | ;;; Armed Bear Common Lisp 213 | 214 | (define-implementation-package :abcl #:qlqs-abcl 215 | (:documentation 216 | "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") 217 | (:class abcl) 218 | (:reexport-from #:system 219 | #:make-socket 220 | #:get-socket-stream)) 221 | 222 | ;;; Clozure CL 223 | 224 | (define-implementation-package :ccl #:qlqs-ccl 225 | (:documentation 226 | "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") 227 | (:class ccl) 228 | (:reexport-from #:ccl 229 | #:make-socket)) 230 | 231 | 232 | ;;; CLASP 233 | 234 | (define-implementation-package :clasp #:qlqs-clasp 235 | (:documentation "CLASP - http://github.com/drmeister/clasp") 236 | (:class clasp) 237 | (:prep 238 | (require 'sockets)) 239 | (:intern #:host-network-address) 240 | (:reexport-from #:sb-bsd-sockets 241 | #:get-host-by-name 242 | #:host-ent-address 243 | #:socket-connect 244 | #:socket-make-stream 245 | #:inet-socket)) 246 | 247 | 248 | ;;; GNU CLISP 249 | 250 | (define-implementation-package :clisp #:qlqs-clisp 251 | (:documentation "GNU CLISP - http://clisp.cons.org/") 252 | (:class clisp) 253 | (:reexport-from #:socket 254 | #:socket-connect) 255 | (:reexport-from #:ext 256 | #:read-byte-sequence)) 257 | 258 | 259 | ;;; CMUCL 260 | 261 | (define-implementation-package :cmu #:qlqs-cmucl 262 | (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") 263 | (:class cmucl) 264 | (:reexport-from #:ext 265 | #:*gc-verbose*) 266 | (:reexport-from #:system 267 | #:make-fd-stream) 268 | (:reexport-from #:extensions 269 | #:connect-to-inet-socket)) 270 | 271 | (defvar qlqs-cmucl:*gc-verbose* nil) 272 | 273 | 274 | ;;; Scieneer CL 275 | 276 | (define-implementation-package :scl #:qlqs-scl 277 | (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") 278 | (:class scl) 279 | (:reexport-from #:system 280 | #:make-fd-stream) 281 | (:reexport-from #:extensions 282 | #:connect-to-inet-socket)) 283 | 284 | ;;; ECL 285 | 286 | (define-implementation-package :ecl #:qlqs-ecl 287 | (:documentation "ECL - http://ecls.sourceforge.net/") 288 | (:class ecl) 289 | (:prep 290 | (require 'sockets)) 291 | (:intern #:host-network-address) 292 | (:reexport-from #:sb-bsd-sockets 293 | #:get-host-by-name 294 | #:host-ent-address 295 | #:socket-connect 296 | #:socket-make-stream 297 | #:inet-socket)) 298 | 299 | 300 | ;;; LispWorks 301 | 302 | (define-implementation-package :lispworks #:qlqs-lispworks 303 | (:documentation "LispWorks - http://www.lispworks.com/") 304 | (:class lispworks) 305 | (:prep 306 | (require "comm")) 307 | (:reexport-from #:comm 308 | #:open-tcp-stream 309 | #:get-host-entry)) 310 | 311 | 312 | ;;; SBCL 313 | 314 | (define-implementation-package :sbcl #:qlqs-sbcl 315 | (:class sbcl) 316 | (:documentation 317 | "Steel Bank Common Lisp - http://www.sbcl.org/") 318 | (:prep 319 | (require 'sb-bsd-sockets)) 320 | (:intern #:host-network-address) 321 | (:reexport-from #:sb-ext 322 | #:compiler-note) 323 | (:reexport-from #:sb-bsd-sockets 324 | #:get-host-by-name 325 | #:inet-socket 326 | #:host-ent-address 327 | #:socket-connect 328 | #:socket-make-stream)) 329 | 330 | ;;; MKCL 331 | 332 | (define-implementation-package :mkcl #:qlqs-mkcl 333 | (:class mkcl) 334 | (:documentation 335 | "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") 336 | (:prep 337 | (require 'sockets)) 338 | (:intern #:host-network-address) 339 | (:reexport-from #:sb-bsd-sockets 340 | #:get-host-by-name 341 | #:inet-socket 342 | #:host-ent-address 343 | #:socket-connect 344 | #:socket-make-stream)) 345 | 346 | ;;; 347 | ;;; Utility function 348 | ;;; 349 | 350 | (in-package #:qlqs-impl-util) 351 | 352 | (definterface call-with-quiet-compilation (fun) 353 | (:implementation t 354 | (let ((*load-verbose* nil) 355 | (*compile-verbose* nil) 356 | (*load-print* nil) 357 | (*compile-print* nil)) 358 | (handler-bind ((warning #'muffle-warning)) 359 | (funcall fun))))) 360 | 361 | (defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) 362 | (fun) 363 | (declare (ignorable fun)) 364 | (handler-bind ((qlqs-sbcl:compiler-note #'muffle-warning)) 365 | (call-next-method))) 366 | 367 | (defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) 368 | (fun) 369 | (declare (ignorable fun)) 370 | (let ((qlqs-cmucl:*gc-verbose* nil)) 371 | (call-next-method))) 372 | 373 | 374 | ;;; 375 | ;;; Low-level networking implementations 376 | ;;; 377 | 378 | (in-package #:qlqs-network) 379 | 380 | (definterface host-address (host) 381 | (:implementation t 382 | host) 383 | (:implementation mkcl 384 | (qlqs-mkcl:host-ent-address (qlqs-mkcl:get-host-by-name host))) 385 | (:implementation sbcl 386 | (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host)))) 387 | 388 | (definterface open-connection (host port) 389 | (:implementation t 390 | (declare (ignorable host port)) 391 | (error "Sorry, quicklisp in implementation ~S is not supported yet." 392 | (lisp-implementation-type))) 393 | (:implementation allegro 394 | (qlqs-allegro:make-socket :remote-host host 395 | :remote-port port)) 396 | (:implementation abcl 397 | (let ((socket (qlqs-abcl:make-socket host port))) 398 | (qlqs-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) 399 | (:implementation ccl 400 | (qlqs-ccl:make-socket :remote-host host 401 | :remote-port port)) 402 | (:implementation clasp 403 | (let* ((endpoint (qlqs-clasp:host-ent-address 404 | (qlqs-clasp:get-host-by-name host))) 405 | (socket (make-instance 'qlqs-clasp:inet-socket 406 | :protocol :tcp 407 | :type :stream))) 408 | (qlqs-clasp:socket-connect socket endpoint port) 409 | (qlqs-clasp:socket-make-stream socket 410 | :element-type '(unsigned-byte 8) 411 | :input t 412 | :output t 413 | :buffering :full))) 414 | (:implementation clisp 415 | (qlqs-clisp:socket-connect port host :element-type '(unsigned-byte 8))) 416 | (:implementation cmucl 417 | (let ((fd (qlqs-cmucl:connect-to-inet-socket host port))) 418 | (qlqs-cmucl:make-fd-stream fd 419 | :element-type '(unsigned-byte 8) 420 | :binary-stream-p t 421 | :input t 422 | :output t))) 423 | (:implementation scl 424 | (let ((fd (qlqs-scl:connect-to-inet-socket host port))) 425 | (qlqs-scl:make-fd-stream fd 426 | :element-type '(unsigned-byte 8) 427 | :input t 428 | :output t))) 429 | (:implementation ecl 430 | (let* ((endpoint (qlqs-ecl:host-ent-address 431 | (qlqs-ecl:get-host-by-name host))) 432 | (socket (make-instance 'qlqs-ecl:inet-socket 433 | :protocol :tcp 434 | :type :stream))) 435 | (qlqs-ecl:socket-connect socket endpoint port) 436 | (qlqs-ecl:socket-make-stream socket 437 | :element-type '(unsigned-byte 8) 438 | :input t 439 | :output t 440 | :buffering :full))) 441 | (:implementation lispworks 442 | (qlqs-lispworks:open-tcp-stream host port 443 | :direction :io 444 | :errorp t 445 | :read-timeout nil 446 | :element-type '(unsigned-byte 8) 447 | :timeout 5)) 448 | (:implementation mkcl 449 | (let* ((endpoint (qlqs-mkcl:host-ent-address 450 | (qlqs-mkcl:get-host-by-name host))) 451 | (socket (make-instance 'qlqs-mkcl:inet-socket 452 | :protocol :tcp 453 | :type :stream))) 454 | (qlqs-mkcl:socket-connect socket endpoint port) 455 | (qlqs-mkcl:socket-make-stream socket 456 | :element-type '(unsigned-byte 8) 457 | :input t 458 | :output t 459 | :buffering :full))) 460 | (:implementation sbcl 461 | (let* ((endpoint (qlqs-sbcl:host-ent-address 462 | (qlqs-sbcl:get-host-by-name host))) 463 | (socket (make-instance 'qlqs-sbcl:inet-socket 464 | :protocol :tcp 465 | :type :stream))) 466 | (qlqs-sbcl:socket-connect socket endpoint port) 467 | (qlqs-sbcl:socket-make-stream socket 468 | :element-type '(unsigned-byte 8) 469 | :input t 470 | :output t 471 | :buffering :full)))) 472 | 473 | (definterface read-octets (buffer connection) 474 | (:implementation t 475 | (read-sequence buffer connection)) 476 | (:implementation allegro 477 | (qlqs-allegro:read-vector buffer connection)) 478 | (:implementation clisp 479 | (qlqs-clisp:read-byte-sequence buffer connection 480 | :no-hang nil 481 | :interactive t))) 482 | 483 | (definterface write-octets (buffer connection) 484 | (:implementation t 485 | (write-sequence buffer connection) 486 | (finish-output connection))) 487 | 488 | (definterface close-connection (connection) 489 | (:implementation t 490 | (ignore-errors (close connection)))) 491 | 492 | (definterface call-with-connection (host port fun) 493 | (:implementation t 494 | (let (connection) 495 | (unwind-protect 496 | (progn 497 | (setf connection (open-connection host port)) 498 | (funcall fun connection)) 499 | (when connection 500 | (close connection)))))) 501 | 502 | (defmacro with-connection ((connection host port) &body body) 503 | `(call-with-connection ,host ,port (lambda (,connection) ,@body))) 504 | 505 | 506 | ;;; 507 | ;;; A text progress bar 508 | ;;; 509 | 510 | (in-package #:qlqs-progress) 511 | 512 | (defclass progress-bar () 513 | ((start-time 514 | :initarg :start-time 515 | :accessor start-time) 516 | (end-time 517 | :initarg :end-time 518 | :accessor end-time) 519 | (progress-character 520 | :initarg :progress-character 521 | :accessor progress-character) 522 | (character-count 523 | :initarg :character-count 524 | :accessor character-count 525 | :documentation "How many characters wide is the progress bar?") 526 | (characters-so-far 527 | :initarg :characters-so-far 528 | :accessor characters-so-far) 529 | (update-interval 530 | :initarg :update-interval 531 | :accessor update-interval 532 | :documentation "Update the progress bar display after this many 533 | internal-time units.") 534 | (last-update-time 535 | :initarg :last-update-time 536 | :accessor last-update-time 537 | :documentation "The display was last updated at this time.") 538 | (total 539 | :initarg :total 540 | :accessor total 541 | :documentation "The total number of units tracked by this progress bar.") 542 | (progress 543 | :initarg :progress 544 | :accessor progress 545 | :documentation "How far in the progress are we?") 546 | (pending 547 | :initarg :pending 548 | :accessor pending 549 | :documentation "How many raw units should be tracked in the next 550 | display update?")) 551 | (:default-initargs 552 | :progress-character #\= 553 | :character-count 50 554 | :characters-so-far 0 555 | :update-interval (floor internal-time-units-per-second 4) 556 | :last-update-time 0 557 | :total 0 558 | :progress 0 559 | :pending 0)) 560 | 561 | (defgeneric start-display (progress-bar)) 562 | (defgeneric update-progress (progress-bar unit-count)) 563 | (defgeneric update-display (progress-bar)) 564 | (defgeneric finish-display (progress-bar)) 565 | (defgeneric elapsed-time (progress-bar)) 566 | (defgeneric units-per-second (progress-bar)) 567 | 568 | (defmethod start-display (progress-bar) 569 | (setf (last-update-time progress-bar) (get-internal-real-time)) 570 | (setf (start-time progress-bar) (get-internal-real-time)) 571 | (fresh-line) 572 | (finish-output)) 573 | 574 | (defmethod update-display (progress-bar) 575 | (incf (progress progress-bar) (pending progress-bar)) 576 | (setf (pending progress-bar) 0) 577 | (setf (last-update-time progress-bar) (get-internal-real-time)) 578 | (let* ((showable (floor (character-count progress-bar) 579 | (/ (total progress-bar) (progress progress-bar)))) 580 | (needed (- showable (characters-so-far progress-bar)))) 581 | (setf (characters-so-far progress-bar) showable) 582 | (dotimes (i needed) 583 | (write-char (progress-character progress-bar))) 584 | (finish-output))) 585 | 586 | (defmethod update-progress (progress-bar unit-count) 587 | (incf (pending progress-bar) unit-count) 588 | (let ((now (get-internal-real-time))) 589 | (when (< (update-interval progress-bar) 590 | (- now (last-update-time progress-bar))) 591 | (update-display progress-bar)))) 592 | 593 | (defmethod finish-display (progress-bar) 594 | (update-display progress-bar) 595 | (setf (end-time progress-bar) (get-internal-real-time)) 596 | (terpri) 597 | (format t "~:D bytes in ~$ seconds (~$KB/sec)" 598 | (total progress-bar) 599 | (elapsed-time progress-bar) 600 | (/ (units-per-second progress-bar) 1024)) 601 | (finish-output)) 602 | 603 | (defmethod elapsed-time (progress-bar) 604 | (/ (- (end-time progress-bar) (start-time progress-bar)) 605 | internal-time-units-per-second)) 606 | 607 | (defmethod units-per-second (progress-bar) 608 | (if (plusp (elapsed-time progress-bar)) 609 | (/ (total progress-bar) (elapsed-time progress-bar)) 610 | 0)) 611 | 612 | (defun kb/sec (progress-bar) 613 | (/ (units-per-second progress-bar) 1024)) 614 | 615 | 616 | 617 | (defparameter *uncertain-progress-chars* "?") 618 | 619 | (defclass uncertain-size-progress-bar (progress-bar) 620 | ((progress-char-index 621 | :initarg :progress-char-index 622 | :accessor progress-char-index) 623 | (units-per-char 624 | :initarg :units-per-char 625 | :accessor units-per-char)) 626 | (:default-initargs 627 | :total 0 628 | :progress-char-index 0 629 | :units-per-char (floor (expt 1024 2) 50))) 630 | 631 | (defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) 632 | unit-count) 633 | (incf (total progress-bar) unit-count)) 634 | 635 | (defmethod progress-character ((progress-bar uncertain-size-progress-bar)) 636 | (let ((index (progress-char-index progress-bar))) 637 | (prog1 638 | (char *uncertain-progress-chars* index) 639 | (setf (progress-char-index progress-bar) 640 | (mod (1+ index) (length *uncertain-progress-chars*)))))) 641 | 642 | (defmethod update-display ((progress-bar uncertain-size-progress-bar)) 643 | (setf (last-update-time progress-bar) (get-internal-real-time)) 644 | (multiple-value-bind (chars pend) 645 | (floor (pending progress-bar) (units-per-char progress-bar)) 646 | (setf (pending progress-bar) pend) 647 | (dotimes (i chars) 648 | (write-char (progress-character progress-bar)) 649 | (incf (characters-so-far progress-bar)) 650 | (when (<= (character-count progress-bar) 651 | (characters-so-far progress-bar)) 652 | (terpri) 653 | (setf (characters-so-far progress-bar) 0) 654 | (finish-output))) 655 | (finish-output))) 656 | 657 | (defun make-progress-bar (total) 658 | (if (or (not total) (zerop total)) 659 | (make-instance 'uncertain-size-progress-bar) 660 | (make-instance 'progress-bar :total total))) 661 | 662 | ;;; 663 | ;;; A simple HTTP client 664 | ;;; 665 | 666 | (in-package #:qlqs-http) 667 | 668 | ;;; Octet data 669 | 670 | (deftype octet () 671 | '(unsigned-byte 8)) 672 | 673 | (defun make-octet-vector (size) 674 | (make-array size :element-type 'octet 675 | :initial-element 0)) 676 | 677 | (defun octet-vector (&rest octets) 678 | (make-array (length octets) :element-type 'octet 679 | :initial-contents octets)) 680 | 681 | ;;; ASCII characters as integers 682 | 683 | (defun acode (char) 684 | (cond ((eql char :cr) 685 | 13) 686 | ((eql char :lf) 687 | 10) 688 | (t 689 | (let ((code (char-code char))) 690 | (if (<= 0 code 127) 691 | code 692 | (error "Character ~S is not in the ASCII character set" 693 | char)))))) 694 | 695 | (defvar *whitespace* 696 | (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) 697 | 698 | (defun whitep (code) 699 | (member code *whitespace*)) 700 | 701 | (defun ascii-vector (string) 702 | (let ((vector (make-octet-vector (length string)))) 703 | (loop for char across string 704 | for code = (char-code char) 705 | for i from 0 706 | if (< 127 code) do 707 | (error "Invalid character for ASCII -- ~A" char) 708 | else 709 | do (setf (aref vector i) code)) 710 | vector)) 711 | 712 | (defun ascii-subseq (vector start end) 713 | "Return a subseq of octet-specialized VECTOR as a string." 714 | (let ((string (make-string (- end start)))) 715 | (loop for i from 0 716 | for j from start below end 717 | do (setf (char string i) (code-char (aref vector j)))) 718 | string)) 719 | 720 | (defun ascii-downcase (code) 721 | (if (<= 65 code 90) 722 | (+ code 32) 723 | code)) 724 | 725 | (defun ascii-equal (a b) 726 | (eql (ascii-downcase a) (ascii-downcase b))) 727 | 728 | (defmacro acase (value &body cases) 729 | (flet ((convert-case-keys (keys) 730 | (mapcar (lambda (key) 731 | (etypecase key 732 | (integer key) 733 | (character (char-code key)) 734 | (symbol 735 | (ecase key 736 | (:cr 13) 737 | (:lf 10) 738 | ((t) t))))) 739 | (if (consp keys) keys (list keys))))) 740 | `(case ,value 741 | ,@(mapcar (lambda (case) 742 | (destructuring-bind (keys &rest body) 743 | case 744 | `(,(if (eql keys t) 745 | t 746 | (convert-case-keys keys)) 747 | ,@body))) 748 | cases)))) 749 | 750 | ;;; Pattern matching (for finding headers) 751 | 752 | (defclass matcher () 753 | ((pattern 754 | :initarg :pattern 755 | :reader pattern) 756 | (pos 757 | :initform 0 758 | :accessor match-pos) 759 | (matchedp 760 | :initform nil 761 | :accessor matchedp))) 762 | 763 | (defun reset-match (matcher) 764 | (setf (match-pos matcher) 0 765 | (matchedp matcher) nil)) 766 | 767 | (define-condition match-failure (error) ()) 768 | 769 | (defun match (matcher input &key (start 0) end error) 770 | (let ((i start) 771 | (end (or end (length input))) 772 | (match-end (length (pattern matcher)))) 773 | (with-slots (pattern pos) 774 | matcher 775 | (loop 776 | (cond ((= pos match-end) 777 | (let ((match-start (- i pos))) 778 | (setf pos 0) 779 | (setf (matchedp matcher) t) 780 | (return (values match-start (+ match-start match-end))))) 781 | ((= i end) 782 | (return nil)) 783 | ((= (aref pattern pos) 784 | (aref input i)) 785 | (incf i) 786 | (incf pos)) 787 | (t 788 | (if error 789 | (error 'match-failure) 790 | (if (zerop pos) 791 | (incf i) 792 | (setf pos 0))))))))) 793 | 794 | (defun ascii-matcher (string) 795 | (make-instance 'matcher 796 | :pattern (ascii-vector string))) 797 | 798 | (defun octet-matcher (&rest octets) 799 | (make-instance 'matcher 800 | :pattern (apply 'octet-vector octets))) 801 | 802 | (defun acode-matcher (&rest codes) 803 | (make-instance 'matcher 804 | :pattern (make-array (length codes) 805 | :element-type 'octet 806 | :initial-contents 807 | (mapcar 'acode codes)))) 808 | 809 | 810 | ;;; "Connection Buffers" are a kind of callback-driven, 811 | ;;; pattern-matching chunky stream. Callbacks can be called for a 812 | ;;; certain number of octets or until one or more patterns are seen in 813 | ;;; the input. cbufs automatically refill themselves from a 814 | ;;; connection as needed. 815 | 816 | (defvar *cbuf-buffer-size* 8192) 817 | 818 | (define-condition end-of-data (error) ()) 819 | 820 | (defclass cbuf () 821 | ((data 822 | :initarg :data 823 | :accessor data) 824 | (connection 825 | :initarg :connection 826 | :accessor connection) 827 | (start 828 | :initarg :start 829 | :accessor start) 830 | (end 831 | :initarg :end 832 | :accessor end) 833 | (eofp 834 | :initarg :eofp 835 | :accessor eofp)) 836 | (:default-initargs 837 | :data (make-octet-vector *cbuf-buffer-size*) 838 | :connection nil 839 | :start 0 840 | :end 0 841 | :eofp nil) 842 | (:documentation "A CBUF is a connection buffer that keeps track of 843 | incoming data from a connection. Several functions make it easy to 844 | treat a CBUF as a kind of chunky, callback-driven stream.")) 845 | 846 | (define-condition cbuf-progress () 847 | ((size 848 | :initarg :size 849 | :accessor cbuf-progress-size 850 | :initform 0))) 851 | 852 | (defun call-processor (fun cbuf start end) 853 | (signal 'cbuf-progress :size (- end start)) 854 | (funcall fun (data cbuf) start end)) 855 | 856 | (defun make-cbuf (connection) 857 | (make-instance 'cbuf :connection connection)) 858 | 859 | (defun make-stream-writer (stream) 860 | "Create a callback for writing data to STREAM." 861 | (lambda (data start end) 862 | (write-sequence data stream :start start :end end))) 863 | 864 | (defgeneric size (cbuf) 865 | (:method ((cbuf cbuf)) 866 | (- (end cbuf) (start cbuf)))) 867 | 868 | (defgeneric emptyp (cbuf) 869 | (:method ((cbuf cbuf)) 870 | (zerop (size cbuf)))) 871 | 872 | (defgeneric refill (cbuf) 873 | (:method ((cbuf cbuf)) 874 | (when (eofp cbuf) 875 | (error 'end-of-data)) 876 | (setf (start cbuf) 0) 877 | (setf (end cbuf) 878 | (read-octets (data cbuf) 879 | (connection cbuf))) 880 | (cond ((emptyp cbuf) 881 | (setf (eofp cbuf) t) 882 | (error 'end-of-data)) 883 | (t (size cbuf))))) 884 | 885 | (defun process-all (fun cbuf) 886 | (unless (emptyp cbuf) 887 | (call-processor fun cbuf (start cbuf) (end cbuf)))) 888 | 889 | (defun multi-cmatch (matchers cbuf) 890 | (let (start end) 891 | (dolist (matcher matchers (values start end)) 892 | (multiple-value-bind (s e) 893 | (match matcher (data cbuf) 894 | :start (start cbuf) 895 | :end (end cbuf)) 896 | (when (and s (or (null start) (< s start))) 897 | (setf start s 898 | end e)))))) 899 | 900 | (defun cmatch (matcher cbuf) 901 | (if (consp matcher) 902 | (multi-cmatch matcher cbuf) 903 | (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) 904 | 905 | (defun call-until-end (fun cbuf) 906 | (handler-case 907 | (loop 908 | (process-all fun cbuf) 909 | (refill cbuf)) 910 | (end-of-data () 911 | (return-from call-until-end)))) 912 | 913 | (defun show-cbuf (context cbuf) 914 | (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) 915 | 916 | (defun call-for-n-octets (n fun cbuf) 917 | (let ((remaining n)) 918 | (loop 919 | (when (<= remaining (size cbuf)) 920 | (let ((end (+ (start cbuf) remaining))) 921 | (call-processor fun cbuf (start cbuf) end) 922 | (setf (start cbuf) end) 923 | (return))) 924 | (process-all fun cbuf) 925 | (decf remaining (size cbuf)) 926 | (refill cbuf)))) 927 | 928 | (defun call-until-matching (matcher fun cbuf) 929 | (loop 930 | (multiple-value-bind (start end) 931 | (cmatch matcher cbuf) 932 | (when start 933 | (call-processor fun cbuf (start cbuf) end) 934 | (setf (start cbuf) end) 935 | (return))) 936 | (process-all fun cbuf) 937 | (refill cbuf))) 938 | 939 | (defun ignore-data (data start end) 940 | (declare (ignore data start end))) 941 | 942 | (defun skip-until-matching (matcher cbuf) 943 | (call-until-matching matcher 'ignore-data cbuf)) 944 | 945 | 946 | ;;; Creating HTTP requests as octet buffers 947 | 948 | (defclass octet-sink () 949 | ((storage 950 | :initarg :storage 951 | :accessor storage)) 952 | (:default-initargs 953 | :storage (make-array 1024 :element-type 'octet 954 | :fill-pointer 0 955 | :adjustable t)) 956 | (:documentation "A simple stream-like target for collecting 957 | octets.")) 958 | 959 | (defun add-octet (octet sink) 960 | (vector-push-extend octet (storage sink))) 961 | 962 | (defun add-octets (octets sink &key (start 0) end) 963 | (setf end (or end (length octets))) 964 | (loop for i from start below end 965 | do (add-octet (aref octets i) sink))) 966 | 967 | (defun add-string (string sink) 968 | (loop for char across string 969 | for code = (char-code char) 970 | do (add-octet code sink))) 971 | 972 | (defun add-strings (sink &rest strings) 973 | (mapc (lambda (string) (add-string string sink)) strings)) 974 | 975 | (defun add-newline (sink) 976 | (add-octet 13 sink) 977 | (add-octet 10 sink)) 978 | 979 | (defun sink-buffer (sink) 980 | (subseq (storage sink) 0)) 981 | 982 | (defvar *proxy-url* nil) 983 | 984 | (defun full-proxy-path (host port path) 985 | (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" 986 | (= port 443) 987 | host 988 | (or (= port 80) 989 | (= port 443)) 990 | port 991 | path)) 992 | 993 | (defun make-request-buffer (host port path &key (method "GET")) 994 | (setf method (string method)) 995 | (when *proxy-url* 996 | (setf path (full-proxy-path host port path))) 997 | (let ((sink (make-instance 'octet-sink))) 998 | (flet ((add-line (&rest strings) 999 | (apply #'add-strings sink strings) 1000 | (add-newline sink))) 1001 | (add-line method " " path " HTTP/1.1") 1002 | (add-line "Host: " host (if (= port 80) "" 1003 | (format nil ":~D" port))) 1004 | (add-line "Connection: close") 1005 | ;; FIXME: get this version string from somewhere else. 1006 | (add-line "User-Agent: quicklisp-bootstrap/" 1007 | qlqs-info:*version*) 1008 | (add-newline sink) 1009 | (sink-buffer sink)))) 1010 | 1011 | (defun sink-until-matching (matcher cbuf) 1012 | (let ((sink (make-instance 'octet-sink))) 1013 | (call-until-matching 1014 | matcher 1015 | (lambda (buffer start end) 1016 | (add-octets buffer sink :start start :end end)) 1017 | cbuf) 1018 | (sink-buffer sink))) 1019 | 1020 | 1021 | ;;; HTTP headers 1022 | 1023 | (defclass header () 1024 | ((data 1025 | :initarg :data 1026 | :accessor data) 1027 | (status 1028 | :initarg :status 1029 | :accessor status) 1030 | (name-starts 1031 | :initarg :name-starts 1032 | :accessor name-starts) 1033 | (name-ends 1034 | :initarg :name-ends 1035 | :accessor name-ends) 1036 | (value-starts 1037 | :initarg :value-starts 1038 | :accessor value-starts) 1039 | (value-ends 1040 | :initarg :value-ends 1041 | :accessor value-ends))) 1042 | 1043 | (defmethod print-object ((header header) stream) 1044 | (print-unreadable-object (header stream :type t) 1045 | (prin1 (status header) stream))) 1046 | 1047 | (defun matches-at (pattern target pos) 1048 | (= (mismatch pattern target :start2 pos) (length pattern))) 1049 | 1050 | (defun header-value-indexes (field-name header) 1051 | (loop with data = (data header) 1052 | with pattern = (ascii-vector (string-downcase field-name)) 1053 | for start across (name-starts header) 1054 | for i from 0 1055 | when (matches-at pattern data start) 1056 | return (values (aref (value-starts header) i) 1057 | (aref (value-ends header) i)))) 1058 | 1059 | (defun ascii-header-value (field-name header) 1060 | (multiple-value-bind (start end) 1061 | (header-value-indexes field-name header) 1062 | (when start 1063 | (ascii-subseq (data header) start end)))) 1064 | 1065 | (defun all-field-names (header) 1066 | (map 'list 1067 | (lambda (start end) 1068 | (ascii-subseq (data header) start end)) 1069 | (name-starts header) 1070 | (name-ends header))) 1071 | 1072 | (defun headers-alist (header) 1073 | (mapcar (lambda (name) 1074 | (cons name (ascii-header-value name header))) 1075 | (all-field-names header))) 1076 | 1077 | (defmethod describe-object :after ((header header) stream) 1078 | (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) 1079 | 1080 | (defun content-length (header) 1081 | (let ((field-value (ascii-header-value "content-length" header))) 1082 | (when field-value 1083 | (let ((value (ignore-errors (parse-integer field-value)))) 1084 | (or value 1085 | (error "Content-Length header field value is not a number -- ~A" 1086 | field-value)))))) 1087 | 1088 | (defun chunkedp (header) 1089 | (string= (ascii-header-value "transfer-encoding" header) "chunked")) 1090 | 1091 | (defun location (header) 1092 | (ascii-header-value "location" header)) 1093 | 1094 | (defun status-code (vector) 1095 | (let* ((space (position (acode #\Space) vector)) 1096 | (c1 (- (aref vector (incf space)) 48)) 1097 | (c2 (- (aref vector (incf space)) 48)) 1098 | (c3 (- (aref vector (incf space)) 48))) 1099 | (+ (* c1 100) 1100 | (* c2 10) 1101 | (* c3 1)))) 1102 | 1103 | (defun force-downcase-field-names (header) 1104 | (loop with data = (data header) 1105 | for start across (name-starts header) 1106 | for end across (name-ends header) 1107 | do (loop for i from start below end 1108 | for code = (aref data i) 1109 | do (setf (aref data i) (ascii-downcase code))))) 1110 | 1111 | (defun skip-white-forward (pos vector) 1112 | (position-if-not 'whitep vector :start pos)) 1113 | 1114 | (defun skip-white-backward (pos vector) 1115 | (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) 1116 | (if nonwhite 1117 | (1+ nonwhite) 1118 | pos))) 1119 | 1120 | (defun contract-field-value-indexes (header) 1121 | "Header field values exclude leading and trailing whitespace; adjust 1122 | the indexes in the header accordingly." 1123 | (loop with starts = (value-starts header) 1124 | with ends = (value-ends header) 1125 | with data = (data header) 1126 | for i from 0 1127 | for start across starts 1128 | for end across ends 1129 | do 1130 | (setf (aref starts i) (skip-white-forward start data)) 1131 | (setf (aref ends i) (skip-white-backward end data)))) 1132 | 1133 | (defun next-line-pos (vector) 1134 | (let ((pos 0)) 1135 | (labels ((finish (&optional (i pos)) 1136 | (return-from next-line-pos i)) 1137 | (after-cr (code) 1138 | (acase code 1139 | (:lf (finish pos)) 1140 | (t (finish (1- pos))))) 1141 | (pending (code) 1142 | (acase code 1143 | (:cr #'after-cr) 1144 | (:lf (finish pos)) 1145 | (t #'pending)))) 1146 | (let ((state #'pending)) 1147 | (loop 1148 | (setf state (funcall state (aref vector pos))) 1149 | (incf pos)))))) 1150 | 1151 | (defun make-hvector () 1152 | (make-array 16 :fill-pointer 0 :adjustable t)) 1153 | 1154 | (defun process-header (vector) 1155 | "Create a HEADER instance from the octet data in VECTOR." 1156 | (let* ((name-starts (make-hvector)) 1157 | (name-ends (make-hvector)) 1158 | (value-starts (make-hvector)) 1159 | (value-ends (make-hvector)) 1160 | (header (make-instance 'header 1161 | :data vector 1162 | :status 999 1163 | :name-starts name-starts 1164 | :name-ends name-ends 1165 | :value-starts value-starts 1166 | :value-ends value-ends)) 1167 | (mark nil) 1168 | (pos (next-line-pos vector))) 1169 | (unless pos 1170 | (error "Unable to process HTTP header")) 1171 | (setf (status header) (status-code vector)) 1172 | (labels ((save (value vector) 1173 | (vector-push-extend value vector)) 1174 | (mark () 1175 | (setf mark pos)) 1176 | (clear-mark () 1177 | (setf mark nil)) 1178 | (finish () 1179 | (if mark 1180 | (save mark value-ends) 1181 | (save pos value-ends)) 1182 | (force-downcase-field-names header) 1183 | (contract-field-value-indexes header) 1184 | (return-from process-header header)) 1185 | (in-new-line (code) 1186 | (acase code 1187 | ((#\Tab #\Space) (setf mark nil) #'in-value) 1188 | (t 1189 | (when mark 1190 | (save mark value-ends)) 1191 | (clear-mark) 1192 | (save pos name-starts) 1193 | (in-name code)))) 1194 | (after-cr (code) 1195 | (acase code 1196 | (:lf #'in-new-line) 1197 | (t (in-new-line code)))) 1198 | (pending-value (code) 1199 | (acase code 1200 | ((#\Tab #\Space) #'pending-value) 1201 | (:cr #'after-cr) 1202 | (:lf #'in-new-line) 1203 | (t (save pos value-starts) #'in-value))) 1204 | (in-name (code) 1205 | (acase code 1206 | (#\: 1207 | (save pos name-ends) 1208 | (save (1+ pos) value-starts) 1209 | #'in-value) 1210 | ((:cr :lf) 1211 | (finish)) 1212 | ((#\Tab #\Space) 1213 | (error "Unexpected whitespace in header field name")) 1214 | (t 1215 | (unless (<= 0 code 127) 1216 | (error "Unexpected non-ASCII header field name")) 1217 | #'in-name))) 1218 | (in-value (code) 1219 | (acase code 1220 | (:lf (mark) #'in-new-line) 1221 | (:cr (mark) #'after-cr) 1222 | (t #'in-value)))) 1223 | (let ((state #'in-new-line)) 1224 | (loop 1225 | (incf pos) 1226 | (when (<= (length vector) pos) 1227 | (error "No header found in response")) 1228 | (setf state (funcall state (aref vector pos)))))))) 1229 | 1230 | 1231 | ;;; HTTP URL parsing 1232 | 1233 | (defclass url () 1234 | ((hostname 1235 | :initarg :hostname 1236 | :accessor hostname 1237 | :initform nil) 1238 | (port 1239 | :initarg :port 1240 | :accessor port 1241 | :initform 80) 1242 | (path 1243 | :initarg :path 1244 | :accessor path 1245 | :initform "/"))) 1246 | 1247 | (defun parse-urlstring (urlstring) 1248 | (setf urlstring (string-trim " " urlstring)) 1249 | (let* ((pos (mismatch urlstring "http://" :test 'char-equal)) 1250 | (mark pos) 1251 | (url (make-instance 'url))) 1252 | (labels ((save () 1253 | (subseq urlstring mark pos)) 1254 | (mark () 1255 | (setf mark pos)) 1256 | (finish () 1257 | (return-from parse-urlstring url)) 1258 | (hostname-char-p (char) 1259 | (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." 1260 | :test 'char-equal)) 1261 | (at-start (char) 1262 | (case char 1263 | (#\/ 1264 | (setf (port url) nil) 1265 | (mark) 1266 | #'in-path) 1267 | (t 1268 | #'in-host))) 1269 | (in-host (char) 1270 | (case char 1271 | ((#\/ :end) 1272 | (setf (hostname url) (save)) 1273 | (mark) 1274 | #'in-path) 1275 | (#\: 1276 | (setf (hostname url) (save)) 1277 | (mark) 1278 | #'in-port) 1279 | (t 1280 | (unless (hostname-char-p char) 1281 | (error "~S is not a valid URL" urlstring)) 1282 | #'in-host))) 1283 | (in-port (char) 1284 | (case char 1285 | ((#\/ :end) 1286 | (setf (port url) 1287 | (parse-integer urlstring 1288 | :start (1+ mark) 1289 | :end pos)) 1290 | (mark) 1291 | #'in-path) 1292 | (t 1293 | (unless (digit-char-p char) 1294 | (error "Bad port in URL ~S" urlstring)) 1295 | #'in-port))) 1296 | (in-path (char) 1297 | (case char 1298 | ((#\# :end) 1299 | (setf (path url) (save)) 1300 | (finish))) 1301 | #'in-path)) 1302 | (let ((state #'at-start)) 1303 | (loop 1304 | (when (<= (length urlstring) pos) 1305 | (funcall state :end) 1306 | (finish)) 1307 | (setf state (funcall state (aref urlstring pos))) 1308 | (incf pos)))))) 1309 | 1310 | (defun url (thing) 1311 | (if (stringp thing) 1312 | (parse-urlstring thing) 1313 | thing)) 1314 | 1315 | (defgeneric request-buffer (method url) 1316 | (:method (method url) 1317 | (setf url (url url)) 1318 | (make-request-buffer (hostname url) (port url) (path url) 1319 | :method method))) 1320 | 1321 | (defun urlstring (url) 1322 | (format nil "~@[http://~A~]~@[:~D~]~A" 1323 | (hostname url) 1324 | (and (/= 80 (port url)) (port url)) 1325 | (path url))) 1326 | 1327 | (defmethod print-object ((url url) stream) 1328 | (print-unreadable-object (url stream :type t) 1329 | (prin1 (urlstring url) stream))) 1330 | 1331 | (defun merge-urls (url1 url2) 1332 | (setf url1 (url url1)) 1333 | (setf url2 (url url2)) 1334 | (make-instance 'url 1335 | :hostname (or (hostname url1) 1336 | (hostname url2)) 1337 | :port (or (port url1) 1338 | (port url2)) 1339 | :path (or (path url1) 1340 | (path url2)))) 1341 | 1342 | 1343 | ;;; Requesting an URL and saving it to a file 1344 | 1345 | (defparameter *maximum-redirects* 10) 1346 | (defvar *default-url-defaults* (url "http://src.quicklisp.org/")) 1347 | 1348 | (defun read-http-header (cbuf) 1349 | (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) 1350 | (acode-matcher :cr :cr) 1351 | (acode-matcher :cr :lf :cr :lf)) 1352 | cbuf))) 1353 | (process-header header-data))) 1354 | 1355 | (defun read-chunk-header (cbuf) 1356 | (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) 1357 | (end (or (position (acode :cr) header-data) 1358 | (position (acode #\;) header-data)))) 1359 | (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) 1360 | 1361 | (defun save-chunk-response (stream cbuf) 1362 | "For a chunked response, read all chunks and write them to STREAM." 1363 | (let ((fun (make-stream-writer stream)) 1364 | (matcher (acode-matcher :cr :lf))) 1365 | (loop 1366 | (let ((chunk-size (read-chunk-header cbuf))) 1367 | (when (zerop chunk-size) 1368 | (return)) 1369 | (call-for-n-octets chunk-size fun cbuf) 1370 | (skip-until-matching matcher cbuf))))) 1371 | 1372 | (defun save-response (file header cbuf) 1373 | (with-open-file (stream file 1374 | :direction :output 1375 | :if-exists :supersede 1376 | :element-type 'octet) 1377 | (let ((content-length (content-length header))) 1378 | (cond ((chunkedp header) 1379 | (save-chunk-response stream cbuf)) 1380 | (content-length 1381 | (call-for-n-octets content-length 1382 | (make-stream-writer stream) 1383 | cbuf)) 1384 | (t 1385 | (call-until-end (make-stream-writer stream) cbuf)))))) 1386 | 1387 | (defun call-with-progress-bar (size fun) 1388 | (let ((progress-bar (make-progress-bar size))) 1389 | (start-display progress-bar) 1390 | (flet ((update (condition) 1391 | (update-progress progress-bar 1392 | (cbuf-progress-size condition)))) 1393 | (handler-bind ((cbuf-progress #'update)) 1394 | (funcall fun))) 1395 | (finish-display progress-bar))) 1396 | 1397 | (defun fetch (url file &key (follow-redirects t) quietly 1398 | (maximum-redirects *maximum-redirects*)) 1399 | "Request URL and write the body of the response to FILE." 1400 | (setf url (merge-urls url *default-url-defaults*)) 1401 | (setf file (merge-pathnames file)) 1402 | (let ((redirect-count 0) 1403 | (original-url url) 1404 | (connect-url (or (url *proxy-url*) url)) 1405 | (stream (if quietly 1406 | (make-broadcast-stream) 1407 | *trace-output*))) 1408 | (loop 1409 | (when (<= maximum-redirects redirect-count) 1410 | (error "Too many redirects for ~A" original-url)) 1411 | (with-connection (connection (hostname connect-url) (port connect-url)) 1412 | (let ((cbuf (make-instance 'cbuf :connection connection)) 1413 | (request (request-buffer "GET" url))) 1414 | (write-octets request connection) 1415 | (let ((header (read-http-header cbuf))) 1416 | (loop while (= (status header) 100) 1417 | do (setf header (read-http-header cbuf))) 1418 | (cond ((= (status header) 200) 1419 | (let ((size (content-length header))) 1420 | (format stream "~&; Fetching ~A~%" url) 1421 | (if (and (numberp size) 1422 | (plusp size)) 1423 | (format stream "; ~$KB~%" (/ size 1024)) 1424 | (format stream "; Unknown size~%")) 1425 | (if quietly 1426 | (save-response file header cbuf) 1427 | (call-with-progress-bar (content-length header) 1428 | (lambda () 1429 | (save-response file header cbuf)))))) 1430 | ((not (<= 300 (status header) 399)) 1431 | (error "Unexpected status for ~A: ~A" 1432 | url (status header)))) 1433 | (if (and follow-redirects (<= 300 (status header) 399)) 1434 | (let ((new-urlstring (ascii-header-value "location" header))) 1435 | (when (not new-urlstring) 1436 | (error "Redirect code ~D received, but no Location: header" 1437 | (status header))) 1438 | (incf redirect-count) 1439 | (setf url (merge-urls new-urlstring 1440 | url)) 1441 | (format stream "~&; Redirecting to ~A~%" url)) 1442 | (return (values header (and file (probe-file file))))))))))) 1443 | 1444 | 1445 | ;;; A primitive tar unpacker 1446 | 1447 | (in-package #:qlqs-minitar) 1448 | 1449 | (defun make-block-buffer () 1450 | (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0)) 1451 | 1452 | (defun skip-n-blocks (n stream) 1453 | (let ((block (make-block-buffer))) 1454 | (dotimes (i n) 1455 | (read-sequence block stream)))) 1456 | 1457 | (defun ascii-subseq (vector start end) 1458 | (let ((string (make-string (- end start)))) 1459 | (loop for i from 0 1460 | for j from start below end 1461 | do (setf (char string i) (code-char (aref vector j)))) 1462 | string)) 1463 | 1464 | (defun block-asciiz-string (block start length) 1465 | (let* ((end (+ start length)) 1466 | (eos (or (position 0 block :start start :end end) 1467 | end))) 1468 | (ascii-subseq block start eos))) 1469 | 1470 | (defun prefix (header) 1471 | (when (plusp (aref header 345)) 1472 | (block-asciiz-string header 345 155))) 1473 | 1474 | (defun name (header) 1475 | (block-asciiz-string header 0 100)) 1476 | 1477 | (defun payload-size (header) 1478 | (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) 1479 | 1480 | (defun nth-block (n file) 1481 | (with-open-file (stream file :element-type '(unsigned-byte 8)) 1482 | (let ((block (make-block-buffer))) 1483 | (skip-n-blocks (1- n) stream) 1484 | (read-sequence block stream) 1485 | block))) 1486 | 1487 | (defun payload-type (code) 1488 | (case code 1489 | (0 :file) 1490 | (48 :file) 1491 | (53 :directory) 1492 | (t :unsupported))) 1493 | 1494 | (defun full-path (header) 1495 | (let ((prefix (prefix header)) 1496 | (name (name header))) 1497 | (if prefix 1498 | (format nil "~A/~A" prefix name) 1499 | name))) 1500 | 1501 | (defun save-file (file size stream) 1502 | (multiple-value-bind (full-blocks partial) 1503 | (truncate size 512) 1504 | (ensure-directories-exist file) 1505 | (with-open-file (outstream file 1506 | :direction :output 1507 | :if-exists :supersede 1508 | :element-type '(unsigned-byte 8)) 1509 | (let ((block (make-block-buffer))) 1510 | (dotimes (i full-blocks) 1511 | (read-sequence block stream) 1512 | (write-sequence block outstream)) 1513 | (when (plusp partial) 1514 | (read-sequence block stream) 1515 | (write-sequence block outstream :end partial)))))) 1516 | 1517 | (defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) 1518 | (let ((block (make-block-buffer))) 1519 | (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) 1520 | (loop 1521 | (let ((size (read-sequence block stream))) 1522 | (when (zerop size) 1523 | (return)) 1524 | (unless (= size 512) 1525 | (error "Bad size on tarfile")) 1526 | (when (every #'zerop block) 1527 | (return)) 1528 | (let* ((payload-code (aref block 156)) 1529 | (payload-type (payload-type payload-code)) 1530 | (tar-path (full-path block)) 1531 | (full-path (merge-pathnames tar-path directory)) 1532 | (payload-size (payload-size block))) 1533 | (case payload-type 1534 | (:file 1535 | (save-file full-path payload-size stream)) 1536 | (:directory 1537 | (ensure-directories-exist full-path)) 1538 | (t 1539 | (warn "Unknown tar block payload code -- ~D" payload-code) 1540 | (skip-n-blocks (ceiling (payload-size block) 512) stream))))))))) 1541 | 1542 | (defun contents (tarfile) 1543 | (let ((block (make-block-buffer)) 1544 | (result '())) 1545 | (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) 1546 | (loop 1547 | (let ((size (read-sequence block stream))) 1548 | (when (zerop size) 1549 | (return (nreverse result))) 1550 | (unless (= size 512) 1551 | (error "Bad size on tarfile")) 1552 | (when (every #'zerop block) 1553 | (return (nreverse result))) 1554 | (let* ((payload-type (payload-type (aref block 156))) 1555 | (tar-path (full-path block)) 1556 | (payload-size (payload-size block))) 1557 | (skip-n-blocks (ceiling payload-size 512) stream) 1558 | (case payload-type 1559 | (:file 1560 | (push tar-path result)) 1561 | (:directory 1562 | (push tar-path result))))))))) 1563 | 1564 | 1565 | ;;; 1566 | ;;; The actual bootstrapping work 1567 | ;;; 1568 | 1569 | (in-package #:quicklisp-quickstart) 1570 | 1571 | (defvar *home* 1572 | (merge-pathnames (make-pathname :directory '(:relative "quicklisp")) 1573 | (user-homedir-pathname))) 1574 | 1575 | (defun qmerge (pathname) 1576 | (merge-pathnames pathname *home*)) 1577 | 1578 | (defun renaming-fetch (url file) 1579 | (let ((tmpfile (qmerge "tmp/fetch.dat"))) 1580 | (fetch url tmpfile) 1581 | (rename-file tmpfile file))) 1582 | 1583 | (defvar *quickstart-parameters* nil 1584 | "This plist is populated with parameters that may carry over to the 1585 | initial configuration of the client, e.g. :proxy-url 1586 | or :initial-dist-url") 1587 | 1588 | (defvar *quicklisp-hostname* "beta.quicklisp.org") 1589 | 1590 | (defvar *client-info-url* 1591 | (format nil "http://~A/client/quicklisp.sexp" 1592 | *quicklisp-hostname*)) 1593 | 1594 | (defclass client-info () 1595 | ((setup-url 1596 | :reader setup-url 1597 | :initarg :setup-url) 1598 | (asdf-url 1599 | :reader asdf-url 1600 | :initarg :asdf-url) 1601 | (client-tar-url 1602 | :reader client-tar-url 1603 | :initarg :client-tar-url) 1604 | (version 1605 | :reader version 1606 | :initarg :version) 1607 | (plist 1608 | :reader plist 1609 | :initarg :plist) 1610 | (source-file 1611 | :reader source-file 1612 | :initarg :source-file))) 1613 | 1614 | (defmethod print-object ((client-info client-info) stream) 1615 | (print-unreadable-object (client-info stream :type t) 1616 | (prin1 (version client-info) stream))) 1617 | 1618 | (defun safely-read (stream) 1619 | (let ((*read-eval* nil)) 1620 | (read stream))) 1621 | 1622 | (defun fetch-client-info-plist (url) 1623 | "Fetch and return the client info data at URL." 1624 | (let ((local-client-info-file (qmerge "tmp/client-info.sexp"))) 1625 | (ensure-directories-exist local-client-info-file) 1626 | (renaming-fetch url local-client-info-file) 1627 | (with-open-file (stream local-client-info-file) 1628 | (list* :source-file local-client-info-file 1629 | (safely-read stream))))) 1630 | 1631 | (defun fetch-client-info (url) 1632 | (let ((plist (fetch-client-info-plist url))) 1633 | (destructuring-bind (&key setup asdf client-tar version 1634 | source-file 1635 | &allow-other-keys) 1636 | plist 1637 | (unless (and setup asdf client-tar version) 1638 | (error "Invalid data from client info URL -- ~A" url)) 1639 | (make-instance 'client-info 1640 | :setup-url (getf setup :url) 1641 | :asdf-url (getf asdf :url) 1642 | :client-tar-url (getf client-tar :url) 1643 | :version version 1644 | :plist plist 1645 | :source-file source-file)))) 1646 | 1647 | (defun client-info-url-from-version (version) 1648 | (format nil "http://~A/client/~A/client-info.sexp" 1649 | *quicklisp-hostname* 1650 | version)) 1651 | 1652 | (defun distinfo-url-from-version (version) 1653 | (format nil "http://~A/dist/~A/distinfo.txt" 1654 | *quicklisp-hostname* 1655 | version)) 1656 | 1657 | (defvar *help-message* 1658 | (format nil "~&~% ==== quicklisp quickstart install help ====~%~% ~ 1659 | quicklisp-quickstart:install can take the following ~ 1660 | optional arguments:~%~% ~ 1661 | :path \"/path/to/installation/\"~%~% ~ 1662 | :proxy \"http://your.proxy:port/\"~%~% ~ 1663 | :client-url ~%~% ~ 1664 | :client-version ~%~% ~ 1665 | :dist-url ~%~% ~ 1666 | :dist-version ~%~%")) 1667 | 1668 | (defvar *after-load-message* 1669 | (format nil "~&~% ==== quicklisp quickstart ~A loaded ====~%~% ~ 1670 | To continue with installation, evaluate: (quicklisp-quickstart:install)~%~% ~ 1671 | For installation options, evaluate: (quicklisp-quickstart:help)~%~%" 1672 | qlqs-info:*version*)) 1673 | 1674 | (defvar *after-initial-setup-message* 1675 | (with-output-to-string (*standard-output*) 1676 | (format t "~&~% ==== quicklisp installed ====~%~%") 1677 | (format t " To load a system, use: (ql:quickload \"system-name\")~%~%") 1678 | (format t " To find systems, use: (ql:system-apropos \"term\")~%~%") 1679 | (format t " To load Quicklisp every time you start Lisp, use: (ql:add-to-init-file)~%~%") 1680 | (format t " For more information, see http://www.quicklisp.org/beta/~%~%"))) 1681 | 1682 | (defun initial-install (&key (client-url *client-info-url*) dist-url) 1683 | (setf *quickstart-parameters* 1684 | (list :proxy-url *proxy-url* 1685 | :initial-dist-url dist-url)) 1686 | (ensure-directories-exist (qmerge "tmp/")) 1687 | (let ((client-info (fetch-client-info client-url)) 1688 | (tmptar (qmerge "tmp/quicklisp.tar")) 1689 | (setup (qmerge "setup.lisp")) 1690 | (asdf (qmerge "asdf.lisp"))) 1691 | (renaming-fetch (client-tar-url client-info) tmptar) 1692 | (unpack-tarball tmptar :directory (qmerge "./")) 1693 | (renaming-fetch (setup-url client-info) setup) 1694 | (renaming-fetch (asdf-url client-info) asdf) 1695 | (rename-file (source-file client-info) (qmerge "client-info.sexp")) 1696 | (load setup :verbose nil :print nil) 1697 | (write-string *after-initial-setup-message*) 1698 | (finish-output))) 1699 | 1700 | (defun help () 1701 | (write-string *help-message*) 1702 | t) 1703 | 1704 | (defun non-empty-file-namestring (pathname) 1705 | (let ((string (file-namestring pathname))) 1706 | (unless (or (null string) 1707 | (equal string "")) 1708 | string))) 1709 | 1710 | (defun install (&key ((:path *home*) *home*) 1711 | ((:proxy *proxy-url*) *proxy-url*) 1712 | client-url 1713 | client-version 1714 | dist-url 1715 | dist-version) 1716 | (setf *home* (merge-pathnames *home* (truename *default-pathname-defaults*))) 1717 | (let ((name (non-empty-file-namestring *home*))) 1718 | (when name 1719 | (warn "Making ~A part of the install pathname directory" 1720 | name) 1721 | ;; This corrects a pathname like "/foo/bar" to "/foo/bar/" and 1722 | ;; "foo" to "foo/" 1723 | (setf *home* 1724 | (make-pathname :defaults *home* 1725 | :directory (append (pathname-directory *home*) 1726 | (list name)))))) 1727 | (let ((setup-file (qmerge "setup.lisp"))) 1728 | (when (probe-file setup-file) 1729 | (multiple-value-bind (result proceed) 1730 | (with-simple-restart (load-setup "Load ~S" setup-file) 1731 | (error "Quicklisp has already been installed. Load ~S instead." 1732 | setup-file)) 1733 | (declare (ignore result)) 1734 | (when proceed 1735 | (return-from install (load setup-file)))))) 1736 | (if (find-package '#:ql) 1737 | (progn 1738 | (write-line "!!! Quicklisp has already been set up. !!!") 1739 | (write-string *after-initial-setup-message*) 1740 | t) 1741 | (call-with-quiet-compilation 1742 | (lambda () 1743 | (let ((client-url (or client-url 1744 | (and client-version 1745 | (client-info-url-from-version client-version)) 1746 | *client-info-url*)) 1747 | ;; It's ok for dist-url to be nil; there's a default in 1748 | ;; the client 1749 | (dist-url (or dist-url 1750 | (and dist-version 1751 | (distinfo-url-from-version dist-version))))) 1752 | (initial-install :client-url client-url 1753 | :dist-url dist-url)))))) 1754 | 1755 | (write-string *after-load-message*) 1756 | 1757 | ;;; End of quicklisp.lisp 1758 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | sbcl --non-interactive \ 4 | --load 'load-deps.lisp' \ 5 | --eval '(ql:quickload :html2clwho/tests)' \ 6 | --eval '(asdf:load-system :html2clwho)' \ 7 | --eval '(uiop:quit (if (html2clwho.test::run-tests) 0 1))' 8 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :html2clwho.test 2 | (:use :cl :html2clwho :fiveam)) 3 | (in-package :html2clwho.test) 4 | 5 | (def-suite html2clwho-suite :description "Build sexp from html") 6 | (in-suite html2clwho-suite) 7 | 8 | (defun is-html (str sexp) 9 | (is (equal (string-trim '(#\Newline) (html2clwho::build-sexp str)) sexp))) 10 | 11 | (def-test empty-tag () 12 | (is-html "" "(:html)")) 13 | 14 | (def-test some-classes () 15 | (is-html "
" "(:div :class \"col-md-4\")")) 16 | 17 | (def-test some-content () 18 | (is-html "
Hello
" "(:div 19 | (:span \"Hello\"))")) 20 | 21 | (def-test simple-comment () 22 | (is-html "" 23 | "(:html #| \"with comment\"|#)")) 24 | 25 | (def-test complex-comment () 26 | (is-html "

This is a paragraph.

27 | 31 |

This is a paragraph too.

" 32 | "(:p \"This is a paragraph.\") #| 33 | (:p \"Look at this cool image:\") 34 | (:img :border \"0\" :src \"pic_trulli.jpg\" :alt \"Trulli\")|# 35 | (:p \"This is a paragraph too.\")")) 36 | 37 | ;; https://stackoverflow.com/questions/54889460/asdftest-system-from-a-makefile-doesnt-return-an-error-return-code 38 | (defun run-tests () 39 | (run! 'html2clwho-suite)) 40 | --------------------------------------------------------------------------------