├── .hgignore ├── CHANGES.md ├── lfarm-ssl ├── packages.lisp ├── test.lisp └── lfarm-ssl.lisp ├── lfarm-gss ├── packages.lisp ├── test.lisp ├── wrapper-stream.lisp └── lfarm-gss.lisp ├── lfarm-ssl.asd ├── lfarm-gss.asd ├── LICENSE ├── lfarm-test ├── package.lisp ├── auth-test.lisp ├── promise-test.lisp ├── 1am.lisp ├── closure-test.lisp ├── base.lisp ├── cognate-test.lisp └── kernel-test.lisp ├── lfarm-admin.asd ├── lfarm-server.asd ├── lfarm-launcher.asd ├── lfarm-common ├── error.lisp ├── text-serializer.lisp ├── default-data-transport.lisp ├── binary-serializer.lisp ├── address.lisp ├── log.lisp ├── data-transport.lisp ├── object-transport.lisp ├── util.lisp ├── package.lisp ├── unwind-protect.lisp ├── socket.lisp └── defwith.lisp ├── lfarm-client ├── lambda.lisp ├── package.lisp ├── promise.lisp ├── closure.lisp └── cognate.lisp ├── lfarm-test.asd ├── lfarm-common.asd ├── lfarm-client.asd ├── lfarm-admin.lisp ├── lfarm-launcher.lisp ├── README.md └── lfarm-server.lisp /.hgignore: -------------------------------------------------------------------------------- 1 | .*\.fasl 2 | .*~ 3 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 2 | # lfarm changes 3 | 4 | ## 0.1.0 5 | 6 | * birthday 7 | -------------------------------------------------------------------------------- /lfarm-ssl/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lfarm-ssl 2 | (:use :cl) 3 | (:export #:ssl-auth-server 4 | #:ssl-auth-client)) 5 | 6 | (in-package #:lfarm-ssl) 7 | -------------------------------------------------------------------------------- /lfarm-gss/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lfarm-gss 2 | (:use #:cl) 3 | (:export #:gss-auth-client 4 | #:gss-auth-server 5 | #:wrapper-stream)) 6 | 7 | (in-package #:lfarm-gss) 8 | -------------------------------------------------------------------------------- /lfarm-ssl.asd: -------------------------------------------------------------------------------- 1 | (defsystem :lfarm-ssl 2 | :description "SSL support for lfarm" 3 | :license "BSD" 4 | :author "Elias Martenson " 5 | :depends-on (:lfarm-common 6 | :cl+ssl) 7 | :serial t 8 | :components ((:module "lfarm-ssl" 9 | :serial t 10 | :components ((:file "packages") 11 | (:file "lfarm-ssl"))))) 12 | -------------------------------------------------------------------------------- /lfarm-gss/test.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel :load-toplevel :execute) 2 | (ql:quickload "lfarm-server") 3 | (ql:quickload "lfarm-client") 4 | (ql:quickload "lfarm-gss")) 5 | 6 | (setq lfarm-common:*log-level* :info) 7 | (setq lfarm-common:*auth* (make-instance 'lfarm-gss:gss-auth)) 8 | 9 | (lfarm-server:start-server (machine-instance) 4500 :background t) 10 | (setf lfarm:*kernel* (lfarm:make-kernel `((,(machine-instance) 4500)))) 11 | -------------------------------------------------------------------------------- /lfarm-gss.asd: -------------------------------------------------------------------------------- 1 | (defsystem :lfarm-gss 2 | :description "GSS-API support for lfarm" 3 | :license "BSD" 4 | :author "Elias Martenson " 5 | :depends-on (:lfarm-common 6 | :cl-gss 7 | :trivial-gray-streams) 8 | :serial t 9 | :components ((:module "lfarm-gss" 10 | :serial t 11 | :components ((:file "packages") 12 | (:file "wrapper-stream") 13 | (:file "lfarm-gss"))))) 14 | -------------------------------------------------------------------------------- /lfarm-ssl/test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Despite its name, this file does not contain any test cases. It's merely a 2 | ;;; program used to set up the nescessary instances when working on the ssl code. 3 | 4 | (eval-when (:compile-toplevel :load-toplevel :execute) 5 | (push #p"/Users/elias/prog/lfarm/" asdf:*central-registry*) 6 | (ql:quickload "lfarm-server") 7 | (ql:quickload "lfarm-client") 8 | (ql:quickload "lfarm-ssl")) 9 | 10 | (let ((lfarm-common:*auth* (make-instance 'lfarm-ssl:ssl-auth-server 11 | :path "/Users/elias/z/server_cert.pem" 12 | :key "/Users/elias/z/server.pem" 13 | ;:password "foofoo" 14 | ))) 15 | (lfarm-server:start-server "localhost" 7777 :background t)) 16 | 17 | (let ((lfarm-common:*auth* (make-instance 'lfarm-ssl:ssl-auth-client 18 | :path "/Users/elias/z/server_cert.pem" 19 | :key "/Users/elias/z/client.pem" 20 | ;:password "foofoo" 21 | ))) 22 | (setq lfarm-client.kernel:*kernel* (lfarm:make-kernel '(("localhost" 7777))))) 23 | -------------------------------------------------------------------------------- /lfarm-ssl/lfarm-ssl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:lfarm-ssl) 2 | 3 | (defclass cert-data () 4 | ((path :initarg :path 5 | :initform nil 6 | :reader cert-data-path) 7 | (key :initarg :key 8 | :initform nil 9 | :reader cert-data-key) 10 | (password :initarg :password 11 | :initform nil 12 | :reader cert-data-password)) 13 | (:documentation "Certificate information for SSL auth models")) 14 | 15 | (defclass ssl-auth-server (cert-data) 16 | () 17 | (:documentation "Server ssl auth model")) 18 | 19 | (defclass ssl-auth-client (cert-data) 20 | () 21 | (:documentation "Client ssl auth model")) 22 | 23 | (defmethod lfarm-common.data-transport:initialize-client-stream ((auth ssl-auth-client) stream server-name) 24 | (cl+ssl:make-ssl-client-stream stream 25 | :certificate (cert-data-path auth) 26 | :key (cert-data-key auth) 27 | :password (cert-data-password auth))) 28 | 29 | (defmethod lfarm-common.data-transport:initialize-server-stream ((auth ssl-auth-server) stream) 30 | (cl+ssl:make-ssl-server-stream stream 31 | :certificate (cert-data-path auth) 32 | :key (cert-data-key auth) 33 | :password (cert-data-password auth))) 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions 5 | are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | * Neither the name of the project nor the names of its 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /lfarm-gss/wrapper-stream.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:lfarm-gss) 2 | 3 | (defclass wrapper-stream (trivial-gray-streams:trivial-gray-stream-mixin 4 | trivial-gray-streams:fundamental-binary-input-stream 5 | trivial-gray-streams:fundamental-binary-output-stream) 6 | ((delegate :initarg :delegate 7 | :initform (error "~s is a required argument for class ~s" :delegate 'wrapper-stream) 8 | :reader wrapper-stream-delegate) 9 | (context :initarg :context 10 | :initform (error "~s is a required argument for class ~s" :context 'wrapper-stream) 11 | :reader wrapper-stream-context) 12 | (description :type string 13 | :initarg :description 14 | :initform "" 15 | :reader wrapper-stream-description))) 16 | 17 | (defmethod trivial-gray-streams:stream-read-byte 18 | ((stream wrapper-stream)) 19 | (read-byte (wrapper-stream-delegate stream))) 20 | 21 | (defmethod trivial-gray-streams:stream-write-byte 22 | ((stream wrapper-stream) char) 23 | (write-byte char (wrapper-stream-delegate stream))) 24 | 25 | (defmethod trivial-gray-streams:stream-read-sequence 26 | ((stream wrapper-stream) seq start end &key) 27 | (read-sequence seq (wrapper-stream-delegate stream) 28 | :start start :end end)) 29 | 30 | (defmethod trivial-gray-streams:stream-write-sequence 31 | ((stream wrapper-stream) seq start end &key) 32 | (write-sequence seq (wrapper-stream-delegate stream) 33 | :start start :end end)) 34 | 35 | (defmethod trivial-gray-streams:stream-finish-output 36 | ((stream wrapper-stream)) 37 | (finish-output (wrapper-stream-delegate stream))) 38 | 39 | (defmethod trivial-gray-streams:stream-force-output 40 | ((stream wrapper-stream)) 41 | (force-output (wrapper-stream-delegate stream))) 42 | -------------------------------------------------------------------------------- /lfarm-test/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lfarm-test 32 | (:documentation 33 | "Test suite for lfarm.") 34 | (:use #:cl 35 | #:lfarm-common 36 | #:lfarm-server 37 | #:lfarm-client 38 | #:lfarm-launcher 39 | #:lfarm-admin 40 | #:lfarm-test.1am) 41 | (:export #:execute)) 42 | 43 | (in-package #:lfarm-test) 44 | -------------------------------------------------------------------------------- /lfarm-admin.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defsystem :lfarm-admin 32 | :description 33 | "Admin component of lfarm, a library for distributing work across machines." 34 | :long-description "See http://github.com/lmj/lfarm" 35 | :version "0.1.0" 36 | :licence "BSD" 37 | :author "James M. Lawrence " 38 | :depends-on (:usocket 39 | :lfarm-common) 40 | :serial t 41 | :components ((:file "lfarm-admin"))) 42 | -------------------------------------------------------------------------------- /lfarm-server.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defsystem :lfarm-server 32 | :description 33 | "Server component of lfarm, a library for distributing work across machines." 34 | :long-description "See http://github.com/lmj/lfarm" 35 | :version "0.1.0" 36 | :licence "BSD" 37 | :author "James M. Lawrence " 38 | :depends-on (:usocket 39 | :lfarm-common) 40 | :serial t 41 | :components ((:file "lfarm-server"))) 42 | -------------------------------------------------------------------------------- /lfarm-launcher.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defsystem :lfarm-launcher 32 | :description 33 | "Testing facility for lfarm, a library for distributing work across machines." 34 | :long-description "See http://github.com/lmj/lfarm" 35 | :version "0.1.0" 36 | :licence "BSD" 37 | :author "James M. Lawrence " 38 | :depends-on (:external-program 39 | :lfarm-server 40 | :lfarm-admin) 41 | :serial t 42 | :components ((:file "lfarm-launcher"))) 43 | -------------------------------------------------------------------------------- /lfarm-common/error.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | (defstruct (task-error-data (:constructor %make-task-error-data)) 34 | (report nil :type string) 35 | (desc nil :type string)) 36 | 37 | (defun make-task-error-data (err) 38 | (%make-task-error-data 39 | :report (princ-to-string err) 40 | :desc (with-output-to-string (stream) (describe err stream)))) 41 | 42 | (define-condition corrupted-stream-error (stream-error) 43 | () 44 | (:report "Invalid data found in the connection stream.")) 45 | -------------------------------------------------------------------------------- /lfarm-common/text-serializer.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; Text serializer: PRINT and READ. 32 | 33 | (in-package #:lfarm-common) 34 | 35 | (defvar *element-type* 36 | #-abcl 'base-char 37 | #+abcl 'character) 38 | 39 | (defvar *keyword-package* (find-package 'keyword)) 40 | 41 | (defun backend-serialize (object stream) 42 | ;; Bind the keyword package to cause all symbols to be written with 43 | ;; their package. 44 | (with-standard-io-syntax 45 | (let ((*package* *keyword-package*) 46 | (*print-circle* t)) 47 | (format stream "~s " object)))) 48 | 49 | (defun backend-deserialize (stream) 50 | (with-standard-io-syntax 51 | (read stream))) 52 | -------------------------------------------------------------------------------- /lfarm-common/default-data-transport.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | ;;; Use the serializer to make a simple protocol. 34 | 35 | (defmethod send-buffer ((auth t) buffer stream) 36 | (declare (ignore auth)) 37 | (backend-serialize (length buffer) stream) 38 | (write-sequence buffer stream)) 39 | 40 | (defmethod receive-buffer ((auth t) stream) 41 | (declare (ignore auth)) 42 | (let ((buffer (make-array (backend-deserialize stream) 43 | :element-type *element-type*))) 44 | (handler-case (read-sequence buffer stream) 45 | (end-of-file () 46 | (error 'corrupted-stream-error :stream stream))) 47 | buffer)) 48 | -------------------------------------------------------------------------------- /lfarm-client/lambda.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-client.kernel) 32 | 33 | (defun named-lambda-form (name lambda-list body) 34 | (let ((args (make-symbol (string 'args)))) 35 | `(lambda (&rest ,args) 36 | (labels ((,name ,lambda-list ,@body)) 37 | (apply #',name ,args))))) 38 | 39 | (defun regular-lambda-form (lambda-list body) 40 | `(lambda ,lambda-list ,@body)) 41 | 42 | (defun lambda-form (name lambda-list body) 43 | (if name 44 | `',(named-lambda-form name lambda-list body) 45 | `',(regular-lambda-form lambda-list body))) 46 | 47 | #-lfarm.with-closures 48 | (defun serialize-lambda (lambda-list body env &key name) 49 | (declare (ignore env)) 50 | (lambda-form name lambda-list body)) 51 | -------------------------------------------------------------------------------- /lfarm-common/binary-serializer.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; Serialization with cl-store. 32 | 33 | (in-package #:lfarm-common) 34 | 35 | (defvar *element-type* 'flexi-streams:octet) 36 | 37 | (defun translate-error (err) 38 | (error (cl-store:caused-by err))) 39 | 40 | (defun backend-serialize (object stream) 41 | (handler-bind ((cl-store:store-error #'translate-error)) 42 | (cl-store:store object stream))) 43 | 44 | (defun backend-deserialize (stream) 45 | (handler-bind ((cl-store:restore-error #'translate-error)) 46 | (cl-store:restore stream))) 47 | 48 | ;;; ensure cl-store is initialized 49 | (let ((seq (flexi-streams:with-output-to-sequence (out) 50 | (cl-store:store 99 out)))) 51 | (flexi-streams:with-input-from-sequence (in seq) 52 | (assert (= 99 (cl-store:restore in))))) 53 | -------------------------------------------------------------------------------- /lfarm-client/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (macrolet 32 | ((package (package-name package-nicknames documentation &rest list) 33 | `(defpackage ,package-name 34 | (:documentation ,documentation) 35 | (:nicknames ,@package-nicknames) 36 | (:use #:cl ,@list) 37 | (:export 38 | ,@(loop for package in list 39 | nconc (loop for symbol being the external-symbols in package 40 | collect (make-symbol (string symbol)))))))) 41 | (package #:lfarm-client (#:lfarm) 42 | "This is a convenience package which exports the external symbols of: 43 | lfarm-client.kernel 44 | lfarm-client.promise 45 | lfarm-client.cognate" 46 | #:lfarm-client.kernel 47 | #:lfarm-client.promise 48 | #:lfarm-client.cognate)) 49 | -------------------------------------------------------------------------------- /lfarm-common/address.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | (defun bad-address (thing) 34 | (error "Address must be a (host port) string-integer pair, not ~s." 35 | thing)) 36 | 37 | (defun ensure-address (address) 38 | (typecase address 39 | (cons (unless (and (= (length address) 2) 40 | (stringp (first address)) 41 | (typep (second address) '(integer 0 65535))) 42 | (bad-address address)) 43 | address) 44 | (otherwise (bad-address address)))) 45 | 46 | (defun ensure-addresses (addresses) 47 | (mapcar #'ensure-address addresses)) 48 | 49 | (defwith with-each-address ((:vars host port) addresses) 50 | ;; check all beforehand 51 | (dolist (address (ensure-addresses addresses)) 52 | (apply #'call-body address))) 53 | 54 | (defwith with-each-address/handle-error ((:vars host port) addresses fn-name) 55 | (with-each-address (host port addresses) 56 | (handler-case (call-body host port) 57 | (error (err) 58 | (warn "~a: failed to contact server ~a:~a -- ~a" 59 | fn-name host port err))))) 60 | -------------------------------------------------------------------------------- /lfarm-common/log.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | (defvar *log-level* :error 34 | "Set to :error to log only errors; set to :info for verbosity.") 35 | 36 | (defvar *log-stream* *debug-io* 37 | "Stream for logging.") 38 | 39 | (defvar *log-lock* (make-lock)) 40 | 41 | (defun timestamp () 42 | (multiple-value-bind (second minute hour) (get-decoded-time) 43 | (format nil "~2,'0d:~2,'0d:~2,'0d" hour minute second))) 44 | 45 | (defun write-log (level package &rest args) 46 | (let ((timestamp (timestamp)) 47 | (*print-readably* nil) 48 | (*print-pretty* nil) 49 | (*print-circle* t)) 50 | (with-lock-held (*log-lock*) 51 | (format *log-stream* "~&~a ~a ~a ~{~s~^ ~}~%" 52 | timestamp level (string-downcase (package-name package)) args) 53 | (finish-output *log-stream*)))) 54 | 55 | (defmacro info (&rest args) 56 | `(case *log-level* 57 | (:info (write-log "info" ,*package* ,@args)))) 58 | 59 | (defmacro bad (&rest args) 60 | `(ccase *log-level* 61 | ((:info :error) (write-log "**ERROR**" ,*package* ,@args)))) 62 | 63 | (defmacro with-errors-logged (&body body) 64 | `(handler-bind ((error (lambda (err) (bad err)))) 65 | ,@body)) 66 | -------------------------------------------------------------------------------- /lfarm-test.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | #+(or sbcl ccl allegro lispworks) 32 | (eval-when (:compile-toplevel :load-toplevel :execute) 33 | (pushnew :lfarm.with-closures *features*)) 34 | 35 | (defsystem :lfarm-test 36 | :description 37 | "Test suite of lfarm, a library for distributing work across machines." 38 | :long-description "See http://github.com/lmj/lfarm" 39 | :version "0.1.0" 40 | :licence "BSD" 41 | :author "James M. Lawrence " 42 | :depends-on (:lfarm-server 43 | :lfarm-client 44 | :lfarm-launcher 45 | :lfarm-admin) 46 | :serial t 47 | :components ((:module "lfarm-test" 48 | :serial t 49 | :components ((:file "1am") 50 | (:file "package") 51 | (:file "base") 52 | (:file "kernel-test") 53 | #+lfarm.with-closures (:file "closure-test") 54 | (:file "promise-test") 55 | (:file "cognate-test") 56 | (:file "auth-test"))))) 57 | 58 | (defmethod perform ((o test-op) (c (eql (find-system :lfarm-test)))) 59 | (declare (ignore o c)) 60 | (funcall (intern (string '#:execute) :lfarm-test))) 61 | -------------------------------------------------------------------------------- /lfarm-common.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defsystem :lfarm-common 32 | :description 33 | "(private) Common components of lfarm, a library for distributing 34 | work across machines." 35 | :long-description "See http://github.com/lmj/lfarm" 36 | :version "0.1.0" 37 | :licence "BSD" 38 | :author "James M. Lawrence " 39 | :depends-on (:alexandria 40 | :bordeaux-threads 41 | :usocket 42 | #-lfarm.with-text-serializer :flexi-streams 43 | #-lfarm.with-text-serializer :cl-store) 44 | :serial t 45 | :components ((:module "lfarm-common" 46 | :serial t 47 | :components ((:file "package") 48 | (:file "error") 49 | (:file "util") 50 | (:file "unwind-protect") 51 | (:file "defwith") 52 | (:file "log") 53 | (:file "address") 54 | #-lfarm.with-text-serializer (:file "binary-serializer") 55 | #+lfarm.with-text-serializer (:file "text-serializer") 56 | (:file "data-transport") 57 | (:file "default-data-transport") 58 | (:file "socket") 59 | (:file "object-transport"))))) 60 | -------------------------------------------------------------------------------- /lfarm-client.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | #+(or sbcl ccl allegro lispworks) 32 | (eval-when (:compile-toplevel :load-toplevel :execute) 33 | (pushnew :lfarm.with-closures *features*)) 34 | 35 | (defsystem :lfarm-client 36 | :description 37 | "Client component of lfarm, a library for distributing work across machines." 38 | :long-description "See http://github.com/lmj/lfarm" 39 | :version "0.1.0" 40 | :licence "BSD" 41 | :author "James M. Lawrence " 42 | :depends-on (:usocket 43 | :lparallel 44 | :lfarm-common 45 | #+lfarm.with-hu-walker 46 | :hu.dwim.walker) 47 | :serial t 48 | :components ((:module "lfarm-client" 49 | :serial t 50 | :components ((:file "kernel") 51 | (:file "lambda") 52 | #+lfarm.with-closures (:file "closure") 53 | (:file "promise") 54 | (:file "cognate") 55 | (:file "package"))))) 56 | 57 | (defmethod perform ((o test-op) (c (eql (find-system :lfarm-client)))) 58 | (declare (ignore o c)) 59 | (load-system '#:lfarm-test) 60 | (test-system '#:lfarm-test)) 61 | 62 | (defmethod perform :after ((o load-op) (c (eql (find-system :lfarm-client)))) 63 | (declare (ignore o c)) 64 | (pushnew :lfarm-client *features*)) 65 | -------------------------------------------------------------------------------- /lfarm-common/data-transport.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common.data-transport) 32 | 33 | (define-condition auth-error (error) 34 | () 35 | (:documentation 36 | "Raise this error or a subclass thereof when auth fails.")) 37 | 38 | (defgeneric initialize-server-stream (auth stream) 39 | (:documentation 40 | "Initialize a server-side stream. Return a new stream or the same 41 | stream.")) 42 | 43 | (defgeneric initialize-client-stream (auth stream server-name) 44 | (:documentation 45 | "Initialize a client-side stream connected to server named 46 | `server-name'. Return a new stream or the same stream.")) 47 | 48 | (defgeneric send-buffer (auth buffer stream) 49 | (:documentation 50 | "Send a (unsigned-byte 8) vector over a stream.")) 51 | 52 | (defgeneric receive-buffer (auth stream) 53 | (:documentation 54 | "Receive a (unsigned-byte 8) vector from a stream.")) 55 | 56 | (defgeneric stream-close (auth stream) 57 | (:documentation 58 | "Callback for when the stream is closed.")) 59 | 60 | ;;; defaults 61 | 62 | (defmethod initialize-server-stream ((auth t) stream) 63 | (declare (ignore auth)) 64 | stream) 65 | 66 | (defmethod initialize-client-stream ((auth t) stream server-name) 67 | (declare (ignore auth server-name)) 68 | stream) 69 | 70 | (defmethod stream-close ((auth t) stream) 71 | (declare (ignore auth stream))) 72 | -------------------------------------------------------------------------------- /lfarm-common/object-transport.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; An object is serialized into a buffer before being written to the 32 | ;;; stream in order to avoid corrupting the stream when a 33 | ;;; serialization error occurs. 34 | ;;; 35 | ;;; The raw object buffer is extracted from the stream before 36 | ;;; deserializing because it may have to be read more than once (for 37 | ;;; undefined package errors). 38 | 39 | (in-package #:lfarm-common) 40 | 41 | #-lfarm.with-text-serializer 42 | (progn 43 | (defun serialize-to-buffer (object) 44 | (flexi-streams:with-output-to-sequence (out :element-type *element-type*) 45 | (backend-serialize object out))) 46 | 47 | (defun deserialize-buffer (buffer) 48 | (flexi-streams:with-input-from-sequence (in buffer) 49 | (backend-deserialize in)))) 50 | 51 | #+lfarm.with-text-serializer 52 | (progn 53 | (defun serialize-to-buffer (object) 54 | (with-output-to-string (out nil :element-type *element-type*) 55 | (backend-serialize object out))) 56 | 57 | (defun deserialize-buffer (buffer) 58 | (backend-deserialize (make-string-input-stream buffer)))) 59 | 60 | (defun send-object (object stream) 61 | (send-buffer *auth* (serialize-to-buffer object) stream) 62 | (force-output stream)) 63 | 64 | (defun receive-serialized-buffer (stream) 65 | (receive-buffer *auth* stream)) 66 | 67 | (defun receive-object (stream) 68 | (deserialize-buffer (receive-serialized-buffer stream))) 69 | -------------------------------------------------------------------------------- /lfarm-common/util.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | (defmacro alias-macro (alias orig) 34 | `(eval-when (:compile-toplevel :load-toplevel :execute) 35 | (setf (macro-function ',alias) (macro-function ',orig)) 36 | ',alias)) 37 | 38 | (defmacro alias-function (alias orig) 39 | `(progn 40 | (setf (symbol-function ',alias) #',orig) 41 | (define-compiler-macro ,alias (&rest args) 42 | `(,',orig ,@args)) 43 | ',alias)) 44 | 45 | (defmacro repeat (n &body body) 46 | `(loop repeat ,n do (progn ,@body))) 47 | 48 | (defmacro with-tag (retry-tag &body body) 49 | "For those of us who forget RETURN-FROM inside TAGBODY." 50 | (with-gensyms (top) 51 | `(block ,top 52 | (tagbody 53 | ,retry-tag 54 | (return-from ,top (progn ,@body)))))) 55 | 56 | (defmacro dosequence ((var sequence &optional return) &body body) 57 | `(block nil 58 | (map nil (lambda (,var) ,@body) ,sequence) 59 | ,@(if return 60 | `((let ((,var nil)) 61 | (declare (ignorable ,var)) 62 | ,return)) 63 | nil))) 64 | 65 | (defun get-time () 66 | (/ (get-internal-real-time) 67 | internal-time-units-per-second)) 68 | 69 | (defun expiredp (start timeout) 70 | (>= (- (get-time) start) 71 | timeout)) 72 | 73 | (defmacro with-timeout ((timeout) &body body) 74 | (with-gensyms (timeout-value start) 75 | `(let* ((,timeout-value ,timeout) 76 | (,start (and ,timeout-value (get-time)))) 77 | (flet ((timeout-expired-p () 78 | (and ,timeout-value 79 | (expiredp ,start ,timeout-value)))) 80 | ,@body)))) 81 | 82 | (defmacro with-lock-predicate/wait (lock predicate &body body) 83 | ;; predicate intentionally evaluated twice 84 | `(when ,predicate 85 | (with-lock-held (,lock) 86 | (when ,predicate 87 | ,@body)))) 88 | -------------------------------------------------------------------------------- /lfarm-admin.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lfarm-admin 32 | (:documentation 33 | "Administrative duties on a server (ping it or end it).") 34 | (:use #:cl 35 | #:lfarm-common) 36 | (:export #:ping 37 | #:end-server)) 38 | 39 | (in-package #:lfarm-admin) 40 | 41 | (defun end-server (host port) 42 | "End the server at host:port. 43 | 44 | This only stops new connections from being made. Connections in 45 | progress are unaffected." 46 | (info "end-server" host port) 47 | (with-connected-stream (stream (socket-connect host port)) 48 | (send-object :end-server stream))) 49 | 50 | (defun write-ping (stream) 51 | (send-object :ping stream)) 52 | 53 | (defun read-pong (stream) 54 | (case (receive-object stream) 55 | (:pong) 56 | (otherwise (error 'corrupted-stream-error :stream stream)))) 57 | 58 | (defun send-ping (host port socket stream) 59 | (info "sending ping" host port) 60 | (write-ping stream) 61 | (info "ping sent" host port socket)) 62 | 63 | (defun receive-pong (socket timeout) 64 | (when (wait-for-input socket :timeout timeout) 65 | (info "detected pong" socket) 66 | (read-pong (socket-stream socket)) 67 | (info "received pong" socket) 68 | t)) 69 | 70 | (defun ping (host port &key (timeout 3)) 71 | "Send a ping to the lfarm server at host:port. 72 | 73 | Keep trying to make contact for `timeout' seconds, or if `timeout' is 74 | nil then try forever. Default is 3 seconds. 75 | 76 | Returns true if successful and nil otherwise." 77 | (info "attempting ping" host port) 78 | (with-tag :retry 79 | (with-timeout (timeout) 80 | (multiple-value-bind (socket stream) 81 | (handler-case (socket-connect/retry host port :timeout timeout) 82 | (connection-refused-error () (return-from ping nil))) 83 | (send-ping host port socket stream) 84 | (cond ((receive-pong socket timeout) 85 | (info "got pong" socket timeout) 86 | t) 87 | ((timeout-expired-p) 88 | (info "ping timed out" socket timeout) 89 | nil) 90 | (t 91 | ;; Attempt to work around CCL bugs (not always successful). 92 | (info "weird socket state; retrying ping" socket timeout) 93 | (go :retry))))))) 94 | -------------------------------------------------------------------------------- /lfarm-test/auth-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-test) 32 | 33 | (defclass password-auth () 34 | ((password :reader password :initarg :password))) 35 | 36 | (define-condition password-auth-error (lfarm-common.data-transport:auth-error) 37 | () 38 | (:report "bad password")) 39 | 40 | (defmethod lfarm-common.data-transport:initialize-client-stream 41 | ((auth password-auth) stream server-name) 42 | (declare (ignore server-name)) 43 | (info "initializing client stream for auth password") 44 | (send-object (password auth) stream) 45 | (info "client sent password") 46 | (handler-case (ecase (receive-object stream) 47 | (:ok (info "client notified that password accepted"))) 48 | (end-of-file () 49 | (info "client detected that server rejected password") 50 | (error 'password-auth-error))) 51 | stream) 52 | 53 | (defmethod lfarm-common.data-transport:initialize-server-stream 54 | ((auth password-auth) stream) 55 | (info "initializing server stream for auth password") 56 | (cond ((equal (password auth) (receive-object stream)) 57 | (info "server accepted password") 58 | (send-object :ok stream)) 59 | (t 60 | (error 'password-auth-error))) 61 | stream) 62 | 63 | (defmethod lfarm-common.data-transport:send-buffer 64 | ((auth password-auth) buffer stream) 65 | (call-next-method auth 66 | (case (deserialize-buffer buffer) 67 | (7 (serialize-to-buffer 8)) 68 | (11 (error "11 is not allowed")) 69 | (otherwise buffer)) 70 | stream)) 71 | 72 | (base-test auth-test 73 | (let ((host *local-host*) 74 | (port (next-port)) 75 | (*auth* (make-instance 'password-auth :password "hello"))) 76 | (with-server (host port) 77 | (with-kernel (*kernel* `((,host ,port))) 78 | (let ((channel (make-channel))) 79 | (submit-task channel #'+ 3 4) 80 | ;; 3 + 4 = 8, hooray! 81 | (is (= 8 (receive-result channel))) 82 | (submit-task channel #'+ 5 6) 83 | (signals task-execution-error 84 | (receive-result channel)))) 85 | (let ((pass (make-instance 'password-auth :password "world"))) 86 | (let ((*auth* pass)) 87 | (signals kernel-creation-error 88 | (make-kernel `((,host ,port))))) 89 | (signals kernel-creation-error 90 | (make-kernel `((,host ,port)) :auth pass)))))) 91 | -------------------------------------------------------------------------------- /lfarm-test/promise-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-test) 32 | 33 | (base-test promises-test 34 | (let ((a (promise)) 35 | (b (promise))) 36 | (fulfill a 3) 37 | (fulfill b 4) 38 | (is (= 12 (* (force a) (force b))))) 39 | (let ((a (promise))) 40 | (is (eq t (fulfill a 3))) 41 | (is (eq nil (fulfill a 4))) 42 | (is (= 3 (force a))))) 43 | 44 | (full-test promises-multiple-value-test 45 | (let ((x (promise))) 46 | (fulfill x (values 3 4 5)) 47 | (multiple-value-bind (p q r) (force x) 48 | (is (= 3 p)) 49 | (is (= 4 q)) 50 | (is (= 5 r)))) 51 | (let ((x (future (values 3 4 5)))) 52 | (multiple-value-bind (p q r) (force x) 53 | (is (= 3 p)) 54 | (is (not (null q))) 55 | (is (= 4 q)) 56 | (is (= 5 r)))) 57 | (let ((x (delay (values 3 4 5)))) 58 | (multiple-value-bind (p q r) (force x) 59 | (is (= 3 p)) 60 | (is (not (null q))) 61 | (is (= 4 q)) 62 | (is (= 5 r))))) 63 | 64 | (defclass some-data () 65 | ((x :initarg :x) 66 | (y :initarg :y))) 67 | 68 | (full-test futures-test 69 | (let ((a (future 3)) 70 | (b (future 4))) 71 | (is (= 7 (+ (force a) (force b))))) 72 | (let ((a (future 5))) 73 | (sleep 0.5) 74 | (is (fulfilledp a)) 75 | (is (= 5 (force a)))) 76 | (let ((a (future (sleep 1.0) 3))) 77 | (is (not (fulfilledp a))) 78 | (sleep 0.5) 79 | (is (eq nil (fulfill a 4))) 80 | (is (not (fulfilledp a))) 81 | (is (= 3 (force a)))) 82 | (let ((a (future 3))) 83 | (sleep 0.5) 84 | (is (eq nil (fulfill a 9))) 85 | (is (= 3 (force a)))) 86 | (let ((f (future (values (+ 3 4) :foo)))) 87 | (is (= 7 (force f))) 88 | (is (eq :foo (nth-value 1 (force f)))))) 89 | 90 | #+(and lfarm.with-closures (not lfarm.with-text-serializer)) 91 | (remote-test future-closure-test 92 | (let ((x 5) 93 | (y 6)) 94 | (let ((f (future (+ x y)))) 95 | (is (= 11 (force f))))) 96 | (broadcast-task (lambda () 97 | (defclass some-data () 98 | ((x :initarg :x) 99 | (y :initarg :y))))) 100 | (let ((some-data (make-instance 'some-data :x 7 :y 8))) 101 | (with-slots (x y) some-data 102 | (let ((f (future (+ x y)))) 103 | (is (= 15 (force f)))))) 104 | (signals cl-store:store-error 105 | (let* ((f (future (+ 3 4))) 106 | (g (future (+ (force f) 5)))) 107 | (force g)))) 108 | 109 | (full-test future-error-test 110 | (let ((f (future (error "foo")))) 111 | (signals task-execution-error 112 | (force f)) 113 | (signals task-execution-error 114 | (force f)))) 115 | -------------------------------------------------------------------------------- /lfarm-test/1am.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2014, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; See https://github.com/lmj/1am 32 | 33 | (defpackage #:lfarm-test.1am 34 | (:use #:cl) 35 | (:export #:test #:is #:signals #:run #:*tests*)) 36 | 37 | (in-package #:lfarm-test.1am) 38 | 39 | (defvar *tests* nil "A list of tests; the default argument to `run'.") 40 | (defvar *pass-count* nil) 41 | (defvar *running* nil) 42 | (defvar *failed-random-state* nil) 43 | 44 | (defun %shuffle (vector) 45 | (loop for i downfrom (- (length vector) 1) to 1 46 | do (rotatef (aref vector i) (aref vector (random (1+ i))))) 47 | vector) 48 | 49 | (defun shuffle (sequence) 50 | (%shuffle (map 'vector #'identity sequence))) 51 | 52 | (defun call-with-random-state (fn) 53 | (let ((*random-state* (or *failed-random-state* 54 | (load-time-value (make-random-state t))))) 55 | (setf *failed-random-state* (make-random-state nil)) 56 | (multiple-value-prog1 (funcall fn) 57 | (setf *failed-random-state* nil)))) 58 | 59 | (defun report (test-count pass-count) 60 | (format t "~&Success: ~s test~:p, ~s check~:p.~%" test-count pass-count)) 61 | 62 | (defun %run (fn test-count) 63 | (let ((*pass-count* 0)) 64 | (multiple-value-prog1 (call-with-random-state fn) 65 | (report test-count *pass-count*)))) 66 | 67 | (defun run (&optional (tests *tests*)) 68 | "Run each test in the sequence `tests'. Default is `*tests*'." 69 | (let ((*running* t)) 70 | (%run (lambda () (map nil #'funcall (shuffle tests))) 71 | (length tests))) 72 | (values)) 73 | 74 | (defun call-test (name fn) 75 | (format t "~&~s" name) 76 | (finish-output) 77 | (if *running* 78 | (funcall fn) 79 | (%run fn 1))) 80 | 81 | (defmacro test (name &body body) 82 | "Define a test function and add it to `*tests*'." 83 | `(progn 84 | (defun ,name () 85 | (call-test ',name (lambda () ,@body))) 86 | (pushnew ',name *tests*) 87 | ',name)) 88 | 89 | (defun passed () 90 | (write-char #\.) 91 | ;; Checks done outside a test run are not tallied. 92 | (when *pass-count* 93 | (incf *pass-count*)) 94 | (values)) 95 | 96 | (defmacro is (form) 97 | "Assert that `form' evaluates to non-nil." 98 | `(progn 99 | (assert ,form) 100 | (passed))) 101 | 102 | (defun %signals (expected fn) 103 | (flet ((handler (condition) 104 | (cond ((typep condition expected) 105 | (passed) 106 | (return-from %signals (values))) 107 | (t (error "Expected to signal ~s, but got ~s:~%~a" 108 | expected (type-of condition) condition))))) 109 | (handler-bind ((condition #'handler)) 110 | (funcall fn))) 111 | (error "Expected to signal ~s, but got nothing." expected)) 112 | 113 | (defmacro signals (condition &body body) 114 | "Assert that `body' signals a condition of type `condition'." 115 | `(%signals ',condition (lambda () ,@body))) 116 | -------------------------------------------------------------------------------- /lfarm-gss/lfarm-gss.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:lfarm-gss) 2 | 3 | (defmethod initialize-instance :after ((stream wrapper-stream) &key &allow-other-keys) 4 | (lfarm-common:info (format nil "initialised ~a instance: ~s" 5 | (wrapper-stream-description stream) 6 | (wrapper-stream-context stream)))) 7 | 8 | (defclass gss-auth-mixin () 9 | ()) 10 | 11 | (defclass gss-auth-client (gss-auth-mixin) 12 | ((service-name :type string 13 | :initform "lfarm" 14 | :initarg :service-name 15 | :reader gss-auth-service-name))) 16 | 17 | (defclass gss-auth-server (gss-auth-mixin) 18 | ((allowed-users :type list 19 | :initform nil 20 | :initarg :allowed-users 21 | :accessor gss-auth-allowed-users))) 22 | 23 | (defgeneric name-accepted (auth name)) 24 | 25 | (defmethod name-accepted ((auth gss-auth-server) name) 26 | (member (cl-gss:name-to-string name) (gss-auth-allowed-users auth) :test #'equal)) 27 | 28 | (defmethod lfarm-common.data-transport:initialize-client-stream ((auth gss-auth-client) stream server-name) 29 | (let ((name (cl-gss:make-name (format nil "~a@~a" (gss-auth-service-name auth) server-name)))) 30 | (loop 31 | with need-reply 32 | with context = nil 33 | with reply-buffer = nil 34 | do (multiple-value-bind (continue-reply context-result buffer flags-reply) 35 | (cl-gss:init-sec name :flags '(:mutual :replay :sequence :integ :conf) 36 | :context context :input-token reply-buffer) 37 | (declare (ignore flags-reply)) 38 | (setq need-reply continue-reply) 39 | (setq context context-result) 40 | (when buffer 41 | (write-with-length buffer stream)) 42 | (when need-reply 43 | (setq reply-buffer (read-with-length stream)))) 44 | while need-reply 45 | finally (return (make-instance 'wrapper-stream 46 | :delegate stream 47 | :context context 48 | :description "client"))))) 49 | 50 | (defmethod lfarm-common.data-transport:initialize-server-stream ((auth gss-auth-server) stream) 51 | (loop 52 | with need-reply 53 | with context = nil 54 | do (let ((reply (read-with-length stream))) 55 | (multiple-value-bind (continue-reply context-reply name buffer flags-reply) 56 | (cl-gss:accept-sec reply :context context) 57 | (declare (ignore flags-reply)) 58 | (unless (name-accepted auth name) 59 | (error 'auth-error)) 60 | (setq need-reply continue-reply) 61 | (setq context context-reply) 62 | (when buffer 63 | (write-with-length buffer stream)))) 64 | while need-reply 65 | finally (return (make-instance 'wrapper-stream 66 | :delegate stream 67 | :context context 68 | :description "server")))) 69 | 70 | (defmethod lfarm-common.data-transport:send-buffer ((auth gss-auth-mixin) buffer stream) 71 | (let ((b (cl-gss:wrap (wrapper-stream-context stream) buffer :conf t))) 72 | (write-with-length b stream))) 73 | 74 | (defmethod lfarm-common.data-transport:receive-buffer ((auth gss-auth-mixin) stream) 75 | (let ((buffer (read-with-length stream))) 76 | (cl-gss:unwrap (wrapper-stream-context stream) buffer))) 77 | 78 | (defun read-with-length (stream &key (length 8)) 79 | (let* ((buf (make-array length :element-type '(unsigned-byte 8)))) 80 | (unless (= (read-sequence buf stream) length) 81 | (error "Stream truncated when reading length")) 82 | (let ((buf-length (loop 83 | with result = 0 84 | for i from 0 below length 85 | do (setq result (logior result (ash (aref buf i) (* (- length i 1) 8)))) 86 | finally (return result)))) 87 | (let ((result-seq (make-array buf-length :element-type '(unsigned-byte 8)))) 88 | (unless (= (read-sequence result-seq stream) buf-length) 89 | (error "Stream truncated when reading buffer")) 90 | result-seq)))) 91 | 92 | (defun write-with-length (buffer stream &key (length 8)) 93 | (let ((length-buffer (make-array length :element-type '(unsigned-byte 8)))) 94 | (loop 95 | for i from 0 below length 96 | do (setf (aref length-buffer i) (logand #xFF (ash (length buffer) (- (* (- length i 1) 8)))))) 97 | (write-sequence length-buffer stream) 98 | (write-sequence buffer stream) 99 | (finish-output stream))) 100 | -------------------------------------------------------------------------------- /lfarm-common/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lfarm-common.data-transport 32 | (:use #:cl) 33 | (:export #:auth-error 34 | #:initialize-client-stream 35 | #:initialize-server-stream 36 | #:send-buffer 37 | #:receive-buffer 38 | #:stream-close)) 39 | 40 | (defpackage #:lfarm-common 41 | (:documentation 42 | "(private) Common components for lfarm.") 43 | (:use #:cl 44 | #:lfarm-common.data-transport) 45 | ;; util 46 | (:export #:with-gensyms 47 | #:when-let 48 | #:when-let* 49 | #:repeat 50 | #:defwith 51 | #:call-body 52 | #:with-tag 53 | #:dosequence 54 | #:unwind-protect/safe 55 | #:unwind-protect/safe-bind 56 | #:named-lambda 57 | #:lambda-list-parameters 58 | #:with-timeout 59 | #:timeout-expired-p 60 | #:alias-macro 61 | #:alias-function 62 | #:unsplice) 63 | ;; threads 64 | (:export #:make-thread 65 | #:make-lock 66 | #:with-lock-held 67 | #:current-thread 68 | #:destroy-thread 69 | #:with-lock-predicate/wait) 70 | ;; log 71 | (:export #:info 72 | #:bad 73 | #:with-errors-logged 74 | #:*log-level* 75 | #:*log-stream*) 76 | ;; socket 77 | (:export #:*auth* 78 | #:+corrupt-stream-flag+ 79 | #:connection-refused-error 80 | #:socket-listen 81 | #:socket-accept 82 | #:socket-connect 83 | #:socket-connect/retry 84 | #:socket-stream 85 | #:socket-close 86 | #:wait-for-input 87 | #:with-connected-socket 88 | #:with-connected-stream 89 | #:*connect-retry-interval*) 90 | ;; address 91 | (:export #:ensure-addresses 92 | #:with-each-address 93 | #:with-each-address/handle-error) 94 | ;; errors 95 | (:export #:make-task-error-data 96 | #:task-error-data 97 | #:task-error-data-report 98 | #:task-error-data-desc 99 | #:corrupted-stream-error) 100 | ;; object transport 101 | (:export #:*element-type* 102 | #:send-object 103 | #:receive-object 104 | #:serialize-to-buffer 105 | #:deserialize-buffer 106 | #:receive-serialized-buffer) 107 | ;; imports 108 | (:import-from #:alexandria 109 | #:with-gensyms 110 | #:when-let 111 | #:when-let* 112 | #:named-lambda) 113 | (:import-from #:bordeaux-threads 114 | #:make-thread 115 | #:make-lock 116 | #:with-lock-held 117 | #:current-thread 118 | #:destroy-thread) 119 | (:import-from #:usocket 120 | #:timeout-error 121 | #:unknown-error 122 | #:connection-aborted-error 123 | #:connection-refused-error)) 124 | 125 | (in-package #:lfarm-common) 126 | -------------------------------------------------------------------------------- /lfarm-common/unwind-protect.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | #+sbcl 34 | (progn 35 | (defmacro without-interrupts (&body body) 36 | `(sb-sys:without-interrupts 37 | ,@body)) 38 | 39 | (defmacro with-interrupts (&body body) 40 | `(sb-sys:with-local-interrupts 41 | ,@body))) 42 | 43 | #+ccl 44 | (progn 45 | (defmacro without-interrupts (&body body) 46 | `(ccl:without-interrupts 47 | ,@body)) 48 | 49 | (defmacro with-interrupts (&body body) 50 | `(ccl:with-interrupts-enabled 51 | ,@body))) 52 | 53 | #-(or sbcl ccl) 54 | (progn 55 | (defmacro without-interrupts (&body body) 56 | `(progn ,@body)) 57 | 58 | (defmacro with-interrupts (&body body) 59 | `(progn ,@body))) 60 | 61 | (defmacro unwind-protect/safe (&key prepare main cleanup abort) 62 | "Interrupt-safe `unwind-protect'. 63 | 64 | `prepare' : executed first, outside of `unwind-protect' 65 | `main' : protected form 66 | `cleanup' : cleanup form 67 | `abort' : executed if `main' does not finish 68 | " 69 | (with-gensyms (finishedp) 70 | `(without-interrupts 71 | ,@(unsplice (when prepare 72 | `(with-interrupts 73 | ,prepare))) 74 | ,(cond ((and main cleanup abort) 75 | `(let ((,finishedp nil)) 76 | (declare (type boolean ,finishedp)) 77 | (unwind-protect 78 | (with-interrupts 79 | (multiple-value-prog1 ,main 80 | (setf ,finishedp t))) 81 | (if ,finishedp 82 | ,cleanup 83 | (unwind-protect ,abort ,cleanup))))) 84 | ((and main cleanup) 85 | `(unwind-protect 86 | (with-interrupts 87 | ,main) 88 | ,cleanup)) 89 | ((and main abort) 90 | `(let ((,finishedp nil)) 91 | (declare (type boolean ,finishedp)) 92 | (unwind-protect 93 | (with-interrupts 94 | (multiple-value-prog1 ,main 95 | (setf ,finishedp t))) 96 | (when (not ,finishedp) 97 | ,abort)))) 98 | (main `(with-interrupts ,main)) 99 | (cleanup `(progn ,cleanup nil)) 100 | (abort nil) 101 | (t nil))))) 102 | 103 | (defmacro unwind-protect/safe-bind (&key bind main cleanup abort) 104 | "Bind a variable inside `unwind-protect' with interrupt safety." 105 | (destructuring-bind (var value) bind 106 | (with-gensyms (uninitialized finishedp) 107 | `(let ((,var ',uninitialized) 108 | (,finishedp nil)) 109 | (without-interrupts 110 | (unwind-protect (progn 111 | (setf ,var (with-interrupts 112 | ,value)) 113 | (with-interrupts 114 | (multiple-value-prog1 ,main 115 | (setf ,finishedp t)))) 116 | (when (not (eq ,var ',uninitialized)) 117 | (if ,finishedp 118 | ,cleanup 119 | (unwind-protect ,abort ,cleanup))))))))) 120 | -------------------------------------------------------------------------------- /lfarm-common/socket.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | (defvar *auth* nil) 34 | 35 | (defvar *connect-retry-interval* 0.25) 36 | 37 | (defconstant +corrupt-stream-flag+ 'corrupt-stream-flag) 38 | 39 | (defclass socket () 40 | ((usocket :reader usocket :initarg :usocket))) 41 | 42 | (defclass streaming-socket (socket) 43 | ((stream :reader socket-stream :initarg :stream))) 44 | 45 | (defun make-socket (usocket) 46 | (make-instance 'socket :usocket usocket)) 47 | 48 | (defun make-streaming-socket (init-fn usocket &rest args) 49 | (unwind-protect/safe 50 | :main (let ((stream (apply init-fn *auth* (usocket:socket-stream usocket) 51 | args))) 52 | (make-instance 'streaming-socket :usocket usocket :stream stream)) 53 | :abort (usocket:socket-close usocket))) 54 | 55 | (defun make-streaming-client-socket (usocket server-name) 56 | (make-streaming-socket #'initialize-client-stream usocket server-name)) 57 | 58 | (defun make-streaming-server-socket (usocket) 59 | (make-streaming-socket #'initialize-server-stream usocket)) 60 | 61 | (defun socket-listen (host port) 62 | (make-socket (usocket:socket-listen host port 63 | :reuse-address t 64 | :element-type *element-type*))) 65 | 66 | (defun socket-accept (socket) 67 | (loop (when-let ((usocket (handler-case (usocket:socket-accept 68 | (usocket socket) 69 | :element-type *element-type*) 70 | (connection-aborted-error ())))) 71 | (return (make-streaming-server-socket usocket))))) 72 | 73 | (defun socket-connect (host port) 74 | (let ((usocket (usocket:socket-connect host port 75 | :element-type *element-type*))) 76 | (make-streaming-client-socket usocket host))) 77 | 78 | (defwith with-connected-socket ((:vars socket-var) socket-value) 79 | (usocket:with-connected-socket (usocket (usocket socket-value)) 80 | (call-body socket-value))) 81 | 82 | (defwith with-connected-stream ((:vars stream-var) socket-value) 83 | (usocket:with-connected-socket (usocket (usocket socket-value)) 84 | (call-body (socket-stream socket-value)))) 85 | 86 | (defun socket-close (socket) 87 | ;; data transport callback 88 | (stream-close *auth* (socket-stream socket)) 89 | (usocket:socket-close (usocket socket))) 90 | 91 | (defun wait-for-input (socket &key timeout) 92 | (usocket:wait-for-input (usocket socket) :timeout timeout :ready-only t)) 93 | 94 | (defun %socket-connect/retry (host port timeout) 95 | (info "socket-connect/retry" host port timeout) 96 | (with-timeout (timeout) 97 | (with-tag :retry 98 | (handler-case (socket-connect host port) 99 | ((or connection-refused-error timeout-error unknown-error) () 100 | (when (timeout-expired-p) 101 | (info "socket-connect/retry timeout" host port) 102 | (error 'connection-refused-error)) 103 | (info "socket-connect/retry again" host port timeout) 104 | (sleep *connect-retry-interval*) 105 | (go :retry)))))) 106 | 107 | (defun socket-connect/retry (host port &key timeout) 108 | (let ((socket (%socket-connect/retry host port timeout))) 109 | (values socket (socket-stream socket)))) 110 | -------------------------------------------------------------------------------- /lfarm-client/promise.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lfarm-client.promise 32 | (:documentation 33 | "Promises and futures.") 34 | (:use #:cl 35 | #:lfarm-common 36 | #:lfarm-client.kernel) 37 | (:export #:promise 38 | #:future 39 | #:speculate 40 | #:delay 41 | #:force 42 | #:fulfill 43 | #:fulfilledp 44 | #:chain)) 45 | 46 | (in-package #:lfarm-client.promise) 47 | 48 | ;;; Avoid `defmethod' since there are outstanding issues with 49 | ;;; concurrent method calls. 50 | 51 | (defconstant +no-result+ 'no-result) 52 | 53 | (defclass future () 54 | ((result :initform +no-result+) 55 | (lock :initform (make-lock)) 56 | (channel :initform (make-channel)))) 57 | 58 | (defwith with-unfulfilled (future) 59 | (with-slots (result lock) future 60 | (with-lock-predicate/wait lock (eq result +no-result+) 61 | (call-body)))) 62 | 63 | (defmacro future (&body body) 64 | (with-gensyms (future channel) 65 | `(let ((,future (make-instance 'future))) 66 | (with-slots ((,channel channel)) ,future 67 | (submit-task ,channel 68 | (lambda () 69 | (multiple-value-list (progn ,@body))))) 70 | ,future))) 71 | 72 | (defun force-future (future) 73 | (with-slots (result channel) future 74 | (with-unfulfilled (future) 75 | (setf result (handler-case (receive-result channel) 76 | (task-execution-error (err) err)))) 77 | (etypecase result 78 | (list (values-list result)) 79 | (task-execution-error (error result))))) 80 | 81 | (defun force (promise) 82 | (typecase promise 83 | (future (force-future promise)) 84 | (otherwise (lparallel:force promise)))) 85 | 86 | (defmacro speculate (&body body) 87 | `(let ((lparallel:*task-priority* :low)) 88 | (force ,@body))) 89 | 90 | (defun fulfill-future (future fn) 91 | (declare (ignore future fn)) 92 | ;; Doing this properly would involve creating a callback for when 93 | ;; the task is submitted. Don't seem worth it (yet). 94 | nil) 95 | 96 | (defun %fulfill (promise fn) 97 | (typecase promise 98 | (future (fulfill-future promise fn)) 99 | (otherwise (lparallel:fulfill promise (funcall fn))))) 100 | 101 | (defmacro fulfill (promise &body body) 102 | `(%fulfill ,promise (lambda () ,@body))) 103 | 104 | (defun maybe-update-status (future) 105 | (with-unfulfilled (future) 106 | (with-slots (result channel) future 107 | (multiple-value-bind (value foundp) (try-receive-result channel) 108 | (when foundp 109 | (setf result value)))))) 110 | 111 | (defun fulfilled-future-p (future) 112 | (maybe-update-status future) 113 | (with-slots (result) future 114 | (not (eq result +no-result+)))) 115 | 116 | (defun fulfilledp (promise) 117 | (typecase promise 118 | (future (fulfilled-future-p promise)) 119 | (otherwise (lparallel:fulfilledp promise)))) 120 | 121 | (alias-function promise lparallel:promise) 122 | (alias-macro delay lparallel:delay) 123 | 124 | ;;; Thwart attempts to serialize promises. 125 | #-(or lfarm.with-text-serializer clisp) 126 | (macrolet ((define-store-lock (type) 127 | `(cl-store:defstore-cl-store (obj ,type stream) 128 | (declare (ignore obj stream)) 129 | (cl-store:store-error "Cannot store object of type ~s." 130 | ',type)))) 131 | (define-store-lock #.(type-of (make-lock)))) 132 | -------------------------------------------------------------------------------- /lfarm-common/defwith.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-common) 32 | 33 | (eval-when (:compile-toplevel :load-toplevel :execute) 34 | (defun unsplice (form) 35 | (if form (list form) nil)) 36 | 37 | (defun strip-aux (lambda-list) 38 | (subseq lambda-list 0 (position '&aux lambda-list))) 39 | 40 | (defun lambda-list-parameters (lambda-list &key discard-aux) 41 | (multiple-value-bind (reqs opts rest keys other auxs) 42 | (alexandria:parse-ordinary-lambda-list lambda-list) 43 | (declare (ignore other)) 44 | (remove-if #'null (append reqs 45 | (mapcar #'first opts) 46 | (mapcar #'third opts) 47 | (list rest) 48 | (mapcar #'cadar keys) 49 | (mapcar #'third keys) 50 | (unless discard-aux 51 | (mapcar #'first auxs))))))) 52 | 53 | (defmacro flet-alias ((name fn) &body body) 54 | `(flet ((,name (&rest args) 55 | (declare (dynamic-extent args)) 56 | (apply ,fn args))) 57 | (declare (inline ,name)) 58 | ,@body)) 59 | 60 | (defmacro define-with-fn (macro-name fn-name lambda-list declares body) 61 | (alexandria:with-gensyms (body-fn) 62 | `(defun ,fn-name (,body-fn ,@lambda-list) 63 | ,@declares 64 | (declare (type function ,body-fn)) 65 | (block ,macro-name 66 | (flet-alias (call-body ,body-fn) 67 | ,@body))))) 68 | 69 | (defmacro define-with-macro (macro-name fn-name lambda-list vars doc) 70 | (let* ((ignore-params (lambda-list-parameters lambda-list :discard-aux t)) 71 | (macro-params (append vars ignore-params))) 72 | (alexandria:with-gensyms (whole body) 73 | `(defmacro ,macro-name (,@(when macro-params `(&whole ,whole)) 74 | ,@(unsplice `(,@vars ,@lambda-list)) 75 | &body ,body) 76 | ,@(unsplice doc) 77 | (declare (ignore ,@ignore-params)) 78 | `(,',fn-name (lambda (,,@vars) ,@,body) 79 | ,@,(when macro-params 80 | `(subseq (second ,whole) ,(length vars)))))))) 81 | 82 | (defmacro defwith (macro-name lambda-list &body body) 83 | "Define a function along with a macro that expands to a call of that 84 | function. Inside `defwith' is an flet named `call-body'. 85 | 86 | (defwith with-foo (value) 87 | (let ((*foo* value)) 88 | (call-body))) 89 | 90 | is equivalent to 91 | 92 | (defun call-with-foo (body-fn value) 93 | (let ((*foo* value)) 94 | (funcall body-fn))) 95 | 96 | (defmacro with-foo ((value) &body body) 97 | `(call-with-foo (lambda () ,@body) ,value)) 98 | 99 | Placing a `:vars' form at the head of the lambda list will generate a 100 | macro that assigns to the given variables. 101 | 102 | (defwith with-add-result ((:vars result) x y) 103 | (call-body (+ x y))) 104 | 105 | is equivalent to 106 | 107 | (defun call-with-add-result (body-fn x y) 108 | (funcall body-fn (+ x y))) 109 | 110 | (defmacro with-add-result ((result x y) &body body) 111 | `(call-with-add-result (lambda (,result) ,@body) ,x ,y)) 112 | " 113 | (let ((fn-name (alexandria:symbolicate '#:call- macro-name)) 114 | (vars (case (ignore-errors (caar lambda-list)) 115 | (:vars (prog1 (cdar lambda-list) 116 | (pop lambda-list))) 117 | (otherwise nil)))) 118 | (multiple-value-bind (body declares doc) 119 | (alexandria:parse-body body :documentation t) 120 | `(progn 121 | (define-with-fn 122 | ,macro-name ,fn-name ,lambda-list ,declares ,body) 123 | (define-with-macro 124 | ,macro-name ,fn-name ,(strip-aux lambda-list) ,vars ,doc))))) 125 | -------------------------------------------------------------------------------- /lfarm-test/closure-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-test) 32 | 33 | (defmacro closure-form (lambda-list &body body &environment env) 34 | (lfarm-client.kernel::maybe-make-closure-form nil lambda-list body env)) 35 | 36 | (defun closure-a (x) 37 | (let ((y (1+ x))) 38 | (closure-form (z) 39 | (+ x y z)))) 40 | 41 | (base-test closure-a-test 42 | (is (equal `(symbol-macrolet () 43 | (let ((x '3) 44 | (y '4)) 45 | (lambda (z) 46 | (+ x y z)))) 47 | (closure-a 3))) 48 | (is (= (+ 3 4 5) 49 | (funcall (eval (closure-a 3)) 5)))) 50 | 51 | (defun closure-b (x) 52 | (symbol-macrolet ((w (1- x))) 53 | (let ((y (1+ x))) 54 | (closure-form (z) 55 | (+ w x y z))))) 56 | 57 | (base-test closure-b-test 58 | (is (equal `(symbol-macrolet ((w (1- x))) 59 | (let ((x '3) 60 | (y '4)) 61 | (lambda (z) 62 | (+ w x y z)))) 63 | (closure-b 3))) 64 | (is (= (+ 2 3 4 5) 65 | (funcall (eval (closure-b 3)) 5)))) 66 | 67 | (defun closure-c (x) 68 | (let ((y (1+ x))) 69 | (closure-form (z) 70 | (loop repeat z collect x collect y)))) 71 | 72 | (base-test closure-c-test 73 | (is (equal `(symbol-macrolet () 74 | (let ((x '3) 75 | (y '4)) 76 | (lambda (z) 77 | (loop repeat z collect x collect y)))) 78 | (closure-c 3))) 79 | (is (equal '(3 4 3 4) 80 | (funcall (eval (closure-c 3)) 2)))) 81 | 82 | (defun closure-d (x) 83 | (let ((instance '(4 5))) 84 | (symbol-macrolet ((fst (first instance)) 85 | (snd (second instance))) 86 | (closure-form () 87 | (+ x fst snd))))) 88 | 89 | (base-test closure-d-test 90 | (is (equal (closure-d 3) 91 | `(symbol-macrolet ((fst (first instance)) 92 | (snd (second instance))) 93 | (let ((instance '(4 5)) 94 | (x '3)) 95 | (lambda () 96 | (+ x fst snd)))))) 97 | (is (= (+ 3 4 5) 98 | (funcall (eval (closure-d 3)))))) 99 | 100 | (defclass stuff () 101 | ((x :initarg :x) 102 | (y :initarg :y))) 103 | 104 | (defun closure-e () 105 | (let ((stuff (make-instance 'stuff :x 3 :y 4))) 106 | (with-slots (x y) stuff 107 | (closure-form () 108 | (+ x y))))) 109 | 110 | (base-test closure-e-test 111 | (is (= (+ 3 4) 112 | (funcall (eval (closure-e)))))) 113 | 114 | (defun closure-f () 115 | (let ((x 3)) 116 | (closure-form (&key y) 117 | (* x y)))) 118 | 119 | (base-test closure-f-test 120 | (is (equal `(symbol-macrolet () 121 | (let ((x '3)) 122 | (lambda (&key y) 123 | (* x y)))) 124 | (closure-f))) 125 | (is (= (* 3 4) 126 | (funcall (eval (closure-f)) :y 4)))) 127 | 128 | (remote-test closure-task-test 129 | (let ((x 3)) 130 | (submit-task *channel* (lambda (y) (+ x y)) 4) 131 | (is (= 7 (receive-result *channel*)))) 132 | (let ((x 3)) 133 | (declare (ignorable x)) 134 | (submit-task *channel* 135 | (lambda (y) 136 | (let ((x 10)) 137 | (+ x y))) 138 | 4) 139 | (is (= 14 (receive-result *channel*)))) 140 | (let ((x 3)) 141 | (symbol-macrolet ((z (1+ x))) 142 | (submit-task *channel* (lambda (y) (+ x y z)) 4) 143 | (is (= 11 (receive-result *channel*))))) 144 | #-lfarm.with-text-serializer 145 | (progn 146 | (broadcast-task (lambda () (defclass stuff () 147 | ((x :initarg :x) 148 | (y :initarg :y))))) 149 | (let ((stuff (make-instance 'stuff :x 3 :y 4))) 150 | (with-slots (x y) stuff 151 | (submit-task *channel* (lambda () (+ x y))) 152 | (is (= 7 (receive-result *channel*))))))) 153 | 154 | (let ((x 3)) 155 | (deftask closure-add-3 (y) 156 | (declare (fixnum y)) 157 | (+ x y))) 158 | 159 | (let ((x 3) 160 | (y 4)) 161 | (deftask closure-twelve () 162 | (* x y))) 163 | 164 | (full-test deftask-closure-test 165 | (submit-task *channel* #'closure-add-3 4) 166 | (is (= 7 (receive-result *channel*))) 167 | (submit-task *channel* #'closure-twelve) 168 | (is (= 12 (receive-result *channel*)))) 169 | 170 | (defvar *reset-imperative-closure*) 171 | 172 | (let ((a 1)) 173 | (setf *reset-imperative-closure* (lambda () (setf a 1))) 174 | (deftask imperative-closure (n) 175 | (if (plusp n) 176 | (+ (incf a) (imperative-closure (- n 1))) 177 | 0))) 178 | 179 | (remote-test imperative-closure-test 180 | (funcall *reset-imperative-closure*) 181 | (submit-task *channel* #'imperative-closure 3) 182 | (is (= (imperative-closure 3) (receive-result *channel*))) 183 | (submit-task *channel* #'imperative-closure 3) 184 | (is (= (imperative-closure 3) (receive-result *channel*))) 185 | (submit-task *channel* #'imperative-closure 3) 186 | (is (= (imperative-closure 3) (receive-result *channel*)))) 187 | 188 | (local-test symbol-macrolet-test 189 | (symbol-macrolet ((a 3)) 190 | (submit-task *channel* (lambda () a)) 191 | (is (= 3 (receive-result *channel*))) 192 | (symbol-macrolet ((b a)) 193 | (submit-task *channel* (lambda () b)) 194 | (is (= 3 (receive-result *channel*))) 195 | (symbol-macrolet ((c b)) 196 | (submit-task *channel* (lambda () c)) 197 | (is (= 3 (receive-result *channel*))))))) 198 | -------------------------------------------------------------------------------- /lfarm-launcher.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lfarm-launcher 32 | (:documentation 33 | "Launch servers locally or remotely.") 34 | (:use #:cl 35 | #:lfarm-common 36 | #:lfarm-server 37 | #:lfarm-admin) 38 | (:export #:start-local-servers 39 | #:end-local-servers) 40 | (:export #:start-remote-servers 41 | #:end-remote-servers) 42 | (:export #:*remote-lisp* 43 | #:*ssh-executable* 44 | #:*ssh-options* 45 | #:*ssh-user* 46 | #:*boot-form*) 47 | (:import-from #:external-program 48 | #:run)) 49 | 50 | (in-package #:lfarm-launcher) 51 | 52 | ;;;; remote servers 53 | 54 | (defun boot-form () 55 | ;; If this running lisp is using text serialization, assume the 56 | ;; remote lisp should as well. 57 | `(progn 58 | #+lfarm.with-text-serializer 59 | (pushnew :lfarm.with-text-serializer *features*) 60 | (unless (find-package :quicklisp-client) 61 | (let ((namestring (merge-pathnames "quicklisp/setup.lisp" 62 | (user-homedir-pathname)))) 63 | (when (probe-file namestring) 64 | (load namestring)))) 65 | (funcall (intern (string :quickload) :quicklisp-client) :lfarm-server))) 66 | 67 | (defvar *remote-lisp* nil) 68 | (defvar *ssh-executable* "ssh") 69 | (defvar *ssh-options* nil) 70 | (defvar *ssh-user* nil) 71 | (defvar *boot-form* (boot-form)) 72 | 73 | (defparameter *ssh-base-opt* '("-o" "ServerAliveInterval=10" 74 | "-o" "ServerAliveCountMax=1")) 75 | 76 | (defun scrub-form (form) 77 | "Replace objects which cause \" (double-quote) to be printed. Does 78 | not descend into vectors." 79 | (typecase form 80 | (cons (cons (scrub-form (car form)) 81 | (scrub-form (cdr form)))) 82 | (string `(string ',(make-symbol form))) 83 | (character (case form 84 | (#\" `(code-char ,(char-code #\"))) 85 | (otherwise form))) 86 | (pathname `(parse-namestring ,(scrub-form (namestring form)))) 87 | (otherwise form))) 88 | 89 | (defun start-form (host port boot) 90 | "Code passed to --eval." 91 | `(progn 92 | ,boot 93 | (funcall (intern (string :start-server) :lfarm-server) ,host ,port) 94 | (ignore-errors (funcall (intern (string :quit) :cl-user))) 95 | (funcall (intern (string :exit) :cl-user)))) 96 | 97 | (defun start-string (host port boot) 98 | "String passed to --eval." 99 | (with-standard-io-syntax 100 | (prin1-to-string (scrub-form (start-form host port boot))))) 101 | 102 | (defun surround-quotes (string) 103 | (concatenate 'string "\"" string "\"")) 104 | 105 | (defun splat (args) 106 | "(splat '(1 2 (3 4) 5 nil (6))) => (1 2 3 4 5 6)" 107 | (mapcan (lambda (arg) 108 | (typecase arg 109 | (list (copy-list arg)) 110 | (otherwise (list arg)))) 111 | args)) 112 | 113 | (defun ssh-host (user host) 114 | (if user 115 | (concatenate 'string user "@" host) 116 | host)) 117 | 118 | (defun start-remote-server (host port lisp boot ssh ssh-opt ssh-user) 119 | (let* ((ssh-host (ssh-host ssh-user host)) 120 | (start (surround-quotes (start-string host port boot))) 121 | (ssh-args (splat (list *ssh-base-opt* ssh-opt ssh-host lisp start)))) 122 | (info "start-remote-server" (prin1-to-string (cons ssh ssh-args))) 123 | (multiple-value-bind (status code) (run ssh ssh-args) 124 | (unless (zerop code) 125 | (error "The ssh command ~a with code ~a:~% ~s" 126 | (string-downcase (string status)) code (cons ssh ssh-args)))))) 127 | 128 | (defun spawn-remote-server (host port lisp boot ssh ssh-opt ssh-user) 129 | (make-thread (lambda () 130 | (start-remote-server host port lisp boot ssh ssh-opt ssh-user)) 131 | :name (format nil "lfarm-launcher ssh ~a ~a" host port))) 132 | 133 | (defun check-string-list (list) 134 | (unless (every #'stringp list) 135 | (error "Not a list of strings: ~s" list))) 136 | 137 | (defun check-args (lisp ssh ssh-opt ssh-user) 138 | ;; Check as much as possible before handing it to ssh. 139 | (check-string-list lisp) 140 | (check-type ssh string) 141 | (check-string-list ssh-opt) 142 | (check-type ssh-user (or null string))) 143 | 144 | (defun start-remote-servers (addresses 145 | &key 146 | ((:remote-lisp lisp) *remote-lisp*) 147 | ((:boot-form boot) *boot-form*) 148 | ((:ssh-executable ssh) *ssh-executable*) 149 | ((:ssh-options ssh-opt) *ssh-options*) 150 | ((:ssh-user ssh-user) *ssh-user*)) 151 | "Launch servers on remote machines via ssh. Assumes non-interactive 152 | login has been set up for each remote machine. 153 | 154 | `addresses' -- a list of (host port) string-integer pairs. 155 | 156 | `remote-lisp' -- The command to execute lisp on the remote machine (list 157 | of strings). It must end with the implementation's eval switch. E.g., 158 | '(\"sbcl\" \"--eval\"). 159 | 160 | `ssh-executable' -- Local ssh executable (string). Default is \"ssh\". 161 | 162 | `ssh-options' -- Command-line options passed to ssh (list of strings). 163 | 164 | `ssh-user' -- Username on the remote machine (string). 165 | 166 | `boot-form' -- Code to load lfarm-server.asd in the remote lisp image 167 | \(and perhaps do other initialization). Default loads it with quicklisp. 168 | Ensure that all symbols are in the CL or CL-USER package." 169 | (check-args lisp ssh ssh-opt ssh-user) 170 | (with-each-address (host port addresses) 171 | (spawn-remote-server host port lisp boot ssh ssh-opt ssh-user))) 172 | 173 | (defun end-servers (addresses fn-name) 174 | (with-each-address/handle-error (host port addresses fn-name) 175 | (end-server host port))) 176 | 177 | (defun end-remote-servers (addresses) 178 | "Shut down remote servers. 179 | 180 | `addresses' is a list of (host port) string-integer pairs." 181 | (end-servers addresses 'end-remote-servers)) 182 | 183 | ;;;; local servers 184 | 185 | (defmacro with-thread-tracker (&body body) 186 | (with-gensyms (threads) 187 | `(let ((,threads nil)) 188 | (flet ((track-thread (thread) 189 | (push thread ,threads))) 190 | (unwind-protect/safe 191 | :main (multiple-value-prog1 ,@body) 192 | :abort (dolist (thread ,threads) 193 | (ignore-errors (destroy-thread thread)))))))) 194 | 195 | (defun start-local-servers (addresses) 196 | "Locally launch servers. 197 | 198 | `addresses' is a list of (host port) string-integer pairs." 199 | (with-thread-tracker 200 | (with-each-address (host port addresses) 201 | (track-thread (start-server host port :background t))))) 202 | 203 | (defun end-local-servers (addresses) 204 | "Shut down local servers. 205 | 206 | `addresses' is a list of (host port) string-integer pairs." 207 | (end-servers addresses 'end-local-servers)) 208 | -------------------------------------------------------------------------------- /lfarm-client/closure.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;;; Serialization of closures. 32 | 33 | ;;; Find free symbols inside the lambda and then use 34 | ;;; `variable-information' from CLTL2 to discover the lexical 35 | ;;; variables and symbol macros captured. `flet' functions are 36 | ;;; ignored. 37 | 38 | (in-package #:lfarm-client.kernel) 39 | 40 | #+sbcl 41 | (eval-when (:compile-toplevel :load-toplevel :execute) 42 | (require 'sb-cltl2)) 43 | 44 | (defun variable-information (var env) 45 | (#+sbcl sb-cltl2:variable-information 46 | #+ccl ccl:variable-information 47 | #+allegro sys:variable-information 48 | #+lispworks hcl:variable-information 49 | var env)) 50 | 51 | (defun lexical-var-p (var env) 52 | (eq :lexical (variable-information var env))) 53 | 54 | (defun symbol-macro-p (var env) 55 | (eq :symbol-macro (variable-information var env))) 56 | 57 | #+(and sbcl (not lfarm.with-hu-walker)) 58 | (defun %find-free-symbols (lambda-list body) 59 | ;; SBCL code walker 60 | (let ((free-symbols nil)) 61 | (flet ((visit (form context env) 62 | (declare (ignore context)) 63 | (typecase form 64 | (symbol 65 | ;; If a lexical variable is recognized then it is 66 | ;; defined somewhere inside the lambda, which means it 67 | ;; is not captured. Similarly throw out 68 | ;; symbol-macrolets defined inside the lambda. 69 | ;; 70 | ;; lexical-var-p is sometimes wrong in conjunction 71 | ;; with sb-walker, so use sb-walker:var-lexical-p. 72 | (unless (or (sb-walker:var-lexical-p form env) 73 | (symbol-macro-p form env)) 74 | (push form free-symbols)))) 75 | form)) 76 | (sb-walker:walk-form `(lambda ,lambda-list ,@body) nil #'visit) 77 | (remove-duplicates free-symbols)))) 78 | 79 | #+lfarm.with-hu-walker 80 | (defun %find-free-symbols (lambda-list body) 81 | ;; hu.dwim code walker 82 | (flet ((walk (form fn) 83 | (hu.dwim.walker:rewrite-ast 84 | (hu.dwim.walker:walk-form form) 85 | (lambda (parent type form) 86 | (declare (ignore parent type)) 87 | (typecase form 88 | (hu.dwim.walker:free-variable-reference-form 89 | (funcall fn form))) 90 | form)))) 91 | (let ((free-symbols nil)) 92 | (handler-bind ((style-warning #'muffle-warning)) 93 | (walk `(lambda ,lambda-list ,@body) 94 | (lambda (sym) (push sym free-symbols)))) 95 | (remove-duplicates (mapcar #'hu.dwim.walker:name-of 96 | free-symbols))))) 97 | 98 | #+(and (not sbcl) (not lfarm.with-hu-walker)) 99 | (defun %find-free-symbols (lambda-list body) 100 | ;; Fake code walker: grab all symbols which are not the head of a 101 | ;; form. The worst case outcome is overshoot: capturing more 102 | ;; variables than necessary. This will cause an error if a 103 | ;; needlessly captured variable is not serializable, but is 104 | ;; otherwise harmless apart from the increased bandwidth. 105 | (labels ((walk-symbols (form fn) 106 | (typecase form 107 | (symbol (funcall fn form)) 108 | (cons (destructuring-bind (first &rest rest) form 109 | (typecase first 110 | (symbol) ; skip 111 | (cons (walk-symbols first fn))) 112 | (mapcar (lambda (form) (walk-symbols form fn)) 113 | rest)))))) 114 | (let ((free-symbols nil)) 115 | (walk-symbols `(progn ,@body) 116 | (lambda (sym) (push sym free-symbols))) 117 | (set-difference (remove-duplicates free-symbols) 118 | (lambda-list-parameters lambda-list))))) 119 | 120 | (defun find-symbol-macros (syms env) 121 | (remove-if-not (lambda (sym) (symbol-macro-p sym env)) syms)) 122 | 123 | (defun sort-symbols (symbols) 124 | (sort symbols #'string< :key #'symbol-name)) 125 | 126 | (defun find-free-symbols (lambda-list body env 127 | &optional (known-symbol-macros nil)) 128 | ;; Expand symbol macros only once; any more could lead to an 129 | ;; unportable result. 130 | ;; 131 | ;; We must track `known-symbol-macros' when using the fake walker. 132 | (let* ((initial-syms (remove-duplicates 133 | (%find-free-symbols lambda-list body))) 134 | (symbol-macros (set-difference (find-symbol-macros initial-syms env) 135 | known-symbol-macros)) 136 | (more-syms (mapcan (lambda (sym-mac) 137 | (find-free-symbols 138 | lambda-list 139 | (list (macroexpand-1 sym-mac env)) 140 | env 141 | (append symbol-macros known-symbol-macros))) 142 | symbol-macros))) 143 | ;; The only reason to sort is to make testing easier. 144 | (sort-symbols (remove-duplicates (append initial-syms more-syms))))) 145 | 146 | (defun find-captures (lambda-list body env) 147 | (loop for sym in (find-free-symbols lambda-list body env) 148 | if (lexical-var-p sym env) collect sym into lexicals 149 | else if (symbol-macro-p sym env) collect sym into symbol-macros 150 | finally (return (values lexicals symbol-macros)))) 151 | 152 | (defun make-closure-form (name lambda-list body env lexicals symbol-macros) 153 | (let ((lambda-type (if name 'named-lambda 'lambda))) 154 | ``(symbol-macrolet 155 | (,,@(loop for var in symbol-macros 156 | collect ``(,',var ,',(macroexpand-1 var env)))) 157 | (let (,,@(loop for var in lexicals 158 | collect ``(,',var ',,var))) 159 | (,',lambda-type ,@',(unsplice name) ,',lambda-list 160 | ,@',body))))) 161 | 162 | (defun maybe-make-closure-form (name lambda-list body env) 163 | (multiple-value-bind (lexicals symbol-macros) 164 | (find-captures lambda-list body env) 165 | (and (or lexicals symbol-macros) 166 | (make-closure-form name lambda-list body env lexicals symbol-macros)))) 167 | 168 | (defun closure-lambda-form (form) 169 | (let ((args (make-symbol (string 'args)))) 170 | ``(lambda (&rest ,',args) 171 | (apply ,,form ,',args)))) 172 | 173 | (defun serialize-lambda (lambda-list body env &key name) 174 | "If no closure is detected, return a lambda form. 175 | 176 | If a closure is detected, generate code for a closure in which the 177 | values of the closed-over variables are assigned their current values. 178 | When evaluated, the generated code produces a closure equivalent (for 179 | our purposes) to a regular lambda with the given `lambda-list' and 180 | `body'. The difference is that it holds a snapshot of the closed-over 181 | variables rather than the original variables themselves." 182 | ;; Need to return a lambda form for `compile'. 183 | (let ((closure-form (maybe-make-closure-form name lambda-list body env))) 184 | (if closure-form 185 | (closure-lambda-form closure-form) 186 | (lambda-form name lambda-list body)))) 187 | -------------------------------------------------------------------------------- /lfarm-test/base.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-test) 32 | 33 | (defvar *local-host* "127.0.0.1") 34 | (defvar *remote-host* "127.0.0.1") 35 | 36 | (defvar *remote-log* nil) 37 | 38 | ;;; Probably too long, but better safe than sorry. 39 | (defvar *wait-interval* 3) 40 | 41 | (defvar *channel*) 42 | 43 | ;;; different ports for simultaneous testing 44 | (defparameter *start-port* (or #+sbcl 10000 45 | #+ccl 11000 46 | #+lispworks 12000 47 | #+allegro 13000 48 | #+abcl 14000 49 | 15000)) 50 | 51 | (defparameter *end-port* 65536) 52 | 53 | (defvar *port* *start-port*) 54 | 55 | (defun next-port () 56 | (setf *port* (let ((next (1+ *port*))) 57 | (if (< next *end-port*) 58 | next 59 | *start-port*)))) 60 | 61 | ;;; Avoid having to type "yes" for verifying local hosts. 62 | (defvar *extra-ssh-options* '("-o" "StrictHostKeyChecking=no")) 63 | 64 | (defun truep (x) (not (null x))) 65 | 66 | (defmacro unwind-protect/safe* (&key prepare main cleanup abort) 67 | `(unwind-protect/safe 68 | :prepare ,prepare 69 | :main ,main 70 | :cleanup (lfarm-common::with-interrupts ,cleanup) 71 | :abort (lfarm-common::with-interrupts ,abort))) 72 | 73 | (defwith with-local-servers (addresses) 74 | (unwind-protect/safe 75 | :prepare (start-local-servers addresses) 76 | :main (call-body) 77 | :cleanup (end-local-servers addresses))) 78 | 79 | (defwith with-remote-servers (addresses) 80 | (unwind-protect/safe 81 | :prepare (start-remote-servers addresses) 82 | :main (call-body) 83 | :cleanup (end-remote-servers addresses))) 84 | 85 | (defwith with-kernel ((:vars kernel) addresses &rest args) 86 | (unwind-protect/safe-bind 87 | :bind (kernel (apply #'make-kernel addresses args)) 88 | :main (call-body kernel) 89 | :cleanup (let ((*kernel* kernel)) 90 | (end-kernel :wait t)))) 91 | 92 | (defwith with-server (host port &rest args) 93 | (unwind-protect/safe* 94 | :prepare (apply #'start-server host port :background t args) 95 | :main (call-body) 96 | :cleanup (end-server host port))) 97 | 98 | (defwith with-connection ((:vars connection) host port) 99 | (unwind-protect/safe-bind 100 | :bind (connection (lfarm-client.kernel::make-connection host port)) 101 | :main (call-body connection) 102 | :cleanup (lfarm-client.kernel::end-connection connection))) 103 | 104 | (defun thread-count () 105 | ;; ccl can spontaneously lose the initial thread 106 | #+ccl 107 | (count "Initial" 108 | (bordeaux-threads:all-threads) 109 | :key #'bordeaux-threads:thread-name 110 | :test-not #'string=) 111 | ;; allegro launches a domain name service 112 | #+allegro 113 | (count-if-not (lambda (name) (search "Domain Name" name :test #'equalp)) 114 | (bordeaux-threads:all-threads) 115 | :key #'bordeaux-threads:thread-name) 116 | #-(or ccl allegro) 117 | (length (bordeaux-threads:all-threads))) 118 | 119 | (defwith with-thread-count-check (sleep-sec) 120 | (sleep 0.4) 121 | (let ((old-thread-count (thread-count))) 122 | (multiple-value-prog1 (call-body) 123 | (sleep sleep-sec) 124 | (is (eql old-thread-count (thread-count)))))) 125 | 126 | (defwith with-local-setup (server-count) 127 | (with-thread-count-check (0.4) 128 | (let ((addresses (loop repeat server-count 129 | collect (list *local-host* (next-port))))) 130 | (with-local-servers (addresses) 131 | (with-kernel (*kernel* addresses) 132 | (let ((*channel* (make-channel))) 133 | (call-body))))))) 134 | 135 | (defwith with-remote-setup (server-count) 136 | (with-thread-count-check (*wait-interval*) 137 | (let ((addresses (loop repeat server-count 138 | collect (list *remote-host* (next-port))))) 139 | (with-remote-servers (addresses) 140 | (with-kernel (*kernel* addresses) 141 | (let ((*channel* (make-channel))) 142 | (call-body))))))) 143 | 144 | (defun stamp () 145 | `(apply #'format nil 146 | "~d~2,'0d~2,'0d~2,'0d~2,'0d~2,'0d-~6,'0d" 147 | (append (reverse (butlast (multiple-value-list (get-decoded-time)) 3)) 148 | (list (let ((*random-state* (make-random-state t))) 149 | (random (expt 10 6))))))) 150 | 151 | (defun boot-log-form (path) 152 | `(progn 153 | (setf (symbol-value (intern (string '#:*log-stream*) :lfarm-server)) 154 | (open (concatenate 'string (namestring ,path) "-" ,(stamp)) 155 | :direction :output 156 | :if-exists :append 157 | :if-does-not-exist :create)) 158 | (setf (symbol-value (intern (string '#:*log-level*) :lfarm-server)) 159 | ,*log-level*))) 160 | 161 | (defun local-lisp () 162 | (or #+sbcl (list (first sb-ext:*posix-argv*) "--eval") 163 | #+ccl (list (first ccl:*command-line-argument-list*) "--eval") 164 | #+lispworks (list (first sys:*line-arguments-list*) "-eval") 165 | #+allegro (list (first (sys:command-line-arguments)) "-e") 166 | #+ecl (list (si:argv 0) "-eval") 167 | #+clisp (append (coerce (ext:argv) 'list) '("-x")) 168 | :need-to-supply-remote-lisp)) 169 | 170 | (defwith with-test-env () 171 | (let ((*ssh-options* (append *extra-ssh-options* *ssh-options*)) 172 | (*boot-form* (if *remote-log* 173 | `(progn 174 | ,*boot-form* 175 | ,(boot-log-form *remote-log*)) 176 | *boot-form*)) 177 | (*remote-lisp* (or *remote-lisp* (local-lisp))) 178 | (*connect-retry-interval* 0.1)) 179 | (call-body))) 180 | 181 | (defmacro base-test (name &body body) 182 | `(test ,name 183 | (with-test-env 184 | ,@body))) 185 | 186 | (defmacro local-test (name &body body) 187 | `(base-test ,name 188 | (with-local-setup (3) 189 | ,@body))) 190 | 191 | (defmacro remote-test (name &body body) 192 | `(base-test ,name 193 | (with-remote-setup (3) 194 | ,@body))) 195 | 196 | (defmacro full-test (name &body body) 197 | (let ((local (alexandria:symbolicate name '#:/local)) 198 | (remote (alexandria:symbolicate name '#:/remote))) 199 | `(progn 200 | (local-test ,local ,@body) 201 | (remote-test ,remote ,@body) 202 | (defun ,name () 203 | (,local) 204 | (,remote))))) 205 | 206 | (defun execute (&key 207 | ((:remote-lisp *remote-lisp*) *remote-lisp*) 208 | ((:ssh-executable *ssh-executable*) *ssh-executable*) 209 | ((:ssh-options *ssh-options*) *ssh-options*) 210 | ((:ssh-user *ssh-user*) *ssh-user*) 211 | ((:boot-form *boot-form*) *boot-form*) 212 | ((:remote-log *remote-log*) *remote-log*) 213 | ((:remote-host *remote-host*) *remote-host*) 214 | ((:wait-interval *wait-interval*) *wait-interval*) 215 | ((:auth *auth*) *auth*)) 216 | "Run the lfarm test suite. 217 | 218 | `remote-lisp' -- The command to execute lisp on the remote machine (list 219 | of strings). It must end with the implementation's eval switch. E.g., 220 | '(\"sbcl\" \"--eval\"). 221 | 222 | `ssh-executable' -- Local ssh executable (string). Default is \"ssh\". 223 | 224 | `ssh-options' -- Command-line options passed to ssh (list of strings). 225 | 226 | `ssh-user' -- Username on the remote machine (string). 227 | 228 | `boot-form' -- Code to load lfarm-server.asd in the remote lisp image 229 | \(and perhaps do other initialization). Default loads it with quicklisp. 230 | Ensure that all symbols are in the CL or CL-USER package. 231 | 232 | `remote-log' -- Pathname for the remote server log. 233 | 234 | `wait-interval' -- Seconds to wait before verifying that all threads 235 | have exited gracefully." 236 | (run)) 237 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lfarm 2 | 3 | lfarm is a Common Lisp library for distributing work across machines 4 | using the [lparallel] (http://lparallel.org) API. 5 | 6 | ### Download 7 | 8 | The easiest way to obtain lfarm is through 9 | [Quicklisp](http://www.quicklisp.org/beta/). Alternatively, one may 10 | [clone the repository](https://github.com/lmj/lfarm.git). 11 | 12 | ### Synopsis 13 | 14 | In lparallel a _kernel_ was defined as abstract entity that schedules 15 | and executes tasks. lparallel implements it with a thread pool, while 16 | in lfarm it is implemented with a set of servers that execute tasks. 17 | 18 | ;; Create two servers bound to ports 11111 and 22222. 19 | (ql:quickload :lfarm-server) 20 | (lfarm-server:start-server "127.0.0.1" 11111 :background t) 21 | (lfarm-server:start-server "127.0.0.1" 22222 :background t) 22 | 23 | ;; Connect to the servers. `lfarm' is a package nickname for `lfarm-client'. 24 | (ql:quickload :lfarm-client) 25 | (setf lfarm:*kernel* (lfarm:make-kernel '(("127.0.0.1" 11111) 26 | ("127.0.0.1" 22222)))) 27 | 28 | ;; Use the lparallel API. 29 | (defpackage :example (:use :cl :lfarm)) 30 | (in-package :example) 31 | 32 | (let ((channel (make-channel))) 33 | (submit-task channel #'+ 3 4) 34 | (receive-result channel)) 35 | ;; => 7 36 | 37 | (let ((f (future (+ 3 4)))) 38 | (force f)) 39 | ;; => 7 40 | 41 | (plet ((x (+ 3 4)) 42 | (y (+ 5 6))) 43 | (+ x y)) 44 | ;; => 18 45 | 46 | (pmapcar '1+ #(1 2 3)) ; => (2 3 4) 47 | (pmapcar #'1+ #(1 2 3)) ; => (2 3 4) 48 | (preduce '+ #(1 2 3)) ; => 6 49 | (pmap-reduce '1+ '+ #(1 2 3)) ; => 9 50 | 51 | Although the servers in this example are local, lfarm servers may run 52 | in separate Lisp instances on remote machines. 53 | 54 | ### Tasks 55 | 56 | There are some restrictions on a task slated for remote execution. A 57 | task must be 58 | 59 | 1. a lambda form, or 60 | 2. a function that exists on the remote servers, or 61 | 3. a function defined with `deftask`. 62 | 63 | `deftask` is just like `defun` except the function definition is 64 | recorded. (A Lisp implementation may record a function definition, but 65 | is not required to do so.) 66 | 67 | (deftask add (x y) 68 | (+ x y)) 69 | 70 | (let ((channel (make-channel))) 71 | (submit-task channel #'add 3 4) 72 | (receive-result channel)) 73 | ;; => 7 74 | 75 | `submit-task` notices that `add` was defined with `deftask` and 76 | converts it to a named lambda before submitting it to a server. 77 | 78 | To define `add` remotely use `broadcast-task`, which executes a given 79 | task on all servers. 80 | 81 | (broadcast-task (lambda () (defun add (x y) (+ x y)))) 82 | 83 | Or more likely `add` would be part of a system that is loaded on all 84 | servers. 85 | 86 | (broadcast-task #'ql:quickload :my-stuff) 87 | 88 | Limited support for closures is available on SBCL, CCL, LispWorks, and 89 | Allegro. Lexical variables and symbol macrolets are captured, but 90 | lexical functions (`flet`, `labels`) are not. 91 | 92 | Tasks are not macroexpanded in order to ensure portability across 93 | clients and servers. 94 | 95 | ### API 96 | 97 | The `lfarm-client` system defines the `lfarm-client` package which has 98 | the nickname `lfarm`. It exports the [lparallel kernel 99 | API](http://lparallel.org/api/kernel) with the following differences. 100 | 101 | * tasks have the aforementioned restrictions placed upon them 102 | * the addition of `deftask` 103 | * `make-kernel` expects addresses, and lacks the `:context` and 104 | `:bindings` arguments 105 | * `task-handler-bind` does not exist 106 | * `*debug-tasks-p*` and `*kernel-spin-count*` exist but have no effect 107 | * `submit-task` is a macro that wraps `submit-task*` (see the Details section) 108 | * the addition of `broadcast-task` which similarly wraps `broadcast-task*` 109 | * `task-execution-error` is signaled when a task fails on a remote 110 | server, instead of the actual error (which may not have local meaning) 111 | 112 | [Promises](http://lparallel.org/api/promises/) and a limited number of 113 | [cognates](http://lparallel.org/api/cognates/) are also available, 114 | found in the packages `lfarm-client.promise` and 115 | `lfarm-client.cognate` respectively and also exported by 116 | `lfarm-client`. 117 | 118 | The systems `lfarm-server` and `lfarm-admin` provide the following functions. 119 | 120 | * `lfarm-server:start-server host port &key background name` -- Start a 121 | server instance listening at `host`:`port`. If `background` is true 122 | then spawn the server in a separate thread named `name`. 123 | 124 | * `lfarm-admin:ping host port &key timeout` -- Send a ping to the lfarm 125 | server at `host`:`port`. Keep trying to make contact for `timeout` 126 | seconds, or if `timeout` is nil then try forever. Default is 3 127 | seconds. Returns true if successful and nil otherwise. 128 | 129 | * `lfarm-admin:end-server host port` -- End the server at `host`:`port`. 130 | This only stops new connections from being made. Connections in 131 | progress are unaffected. 132 | 133 | ### Security 134 | 135 | The purpose of an lfarm server is to execute arbitrary code, so it is 136 | highly advised to enable some form of security. lfarm directly 137 | supports Kerberos (or Active Directory) authentication. Alternatively, 138 | SSH tunnels may be used. 139 | 140 | #### Security with SSH tunneling 141 | 142 | ;; On the remote machine 143 | (ql:quickload :lfarm-server) 144 | (lfarm-server:start-server "127.0.0.1" 33333) 145 | 146 | To create a tunnel, 147 | 148 | # On the local machine 149 | $ ssh -f -L 33333:127.0.0.1:33333 -N 150 | 151 | The remote server should now be accessible locally. 152 | 153 | ;; On the local machine 154 | (ql:quickload :lfarm-admin) 155 | (lfarm-admin:ping "127.0.0.1" 33333) ;=> T 156 | 157 | Of course there is still local security to consider, as local users on 158 | both ends have access to the server. If this is a concern then a 159 | packet filtering tool such as iptables may be used. 160 | 161 | #### Security with Kerberos/GSSAPI 162 | 163 | The `lfarm-gss` system provides support for GSSAPI authentication. The 164 | `:auth` argument to `lfarm-server:start-server` and 165 | `lfarm-client:make-kernel` accepts an instance of 166 | `lfarm-gss:gss-auth-server` and `lfarm-gss:gss-auth-client` 167 | respectively. 168 | 169 | When creating a server, the class `lfarm-gss:gss-auth-server` accepts 170 | the initialization keyword `:service-name`. This value is indicats 171 | which service type should be used when requesting a ticket for the 172 | remote service. The default is `lfarm`. In other words, if an attempt 173 | is done to connect to the server at `server.example.com`, the service 174 | principal will be `lfarm/server.example.com`. 175 | 176 | When creating a kernel (client), the class `lfarm-gss:gss-auth-client` 177 | accepts the initialization keyword `:allowed-users` which specifies a 178 | list of all users that are allowed to connect to the server. Each 179 | element should be a string representing the principal name (including 180 | realm) of the user that is allowed to connect. For example: 181 | `user@EXAMPLE.COM`. 182 | 183 | If a more complex authorization mechanism is needed which is not 184 | covered by the simple user list as described above, you can subclass 185 | the `gss-auth-server` class and then implement the method 186 | `lfarm-gss:name-accepted` on your new class. This generic function 187 | takes two arguments, the authentication object and the name to be 188 | verified, and should return non-NIL if the user is allowed to connect. 189 | Note that the name is an instance of `cl-gss:name`, and you need to 190 | call the function `cl-gss:name-to-string` on it to extract the actual 191 | name. 192 | 193 | The server needs to have access to the service principal in a keytab 194 | file. How to create the keytab file depends on your Kerberos server 195 | implementation: 196 | 197 | * For MIT Kerberos: 198 | http://web.mit.edu/kerberos/krb5-1.5/krb5-1.5.4/doc/krb5-admin/Adding-Principals-to-Keytabs.html 199 | 200 | * For Heimdal: 201 | http://www.h5l.org/manual/HEAD/info/heimdal/keytabs.html (don't 202 | forget to add the `-k` flag to specify the file to which the key 203 | should be written) 204 | 205 | * For Active Directory: 206 | http://technet.microsoft.com/en-us/library/bb742433.aspx 207 | 208 | Once you have the keytab file, you have to make sure that it is 209 | loaded. The easiest way to do this is to simply call 210 | `CL-GSS:KRB5-REGISTER-ACCEPTOR-IDENTITY` and pass in the name of the 211 | keytab file. 212 | 213 | The other way is to make sure the environment variable `KRB5_KTNAME` 214 | is set to the path of the keytab file and that it is readable by the 215 | lfarm server instance. 216 | 217 | If the keytab file has not been loaded, the server will fail to 218 | authenticate and you will get a security error when the client 219 | attempts to connect to the server. 220 | 221 | ## Details 222 | 223 | That covers perhaps all you need to know about lfarm. Those who are 224 | curious may read on (or not). 225 | 226 | ### Serialization 227 | 228 | Serialization is done with 229 | [cl-store](http://common-lisp.net/project/cl-store/). It uses a 230 | portable serialization format, allowing lfarm clients and servers to 231 | run on different Lisp implementations. 232 | 233 | ### Packages 234 | 235 | A symbol is deserialized on the remote server with its home package 236 | intact. If the server encounters a symbol whose package does not 237 | exist, an empty version of the package is automatically generated. 238 | 239 | ### Connection errors 240 | 241 | The lfarm client is obstinate with regards to connections: if there is 242 | a connection error then it tries to reconnect, and will continue 243 | trying. We may therefore restart servers while using the same kernel 244 | instance, or call `make-kernel` before any servers exist (the call 245 | will block until they do). 246 | 247 | Note it is possible for a task to be executed twice (or more). If a 248 | connection error occurs in the time interval after a task has been 249 | submitted and before its result has been received, the client will 250 | attempt to submit the task again. 251 | 252 | ### submit-task 253 | 254 | In lparallel `submit-task` is a function, but in lfarm it is a macro 255 | that provides syntactic sugar for the function `submit-task*`. 256 | 257 | (submit-task channel #'+ 3 4) 258 | ;; =macroexpand=> (SUBMIT-TASK* CHANNEL '+ 3 4) 259 | 260 | (submit-task channel (lambda (x) (1+ x)) 3) 261 | ;; =macroexpand=> (SUBMIT-TASK* CHANNEL '(LAMBDA (X) (1+ X)) 3) 262 | 263 | `submit-task` may alter the task argument before giving it to 264 | `submit-task*`, which expects a symbol or a lambda form. Sharp-quote 265 | is replaced with quote, and a lambda form gets quoted. This provides a 266 | semblance with `lparallel:submit-task` and relieves us from having to 267 | write `'(lambda ...)` and `'f` in place of `(lambda ...)` and `#'f`. 268 | 269 | ### Logging 270 | 271 | Verbose logging is enabled by binding `lfarm-common:*log-level*` to 272 | `:info` (default is `:error`). The log stream is 273 | `lfarm-common:*log-stream*` (default is `*debug-io*`). 274 | 275 | ### Tests 276 | 277 | The lfarm test suite assumes a working ssh executable is present and 278 | that passwordless authorization has been set up for "ssh localhost". 279 | To run it load the `lfarm-test` system and call `lfarm-test:execute`, 280 | which may be given some configuration options. Unrecognized Lisp 281 | implementations will require configuration (namely, specifying the 282 | lisp executable and the command-line switch to eval a form). Tests 283 | also assume that Quicklisp has been installed (but not necessarily 284 | loaded), although configuration may remove this assumption. 285 | 286 | ### Implementation 287 | 288 | The client has an internal lparallel kernel in which each worker 289 | thread manages a connection to an assigned remote server, one worker 290 | per server. When a worker connects to a server, the server enters a 291 | task execution loop wherein a form is deserialized, maybe compiled, 292 | and funcalled; repeat. A server may serve multiple clients. 293 | 294 | Though an async backend is possible, this threaded implementation was 295 | chosen because it was easy and portable. 296 | 297 | Opportunities for optimization in the realm of remote task queues and 298 | remote task stealing have been callously ignored. Task queues are 299 | local. 300 | 301 | ### Author 302 | 303 | James M. Lawrence 304 | 305 | Kerberos support by Elias Martenson 306 | -------------------------------------------------------------------------------- /lfarm-server.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lfarm-server 32 | (:documentation 33 | "A server accepts tasks, executes them, and returns the results.") 34 | (:use #:cl 35 | #:lfarm-common) 36 | (:export #:start-server)) 37 | 38 | (in-package #:lfarm-server) 39 | 40 | ;;;; util 41 | 42 | (defwith ignore-errors/log () 43 | (handler-case (call-body) 44 | (error (err) 45 | (info "ignoring error" err) 46 | (values nil err)))) 47 | 48 | (defun socket-close* (socket) 49 | (ignore-errors/log (socket-close socket))) 50 | 51 | ;;; CCL sometimes balks at connection attempts (issue #1050) 52 | #+ccl 53 | (defwith with-bug-handler () 54 | (with-tag :retry 55 | (handler-bind (((or usocket:unknown-error usocket:invalid-argument-error) 56 | (lambda (err) 57 | (info "socket error bug, retrying" err) 58 | (go :retry)))) 59 | (call-body)))) 60 | 61 | #-ccl 62 | (defwith with-bug-handler () 63 | (call-body)) 64 | 65 | (defmacro dynamic-closure (vars &body body) 66 | "Capture the values of the dynamic variables in `vars' and return a 67 | closure in which those variables are bound to the captured values." 68 | (let ((syms (loop repeat (length vars) collect (gensym)))) 69 | `(let ,(mapcar #'list syms vars) 70 | (lambda () 71 | (let ,(mapcar #'list vars syms) 72 | ,@body))))) 73 | 74 | ;;;; package generator 75 | 76 | (defvar *package-creation-lock* (make-lock)) 77 | 78 | ;;; Allegro and ABCL signal `reader-error' for a missing package 79 | ;;; during `read'. We must parse the report string in order to get the 80 | ;;; package name. 81 | #+(and (or abcl allegro) lfarm.with-text-serializer) 82 | (progn 83 | (defparameter *match-around* #+abcl '("The package \"" "\" can't be found.") 84 | #+allegro '("Package \"" "\" not found")) 85 | 86 | (defun match-around (seq left right) 87 | ;; (match-around "hello !want this! world" "hello !" "! world") 88 | ;; => "want this" 89 | (when-let* ((left-pos (search left seq)) 90 | (match-pos (+ left-pos (length left))) 91 | (right-pos (search right seq :start2 match-pos))) 92 | (subseq seq match-pos right-pos))) 93 | 94 | (defun extract-package-name (err) 95 | (apply #'match-around (princ-to-string err) *match-around*)) 96 | 97 | (defwith with-missing-package-handler (action) 98 | (handler-bind ((reader-error 99 | (lambda (err) 100 | (when-let (name (extract-package-name err)) 101 | (funcall action name))))) 102 | (call-body)))) 103 | 104 | ;;; Allegro signals `type-error' for a missing package during 105 | ;;; `cl-store:restore'. According to Franz, if package `foo' does not 106 | ;;; exist then `:foo' is not a package designator, which is why 107 | ;;; (intern "BAR" :foo) signals a `type-error'. `cl-store:restore' 108 | ;;; calls `intern' when restoring a symbol. 109 | #+(and allegro (not lfarm.with-text-serializer)) 110 | (defwith with-missing-package-handler (action) 111 | (handler-bind ((type-error 112 | (lambda (err) 113 | (when (eq 'package (type-error-expected-type err)) 114 | (funcall action (type-error-datum err)))))) 115 | (call-body))) 116 | 117 | ;;; In all other cases `package-error' is signaled for a missing package. 118 | #-(or (and (or abcl allegro) lfarm.with-text-serializer) 119 | (and allegro (not lfarm.with-text-serializer))) 120 | (defwith with-missing-package-handler (action) 121 | (handler-bind ((package-error 122 | (lambda (err) 123 | (funcall action (package-error-package err))))) 124 | (call-body))) 125 | 126 | (defwith with-package-generator () 127 | (with-tag :retry 128 | (flet ((make-package-and-retry (name) 129 | (with-lock-predicate/wait 130 | *package-creation-lock* (not (find-package name)) 131 | (info "creating package" name) 132 | (make-package name :use nil)) 133 | (go :retry))) 134 | (with-missing-package-handler (#'make-package-and-retry) 135 | (call-body))))) 136 | 137 | ;;;; task category tracking 138 | 139 | ;;; Vector of task category ids currently running. 140 | (defvar *tasks*) 141 | 142 | ;;; Lock for *tasks*. 143 | (defvar *tasks-lock*) 144 | 145 | ;;; Each task loop thread has an index into the `*tasks*' vector. 146 | (defvar *task-index*) 147 | 148 | ;;; Value when no job is running. 149 | (defconstant +idle+ 'idle) 150 | 151 | (defwith with-task-tracking () 152 | (let ((*tasks* (make-array 0 :fill-pointer 0 :adjustable t)) 153 | (*tasks-lock* (make-lock))) 154 | (call-body))) 155 | 156 | (defwith with-tasks-lock () 157 | (with-lock-held (*tasks-lock*) 158 | (call-body))) 159 | 160 | (defwith environment-closure () 161 | (dynamic-closure (*auth* *tasks* *tasks-lock*) 162 | (call-body))) 163 | 164 | (defun acquire-task-index () 165 | (with-tasks-lock 166 | (let ((index (position nil *tasks*))) 167 | (if index 168 | (prog1 index 169 | (setf (aref *tasks* index) +idle+)) 170 | (prog1 (length *tasks*) 171 | (vector-push-extend +idle+ *tasks*)))))) 172 | 173 | (defun release-task-index () 174 | (setf (aref *tasks* *task-index*) nil)) 175 | 176 | (defwith with-task-index () 177 | (unwind-protect/safe-bind 178 | :bind (*task-index* (acquire-task-index)) 179 | :main (call-body) 180 | :cleanup (release-task-index))) 181 | 182 | (defwith with-task-category-id (task-category-id) 183 | (let ((previous (aref *tasks* *task-index*))) 184 | (assert previous) 185 | (unwind-protect/safe 186 | :prepare (setf (aref *tasks* *task-index*) 187 | (cons task-category-id (current-thread))) 188 | :main (call-body) 189 | :cleanup (setf (aref *tasks* *task-index*) previous)))) 190 | 191 | (defun kill-tasks (task-category-id) 192 | (dosequence (elem (with-tasks-lock (copy-seq *tasks*))) 193 | (etypecase elem 194 | (cons (destructuring-bind (id . thread) elem 195 | (when (eql id task-category-id) 196 | (info "killing task loop" id thread) 197 | (ignore-errors/log (destroy-thread thread))))) 198 | (null) 199 | (symbol (assert (eq elem +idle+)))))) 200 | 201 | ;;;; task loop 202 | 203 | (defun maybe-compile (fn-form) 204 | (etypecase fn-form 205 | (symbol fn-form) 206 | (cons (compile nil fn-form)))) 207 | 208 | (defun exec-task (task) 209 | (destructuring-bind (task-category-id fn-form &rest args) task 210 | (with-task-category-id (task-category-id) 211 | (apply (maybe-compile fn-form) args)))) 212 | 213 | (defun deserialize-task (buffer corrupt-handler) 214 | (with-package-generator 215 | (handler-bind ((end-of-file corrupt-handler)) 216 | (deserialize-buffer buffer)))) 217 | 218 | (defun process-task (stream buffer task-handler corrupt-handler) 219 | (let* ((task (deserialize-task buffer corrupt-handler)) 220 | (result (handler-bind ((error task-handler)) 221 | (exec-task task)))) 222 | (info "task result" result stream) 223 | (handler-bind ((error task-handler)) 224 | (send-object result stream)))) 225 | 226 | (defun read-task-buffer (stream clean-return corrupt-handler) 227 | (handler-bind ((end-of-file clean-return) 228 | (corrupted-stream-error corrupt-handler)) 229 | (receive-serialized-buffer stream))) 230 | 231 | (defun read-and-process-task (stream clean-return corrupt-handler next-task) 232 | (let ((buffer (read-task-buffer stream clean-return corrupt-handler))) 233 | (info "new task" buffer stream) 234 | (flet ((task-handler (err) 235 | (info "error during task execution" err stream) 236 | (send-object (make-task-error-data err) stream) 237 | (funcall next-task))) 238 | (process-task stream buffer #'task-handler corrupt-handler)))) 239 | 240 | (defun task-loop (stream) 241 | (info "start task loop" stream (current-thread)) 242 | (with-tag :next-task 243 | (info "reading next task") 244 | (flet ((clean-return (err) 245 | (declare (ignore err)) 246 | (info "end task loop" stream) 247 | (return-from task-loop)) 248 | (corrupt-handler (err) 249 | (info "corrupted stream" err stream) 250 | (ignore-errors/log (send-object +corrupt-stream-flag+ stream)) 251 | (go :next-task)) 252 | (next-task () 253 | (go :next-task))) 254 | (read-and-process-task 255 | stream #'clean-return #'corrupt-handler #'next-task)) 256 | (go :next-task))) 257 | 258 | ;;;; responses 259 | 260 | (defun respond (message stream) 261 | (ecase message 262 | (:ping (send-object :pong stream)) 263 | (:task-loop (send-object :in-task-loop stream) 264 | (with-task-index 265 | (task-loop stream))) 266 | (:kill-tasks (kill-tasks (receive-object stream))))) 267 | 268 | ;;;; dispatch 269 | 270 | (defun call-respond (message socket) 271 | (with-errors-logged 272 | (unwind-protect/safe 273 | :main (respond message (socket-stream socket)) 274 | :cleanup (socket-close* socket)))) 275 | 276 | (defun spawn-response (message socket) 277 | (make-thread (environment-closure 278 | (call-respond message socket)) 279 | :name (format nil "lfarm-server response ~a" message))) 280 | 281 | (defun dispatch (socket) 282 | (let ((message (receive-object (socket-stream socket)))) 283 | (info "message" message socket) 284 | (case message 285 | (:end-server (socket-close* socket)) 286 | (otherwise (spawn-response message socket))) 287 | message)) 288 | 289 | ;;;; start-server 290 | 291 | (defwith with-auth-error-handler () 292 | (handler-case (call-body) 293 | (lfarm-common.data-transport:auth-error (err) 294 | (info "auth error:" (princ-to-string err)) 295 | nil))) 296 | 297 | (defwith with-server ((:vars server) host port) 298 | (with-errors-logged 299 | (with-bug-handler 300 | (with-connected-socket (server (socket-listen host port)) 301 | (with-task-tracking 302 | (call-body server)))))) 303 | 304 | (defun server-loop (server) 305 | (loop (with-auth-error-handler 306 | (unwind-protect/safe-bind 307 | :bind (socket (socket-accept server)) 308 | :main (case (dispatch socket) 309 | (:end-server (return))) 310 | :abort (socket-close* socket))))) 311 | 312 | (defun %start-server (host port) 313 | (info "server starting" host port *auth*) 314 | (with-server (server host port) 315 | (server-loop server)) 316 | (info "server ending" host port)) 317 | 318 | (defun spawn-server (host port name) 319 | (make-thread (dynamic-closure (*auth*) (%start-server host port)) 320 | :name name)) 321 | 322 | (defun start-server (host port 323 | &key 324 | background 325 | (name (format nil "lfarm-server ~a:~a" host port)) 326 | ((:auth *auth*) *auth*)) 327 | "Start a server instance listening at host:port. 328 | 329 | If `background' is true then spawn the server in a separate thread 330 | named `name'." 331 | (if background 332 | (spawn-server host port name) 333 | (%start-server host port))) 334 | -------------------------------------------------------------------------------- /lfarm-test/cognate-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-test) 32 | 33 | (full-test plet-test 34 | (plet ((x 3) 35 | (y 4)) 36 | (is (= 7 (+ x y)))) 37 | #+lfarm.with-closures 38 | (let ((a 10)) 39 | (plet ((x (+ a 3)) 40 | (y (+ a 4))) 41 | (is (= 27 (+ x y)))))) 42 | 43 | (full-test pmap-into-test 44 | (let ((a (list nil nil nil))) 45 | (pmap-into a '+ '(5 6 7) '(10 11 12)) 46 | (is (equal '(15 17 19) a)) 47 | (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) 48 | (is (equal '(15 17 19) a)) 49 | (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) 50 | (is (equal '(15 17 19) a))) 51 | (let ((a (list nil))) 52 | (pmap-into a '+ '(5 6 7) '(10 11 12)) 53 | (is (equal '(15) a)) 54 | (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) 55 | (is (equal '(15) a)) 56 | (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) 57 | (is (equal '(15) a))) 58 | (let ((a (vector nil nil nil))) 59 | (pmap-into a '+ '(5 6 7) '(10 11 12)) 60 | (is (equalp #(15 17 19) a)) 61 | (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) 62 | (is (equalp #(15 17 19) a)) 63 | (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) 64 | (is (equalp #(15 17 19) a))) 65 | (let ((a (vector nil))) 66 | (pmap-into a '+ '(5 6 7) '(10 11 12)) 67 | (is (equalp #(15) a)) 68 | (pmap-into a '+ :parts 2 '(5 6 7) '(10 11 12)) 69 | (is (equalp #(15) a)) 70 | (pmap-into a '+ :parts 3 '(5 6 7) '(10 11 12)) 71 | (is (equalp #(15) a)))) 72 | 73 | (full-test pmap-test 74 | (is (equalp (map 'vector (lambda (x) (* x x)) #(3 4 5 6)) 75 | (pmap 'vector (lambda (x) (* x x)) #(3 4 5 6)))) 76 | (is (equalp (map 'vector (lambda (x) (* x x)) '(3 4 5 6)) 77 | (pmap 'vector (lambda (x) (* x x)) '(3 4 5 6)))) 78 | #-lfarm.with-text-serializer 79 | (let ((type '(simple-array fixnum (*)))) 80 | (is (equalp (map type (lambda (x) (* x x)) #(3 4 5 6)) 81 | (pmap type (lambda (x) (* x x)) #(3 4 5 6)))) 82 | (is (equalp (map type (lambda (x) (* x x)) '(3 4 5 6)) 83 | (pmap type (lambda (x) (* x x)) '(3 4 5 6)))))) 84 | 85 | (full-test degenerate-pmaps-test 86 | (is (eq (map nil #'identity '(0 1 2 3)) 87 | (pmap nil #'identity '(0 1 2 3)))) 88 | (is (eq (map nil 'identity '(0 1 2 3)) 89 | (pmap nil 'identity '(0 1 2 3)))) 90 | (is (eq (map-into nil '+ '(2 3) '(4 5)) 91 | (pmap-into nil '+ '(2 3) '(4 5)))) 92 | (is (equalp (map 'vector #'identity '(0 1 2 3)) 93 | (pmap 'vector #'identity '(0 1 2 3)))) 94 | (is (equalp (map 'vector 'identity '(0 1 2 3)) 95 | (pmap 'vector 'identity '(0 1 2 3)))) 96 | (is (equalp (map-into nil '+ '(2 3) '(4 5)) 97 | (pmap-into nil '+ '(2 3) '(4 5))))) 98 | 99 | (full-test pmapcar-test 100 | (is (equal '(15 17 19) 101 | (pmapcar '+ '(5 6 7) '(10 11 12)))) 102 | (is (equal '(15 17 19) 103 | (pmapcar '+ :parts 2 '(5 6 7) '(10 11 12))))) 104 | 105 | (full-test pmapcar-handles-sequences-test 106 | (is (equal (mapcar '+ '(1 2 3) '(4 5 6)) 107 | (pmapcar '+ '(1 2 3) #(4 5 6)))) 108 | (is (equal (mapcar '+ '(1 2 3) '(4 5 6)) 109 | (pmapcar '+ :parts 2 '(1 2 3) #(4 5 6))))) 110 | 111 | (deftask sq (x) 112 | (* x x)) 113 | 114 | (local-test pmap-parts-arg-test 115 | (loop for parts from 1 to 8 116 | do (loop for n from 1 to 6 117 | for a = (loop repeat n collect (random n)) 118 | do (is (equalp ( map-into (make-array n) #'sq a) 119 | (pmap-into (make-array n) #'sq :parts parts a))) 120 | (is (equal ( map-into (make-list n) #'sq a) 121 | (pmap-into (make-list n) #'sq :parts parts a))) 122 | (is (equalp ( map 'vector #'sq a) 123 | (pmap 'vector #'sq :parts parts a))) 124 | (is (equal ( map 'list #'sq a) 125 | (pmap 'list #'sq :parts parts a))) 126 | (is (equal ( mapcar #'sq a) 127 | (pmapcar #'sq :parts parts a)))))) 128 | 129 | (deftask seven () 130 | 7) 131 | 132 | (full-test pmap-into-thunk-test 133 | (let ((a (make-array 3 :initial-element 1))) 134 | (is (equalp #(9 9 9) 135 | (pmap-into a (lambda () 9)))) 136 | (is (equalp #(7 7 7) 137 | (pmap-into a 'seven))) 138 | (is (equalp #(7 7 7) 139 | (pmap-into a #'seven))) 140 | #+lfarm.with-closures 141 | (let ((c 10)) 142 | (is (equalp #(19 19 19) 143 | (pmap-into a (lambda () (+ c 9)))))))) 144 | 145 | #+lfarm.with-closures 146 | (remote-test pmap-closure-test 147 | (let ((a 10)) 148 | (is (equalp #(11 12 13) 149 | (pmap 'vector (lambda (x) (+ a x)) #(1 2 3)))) 150 | (is (equal '(11 12 13) 151 | (pmapcar (lambda (x) (+ a x)) #(1 2 3)))) 152 | (let ((result (make-array 3))) 153 | (is (equalp #(11 12 13) 154 | (pmap-into result (lambda (x) (+ a x)) #(1 2 3)))) 155 | (is (equalp #(11 12 13) 156 | result))))) 157 | 158 | (full-test pmap-with-size-constraint-test 159 | (is (equal '(2 11) 160 | (pmapcar '1+ :size 2 '(1 10 100 1000)))) 161 | (is (equal '(2 11) 162 | (pmap 'list '1+ :size 2 '(1 10 100 1000)))) 163 | (is (equalp #(2 11) 164 | (pmap 'vector '1+ :size 2 '(1 10 100 1000)))) 165 | (is (equalp #(2 11) 166 | (pmap 'vector '1+ :size 2 #(1 10 100 1000)))) 167 | (is (equalp #(2 11 99 99) 168 | (pmap-into (vector 99 99 99 99) '1+ :size 2 #(1 10 100 1000)))) 169 | (is (equal '(2 11) 170 | (pmap-into (list 'a 'b) '1+ :size 2 '(1 10 100 1000)))) 171 | (is (equal '(2 11 c d) 172 | (pmap-into (list 'a 'b 'c 'd) '1+ :size 2 '(1 10 100 1000))))) 173 | 174 | (full-test pmap-into-edge-test 175 | (is (equalp #(1 2 3) 176 | (pmap-into (vector 9 9 9) 'identity (vector 1 2 3)))) 177 | (is (equalp #(1 2 3) 178 | (pmap-into (vector 9 9 9) 'identity :size 3 (vector 1 2 3)))) 179 | (is (equalp #(1 2 9) 180 | (pmap-into (vector 9 9 9) 'identity :size 2 (vector 1 2 3)))) 181 | (is (equalp #(9 9 9) 182 | (pmap-into (vector 9 9 9) 'identity :size 0 (vector 1 2 3)))) 183 | (is (equalp #(9 9 9) 184 | (pmap-into (vector 9 9 9) 'identity (vector)))) 185 | (is (equalp #() 186 | (pmap-into (vector) 'identity (vector 1 2 3)))) 187 | (let ((v (make-array 3 :fill-pointer 0))) 188 | (is (equalp #(1 2 3) 189 | (pmap-into v 'identity (vector 1 2 3)))) 190 | (is (equalp #(1 2 3) v))) 191 | (let ((v (make-array 3 :fill-pointer 0))) 192 | (is (equalp #(1 2) 193 | (pmap-into v 'identity (vector 1 2)))) 194 | (is (equalp #(1 2) v))) 195 | (let ((v (make-array 3 :fill-pointer 3))) 196 | (is (equalp #(1 2) 197 | (pmap-into v 'identity (vector 1 2)))) 198 | (is (equalp #(1 2) v))) 199 | (let ((v (make-array 3 :fill-pointer 3))) 200 | (is (equalp #(1) 201 | (pmap-into v 'identity :size 1 (vector 1 2)))) 202 | (is (equalp #(1) v)))) 203 | 204 | (deftask mul3 (x y z) 205 | (* x y z)) 206 | 207 | (full-test grind-pmap-test 208 | (dotimes (n 100) 209 | (let ((a (map-into (make-array n) (let ((i 0)) 210 | (lambda () 211 | (incf i))))) 212 | (b (map-into (make-array n) (let ((i 10)) 213 | (lambda () 214 | (incf i))))) 215 | (c (map-into (make-array n) (let ((i 20)) 216 | (lambda () 217 | (incf i)))))) 218 | (is (equalp (map 'vector #'mul3 a b c) 219 | (pmap 'vector #'mul3 a b c)))))) 220 | 221 | (full-test preduce-partial-test 222 | (signals simple-error 223 | (preduce-partial #'+ #() :initial-value 0)) 224 | (signals simple-error 225 | (preduce-partial #'+ '() :initial-value 0)) 226 | (signals simple-error 227 | (preduce-partial #'+ '())) 228 | (is (equalp (preduce-partial #'+ '(3 4 5 6 7 8 9 10) :parts 1) 229 | #(52))) 230 | (is (equalp (preduce-partial #'+ '(3 4 5 6 7 8 9 10) :parts 2) 231 | #(18 34))) 232 | (is (equalp (preduce-partial #'+ '(3 4 5 6 7 8 9 10) :parts 2 :from-end t) 233 | #(18 34))) 234 | (is (equalp (preduce-partial #'+ #(3 4 5 6 7 8) :parts 3 :from-end t) 235 | #(7 11 15))) 236 | (is (equalp (preduce-partial #'+ #(3 4 5 6 7 8) :parts 3) 237 | #(7 11 15)))) 238 | 239 | (deftask associative/non-commutative (a b) 240 | (vector (+ (* (aref a 0) (aref b 0)) (* (aref a 1) (aref b 2))) 241 | (+ (* (aref a 0) (aref b 1)) (* (aref a 1) (aref b 3))) 242 | (+ (* (aref a 2) (aref b 0)) (* (aref a 3) (aref b 2))) 243 | (+ (* (aref a 2) (aref b 1)) (* (aref a 3) (aref b 3))))) 244 | 245 | (defmacro collect-n (n &body body) 246 | "Execute `body' `n' times, collecting the results into a list." 247 | `(loop repeat ,n collect (progn ,@body))) 248 | 249 | (full-test preduce-test 250 | (is (equalp (reduce (lambda (x y) (+ x y)) #(1 2 3 4 5 6)) 251 | (preduce (lambda (x y) (+ x y)) #(1 2 3 4 5 6)))) 252 | #+lfarm.with-closures 253 | (let ((z 10)) 254 | (is (equalp (reduce (lambda (x y) (+ x y z)) #(1 2 3 4 5 6)) 255 | (preduce (lambda (x y) (+ x y z)) #(1 2 3 4 5 6))))) 256 | (let ((a '(0 1 2 3 4 5 6 7)) 257 | (b '((9 . 0) (9 . 1) (9 . 2) (9 . 3))) 258 | (c (collect-n 20 (random 100))) 259 | (d (collect-n 20 (vector (random 10) 260 | (random 10) 261 | (random 10) 262 | (random 10))))) 263 | (macrolet 264 | ((verify (test &rest args) 265 | `(loop for parts from 1 to 10 266 | do (is (funcall ,test 267 | (reduce ,@args) 268 | (preduce ,@args))) 269 | (is (funcall ,test 270 | (reduce ,@args) 271 | (preduce ,@args :from-end t)))))) 272 | (verify #'= #'+ a) 273 | (verify #'= #'+ a :initial-value 0) 274 | (verify #'= #'+ b :key #'cdr) 275 | (verify #'= #'+ c) 276 | (verify #'= #'+ c :initial-value 0) 277 | (verify #'= #'+ c :start 5) 278 | (verify #'= #'+ c :end 5) 279 | (verify #'= #'+ c :start 5 :end 16) 280 | (verify #'= #'+ c :start 5 :end 16 :from-end t) 281 | (verify #'= #'+ c :start 5 :end 16 :initial-value 0) 282 | (verify #'= #'* c :start 5 :end 16 :initial-value 1) 283 | (verify #'= #'* c :start 5 :end 16 :initial-value 1 :from-end t) 284 | 285 | (verify #'equalp #'associative/non-commutative d) 286 | (verify #'equalp #'associative/non-commutative d :start 5) 287 | (verify #'equalp #'associative/non-commutative d :end 5) 288 | (verify #'equalp #'associative/non-commutative d :start 5 :end 16) 289 | (verify #'equalp 290 | #'associative/non-commutative d 291 | :start 5 292 | :end 16 293 | :initial-value (vector 1 0 0 1)) 294 | (verify #'equalp 295 | #'associative/non-commutative d 296 | :start 5 297 | :end 16 298 | :initial-value (vector 1 0 0 1) 299 | :from-end t)))) 300 | 301 | (full-test pmap-reduce-test 302 | (let ((c (collect-n 3 (random 100)))) 303 | (is (equal (preduce #'+ c :key (lambda (x) (* x x))) 304 | (pmap-reduce (lambda (x) (* x x)) #'+ c))) 305 | (is (equal (+ 9 16 25) 306 | (pmap-reduce (lambda (x) (* x x)) #'+ '(3 4 5)))))) 307 | -------------------------------------------------------------------------------- /lfarm-test/kernel-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (in-package #:lfarm-test) 32 | 33 | (full-test basic-test 34 | (submit-task *channel* '+ 3 4) 35 | (is (= 7 (receive-result *channel*))) 36 | (submit-task *channel* '* 5 6) 37 | (is (= 30 (receive-result *channel*))) 38 | (submit-task *channel* #'+ 7 8) 39 | (is (= 15 (receive-result *channel*))) 40 | (submit-task *channel* 'floor 7 3) 41 | (is (= 2 (receive-result *channel*))) 42 | (submit-task *channel* (lambda () (values))) 43 | (is (equal nil (receive-result *channel*))) 44 | (let ((fn '+)) 45 | (submit-task *channel* fn 1 2) 46 | (is (= 3 (receive-result *channel*))))) 47 | 48 | (full-test lambda-test 49 | (submit-task *channel* (lambda (x y) (+ x y)) 3 4) 50 | (is (= 7 (receive-result *channel*))) 51 | (submit-task *channel* #'(lambda (x y) (* x y)) 5 6) 52 | (is (= 30 (receive-result *channel*))) 53 | (submit-task *channel* (lambda () 9)) 54 | (is (= 9 (receive-result *channel*)))) 55 | 56 | (deftask foo (x y) 57 | (+ x y)) 58 | 59 | (deftask* bar (x y) 60 | (* x y)) 61 | 62 | (deftask* fib (n) 63 | (if (< n 2) 64 | n 65 | (+ (fib (- n 1)) 66 | (fib (- n 2))))) 67 | 68 | (deftask add2 (&key x y) 69 | (+ x y)) 70 | 71 | (deftask llk-check (&rest args &key x y z) 72 | (declare (ignore x y z)) 73 | args) 74 | 75 | (full-test deftask-test 76 | (submit-task *channel* 'foo 3 4) 77 | (is (= 7 (receive-result *channel*))) 78 | (submit-task *channel* #'foo 5 6) 79 | (is (= 11 (receive-result *channel*))) 80 | (submit-task *channel* 'bar 3 4) 81 | (is (= 12 (receive-result *channel*))) 82 | (submit-task *channel* #'bar 5 6) 83 | (is (= 30 (receive-result *channel*))) 84 | (let ((f 'foo)) 85 | (submit-task *channel* f 1 2) 86 | (is (= 3 (receive-result *channel*)))) 87 | (let ((f '(lambda (p q) (+ p q)))) 88 | (submit-task *channel* f 1 2) 89 | (is (= 3 (receive-result *channel*)))) 90 | (submit-task *channel* #'fib 10) 91 | (is (= 55 (receive-result *channel*))) 92 | (submit-task *channel* #'add2 :x 1 :y 2) 93 | (is (= 3 (receive-result *channel*))) 94 | (submit-task *channel* #'llk-check :x 1 :y 2 :z 3) 95 | (is (equal '(:x 1 :y 2 :z 3) (receive-result *channel*)))) 96 | 97 | (defvar *somevar* nil) 98 | 99 | (deftask hello (&key world) 100 | world) 101 | 102 | (full-test task-error-test 103 | (submit-task *channel* #'hello :z 9) 104 | (signals task-execution-error 105 | (receive-result *channel*)) 106 | (submit-task *channel* 'blah 3 4) 107 | (signals task-execution-error 108 | (receive-result *channel*)) 109 | (submit-task *channel* (lambda () (+ 3 *somevar*))) 110 | (signals task-execution-error 111 | (receive-result *channel*)) 112 | (submit-task *channel* (lambda () (error "foo"))) 113 | (signals task-execution-error 114 | (receive-result *channel*)) 115 | (setf *somevar* nil) 116 | (submit-task *channel* (lambda () (funcall *somevar*))) 117 | (signals task-execution-error 118 | (receive-result *channel*)) 119 | (let ((f #'foo)) 120 | (signals invalid-task-error 121 | (submit-task *channel* f 1 2)))) 122 | 123 | (defwith with-temp-package (name) 124 | (unwind-protect/safe 125 | :prepare (make-package name) 126 | :main (call-body) 127 | :cleanup (delete-package name))) 128 | 129 | (full-test package-test () 130 | (let ((name :lfarm-test.bar)) 131 | (with-temp-package (name) 132 | (let ((sym (intern "FOO" name))) 133 | (submit-task *channel* (lambda (x) x) sym) 134 | (is (eq sym (receive-result *channel*))))))) 135 | 136 | #+lfarm.with-closures 137 | (full-test package-test/closure () 138 | (let ((name :lfarm-test.bar)) 139 | (with-temp-package (name) 140 | (let ((sym (intern "FOO" name))) 141 | (submit-task *channel* (lambda () sym)) 142 | (is (eq sym (receive-result *channel*))))))) 143 | 144 | (full-test invalid-task-test 145 | (signals invalid-task-error 146 | (submit-task* *channel* #'+)) 147 | (signals invalid-task-error 148 | (submit-task* *channel* '(junk 9))) 149 | (signals invalid-task-error 150 | (broadcast-task* *channel* #'+)) 151 | (signals invalid-task-error 152 | (broadcast-task* *channel* '(junk 9))) 153 | (let ((f #'+)) 154 | (signals invalid-task-error 155 | (submit-task *channel* f 3 4)) 156 | (signals invalid-task-error 157 | (broadcast-task *channel* f 3 4)))) 158 | 159 | (base-test raw-local-test 160 | (let ((host *local-host*) 161 | (port (next-port))) 162 | (with-server (host port) 163 | (with-connection (connection host port) 164 | (let ((stream (socket-stream connection))) 165 | (send-object '(1111 + 3 4) stream) 166 | (is (= 7 (receive-object stream)))))))) 167 | 168 | (base-test raw-remote-test 169 | (let* ((host *remote-host*) 170 | (port (next-port))) 171 | (with-remote-servers (`((,host ,port))) 172 | (with-connection (connection host port) 173 | (let ((stream (socket-stream connection))) 174 | (send-object '(1111 + 3 4) stream) 175 | (is (= 7 (receive-object stream)))))))) 176 | 177 | (remote-test broadcast-test 178 | (is (not (find-package :lfarm-test.foo))) 179 | (broadcast-task (lambda () (make-package :lfarm-test.foo) nil)) 180 | (submit-task *channel* (lambda () (and (find-package :lfarm-test.foo) 3))) 181 | (is (not (find-package :lfarm-test.foo))) 182 | (is (eql 3 (receive-result *channel*)))) 183 | 184 | #-abcl 185 | (base-test reconnect-test 186 | (let ((host *local-host*) 187 | (port (next-port))) 188 | (with-server (host port) 189 | (with-kernel (*kernel* `((,host ,port))) 190 | (let ((channel (make-channel))) 191 | (lparallel:submit-task (lfarm-client.kernel::internal-channel channel) 192 | (lambda () lfarm-client.kernel::*connection*)) 193 | (let ((connection (lparallel:receive-result 194 | (lfarm-client.kernel::internal-channel channel)))) 195 | (lfarm-client.kernel::end-connection connection) 196 | (submit-task channel #'+ 3 4) 197 | (is (= 7 (receive-result channel))))))))) 198 | 199 | (base-test local-ping-test 200 | (let ((host *local-host*) 201 | (port (next-port))) 202 | (with-server (host port) 203 | (is (truep (ping host port)))))) 204 | 205 | (base-test remote-ping-test 206 | (let ((host *remote-host*) 207 | (port (next-port))) 208 | (with-remote-servers (`((,host ,port))) 209 | (is (truep (ping host port)))))) 210 | 211 | #-abcl 212 | (base-test no-server-test 213 | (with-thread-count-check (0.4) 214 | (let ((host *local-host*) 215 | (port (next-port))) 216 | (is (null (ping host port :timeout 1))) 217 | (let (kernel) 218 | (unwind-protect/safe 219 | :main (progn 220 | (bordeaux-threads:make-thread 221 | (lambda () 222 | (setf kernel (make-kernel `((,host ,port)))))) 223 | (sleep 0.4) 224 | (with-server (host port) 225 | (sleep 0.4) 226 | (is (truep kernel)) 227 | (let* ((*kernel* kernel) 228 | (channel (make-channel))) 229 | (submit-task channel '+ 7 8) 230 | (is (= 15 (receive-result channel)))))) 231 | :cleanup (when kernel 232 | (let ((*kernel* kernel)) 233 | (end-kernel :wait t)))))))) 234 | 235 | (remote-test unreadable-result-test 236 | (submit-task *channel* (lambda () 237 | (intern (string '#:blah) 238 | (make-package :abc :use nil)))) 239 | (signals (or type-error reader-error package-error) 240 | (receive-result *channel*))) 241 | 242 | (base-test big-data-test 243 | (let ((addresses `((,*local-host* ,(next-port))))) 244 | (with-local-servers (addresses) 245 | (with-kernel (*kernel* addresses) 246 | (is (= (length addresses) (kernel-worker-count))) 247 | (let ((channel (make-channel)) 248 | (data (make-array 100 :initial-element 9))) 249 | (submit-task channel 250 | (lambda (data) 251 | (map 'vector (lambda (x) (* x x)) data)) 252 | data) 253 | (is (equalp (map 'vector (lambda (x) (* x x)) data) 254 | (receive-result channel)))))))) 255 | 256 | (full-test circular-test 257 | (let ((list (list 1 2 3))) 258 | (setf (cdr (last list)) list) 259 | (submit-task *channel* 260 | (lambda (list) 261 | (+ (first list) (second list) (third list))) 262 | list)) 263 | (is (= 6 (receive-result *channel*)))) 264 | 265 | #-lparallel.without-kill 266 | (base-test kill-test 267 | (let ((addresses `((,*local-host* ,(next-port)) 268 | (,*local-host* ,(next-port))))) 269 | (with-local-servers (addresses) 270 | ;; manually muffle warnings from worker threads 271 | (let ((*error-output* (make-broadcast-stream))) 272 | (with-kernel (kernel addresses) 273 | (let* ((*kernel* kernel) 274 | (*channel* (make-channel))) 275 | (submit-task *channel* #'+ 3 4) 276 | (is (= 7 (receive-result *channel*))) 277 | (let ((lfarm-client:*task-category* 'sleeper)) 278 | (submit-task *channel* 'sleep 9999)) 279 | (sleep 0.2) 280 | (is (= 1 (count 'sleeper (task-categories-running)))) 281 | (kill-tasks 'sleeper) 282 | (sleep 0.2) 283 | (is (every #'null (task-categories-running))) 284 | (signals task-killed-error 285 | (receive-result *channel*)) 286 | (submit-task *channel* #'+ 5 6) 287 | (is (= 11 (receive-result *channel*))) 288 | (sleep 2))))))) 289 | 290 | (base-test kernel-error-test 291 | (let ((host *local-host*) 292 | (port (next-port)) 293 | (handler-called-p nil) 294 | (*kernel* nil)) 295 | (with-server (host port) 296 | (signals no-kernel-error 297 | (make-channel)) 298 | (with-kernel (kernel `((,host ,port))) 299 | (let ((channel (handler-bind 300 | ((no-kernel-error 301 | (lambda (err) 302 | (declare (ignore err)) 303 | (setf handler-called-p t) 304 | (invoke-restart 'store-value kernel)))) 305 | (make-channel)))) 306 | (submit-task channel '+ 4 5) 307 | (is (not (null handler-called-p))) 308 | (is (= 9 (receive-result channel)))))))) 309 | 310 | (local-test submit-timeout-test 311 | (let ((channel (make-channel))) 312 | (submit-timeout channel 0.1 'timeout) 313 | (submit-task channel (lambda () 3)) 314 | (is (eql 3 (receive-result channel))) 315 | (is (eq 'timeout (receive-result channel))))) 316 | 317 | #-lparallel.without-kill 318 | (local-test cancel-timeout-test 319 | (let* ((channel (make-channel)) 320 | (timeout (submit-timeout channel 999 'timeout))) 321 | (sleep 0.2) 322 | (cancel-timeout timeout 'a) 323 | (is (eq 'a (receive-result channel))))) 324 | 325 | (local-test try-receive-test 326 | (multiple-value-bind (a b) (try-receive-result *channel*) 327 | (is (null a)) 328 | (is (null b))) 329 | (submit-task *channel* (lambda () 3)) 330 | (sleep 0.5) 331 | (multiple-value-bind (a b) (try-receive-result *channel*) 332 | (is (eq t b)) 333 | (is (= 3 a))) 334 | (multiple-value-bind (a b) (try-receive-result *channel*) 335 | (is (null a)) 336 | (is (null b)))) 337 | 338 | #-lparallel.without-bordeaux-threads-condition-wait-timeout 339 | (local-test try-receive-result-timeout-test 340 | (submit-task *channel* 341 | (lambda () 342 | (sleep 1.0) 343 | 99)) 344 | (let ((flag nil)) 345 | (make-thread (lambda () 346 | (sleep 0.25) 347 | (setf flag t))) 348 | (multiple-value-bind (a b) (try-receive-result *channel* :timeout 0.5) 349 | (is (null a)) 350 | (is (null b))) 351 | (is (eq t flag)) 352 | (multiple-value-bind (a b) (try-receive-result *channel* :timeout 1.0) 353 | (is (= 99 a)) 354 | (is (eq t b))))) 355 | 356 | (local-test multi-receive-test 357 | (submit-task *channel* '+ 3 4) 358 | (submit-task *channel* '+ 5 6) 359 | (submit-task *channel* '+ 7 8) 360 | (let ((results nil)) 361 | (do-fast-receives (r *channel* 3) 362 | (push r results)) 363 | (is (equal '(7 11 15) (sort results #'<))))) 364 | 365 | (full-test many-task-test 366 | (let ((n (ecase *log-level* 367 | (:info 5) 368 | (:error 1000)))) 369 | (repeat n 370 | (submit-task *channel* (lambda ())) 371 | (is (null (receive-result *channel*)))) 372 | (repeat n 373 | (submit-task *channel* (lambda ()))) 374 | (repeat n 375 | (is (null (receive-result *channel*)))) 376 | (repeat n 377 | (let ((*task-priority* :low)) 378 | (submit-task *channel* (lambda ()))) 379 | (is (null (receive-result *channel*)))) 380 | (repeat n 381 | (let ((*task-priority* :low)) 382 | (submit-task *channel* (lambda ())))) 383 | (repeat n 384 | (is (null (receive-result *channel*)))))) 385 | 386 | (base-test task-categories-test 387 | (with-local-setup (2) 388 | (is (notany #'identity (task-categories-running))) 389 | (let ((channel (make-channel))) 390 | (submit-task channel (lambda () (sleep 0.4))) 391 | (sleep 0.2) 392 | (is (eql 1 (count :default (task-categories-running)))))) 393 | (with-local-setup (2) 394 | (let ((channel (make-channel))) 395 | (let ((*task-category* :foo)) 396 | (submit-task channel (lambda () (sleep 0.4)))) 397 | (sleep 0.2) 398 | (is (eql 1 (count :foo (task-categories-running)))))) 399 | (with-local-setup (2) 400 | (let ((channel (make-channel))) 401 | (let ((*task-category* 999)) 402 | (submit-task channel (lambda () (sleep 0.4)))) 403 | (sleep 0.2) 404 | (is (eql 1 (count 999 (task-categories-running)))))) 405 | (with-local-setup (2) 406 | (let ((channel (make-channel))) 407 | (let ((*task-category* :foo)) 408 | (submit-task channel (lambda () (sleep 0.4))) 409 | (submit-task channel (lambda () (sleep 0.4)))) 410 | (sleep 0.2) 411 | (is (eql 2 (count :foo (task-categories-running))))))) 412 | 413 | (defparameter *nil* nil) 414 | 415 | #-lparallel.without-kill 416 | (base-test default-kill-task-test 417 | (let ((*error-output* (make-broadcast-stream))) 418 | (with-local-setup (2) 419 | (submit-task *channel* (lambda () (loop until *nil*))) 420 | (submit-task *channel* (lambda () (loop until *nil*))) 421 | (sleep 0.2) 422 | (submit-task *channel* (lambda () 'survived)) 423 | (sleep 0.2) 424 | (kill-tasks *task-category*) 425 | (sleep 0.2) 426 | (let ((errors nil) 427 | (regulars nil)) 428 | (repeat 3 429 | (handler-case (push (receive-result *channel*) regulars) 430 | (task-killed-error (e) 431 | (push e errors)))) 432 | (is (= 2 (length errors))) 433 | (is (equal '(survived) regulars)))))) 434 | 435 | #-lparallel.without-kill 436 | (base-test custom-kill-task-test 437 | (let ((*error-output* (make-broadcast-stream))) 438 | (with-remote-setup (2) 439 | (let ((*task-category* 'blah)) 440 | (submit-task *channel* (lambda () 441 | (let ((*nil* nil)) 442 | (declare (special *nil*)) 443 | (loop until *nil*)))) 444 | (submit-task *channel* (lambda () 445 | (let ((*nil* nil)) 446 | (declare (special *nil*)) 447 | (loop until *nil*))))) 448 | (sleep 0.2) 449 | (submit-task *channel* (lambda () 'survived)) 450 | (sleep 0.2) 451 | (kill-tasks 'blah) 452 | (sleep 0.2) 453 | (let ((errors nil) 454 | (regulars nil)) 455 | (repeat 3 456 | (handler-case (push (receive-result *channel*) regulars) 457 | (task-killed-error (e) 458 | (push e errors)))) 459 | (is (= 2 (length errors))) 460 | (is (equal '(survived) regulars)))))) 461 | 462 | (local-test submit-after-end-kernel-test 463 | (let ((channel (make-channel))) 464 | (end-kernel :wait t) 465 | (signals error 466 | (submit-task channel (lambda ()))))) 467 | 468 | (local-test double-end-kernel-test 469 | (let ((addresses `((,*local-host* ,(next-port)) 470 | (,*local-host* ,(next-port))))) 471 | (with-local-servers (addresses) 472 | (let* ((kernel (make-kernel addresses)) 473 | (*kernel* kernel)) 474 | (end-kernel :wait t) 475 | (let ((*kernel* kernel)) 476 | (end-kernel :wait t))))) 477 | ;; got here without an error 478 | (is (= 1 1))) 479 | 480 | (defparameter *memo* nil) 481 | 482 | #-lparallel.without-kill 483 | (base-test resubmit-test 484 | (setf *memo* 0) 485 | (with-local-setup (1) 486 | (submit-task *channel* (lambda () 487 | (incf *memo*) 488 | (sleep 0.6) 489 | :done)) 490 | (sleep 0.2) 491 | (dolist (thread (bordeaux-threads:all-threads)) 492 | (when (string= "lfarm-server response TASK-LOOP" 493 | (bordeaux-threads:thread-name thread)) 494 | (bordeaux-threads:destroy-thread thread))) 495 | (is (eq :done (receive-result *channel*))) 496 | (is (= 2 *memo*)))) 497 | -------------------------------------------------------------------------------- /lfarm-client/cognate.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2013, James M. Lawrence. All rights reserved. 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials provided 13 | ;;; with the distribution. 14 | ;;; 15 | ;;; * Neither the name of the project nor the names of its 16 | ;;; contributors may be used to endorse or promote products derived 17 | ;;; from this software without specific prior written permission. 18 | ;;; 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | ;;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | (defpackage #:lfarm-client.cognate 32 | (:documentation 33 | "Promises and futures.") 34 | (:use #:cl 35 | #:lfarm-common 36 | #:lfarm-client.kernel 37 | #:lfarm-client.promise) 38 | (:export #:plet 39 | #:pmap 40 | #:pmapcar 41 | #:pmap-into 42 | #:preduce 43 | #:preduce-partial 44 | #:pmap-reduce) 45 | (:import-from #:lfarm-client.kernel 46 | #:maybe-convert-task 47 | #:maybe-convert-task-form)) 48 | 49 | (in-package #:lfarm-client.cognate) 50 | 51 | ;;;; plet 52 | 53 | (defun pairp (form) 54 | (and (consp form) (eql (length form) 2))) 55 | 56 | (defun parse-bindings (bindings) 57 | (let* ((pairs (remove-if-not #'pairp bindings)) 58 | (non-pairs (remove-if #'pairp bindings)) 59 | (syms (loop for (name nil) in pairs 60 | collect (gensym (symbol-name name))))) 61 | (values pairs non-pairs syms))) 62 | 63 | (defmacro plet (bindings &body body) 64 | "The syntax of `plet' matches that of `let'. 65 | 66 | plet ({var-no-init | (var [init-form])}*) form* 67 | 68 | For each (var init-form) pair, a future is created which executes 69 | `init-form'. Inside `body', `var' is a symbol macro which expands to a 70 | `force' form for the corresponding future. 71 | 72 | Each `var-no-init' is bound to nil and each `var' without `init-form' 73 | is bound to nil (no future is created)." 74 | (multiple-value-bind (pairs non-pairs syms) (parse-bindings bindings) 75 | `(symbol-macrolet ,(loop for sym in syms 76 | for (name nil) in pairs 77 | collect `(,name (force ,sym))) 78 | (let (,@(loop for sym in syms 79 | for (nil form) in pairs 80 | collect `(,sym (future ,form))) 81 | ,@non-pairs) 82 | ,@body)))) 83 | 84 | ;;;; subdivide 85 | 86 | (defun find-num-parts (size parts-hint) 87 | (multiple-value-bind (quo rem) (floor size parts-hint) 88 | (values (if (zerop quo) rem parts-hint) quo rem))) 89 | 90 | (defmacro with-parts (seq-size parts-hint &body body) 91 | (with-gensyms (quo rem index num-parts part-offset part-size) 92 | `(multiple-value-bind 93 | (,num-parts ,quo ,rem) (find-num-parts ,seq-size ,parts-hint) 94 | (let ((,index 0) 95 | (,part-offset 0) 96 | (,part-size 0)) 97 | (flet ((next-part () 98 | (when (< ,index ,num-parts) 99 | (unless (zerop ,index) 100 | (incf ,part-offset ,part-size)) 101 | (setf ,part-size (if (< ,index ,rem) (1+ ,quo) ,quo)) 102 | (incf ,index))) 103 | (part-size () ,part-size) 104 | (part-offset () ,part-offset) 105 | (num-parts () ,num-parts)) 106 | (declare (inline part-size part-offset num-parts) 107 | (ignorable #'part-size #'part-offset #'num-parts)) 108 | ,@body))))) 109 | 110 | (defun zip/vector (seqs) 111 | (apply #'map 'vector #'list seqs)) 112 | 113 | (defun find-min-length (seqs) 114 | (reduce #'min seqs :key #'length)) 115 | 116 | (defun get-parts-hint (parts-hint) 117 | (cond (parts-hint 118 | (check-type parts-hint (integer 1 #.most-positive-fixnum)) 119 | parts-hint) 120 | (t 121 | (kernel-worker-count)))) 122 | 123 | (defmacro pop-plist (list) 124 | `(loop while (keywordp (car ,list)) 125 | collect (pop ,list) 126 | collect (pop ,list))) 127 | 128 | (defun %parse-options (args) 129 | (destructuring-bind (&key size parts) (pop-plist args) 130 | (values args size parts))) 131 | 132 | (defun parse-options (args) 133 | (multiple-value-bind (seqs size parts) (%parse-options args) 134 | (unless seqs 135 | (error "Input sequence(s) for parallelization not found.")) 136 | (unless size 137 | (setf size (find-min-length seqs))) 138 | (setf parts (get-parts-hint parts)) 139 | (values seqs size parts))) 140 | 141 | (defmacro with-parsed-options ((args size parts) &body body) 142 | `(multiple-value-bind (,args ,size ,parts) (parse-options ,args) 143 | ,@body)) 144 | 145 | (defun subdivide-array (array size parts-hint) 146 | ;; Create copies, in contradistinction to lparallel. Otherwise we 147 | ;; send unnecessary data over the wire. A serialized displaced 148 | ;; vector includes its displaced-to vector. 149 | (with-parts size parts-hint 150 | (map-into (make-array (num-parts)) 151 | (lambda () 152 | (next-part) 153 | (replace (make-array (part-size) 154 | :element-type (array-element-type array)) 155 | array 156 | :start2 (part-offset)))))) 157 | 158 | (defun subdivide-list (list size parts-hint) 159 | ;; Create copies, in contradistinction to lparallel. Otherwise we 160 | ;; send unnecessary data over the wire. 161 | (with-parts size parts-hint 162 | (loop with p = list 163 | while (next-part) 164 | collect (loop repeat (part-size) 165 | collect (car p) 166 | do (setf p (cdr p)))))) 167 | 168 | (defun make-parts (result size parts-hint) 169 | (etypecase result 170 | (list (subdivide-list result size parts-hint)) 171 | (vector (subdivide-array result size parts-hint)))) 172 | 173 | (defun make-input-parts (sequences size parts-hint) 174 | "Subdivide and interleave sequences for parallel mapping." 175 | (zip/vector (mapcar (lambda (seq) (make-parts seq size parts-hint)) 176 | sequences))) 177 | 178 | ;;;; task util 179 | 180 | (defun receive-indexed (channel count) 181 | (loop with result = (make-array count) 182 | repeat count 183 | do (destructuring-bind (index . data) (receive-result channel) 184 | (setf (aref result index) data)) 185 | finally (return result))) 186 | 187 | (defun task->fn-form (task) 188 | (etypecase task 189 | (symbol `',task) 190 | (cons task))) 191 | 192 | (defmacro funcall-task (task &rest args) 193 | (with-gensyms (channel) 194 | `(let ((,channel (make-channel))) 195 | (submit-task ,channel ,task ,@args) 196 | (receive-result ,channel)))) 197 | 198 | ;;;; pmap 199 | 200 | (defwith with-max-fill-pointer (seq) 201 | (if (and (vectorp seq) 202 | (array-has-fill-pointer-p seq)) 203 | (let ((prev-fill-pointer (fill-pointer seq))) 204 | (unwind-protect/safe 205 | :prepare (setf (fill-pointer seq) (array-total-size seq)) 206 | :main (call-body) 207 | :cleanup (setf (fill-pointer seq) prev-fill-pointer))) 208 | (call-body))) 209 | 210 | (defun mapping-task (subresult-type task) 211 | `(lambda (subseqs part-index part-size) 212 | (cons part-index (apply #'map-into 213 | (make-sequence ',subresult-type part-size) 214 | ,(task->fn-form task) 215 | subseqs)))) 216 | 217 | (defun subresult-type (result-seq) 218 | (let ((element-type (etypecase result-seq 219 | (list t) 220 | (vector (array-element-type result-seq))))) 221 | `(simple-array ,element-type (*)))) 222 | 223 | (defun pmap-into/submit (channel result-seq task sequences size parts-hint) 224 | (let* ((task (maybe-convert-task task)) 225 | (mapping-task (mapping-task (subresult-type result-seq) task)) 226 | (input-parts (make-input-parts sequences size parts-hint))) 227 | (with-parts size parts-hint 228 | (loop for subseqs across input-parts 229 | for part-index from 0 230 | while (next-part) 231 | do (submit-task channel mapping-task subseqs 232 | part-index (part-size)))))) 233 | 234 | (defun pmap-into/receive (channel result-seq size parts-hint) 235 | (with-parts size parts-hint 236 | (let ((result-parts (receive-indexed channel (num-parts)))) 237 | (with-max-fill-pointer (result-seq) 238 | (loop for index from 0 239 | while (next-part) 240 | do (replace result-seq (aref result-parts index) 241 | :start1 (part-offset) 242 | :end1 (+ (part-offset) (part-size)))))))) 243 | 244 | (defun pmap-into/parsed (result-seq task sequences size parts-hint) 245 | (let ((channel (make-channel))) 246 | (pmap-into/submit channel result-seq task sequences size parts-hint) 247 | (pmap-into/receive channel result-seq size parts-hint)) 248 | result-seq) 249 | 250 | (defun pmap/parsed (result-type function sequences size parts-hint) 251 | ;; do nothing for (pmap nil ...) 252 | (when result-type 253 | (pmap-into/parsed (make-sequence result-type size) 254 | function 255 | sequences 256 | size 257 | parts-hint))) 258 | 259 | (defun pmap/unparsed (result-type function sequences) 260 | (with-parsed-options (sequences size parts-hint) 261 | (pmap/parsed result-type function sequences size parts-hint))) 262 | 263 | (defun pmap/fn (result-type task first-sequence &rest more-sequences) 264 | (pmap/unparsed result-type task (cons first-sequence more-sequences))) 265 | 266 | (defmacro pmap (result-type task first-sequence &rest more-sequences 267 | &environment env) 268 | "Parallel version of `map'. Keyword arguments `parts' and `size' are 269 | also accepted. 270 | 271 | The `parts' option divides each sequence into `parts' number of parts. 272 | Default is (kernel-worker-count). 273 | 274 | The `size' option limits the number of elements mapped to `size'. When 275 | given, no `length' calls are made on the sequence(s) passed. 276 | 277 | Warning: `size' must be less than or equal to the length of the 278 | smallest sequence passed. It is unspecified what happens when that 279 | condition is not met." 280 | `(pmap/fn ,result-type 281 | ,(maybe-convert-task-form task env) 282 | ,first-sequence 283 | ,@more-sequences)) 284 | 285 | (defun pmapcar/fn (task first-sequence &rest more-sequences) 286 | (apply #'pmap/fn 'list task (cons first-sequence more-sequences))) 287 | 288 | (defmacro pmapcar (task first-sequence &rest more-sequences 289 | &environment env) 290 | "Parallel version of `mapcar'. Keyword arguments `parts' and `size' 291 | are also accepted (see `pmap'). 292 | 293 | Unlike `mapcar', `pmapcar' also accepts vectors." 294 | `(pmap/fn 'list 295 | ,(maybe-convert-task-form task env) 296 | ,first-sequence 297 | ,@more-sequences)) 298 | 299 | (defun pmap-into-thunk-form (task) 300 | (with-gensyms (x) 301 | (etypecase task 302 | (cons (destructuring-bind (head lambda-list &rest body) task 303 | (assert (eq head 'lambda)) 304 | `(lambda (,x ,@lambda-list) 305 | (declare (ignore ,x)) 306 | ,@body)))))) 307 | 308 | (defun pmap-into/unparsed (result-seq task args) 309 | (let ((task (maybe-convert-task task))) 310 | (multiple-value-bind (seqs size parts-hint) (%parse-options args) 311 | (let* ((has-fill-p (and (arrayp result-seq) 312 | (array-has-fill-pointer-p result-seq))) 313 | (parts-hint (get-parts-hint parts-hint)) 314 | (size (or size 315 | (let ((limit (if has-fill-p 316 | (array-total-size result-seq) 317 | (length result-seq)))) 318 | (if seqs 319 | (min limit (find-min-length seqs)) 320 | limit))))) 321 | (prog1 (if seqs 322 | (pmap-into/parsed result-seq task seqs 323 | size parts-hint) 324 | (pmap-into/parsed result-seq 325 | (pmap-into-thunk-form task) 326 | (list result-seq) 327 | size 328 | parts-hint)) 329 | (when has-fill-p 330 | (setf (fill-pointer result-seq) size))))))) 331 | 332 | (defun pmap-into/fn (result-sequence task &rest sequences) 333 | (typecase result-sequence 334 | ((or array list) 335 | (pmap-into/unparsed result-sequence task sequences)) 336 | (t 337 | (apply #'map-into result-sequence task sequences))) 338 | result-sequence) 339 | 340 | (defmacro pmap-into (result-sequence task &rest sequences &environment env) 341 | "Parallel version of `map-into'. Keyword arguments `parts' and 342 | `size' are also accepted (see `pmap')." 343 | `(pmap-into/fn ,result-sequence 344 | ,(maybe-convert-task-form task env) 345 | ,@sequences)) 346 | 347 | ;;;; preduce 348 | 349 | (defun reducing-task (task keyword-args) 350 | (let ((keyword-args (copy-list keyword-args))) 351 | (when-let (key (getf keyword-args :key)) 352 | (setf (getf keyword-args :key) (task->fn-form key))) 353 | `(lambda (sequence start end result-index) 354 | (cons result-index 355 | (reduce ,(task->fn-form task) sequence 356 | :start start 357 | :end end 358 | ,@keyword-args))))) 359 | 360 | (defun preduce-partial/vector (task sequence start size parts 361 | &rest keyword-args) 362 | (let ((reducing-task (reducing-task task keyword-args)) 363 | (channel (make-channel))) 364 | (with-parts size parts 365 | (loop for result-index from 0 366 | while (next-part) 367 | do (submit-task channel 368 | reducing-task 369 | sequence 370 | (+ start (part-offset)) 371 | (+ start (part-offset) (part-size)) 372 | result-index)) 373 | (receive-indexed channel (num-parts))))) 374 | 375 | (defun preduce-partial/list (task sequence start size parts 376 | &rest keyword-args) 377 | (let ((reducing-task (reducing-task task keyword-args)) 378 | (channel (make-channel))) 379 | (with-parts size parts 380 | (loop with subseq = (nthcdr start sequence) 381 | for result-index from 0 382 | while (next-part) 383 | do (submit-task channel 384 | reducing-task 385 | subseq 386 | 0 387 | (part-size) 388 | result-index) 389 | (setf subseq (nthcdr (part-size) subseq))) 390 | (receive-indexed channel (num-parts))))) 391 | 392 | (defun %preduce-partial (task sequence start size parts 393 | &rest keyword-args) 394 | (etypecase sequence 395 | (vector (apply #'preduce-partial/vector 396 | task sequence start size parts keyword-args)) 397 | (list (apply #'preduce-partial/list 398 | task sequence start size parts keyword-args)))) 399 | 400 | (defun reduce/remote (task results) 401 | (funcall-task `(lambda (results) 402 | (reduce ,(task->fn-form task) results)) 403 | results)) 404 | 405 | (defun preduce/common (task sequence subsize 406 | &key 407 | key 408 | from-end 409 | (start 0) 410 | end 411 | (initial-value nil initial-value-given-p) 412 | parts 413 | recurse 414 | partial) 415 | (declare (ignore end)) 416 | (let ((task (maybe-convert-task task))) 417 | (cond ((zerop subsize) 418 | (when partial 419 | (error "PREDUCE-PARTIAL given zero-length sequence")) 420 | (if initial-value-given-p 421 | initial-value 422 | (funcall-task task))) 423 | (t 424 | (let* ((parts-hint (get-parts-hint parts)) 425 | (results (apply #'%preduce-partial 426 | task sequence start subsize parts-hint 427 | :key key 428 | :from-end from-end 429 | (when initial-value-given-p 430 | (list :initial-value initial-value))))) 431 | (if partial 432 | results 433 | (let ((new-size (length results))) 434 | (if (and recurse (>= new-size 4)) 435 | (apply #'preduce/common 436 | task 437 | results 438 | new-size 439 | :from-end from-end 440 | :parts (min parts-hint (floor new-size 2)) 441 | :recurse recurse 442 | (when initial-value-given-p 443 | (list :initial-value initial-value))) 444 | (reduce/remote task results))))))))) 445 | 446 | (defun subsize (seq size start end) 447 | (let ((result (- (or end size) start))) 448 | (when (or (minusp result) (> result size)) 449 | (error "Bad interval for sequence operation on ~a: start=~a end=~a" 450 | seq start end)) 451 | result)) 452 | 453 | (defun preduce/fn (task sequence &rest args 454 | &key key from-end (start 0) end initial-value parts recurse) 455 | (declare (ignore key from-end initial-value parts recurse)) 456 | (etypecase sequence 457 | ((or vector list) 458 | (apply #'preduce/common 459 | task 460 | sequence 461 | (subsize sequence (length sequence) start end) 462 | args)))) 463 | 464 | (defun maybe-convert-key-form (keyword-args env) 465 | (let ((keyword-args (copy-list keyword-args))) 466 | (when-let (key (getf keyword-args :key)) 467 | (setf (getf keyword-args :key) (maybe-convert-task-form key env))) 468 | keyword-args)) 469 | 470 | (defmacro preduce (task sequence &rest args 471 | &key key from-end (start 0) end initial-value parts recurse 472 | &environment env) 473 | "Parallel version of `reduce'. 474 | 475 | `preduce' subdivides the input sequence into `parts' number of parts 476 | and, in parallel, calls `reduce' on each part. The partial results are 477 | then reduced again, either by `reduce' (the default) or, if `recurse' 478 | is non-nil, by `preduce'. 479 | 480 | `parts' defaults to (kernel-worker-count). 481 | 482 | `key' is thrown out while reducing the partial results. It applies to 483 | the first pass only. 484 | 485 | `start' and `end' have the same meaning as in `reduce'. 486 | 487 | `from-end' means \"from the end of each part\". 488 | 489 | `initial-value' means \"initial value of each part\"." 490 | (declare (ignore key from-end start end initial-value parts recurse)) 491 | `(preduce/fn ,(maybe-convert-task-form task env) 492 | ,sequence 493 | ,@(maybe-convert-key-form args env))) 494 | 495 | (defun preduce-partial/fn (task sequence &rest args 496 | &key key from-end (start 0) end initial-value parts) 497 | (declare (ignore key from-end initial-value parts)) 498 | (apply #'preduce/common 499 | task 500 | sequence 501 | (subsize sequence (length sequence) start end) 502 | :partial t 503 | args)) 504 | 505 | (defmacro preduce-partial (task sequence &rest args 506 | &key key from-end (start 0) end initial-value parts 507 | &environment env) 508 | "Like `preduce' but only does a single reducing pass. 509 | 510 | The length of `sequence' must not be zero. 511 | 512 | Returns the partial results as a vector." 513 | (declare (ignore key from-end start end initial-value parts)) 514 | `(preduce-partial/fn ,(maybe-convert-task-form task env) 515 | ,sequence 516 | ,@(maybe-convert-key-form args env))) 517 | 518 | (defmacro pmap-reduce (map-function reduce-function sequence 519 | &rest args 520 | &key start end initial-value parts recurse) 521 | "Equivalent to (preduce reduce-function sequence :key map-function ...)." 522 | (declare (ignore start end initial-value parts recurse)) 523 | `(preduce ,reduce-function ,sequence :key ,map-function ,@args)) 524 | --------------------------------------------------------------------------------