├── cmdline.lisp ├── test ├── a.lisp ├── b.lisp ├── c.lisp ├── d.lisp ├── e.lisp └── blueprint ├── modules ├── git │ ├── package.lisp │ ├── forge-module-git.asd │ └── git.lisp └── lisp │ ├── package.lisp │ ├── forge-module-lisp.asd │ └── lisp.lisp ├── client ├── package.lisp ├── forge-client.asd ├── client.lisp ├── server.lisp └── network.lisp ├── README.md ├── test.lisp ├── support ├── fork.lisp ├── package.lisp ├── forge-support.asd ├── socket.lisp ├── environment.lisp ├── process.lisp └── toolkit.lisp ├── communication ├── forge-communication.asd ├── package.lisp ├── in-process.lisp ├── tcp.lisp ├── communication.lisp └── binary.lisp ├── forge.asd ├── icon.svg ├── tcp.lisp ├── dot.lisp ├── realization.lisp ├── logo.svg ├── package.lisp ├── module.lisp ├── blueprint.lisp ├── version.lisp ├── toolkit.lisp ├── README.mess ├── project.lisp ├── plan.lisp ├── constraints.lisp ├── network.lisp └── basic.lisp /cmdline.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge) 2 | -------------------------------------------------------------------------------- /test/a.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel) 2 | (print '(:compile :a)) 3 | (finish-output)) 4 | (eval-when (:load-toplevel) 5 | (print '(:load :a)) 6 | (finish-output)) 7 | (eval-when (:execute) 8 | (print '(:execute :a)) 9 | (finish-output)) 10 | -------------------------------------------------------------------------------- /test/b.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel) 2 | (print '(:compile :b)) 3 | (finish-output)) 4 | (eval-when (:load-toplevel) 5 | (print '(:load :b)) 6 | (finish-output)) 7 | (eval-when (:execute) 8 | (print '(:execute :b)) 9 | (finish-output)) 10 | -------------------------------------------------------------------------------- /test/c.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel) 2 | (print '(:compile :c)) 3 | (finish-output)) 4 | (eval-when (:load-toplevel) 5 | (print '(:load :c)) 6 | (finish-output)) 7 | (eval-when (:execute) 8 | (print '(:execute :c)) 9 | (finish-output)) 10 | -------------------------------------------------------------------------------- /test/d.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel) 2 | (print '(:compile :d)) 3 | (finish-output)) 4 | (eval-when (:load-toplevel) 5 | (print '(:load :d)) 6 | (finish-output)) 7 | (eval-when (:execute) 8 | (print '(:execute :d)) 9 | (finish-output)) 10 | -------------------------------------------------------------------------------- /test/e.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel) 2 | (print '(:compile :e)) 3 | (finish-output)) 4 | (eval-when (:load-toplevel) 5 | (print '(:load :e)) 6 | (finish-output)) 7 | (eval-when (:execute) 8 | (print '(:execute :e)) 9 | (finish-output)) 10 | -------------------------------------------------------------------------------- /test/blueprint: -------------------------------------------------------------------------------- 1 | ;; -*- mode: lisp; slime-buffer-package: org.shirakumo.forge.user -*- 2 | (forge:define-project (lisp) 3 | :name "test" 4 | :version 0 5 | :components 6 | ("*.lisp" 7 | ("c" :depends-on ("a")) 8 | ("d" :depends-on ("a" "b")) 9 | ("e" :depends-on ("c" "d")))) 10 | -------------------------------------------------------------------------------- /modules/git/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge.modules.git 2 | (:use #:cl) 3 | (:local-nicknames 4 | (#:support #:org.shirakumo.forge.support) 5 | (#:communication #:org.shirakumo.forge.communication) 6 | (#:forge #:org.shirakumo.forge) 7 | (#:promise #:org.shirakumo.promise)) 8 | (:export)) 9 | -------------------------------------------------------------------------------- /modules/lisp/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge.modules.lisp 2 | (:use #:cl) 3 | (:local-nicknames 4 | (#:support #:org.shirakumo.forge.support) 5 | (#:communication #:org.shirakumo.forge.communication) 6 | (#:forge #:org.shirakumo.forge) 7 | (#:promise #:org.shirakumo.promise)) 8 | (:export)) 9 | -------------------------------------------------------------------------------- /client/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge.client 2 | (:use #:cl) 3 | (:shadow #:log) 4 | (:local-nicknames 5 | (#:support #:org.shirakumo.forge.support) 6 | (#:tcp #:org.shirakumo.forge.communication.tcp) 7 | (#:in-process #:org.shirakumo.forge.communication.in-process) 8 | (#:communication #:org.shirakumo.forge.communication)) 9 | (:export 10 | #:start 11 | #:stop 12 | #:connected-p 13 | #:prune 14 | #:request-effect 15 | #:load-project)) 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # This repository has [moved](https://shinmera.com/projects/forge)! 2 | Due to Microsoft's continued enshittification of the platform this repository has been moved to [Codeberg](https://shinmera.com/projects/forge) in August of 2025. It will not receive further updates or patches. **Issues and pull requests will not be looked at here either**, please submit your patches and issue tickets on Codeberg, or send them directly via good old email patches to [shirakumo@tymoon.eu](mailto:shirakumo@tymoon.eu). 3 | 4 | Thanks. -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload :forge-module-lisp) 2 | (in-package #:org.shirakumo.forge) 3 | 4 | (rename-package *package* (package-name *package*) '(forge)) 5 | (unless (boundp '*database*) 6 | (setf *database* (make-instance 'basic-database))) 7 | (setf (v:repl-level) :trace) 8 | (start T :if-exists NIL) 9 | 10 | (setf (find-registry :cache *server* :if-exists NIL) #p"~/.cache/forge/") 11 | (add-blueprint-search-path #p"~/Projects/cl/forge/") 12 | (load-blueprints) 13 | (dot (build "test" :executor 'dummy-executor) #p"~/a.png") 14 | (build "test") 15 | -------------------------------------------------------------------------------- /modules/lisp/forge-module-lisp.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem forge-module-lisp 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "" 7 | :homepage "https://shinmera.com/docs/forge" 8 | :bug-tracker "https://shinmera.com/project/forge/issues" 9 | :source-control (:git "https://shinmera.com/project/forge.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "lisp")) 13 | :depends-on (:forge 14 | :stealth-mixin)) 15 | -------------------------------------------------------------------------------- /modules/git/forge-module-git.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem forge-module-git 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "Git support modules for Forge" 7 | :homepage "https://shinmera.com/docs/forge" 8 | :bug-tracker "https://shinmera.com/project/forge/issues" 9 | :source-control (:git "https://shinmera.com/project/forge.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "git")) 13 | :depends-on (:forge 14 | :legit)) 15 | -------------------------------------------------------------------------------- /support/fork.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.support) 2 | 3 | (defun fork () 4 | #+sbcl 5 | (sb-posix:fork) 6 | #-sbcl 7 | (error 'implementation-unsupported)) 8 | 9 | (defun pipe () 10 | #+sbcl 11 | (multiple-value-bind (a b) (sb-posix:pipe) 12 | (values (sb-sys:make-fd-stream a :input NIL :output t 13 | :element-type '(unsigned-byte 8)) 14 | (sb-sys:make-fd-stream b :input T :output NIL 15 | :element-type '(unsigned-byte 8)))) 16 | #-sbcl 17 | (error 'implementation-unsupported)) 18 | -------------------------------------------------------------------------------- /modules/git/git.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.modules.git) 2 | 3 | (forge:define-module git () 4 | ()) 5 | 6 | (defmethod forge:ensure-version ((_ (eql :git))) 7 | (forge:ensure-version (legit:git-describe :tags T))) 8 | 9 | (defmethod forge:ensure-version ((_ (eql :git-hash))) 10 | (forge:parse-version (legit:git-rev-parse "HEAD"))) 11 | 12 | (defmethod forge:ensure-version ((_ (eql :git-tag))) 13 | (forge:ensure-version (legit:git-describe :tags T :abbrev "0"))) 14 | 15 | (defmethod forge:ensure-version ((_ (eql :git-branch))) 16 | (forge:ensure-version (legit:git-rev-parse "HEAD" :abbrev-ref T))) 17 | -------------------------------------------------------------------------------- /client/forge-client.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem forge-client 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "" 7 | :homepage "https://shinmera.com/docs/forge" 8 | :bug-tracker "https://shinmera.com/project/forge/issues" 9 | :source-control (:git "https://shinmera.com/project/forge.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "server") 13 | (:file "network") 14 | (:file "client")) 15 | :depends-on (:forge-support 16 | :forge-communication)) 17 | -------------------------------------------------------------------------------- /communication/forge-communication.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem forge-communication 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "" 7 | :homepage "https://shinmera.com/docs/forge" 8 | :bug-tracker "https://shinmera.com/project/forge/issues" 9 | :source-control (:git "https://shinmera.com/project/forge.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "communication") 13 | (:file "binary") 14 | (:file "in-process") 15 | (:file "tcp")) 16 | :depends-on (:forge-support)) 17 | -------------------------------------------------------------------------------- /support/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge.support 2 | (:use #:cl) 3 | ;; toolkit.lisp 4 | (:export 5 | #:*debugger* 6 | #:forge-condition 7 | #:arguments 8 | #:define-condition* 9 | #:argument-missing 10 | #:arg! 11 | #:implementation-unsupported 12 | #:with-retry-restart 13 | #:try-files 14 | #:or* 15 | #:call 16 | #:prototype 17 | #:generic< 18 | #:handler-case*) 19 | ;; socket.lisp 20 | (:export 21 | #:open-tcp) 22 | ;; process.lisp 23 | (:export 24 | #:launch 25 | #:terminate 26 | #:exit-code) 27 | ;; environment.lisp 28 | (:export 29 | #:envvar 30 | #:default-config-directory 31 | #:default-cache-directory) 32 | ;; fork.lisp 33 | (:export 34 | #:fork)) 35 | -------------------------------------------------------------------------------- /support/forge-support.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem forge-support 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "Support functions for Forge to run on multiple implementations." 7 | :homepage "https://shinmera.com/docs/forge" 8 | :bug-tracker "https://shinmera.com/project/forge/issues" 9 | :source-control (:git "https://shinmera.com/project/forge.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "toolkit") 13 | (:file "process") 14 | (:file "socket") 15 | (:file "environment")) 16 | :depends-on ((:feature :allegro (:require :sock)) 17 | (:feature :clasp (:require :sockets)) 18 | (:feature :ecl (:require :sockets)) 19 | (:feature :lispworks (:require "comm")) 20 | (:feature :mkcl (:require :sockets)) 21 | (:feature :sbcl (:require :sb-bsd-sockets)) 22 | (:feature :sbcl (:require :sb-posix)))) 23 | -------------------------------------------------------------------------------- /forge.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem forge 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "" 7 | :homepage "https://shinmera.com/docs/forge" 8 | :bug-tracker "https://shinmera.com/project/forge/issues" 9 | :source-control (:git "https://shinmera.com/project/forge.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "toolkit") 13 | (:file "tcp") 14 | (:file "version") 15 | (:file "constraints") 16 | (:file "network") 17 | (:file "plan") 18 | (:file "module") 19 | (:file "blueprint") 20 | (:file "project") 21 | (:file "basic") 22 | (:file "dot")) 23 | :depends-on (:forge-support 24 | :forge-communication 25 | :closer-mop 26 | :promise 27 | :cl-ppcre 28 | :usocket 29 | :documentation-utils 30 | :pathname-utils 31 | :bordeaux-threads 32 | :verbose 33 | :alexandria 34 | :ironclad 35 | :cffi)) 36 | -------------------------------------------------------------------------------- /support/socket.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.support) 2 | 3 | (defun open-tcp (host port &key timeout (element-type '(unsigned-byte 8))) 4 | ;; FIXME: handle timeout 5 | #+allegro 6 | (excl:make-socket :remote-host host :remote-port port) 7 | #+abcl 8 | (let ((socket (system:make-socket host port))) 9 | (system:get-socket-stream socket :element-type element-type)) 10 | #+ccl 11 | (ccl:make-socket :remote-host host :remote-port port) 12 | #+(or clasp ecl sbcl mkcl) 13 | (let* ((endpoint (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name host))) 14 | (socket (make-instance 'sb-bsd-sockets:inet-socket :protocol :tcp :type :stream))) 15 | (sb-bsd-sockets:socket-connect socket endpoint port) 16 | (sb-bsd-sockets:socket-make-stream socket 17 | :element-type element-type 18 | :input T :output T 19 | :buffering :full)) 20 | #+clisp 21 | (socket:socket-connect port host :element-type element-type) 22 | #+(or cmucl scl) 23 | (let ((fd (extensions:connect-to-inet-socket host port))) 24 | (extensions:make-fd-stream fd :element-type element-type 25 | :input T :output T)) 26 | #+lispworks 27 | (comm:open-tcp-stream host port :element-type element-type 28 | :direction :io 29 | :errorp T 30 | :read-timeout NIL 31 | :timeout 5) 32 | #-(or allegro abcl ccl clasp ecl sbcl mkcl clisp cmucl scl lispworks) 33 | (error 'implementation-unsupported)) 34 | -------------------------------------------------------------------------------- /communication/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge.communication 2 | (:use #:cl) 3 | (:local-nicknames 4 | (#:support #:org.shirakumo.forge.support)) 5 | ;; communication.lisp 6 | (:export 7 | #:version 8 | #:connection-failed 9 | #:host 10 | #:name 11 | #:report 12 | #:init-id-counter 13 | #:host 14 | #:connect 15 | #:serve 16 | #:connection 17 | #:host 18 | #:alive-p 19 | #:send 20 | #:receive 21 | #:handle 22 | #:send! 23 | #:reply! 24 | #:client-connection 25 | #:server-connection 26 | #:connections 27 | #:message 28 | #:id 29 | #:reply 30 | #:connection-lost 31 | #:command 32 | #:exit 33 | #:ok 34 | #:ping 35 | #:pong 36 | #:connect 37 | #:machine 38 | #:client-id 39 | #:version 40 | #:error-message 41 | #:warning-message 42 | #:esend 43 | #:condition-type 44 | #:arguments 45 | #:report 46 | #:eval-request 47 | #:form 48 | #:return-message 49 | #:value 50 | #:effect-request 51 | #:effect-type 52 | #:parameters 53 | #:version 54 | #:execute-on 55 | #:file 56 | #:make-file 57 | #:file-source 58 | #:file-target 59 | #:dummy-object 60 | #:dummy-object-description 61 | #:dummy-symbol 62 | #:make-dummy-symbol 63 | #:dummy-symbol-package 64 | #:dummy-symbol-name 65 | #:artefact 66 | #:make-artefact 67 | #:artefact-registry 68 | #:artefact-path 69 | #:artefact-machine 70 | #:encode-message 71 | #:decode-message 72 | #:exit-command-loop 73 | #:handshake) 74 | ;; binary.lisp 75 | (:export 76 | #:wu8 77 | #:wu16 78 | #:wu32 79 | #:wu64 80 | #:ru8 81 | #:ru16 82 | #:ru32 83 | #:ru64 84 | #:ri8 85 | #:ri16 86 | #:ri32 87 | #:ri64 88 | #:ensure-encoding-type-id 89 | #:encoding-type-id 90 | #:define-encoding)) 91 | -------------------------------------------------------------------------------- /client/client.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.client) 2 | 3 | (defun forge-package-p (package) 4 | (flet ((match (name) 5 | (string= #1="ORG.SHIRAKUMO.FORGE" name :end2 (min (length name) (length #1#))))) 6 | (or (match (package-name package)) 7 | (some #'match (package-nicknames package))))) 8 | 9 | (defun prune-package (package) 10 | (do-symbols (symbol package (delete-package package)) 11 | (when (eq (symbol-package symbol) package) 12 | (makunbound symbol) 13 | (fmakunbound symbol) 14 | (when (find-class symbol) 15 | (setf (find-class symbol) NIL))))) 16 | 17 | (defun prune () 18 | (kill-server) 19 | (prune-package (remove-if-not #'forge-package-p (list-all-packages)))) 20 | 21 | (defun ensure-effect-type (effect-type) 22 | (etypecase effect-type 23 | (symbol effect-type) 24 | (communication:dummy-symbol effect-type) 25 | (string (let ((colon (position #\: effect-type))) 26 | (communication:make-dummy-symbol 27 | (subseq effect-type 0 colon) (subseq effect-type (1+ colon))))) 28 | (list (communication:make-dummy-symbol 29 | (first effect-type) (second effect-type))))) 30 | 31 | (defun request-effect (effect-type parameters &key (version T) (execute-on :self) (connection *connection*)) 32 | (unless connection 33 | (setf connection (start :dedicate NIL))) 34 | (let ((message (make-instance 'communication:effect-request 35 | :effect-type (ensure-effect-type effect-type) 36 | :parameters parameters 37 | :version version 38 | :execute-on execute-on))) 39 | (communication:send message connection) 40 | (command-loop connection :until (communication:id message)))) 41 | 42 | (defun load-project (project &key (version T) (connection *connection*)) 43 | (request-effect (communication:make-dummy-symbol "ORG.SHIRAKUMO.FORGE.MODULES.LISP" "LOAD-EFFECT") 44 | (list :project project) :version version :connection connection)) 45 | -------------------------------------------------------------------------------- /client/server.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.client) 2 | 3 | (defvar *forge-binary* 4 | #+unix (merge-pathnames ".local/bin/forge" (user-homedir-pathname)) 5 | #+win32 "forge.exe") 6 | (defvar *forge-process* NIL) 7 | (defvar *forge-source-root* 8 | (let ((this #.(or *compile-file-pathname* *load-pathname*))) 9 | (make-pathname :name NIL :type NIL :version NIL 10 | :directory (butlast (pathname-directory this)) 11 | :host (pathname-host this) 12 | :device (pathname-device this)))) 13 | 14 | (defun load-server (&optional (forge-source-root *forge-source-root*)) 15 | (unless (and (find-package '#:org.shirakumo.forge) 16 | (find-symbol '#:loaded-p '#:org.shirakumo.forge) 17 | (symbol-value (find-symbol '#:loaded-p '#:org.shirakumo.forge))) 18 | (load (support:try-files (merge-pathnames "bootstrap.fasl" forge-source-root) 19 | (merge-pathnames "bootstrap.lisp" forge-source-root) 20 | (merge-pathnames "bootstrap.fasl" #.*load-pathname*) 21 | (merge-pathnames "bootstrap.lisp" #.*load-pathname*))))) 22 | 23 | (defgeneric launch-server (method &key connect &allow-other-keys)) 24 | 25 | (defmethod launch-server ((method (eql :binary)) &key (binary *forge-binary*) (address "127.0.0.1") (port TCP:DEFAULT-PORT)) 26 | (when (and *forge-process* (null (support:exit-code *forge-process*))) 27 | (error 'process-already-running :process *forge-process*)) 28 | (setf *forge-process* (support:launch binary (list "launch" address (princ-to-string port)))) 29 | (make-instance 'tcp:host :address address :port port)) 30 | 31 | (defmethod launch-server ((method (eql :launch-self)) &key) 32 | ;; TODO: self-launching 33 | ) 34 | 35 | (defmethod launch-server ((method (eql :in-process)) &key) 36 | #+asdf (if (asdf:find-system :forge-server) 37 | (asdf:load-system :forge-server) 38 | (load-server)) 39 | #-asdf (load-server) 40 | (communication:serve (make-instance 'in-process:host))) 41 | 42 | (defun kill-server () 43 | (stop) 44 | (when *forge-process* 45 | (support:terminate *forge-process*) 46 | (setf *forge-process* NIL))) 47 | -------------------------------------------------------------------------------- /icon.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 16 | 36 | 38 | 42 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /tcp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file patches up the other side of the TCP protocol for server-side communication. 3 | 4 | (in-package #:org.shirakumo.forge.communication.tcp) 5 | 6 | (defmethod communication:serve ((host host)) 7 | (let ((socket (usocket:socket-listen (address host) (port host) 8 | :reuse-address T 9 | :element-type '(unsigned-byte 8)))) 10 | (when socket 11 | (make-instance 'server-connection :host host :socket socket)))) 12 | 13 | (defmethod communication:connect ((host host) machine &key id timeout) 14 | (let ((socket (usocket:socket-connect (address host) (port host) 15 | :timeout timeout 16 | :element-type '(unsigned-byte 8)))) 17 | (communication:handshake (make-instance 'client-connection :name id :host host :socket socket) 18 | machine :id id :timeout timeout))) 19 | 20 | (defmethod communication:receive ((server server-connection) &key timeout) 21 | (when (or (null timeout) (usocket:wait-for-input (socket server) :timeout timeout :ready-only T)) 22 | (let* ((socket (usocket:socket-accept (socket server) :element-type '(unsigned-byte 8))) 23 | (client (make-instance 'client-connection :name NIL :host (communication:host server) :socket socket))) 24 | (push client (connections server)) 25 | client))) 26 | 27 | (defmethod communication:receive ((connection client-connection) &key timeout) 28 | (when (or (null timeout) (usocket:wait-for-input (socket connection) :timeout timeout :ready-only T)) 29 | (communication:decode-message T (usocket:socket-stream (socket connection))))) 30 | 31 | (defmethod communication:send (message (connection client-connection)) 32 | (let ((stream (usocket:socket-stream (socket connection)))) 33 | (communication:encode-message message stream) 34 | (force-output stream))) 35 | 36 | (defmethod communication:alive-p ((connection client-connection)) 37 | (and (not (null (socket connection))) 38 | (open-stream-p (usocket:socket-stream (socket connection))))) 39 | 40 | (defmethod close ((connection server-connection) &key abort) 41 | (declare (ignore abort)) 42 | (usocket:socket-close (socket connection))) 43 | 44 | (defmethod close ((connection client-connection) &key abort) 45 | (declare (ignore abort)) 46 | (usocket:socket-close (socket connection))) 47 | -------------------------------------------------------------------------------- /communication/in-process.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge.communication.in-process 2 | (:use #:cl) 3 | (:local-nicknames 4 | (#:communication #:org.shirakumo.forge.communication)) 5 | (:export 6 | #:host)) 7 | (in-package #:org.shirakumo.forge.communication.in-process) 8 | 9 | (defclass host (communication:host communication:client-connection communication:server-connection) 10 | ((state :initform :closed :accessor state) 11 | (name :initform NIL) 12 | (queue :reader queue))) 13 | 14 | (defmethod initialize-instance :after ((host host) &key) 15 | (let ((sentinel (cons NIL NIL))) 16 | (setf (slot-value host 'queue) (cons sentinel sentinel)))) 17 | 18 | (defmethod communication:connect ((host host) machine &key id timeout) 19 | (declare (ignore id timeout)) 20 | (ecase (state host) 21 | (:serving 22 | (setf (state host) :connected) 23 | host) 24 | (:connected 25 | host))) 26 | 27 | (defmethod communication:serve ((host host)) 28 | (ecase (state host) 29 | (:closed 30 | (setf (state host) :serving) 31 | host) 32 | ((:serving :connected) 33 | host))) 34 | 35 | (defmethod communication:host ((host host)) 36 | host) 37 | 38 | (defmethod communication:connections ((host host)) 39 | (list host)) 40 | 41 | (defmethod communication:alive-p ((host host)) 42 | (not (eql :closed (state host)))) 43 | 44 | (defmethod communication:handle :before ((message communication:connection-lost) (host host)) 45 | (close host :abort T)) 46 | 47 | (defmethod close ((host host) &key abort) 48 | (declare (ignore abort)) 49 | (ecase (state host) 50 | (:closed) 51 | (:connected 52 | (setf (state host) :serving) 53 | (communication:send (make-instance 'communication:connection-lost :connection host) host)) 54 | (:serving 55 | (setf (car (queue host)) NIL) 56 | (setf (cdr (queue host)) NIL) 57 | (setf (state host) :closed)))) 58 | 59 | (defmethod communication:send (message (host host)) 60 | (communication:handle message host)) 61 | 62 | (defmethod communication:receive ((host host) &key timeout) 63 | (declare (ignore timeout)) 64 | (let ((start (pop (car (queue host))))) 65 | (unless (car (queue host)) 66 | (setf (cdr (queue host)) NIL)) 67 | start)) 68 | 69 | (defmethod communication:handle ((command communication:exit) (host host)) 70 | (setf (state host) :closed) 71 | (when (find-restart 'communication:exit-command-loop) 72 | (invoke-restart 'communication:exit-command-loop))) 73 | -------------------------------------------------------------------------------- /communication/tcp.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge.communication.tcp 2 | (:use #:cl) 3 | (:local-nicknames 4 | (#:communication #:org.shirakumo.forge.communication) 5 | (#:socket #:org.shirakumo.forge.support)) 6 | (:export 7 | #:DEFAULT-PORT 8 | #:host 9 | #:address 10 | #:port 11 | #:socket 12 | #:connection 13 | #:client-connection 14 | #:server-connection)) 15 | (in-package #:org.shirakumo.forge.communication.tcp) 16 | 17 | (defconstant DEFAULT-PORT 1984) 18 | 19 | (defclass host (communication:host) 20 | ((address :initarg :address :initform "127.0.0.1" :reader address) 21 | (port :initarg :port :initform DEFAULT-PORT :reader port))) 22 | 23 | (defmethod communication:connect ((host host) machine &key id timeout) 24 | (let ((socket (socket:open-tcp (address host) (port host) :timeout timeout))) 25 | (when socket 26 | (communication:handshake (make-instance 'client-connection :name id :host host :socket socket) 27 | machine :id id :timeout timeout)))) 28 | 29 | (defclass connection (communication:connection) 30 | ((host :initarg :host :initform (error "HOST required.") :reader communication:host) 31 | (socket :initarg :socket :initform (error "SOCKET required.") :accessor socket))) 32 | 33 | (defmethod communication:alive-p ((connection connection)) 34 | (not (null (socket connection)))) 35 | 36 | (defmethod close ((connection connection) &key abort) 37 | (ignore-errors (close (socket connection) :abort abort)) 38 | (setf (socket connection) NIL)) 39 | 40 | (defclass client-connection (connection communication:client-connection) ()) 41 | 42 | (defmethod communication:alive-p ((connection client-connection)) 43 | (and (not (null (socket connection))) 44 | (open-stream-p (socket connection)))) 45 | 46 | (defmethod communication:handle :before ((message communication:connection-lost) (connection client-connection)) 47 | (close connection :abort T)) 48 | 49 | (defmethod communication:receive ((connection client-connection) &key timeout) 50 | (declare (ignore timeout)) 51 | (communication:decode-message T (socket connection))) 52 | 53 | (defmethod communication:send (message (connection client-connection)) 54 | (let ((socket (socket connection))) 55 | (communication:encode-message message socket) 56 | (force-output socket))) 57 | 58 | (defclass server-connection (connection communication:server-connection) 59 | ((connections :initform () :accessor connections :reader communication:connections))) 60 | -------------------------------------------------------------------------------- /dot.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file defines a Graphviz plotter to visualise plans and 3 | ;;; other parts of the Forge ecosystem for easier debugging. 4 | 5 | (in-package #:org.shirakumo.forge) 6 | 7 | (defgeneric dot (thing stream)) 8 | 9 | (defmethod dot (thing (target pathname)) 10 | (if (find (pathname-type target) '("png" "svg" "pdf" "ps" "gif" "jpg") :test #'string=) 11 | (let ((temp (make-pathname :type "gv" :defaults target))) 12 | (unwind-protect 13 | (progn 14 | (dot thing temp) 15 | (uiop:run-program (list "dot" 16 | (format NIL "-T~a" (pathname-type target)) 17 | (format NIL "-o~a" (uiop:native-namestring target)) 18 | (namestring (truename temp))) 19 | :output T :error-output T)) 20 | (delete-file temp))) 21 | (with-open-file (stream target :direction :output 22 | :if-exists :supersede) 23 | (dot thing stream))) 24 | target) 25 | 26 | (defmethod dot (thing (target string)) 27 | (dot thing (pathname target))) 28 | 29 | (defmethod dot (thing (target (eql T))) 30 | (dot thing *standard-output*)) 31 | 32 | (defmethod dot (thing (target null)) 33 | (with-output-to-string (stream) 34 | (dot thing stream))) 35 | 36 | (defmethod dot ((plan plan) (stream stream)) 37 | (flet ((output (format-string &rest format-args) 38 | (format stream "~?~%" format-string format-args))) 39 | (output "digraph plan {") 40 | (output " splines=ortho;") 41 | (let ((visit-cache (make-hash-table :test 'eq)) 42 | (counter 0)) 43 | (labels ((visit (step) 44 | (unless (gethash step visit-cache) 45 | (let ((count (incf counter))) 46 | (setf (gethash step visit-cache) count) 47 | (output " s~d [shape=box,label=~s];" count (dot step NIL)) 48 | (loop for successor in (successors step) 49 | do (visit successor) 50 | (output " s~d -> s~d;" count (gethash successor visit-cache))))))) 51 | (loop for step across (first-steps plan) 52 | do (visit step)))) 53 | (output "}"))) 54 | 55 | (defmethod dot ((step step) (stream stream)) 56 | (dot (operation step) stream) 57 | (write-char #\Space stream) 58 | (dot (component step) stream)) 59 | 60 | (defmethod dot ((component file-component) (stream stream)) 61 | (format stream "~a" (list (registry (artefact component)) 62 | (full-path component)))) 63 | 64 | (defmethod dot ((component component) (stream stream)) 65 | (format stream "~a" (type-of component))) 66 | 67 | (defmethod dot ((operation operation) (stream stream)) 68 | (format stream "~a" (type-of operation))) 69 | -------------------------------------------------------------------------------- /support/environment.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.support) 2 | 3 | (defun envvar (name) 4 | #+(or abcl clasp clisp ecl xcl) (ext:getenv name) 5 | #+allegro (sys:getenv name) 6 | #+clozure (ccl:getenv name) 7 | #+cmucl (unix:unix-getenv name) 8 | #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) 9 | #+cormanlisp 10 | (let* ((buffer (ct:malloc 1)) 11 | (cname (ct:lisp-string-to-c-string name)) 12 | (needed-size (win:getenvironmentvariable cname buffer 0)) 13 | (buffer1 (ct:malloc (1+ needed-size)))) 14 | (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) 15 | nil 16 | (ct:c-string-to-lisp-string buffer1)) 17 | (ct:free buffer) 18 | (ct:free buffer1))) 19 | #+gcl (system:getenv name) 20 | #+lispworks (lispworks:environment-variable name) 21 | #+mcl (ccl:with-cstrs ((name name)) 22 | (let ((value (_getenv name))) 23 | (unless (ccl:%null-ptr-p value) 24 | (ccl:%get-cstring value)))) 25 | #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) name) 26 | #+sbcl (sb-ext:posix-getenv name) 27 | #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) 28 | nil) 29 | 30 | (defun (setf envvar) (value name) 31 | #+allegro (setf (sys:getenv name) ,val) 32 | #+clasp (ext:setenv name value) 33 | #+clisp (system::setenv name value) 34 | #+clozure (ccl:setenv name value) 35 | #+cmucl (unix:unix-setenv name value 1) 36 | #+(or ecl clasp) (ext:setenv name value) 37 | #+lispworks (setf (lispworks:environment-variable name) value) 38 | #+mkcl (mkcl:setenv name value) 39 | #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :setenv name value 1)) 40 | #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) 41 | value) 42 | 43 | (defun default-config-directory () 44 | (pathname 45 | (or* (envvar "FORGE_CONFIG_DIR") 46 | (merge-pathnames "forge/" 47 | (or* (envvar "XDG_CONFIG_HOME") 48 | #+win32 (envvar "AppData") 49 | (merge-pathnames #+darwin "Library/Preferences/" 50 | #+win32 "AppData/Local/" 51 | #+(and (not darwin) unix) ".config/" 52 | (user-homedir-pathname))))))) 53 | 54 | (defun default-cache-directory () 55 | (pathname 56 | (or* (ennvar "FORGE_CACHE_DIR") 57 | (merge-pathnames "forge/" 58 | (or* (envvar "XDG_CACHE_HOME") 59 | #+win32 (envvar "temp") 60 | (merge-pathnames #+darwin "Library/Caches/" 61 | #+win32 "AppData/Local/Temp/" 62 | #+(and (not darwin) unix) ".cache/" 63 | (user-homedir-pathname))))))) 64 | -------------------------------------------------------------------------------- /support/process.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.support) 2 | 3 | (defun %launch (program args &key (output *standard-output*) (error *error-output*)) 4 | (macrolet ((call (fun &rest args) 5 | `(,fun ,@args :output output 6 | :error-output error 7 | :error error 8 | :if-output-exists :append 9 | :if-error-output-exists :append 10 | :if-error-exists :append 11 | :wait NIL 12 | :element-type 'character 13 | :external-format :utf-8 14 | :save-exit-status T 15 | :allow-other-keys T))) 16 | #+abcl (call sys:run-program program args) 17 | #+allegro (call excl:run-shell-command (coerce (list* program args) 'vector)) 18 | #+clozure (call ccl:run-program program args) 19 | #+(or cmucl ecl) (call ext:run-program program args) 20 | #+lispworks (call system:run-shell-command (list* program args)) 21 | #+mkcl (call mk-ext:run-program program args) 22 | #+sbcl (call sb-ext:run-program program args) 23 | #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl) 24 | (error 'implementation-unsupported))) 25 | 26 | (defun launch (program args) 27 | #+(or abcl clozure cmucl sbcl) (%launch program args) 28 | #+allegro 29 | (multiple-value-bind (in-or-io out-or-err err-or-pid pid-or-nil) (%launch program args) 30 | (declare (ignore in-or-io out-or-err)) 31 | (or pid-or-nill err-or-pid)) 32 | #+ecl (nth-value 2 (%launch program args)) 33 | #+lispworks 34 | (multiple-value-bind (io-or-pid err-or-nil #-lispworks7+ pid-or-nil) (%launch program args) 35 | (declare (ignore err-or-nil)) 36 | (or pid-or-nil io-or-pid)) 37 | #+mkcl (nth-value 1 (%launch program args)) 38 | #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl) 39 | (error 'implementation-unsupported)) 40 | 41 | (defun terminate (process) 42 | #+abcl (sys:process-kill process) 43 | #+(and allegro unix) (excl.osi:kill process 15) 44 | #+(and clozure unix) (ccl:signal-external-process process 15) 45 | #+(and cmucl unix) (ext:process-kill process 15) 46 | #+ecl (ext:terminate-process process) 47 | #+lispworks7+ (sys:pipe-kill-process process) 48 | #+mkcl (mk-ext:terminate-process process) 49 | #+(and sbcl unix) (sb-ext:process-kill process 15) 50 | #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl) 51 | (error 'implementation-unsupported)) 52 | 53 | (defun exit-code (process) 54 | #+abcl (unless (sys:process-alive-p process) 0) 55 | #+allegro (sys:reap-os-subprocess :pid process :wait NIL) 56 | #+clozure (nth-value 1 (ccl:external-process-status process)) 57 | #+cmucl (let ((status (ext:process-status process))) 58 | (when (member status '(:exited :signaled)) 59 | (ext:process-exit-code process))) 60 | #+ecl (nth-value 1 (ext:external-process-status process)) 61 | #+lispworks 62 | #+lispworks7+ (sys:pipe-exit-status process :wait NIL) 63 | #-lispworks7+ (sys:pid-exit-status process :wait NIL) 64 | #+mkcl (let ((status (mk-ext:process-status process))) 65 | (when (eq status :exited) 66 | (mk-ext:process-exit-code process))) 67 | #+sbcl (let ((status (sb-ext:process-status process))) 68 | (unless (eq status :running) 69 | (sb-ext:process-exit-code process))) 70 | #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl) 71 | (error 'implementation-unsupported)) 72 | -------------------------------------------------------------------------------- /realization.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge) 2 | 3 | (defclass local-step () 4 | ((predecessors :initarg :predecessors :initform () :accessor predecessors) 5 | (successors :initarg :successors :initform () :accessor successors) 6 | (complete-p :initarg :complete-p :initform NIL :accessor complete-p) 7 | (client :initarg :client :initform NIL :reader client))) 8 | 9 | (defclass executor () 10 | ()) 11 | 12 | (defgeneric realize (plan executor)) 13 | (defgeneric localize (operation component client)) 14 | (defgeneric map-steps (function plan &key gather)) 15 | (defgeneric client-suitable-p (client step)) 16 | (defgeneric select-client (step executor)) 17 | (defgeneric perform (plan executor)) 18 | 19 | (defmacro do-steps ((step plan &rest args) &body body) 20 | `(block NIL (map-steps (lambda (,step) ,@body) ,plan ,@args))) 21 | 22 | (defmethod perform :around ((step local-step) (client client)) 23 | (if (complete-p step) 24 | (promise:pend :success step) 25 | (promise:-> (call-next-method) 26 | (:then () (setf (complete-p step) T) step)))) 27 | 28 | (defmethod realize ((plan plan) (executor executor)) 29 | (do-steps (step plan :gather T) 30 | (realize step executor))) 31 | 32 | (defmethod realize ((step step) (executor executor)) 33 | (localize (operation step) (component step) (select-client step executor))) 34 | 35 | (defmethod map-steps (function (plan plan) &key gather) 36 | (let ((tentative (map 'list #'identity (first-steps plan))) 37 | (map (make-hash-table :test 'eq))) 38 | ;; First map the steps 39 | (loop while tentative 40 | for step = (pop tentative) 41 | do (unless (gethash step map) 42 | (let ((replacement (funcall function step))) 43 | (setf (gethash step map) (or replacement T))) 44 | (dolist (step (successors step)) 45 | (push step tentative)))) 46 | ;; Then replace the new links in the new steps and put them into a plan. 47 | (when gather 48 | (flet ((rep (step) 49 | (gethash step map))) 50 | (loop for step being the hash-values of map 51 | do (setf (predecessors step) (mapcar #'rep (predecessors step))) 52 | (setf (successors step) (mapcar #'rep (successors step)))) 53 | (let ((plan (make-instance 'plan))) 54 | (setf (first-steps plan) (map 'vector #'rep (first-steps plan))) 55 | (setf (final-steps plan) (map 'vector #'rep (final-steps plan))) 56 | plan))))) 57 | 58 | (defclass single-executor () 59 | ((client :initarg :client :initform NIL :accessor client))) 60 | 61 | (defmethod select-client ((step step) (executor single-executor)) 62 | (client executor)) 63 | 64 | (defmethod realize :before ((plan plan) (executor single-executor)) 65 | (unless (client executor) 66 | (dolist (client (list-clients *server*)) 67 | (unless (eql :skip (do-steps (step plan) 68 | (unless (client-suitable-p client step) 69 | (return :skip)))) 70 | (setf (client executor) client) 71 | (return)))) 72 | (unless (client executor) 73 | (error "Could not find any client that can execute all steps in this plan."))) 74 | 75 | (defun compute-step-sequence (plan) 76 | (let ((visit (make-hash-table :test 'eq)) 77 | (sequence ())) 78 | (labels ((visit (step) 79 | (unless (gethash step visit) 80 | (dolist (successor (successors step)) 81 | (visit successor)) 82 | (push step sequence) 83 | (setf (gethash step visit) T)))) 84 | (loop for step across (first-steps plan) 85 | do (visit step)) 86 | sequence))) 87 | 88 | (defmethod perform ((plan plan) (executor single-executor)) 89 | (promise:do-promised (step (compute-step-sequence plan)) 90 | (handler-bind ((error #'invoke-debugger)) 91 | (perform step ())))) 92 | -------------------------------------------------------------------------------- /support/toolkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.support) 2 | 3 | (defvar *debugger* T) 4 | 5 | (define-condition forge-condition (condition) 6 | ()) 7 | 8 | (defgeneric arguments (condition) 9 | (:method-combination append)) 10 | 11 | (defmethod arguments append ((condition condition)) 12 | ()) 13 | 14 | (defmacro define-condition* (name superclasses slots report) 15 | (let ((slots (loop for slot in slots 16 | collect (if (listp slot) 17 | slot 18 | (list slot :initarg (intern (string slot) "KEYWORD") 19 | :initform `(arg! ,(intern (string slot) "KEYWORD")) 20 | :reader slot))))) 21 | `(progn 22 | (define-condition ,name (,@superclasses forge-condition) 23 | ,slots 24 | (:report (lambda (c s) 25 | (declare (ignorable c)) 26 | (format s ,(first report) 27 | ,@(loop for arg in (rest report) 28 | collect (if (symbolp arg) 29 | `(,arg c) 30 | `((lambda (condition) ,arg) c))))))) 31 | (defmethod arguments append ((,name ,name)) 32 | (list ,@(loop for (slot . args) in slots 33 | for reader = (getf args :reader) 34 | for initarg = (getf args :initarg) 35 | when initarg collect initarg 36 | when initarg collect (if reader 37 | `(,reader ,name) 38 | `(slot-value ,name ',slot)))))))) 39 | 40 | (define-condition* argument-missing (error) 41 | (argument) ("The argument~% ~s~%was required, but not given." argument)) 42 | 43 | (defun arg! (argument) 44 | (error 'argument-missing :argument argument)) 45 | 46 | (define-condition* implementation-unsupported (error) 47 | () ("Your implementation is not supported or does not support a required feature for Forge.")) 48 | 49 | (defmacro with-retry-restart ((&optional (name 'retry) (format-string "Retry") &rest format-args) &body body) 50 | (let ((block (gensym "BLOCK")) 51 | (retry (gensym "RETRY"))) 52 | `(block ,block 53 | (tagbody 54 | ,retry 55 | (restart-case 56 | (return-from ,block 57 | (progn ,@body)) 58 | (,name () 59 | :report (lambda (s) (format s ,format-string ,@format-args)) 60 | (go ,retry))))))) 61 | 62 | (defun try-files (&rest pathnames) 63 | (loop for path in pathnames 64 | do (when (probe-file path) (return path)) 65 | finally (error "No matching paths."))) 66 | 67 | (defmacro or* (&rest args) 68 | (let ((v (gensym "VALUE"))) 69 | `(or ,@(loop for arg in args 70 | collect `(let ((,v ,arg)) 71 | (when (and ,v (not (equal ,v ""))) 72 | ,v)))))) 73 | 74 | (defun call (package name &rest args) 75 | (apply (or (find-symbol (string name) package) 76 | (error "No symbol named ~s found in ~s." name package)) 77 | args)) 78 | 79 | (defgeneric generic< (a b) 80 | (:method ((a real) (b real)) 81 | (< a b)) 82 | (:method ((a string) (b string)) 83 | (string< a b)) 84 | (:method ((a pathname) (b pathname)) 85 | (string< (namestring a) (namestring b))) 86 | (:method ((a symbol) (b symbol)) 87 | (cond ((eq (symbol-package a) (symbol-package b)) 88 | (string< (symbol-name a) (symbol-name b))) 89 | ((null (symbol-package b)) 90 | T) 91 | ((null (symbol-package a)) 92 | NIL) 93 | (T 94 | (string< (package-name (symbol-package a)) (package-name (symbol-package b))))))) 95 | 96 | (defmacro handler-case* (body &body cases) 97 | (let ((return (gensym "RETURN"))) 98 | `(block ,return 99 | (handler-bind 100 | ,(loop for (type vars . body) in cases 101 | collect `(,type (lambda ,vars 102 | (when *debugger* 103 | (with-simple-restart (continue "Continue") 104 | (invoke-debugger ,@vars))) 105 | (return-from ,return 106 | (progn ,@body))))) 107 | ,body)))) 108 | -------------------------------------------------------------------------------- /logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 16 | 36 | 38 | 44 | 45 | 49 | 53 | 58 | 62 | 66 | 70 | 74 | 78 | 79 | 80 | 81 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.forge 2 | (:use #:cl) 3 | (:shadow #:step #:*modules*) 4 | (:local-nicknames 5 | (#:support #:org.shirakumo.forge.support) 6 | (#:communication #:org.shirakumo.forge.communication) 7 | (#:tcp #:org.shirakumo.forge.communication.tcp) 8 | (#:in-process #:org.shirakumo.forge.communication.in-process) 9 | (#:promise #:org.shirakumo.promise) 10 | (#:bt #:bordeaux-threads) 11 | (#:v #:org.shirakumo.verbose)) 12 | ;; basic.lisp 13 | (:export 14 | #:basic-database 15 | #:parameter-plist-effect 16 | #:parameter-alist-effect 17 | #:basic-policy 18 | #:linear-executor 19 | #:force 20 | #:client 21 | #:file-component 22 | #:full-path 23 | #:hash 24 | #:parent-component 25 | #:children 26 | #:child-component 27 | #:parent 28 | #:dependencies-component 29 | #:depends-on 30 | #:normalize-dependency-spec) 31 | ;; blueprint.lisp 32 | (:export 33 | #:*blueprint* 34 | #:*blueprint-search-paths* 35 | #:blueprint 36 | #:path 37 | #:projects 38 | #:list-blueprints 39 | #:load-blueprint-file 40 | #:load-blueprint 41 | #:add-blueprint-search-path 42 | #:discover-blueprint-files 43 | #:load-blueprints 44 | #:reload-blueprints 45 | #:handle-blueprint-form) 46 | ;; constraints.lisp 47 | (:export 48 | #:constraints-incompatible 49 | #:a 50 | #:b 51 | #:parse-constraint 52 | #:define-constraint-parser 53 | #:constraint 54 | #:version-constraint 55 | #:version-match-p 56 | #:constraint-subset-p 57 | #:unify 58 | #:widen 59 | #:unify* 60 | #:match-constraint 61 | #:version-unspecific-constraint 62 | #:version-equal-constraint 63 | #:version 64 | #:version-range-constraint 65 | #:min-version 66 | #:max-version 67 | #:constraint-union 68 | #:constraints) 69 | ;; module.lisp 70 | (:export 71 | #:module-entry-point-search-function 72 | #:define-module-entry-point-search-function 73 | #:find-module-entry-point 74 | #:module 75 | #:load-module 76 | #:find-module 77 | #:register-module 78 | #:on-client-connect 79 | #:list-modules 80 | #:define-module) 81 | ;; network.lisp 82 | (:export 83 | #:*server* 84 | #:no-such-client 85 | #:name 86 | #:server 87 | #:no-such-machine 88 | #:peer 89 | #:name 90 | #:machine 91 | #:connection 92 | #:server 93 | #:on-existing-client 94 | #:start 95 | #:stop 96 | #:list-clients 97 | #:find-machine 98 | #:delete-machine 99 | #:with-promise 100 | #:client 101 | #:server 102 | #:promise-reply 103 | #:with-client-eval) 104 | ;; plan.lisp 105 | (:export 106 | #:dependency-cycle-detected 107 | #:effect 108 | #:unsatisfiable-dependency 109 | #:dependency 110 | #:operation 111 | #:component 112 | #:unsatisfiable-effect 113 | #:effect 114 | #:*database* 115 | #:database 116 | #:map-effects 117 | #:list-effects 118 | #:find-effect 119 | #:register-effect 120 | #:do-effects 121 | #:component 122 | #:name 123 | #:supported-operations 124 | #:operation 125 | #:dependencies 126 | #:perform 127 | #:make-effect 128 | #:ensure-effect 129 | #:dependency 130 | #:effect-type 131 | #:parameters 132 | #:version 133 | #:hard-p 134 | #:depend 135 | #:effect 136 | #:sources 137 | #:parameters 138 | #:add-source 139 | #:normalize-parameters 140 | #:variant-p 141 | #:compiler 142 | #:name 143 | #:cache-directory 144 | #:policy 145 | #:compiler 146 | #:in-order-to 147 | #:select-source 148 | #:select-effect-set 149 | #:compute-plan 150 | #:retry 151 | #:make-operation 152 | #:select-compiler 153 | #:executor 154 | #:plan 155 | #:first-steps 156 | #:final-steps 157 | #:make-step 158 | #:step 159 | #:operation 160 | #:component 161 | #:effect 162 | #:predecessors 163 | #:successors 164 | #:complete-p 165 | #:forced-p 166 | #:compound-step 167 | #:inner-effect 168 | #:execute 169 | #:effect-needed-p 170 | #:step-needed-p 171 | #:connect) 172 | ;; project.lisp 173 | (:export 174 | #:project 175 | #:blueprint 176 | #:metadata 177 | #:in-order-to 178 | #:ensure-version 179 | #:find-project 180 | #:register-project 181 | #:delete-project 182 | #:build 183 | #:normalize-component-spec 184 | #:parse-component 185 | #:default-component-type 186 | #:default-project-type 187 | #:list-projects 188 | #:define-project 189 | #:forge) 190 | ;; version.lisp 191 | (:export 192 | #:version 193 | #:version= 194 | #:version< 195 | #:to-string 196 | #:parse-version 197 | #:unknown-version 198 | #:maximal-version 199 | #:minimal-version 200 | #:integer-version 201 | #:value 202 | #:hashed-version 203 | #:value 204 | #:separated-version 205 | #:value 206 | #:compound-version 207 | #:versions 208 | #:version-from-string 209 | #:versioned-object 210 | #:version)) 211 | 212 | (defpackage #:org.shirakumo.forge.user 213 | (:use #:cl) 214 | (:local-nicknames 215 | (#:forge #:org.shirakumo.forge))) 216 | -------------------------------------------------------------------------------- /module.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; In this file the "module" protocol is defined. Modules allow for extensions 3 | ;;; to Forge's capabilities and are what's used to define the required 4 | ;;; components, operations, and effects to actually build projects for a 5 | ;;; particular language. 6 | ;;; The blueprint system hooks into the module system to automatically load the 7 | ;;; desired modules into the Forge process. 8 | 9 | (in-package #:org.shirakumo.forge) 10 | 11 | (support:define-condition* no-such-module (error) 12 | (designator) ("A module with the name~% ~s~%does not exist." designator)) 13 | 14 | (support:define-condition* module-already-exists (error) 15 | (designator) ("A module with the name~% ~s~%already exists." designator)) 16 | 17 | (defvar *module-entry-point-search-functions* (make-hash-table :test 'eql)) 18 | 19 | (defun module-entry-point-search-function (name) 20 | (gethash name *module-entry-point-search-functions*)) 21 | 22 | (defun (setf module-entry-point-search-function) (value name) 23 | (cond (value 24 | (setf (gethash name *module-entry-point-search-functions*) value)) 25 | (T 26 | (remhash name *module-entry-point-search-functions*) 27 | name))) 28 | 29 | (defmacro define-module-entry-point-search-function (name (designator) &body body) 30 | `(setf (gethash ',name *module-entry-point-search-functions*) 31 | (lambda (,designator) 32 | (block NIL 33 | ,@body)))) 34 | 35 | (defun find-module-entry-point (designator &key (if-does-not-exist :error)) 36 | (or (loop for function being the hash-values of *module-entry-point-search-functions* 37 | for value = (funcall function designator) 38 | when value 39 | do (return value)) 40 | (ecase if-does-not-exist 41 | ((NIL) NIL) 42 | (:error 43 | (restart-case (error 'no-such-module :designator designator) 44 | (use-value (value) 45 | :report "Use the provided value" 46 | value)))))) 47 | 48 | (defvar *modules* (make-hash-table :test 'equal)) 49 | 50 | (defclass module () 51 | ((name :initarg :name :initform (support:arg! :name) :reader name))) 52 | 53 | (defgeneric load-module (designator &key if-exists if-does-not-exist)) 54 | (defgeneric find-module (designator &key if-does-not-exist)) 55 | (defgeneric register-module (module)) 56 | (defgeneric on-client-connect (module client)) 57 | 58 | (defun list-modules () 59 | (loop for module being the hash-values of *modules* 60 | collect module)) 61 | 62 | (defmethod load-module ((designator symbol) &key (if-exists :ignore) (if-does-not-exist :error)) 63 | (let ((module (find-module designator :if-does-not-exist NIL))) 64 | (when module 65 | (ecase if-exists 66 | ((NIL) (return-from load-module NIL)) 67 | (:ignore (return-from load-module module)) 68 | (:error (error 'module-already-exists :designator designator)) 69 | (:reload)))) 70 | (let ((entry-point (find-module-entry-point designator :if-does-not-exist if-does-not-exist))) 71 | (v:info :forge.module "Loading module for ~a" designator) 72 | (load-module entry-point :if-exists :reload))) 73 | 74 | (defmethod load-module ((designator pathname) &key if-exists if-does-not-exist) 75 | (declare (ignore if-exists if-does-not-exist)) 76 | (load designator)) 77 | 78 | (defmethod find-module (designator &key (if-does-not-exist :error)) 79 | (let ((module (gethash (string-downcase designator) *modules*))) 80 | (or module 81 | (ecase if-does-not-exist 82 | ((NIL) NIL) 83 | (:error (error 'no-such-module :designator designator)) 84 | (:load (load-module designator) 85 | (find-module designator)))))) 86 | 87 | (defmethod find-module ((designator module) &key if-does-not-exist) 88 | (declare (ignore if-does-not-exist)) 89 | designator) 90 | 91 | (defmethod register-module ((module module)) 92 | (setf (gethash (string-downcase (name module)) *modules*) module)) 93 | 94 | (defmethod on-client-connect ((module module) (client client))) 95 | 96 | (defmethod on-client-connect ((all (eql T)) (client client)) 97 | (dolist (module (list-modules)) 98 | (on-client-connect module client))) 99 | 100 | (defmacro define-module (module superclasses slots &rest initargs) 101 | (let ((instance (gensym "INSTANCE"))) 102 | (remf initargs :class) 103 | `(progn 104 | (defclass ,module (,@superclasses module) 105 | ,slots) 106 | (let ((,instance (or (find-module ',module :if-does-not-exist NIL) 107 | (make-instance ',module :name ',module)))) 108 | (register-module ,instance) 109 | (reinitialize-instance ,instance ,@initargs))))) 110 | 111 | #+asdf 112 | (define-module-entry-point-search-function asdf (designator) 113 | (asdf:find-system (format NIL "forge-module-~(~a~)" designator) NIL)) 114 | 115 | #+asdf 116 | (defmethod load-module ((designator asdf:system) &key if-exists if-does-not-exist) 117 | (declare (ignore if-does-not-exist)) 118 | (unless (find (asdf:component-name designator) (asdf:already-loaded-systems) :test #'string=) 119 | (ecase if-exists 120 | ((NIL) (return-from load-module NIL)) 121 | (:error (error 'module-already-exists :designator designator)) 122 | (:reload))) 123 | (let ((*package* (find-package :cl-user))) 124 | (asdf:load-system designator :verbose NIL)) 125 | (find-module (asdf:component-name designator))) 126 | 127 | -------------------------------------------------------------------------------- /client/network.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.client) 2 | 3 | (defvar *connection* NIL) 4 | (defvar *machine* (machine-instance)) 5 | 6 | (support:define-condition* already-connected (error) 7 | (connection) ("Connection already established through~% ~a" connection)) 8 | 9 | (support:define-condition* connection-lost (error) 10 | (connection) ("Connection through~% ~a~%lost." connection)) 11 | 12 | (defun log (level message &rest args) 13 | (format (ecase level 14 | ((:info :error) *error-output*) 15 | ((:debug :trace) *debug-io*)) 16 | "FORGE [~5a] ~?" level message args)) 17 | 18 | (defun try-connect (host machine &key id timeout) 19 | (support:handler-case* (communication:connect host machine :id id :timeout timeout) 20 | (error (e) 21 | (log :error "Failed to connect to~% ~a~%~a" host e) 22 | NIL))) 23 | 24 | (defun connected-p (&optional (connection *connection*)) 25 | (and connection (communication:alive-p connection))) 26 | 27 | (defun start (&key (address "127.0.0.1") 28 | (port TCP:DEFAULT-PORT) 29 | (timeout 1.0) 30 | (machine *machine*) 31 | id 32 | host 33 | (if-unavailable :launch) 34 | (launch-method :binary) 35 | (launch-arguments ()) 36 | (dedicate T)) 37 | (when (connected-p) 38 | (error 'already-connected :connection *connection*)) 39 | (support:with-retry-restart () 40 | (communication:init-id-counter machine) 41 | (setf *machine* machine) 42 | (let ((host (or host (make-instance 'tcp:host :address address :port port)))) 43 | (loop (with-simple-restart (retry "Retry connecting.") 44 | (let ((connection (or (try-connect host machine :id id :timeout timeout) 45 | (ecase if-unavailable 46 | ((NIL) 47 | NIL) 48 | (:error 49 | (error 'communication:connection-failed :host host :report NIL)) 50 | (:launch 51 | (setf host (apply #'launch-server launch-method :address address :port port launch-arguments)) 52 | (invoke-restart 'retry)))))) 53 | (setf *connection* connection) 54 | (if dedicate 55 | (return 56 | (unwind-protect (command-loop connection) 57 | (ignore-errors (close connection)) 58 | (setf *connection* NIL))) 59 | (return connection)))))))) 60 | 61 | (defun stop (&optional (connection *connection*)) 62 | (cond ((find-restart 'communication:exit-command-loop) 63 | (invoke-restart 'communication:exit-command-loop)) 64 | ((connected-p connection) 65 | (ignore-errors (communication:send! connection 'communication:exit)) 66 | (ignore-errors (close connection)) 67 | (when (eq connection *connection*) (setf *connection* NIL))))) 68 | 69 | (defun handle-reconnect (connection &key (on-reconnect-failure :sleep)) 70 | (let ((host (communication:host connection))) 71 | (log :info "Trying to reconnect to~% ~a" host) 72 | (with-simple-restart (abort "Exit reconnection.") 73 | (loop (setf connection (try-connect host *machine*)) 74 | (when connection (return connection)) 75 | (etypecase on-reconnect-failure 76 | (null (return)) 77 | ((eql :sleep) (sleep 10)) 78 | ((eql :error) (error 'connection-lost :connection connection)) 79 | ((or symbol function) 80 | (with-simple-restart (reconnect "Attempt to reconnect again.") 81 | (return (funcall on-reconnect-failure))))))))) 82 | 83 | (defun command-loop (connection &key (on-disconnect :reconnect) (on-reconnect-failure :sleep) until) 84 | (restart-case 85 | (loop (unless (communication:alive-p connection) 86 | (restart-case 87 | (case on-disconnect 88 | ((NIL) 89 | (return NIL)) 90 | (:error 91 | (error 'connection-lost :connection connection)) 92 | (:reconnect 93 | (invoke-restart 'reconnect))) 94 | (reconnect () 95 | :report "Attempt to reconnect." 96 | (setf connection (handle-reconnect connection :on-reconnect-failure on-reconnect-failure)) 97 | (unless connection (return))))) 98 | (handler-case 99 | (let ((message (communication:receive connection :timeout 1.0))) 100 | (when message 101 | (handler-case 102 | (communication:handle message connection) 103 | (error (e) 104 | (communication:esend connection e message))) 105 | (when (and until (equal (communication:id message) until)) 106 | (invoke-restart 'quit)))) 107 | (error (e) 108 | (ignore-errors (communication:esend connection e))))) 109 | (communication:exit-command-loop () 110 | :report "Close the connection and exit the command loop." 111 | (close connection)) 112 | (quit () 113 | :report "Quit the command loop without closing the connection" 114 | connection))) 115 | -------------------------------------------------------------------------------- /blueprint.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file defines the blueprint mechanism, which is the way by which 3 | ;;; users define projects and their components for Forge. Blueprints by 4 | ;;; themselves are merely files with the fixed name "blueprint", which 5 | ;;; contain a number of project definition expressions. 6 | 7 | (in-package #:org.shirakumo.forge) 8 | 9 | (defvar *blueprints* (make-hash-table :test 'equal)) 10 | (defvar *blueprint-search-paths* ()) 11 | (defvar *blueprint* NIL) 12 | 13 | (support:define-condition* no-such-blueprint (error) 14 | (path) ("Could not find a registered blueprint with path~% ~a" path)) 15 | 16 | (defclass blueprint () 17 | ((path :initform NIL :accessor path) 18 | (hash :initarg :hash :initform NIL :accessor hash) 19 | (projects :initform (make-hash-table :test 'equalp) :accessor projects))) 20 | 21 | (defmethod shared-initialize :after ((blueprint blueprint) slots &key path hash) 22 | (when path 23 | (setf (path blueprint) path)) 24 | (when (and path (null hash)) 25 | (setf (hash blueprint) (hash-file path)))) 26 | 27 | (defmethod print-object ((blueprint blueprint) stream) 28 | (print-unreadable-object (blueprint stream :type T) 29 | (format stream "~a" (path blueprint)))) 30 | 31 | (defmethod make-load-form ((blueprint blueprint) &optional env) 32 | (declare (ignore env)) 33 | `(blueprint ,(path blueprint))) 34 | 35 | (defmethod (setf path) ((path pathname) (blueprint blueprint)) 36 | (let ((old (path blueprint))) 37 | (setf (slot-value blueprint 'path) (truename path)) 38 | (when old (setf (blueprint old) NIL)) 39 | (setf (blueprint path) blueprint))) 40 | 41 | (defmethod blueprint ((path pathname)) 42 | (or (gethash (truename path) *blueprints*) 43 | (restart-case (error 'no-such-blueprint :path path) 44 | (load-blueprint () 45 | :report "Try to load the file as a blueprint" 46 | (load-blueprint path))))) 47 | 48 | (defmethod (setf blueprint) ((blueprint blueprint) (path pathname)) 49 | (setf (gethash (truename path) *blueprints*) blueprint)) 50 | 51 | (defmethod (setf blueprint) ((null null) (path pathname)) 52 | (remhash path *blueprints*)) 53 | 54 | (defun list-blueprints () 55 | (alexandria:hash-table-values *blueprints*)) 56 | 57 | (defmethod load-blueprint-file ((blueprint blueprint) path) 58 | ;; FIXME: use Eclector to catch attempts at introducing symbols into external packages 59 | (with-standard-io-syntax 60 | (let* ((hash (hash-file path)) 61 | (blueprint-package (make-blueprint-package)) 62 | (*package* blueprint-package) 63 | (*read-eval* NIL)) 64 | (unwind-protect 65 | (with-open-file (stream path :direction :input :external-format :utf-8) 66 | (loop with *blueprint* = blueprint 67 | for form = (read stream NIL '#1=#:eof) 68 | until (eq form '#1#) 69 | do (etypecase form 70 | (cons 71 | (handle-blueprint-form (car form) (cdr form))))) 72 | (setf (hash blueprint) hash) 73 | blueprint) 74 | (ignore-errors (delete-package blueprint-package)))))) 75 | 76 | (defmethod load-blueprint ((blueprint blueprint) &key force) 77 | (when (or force (string/= (hash blueprint) (hash-file (path blueprint)))) 78 | (let ((temp (tempfile :type "lisp"))) 79 | ;; We copy the file out to ensure that changes to the original while loading 80 | ;; don't impact the load and are properly detected as new changes when 81 | ;; attempting to load the file again. 82 | (uiop:copy-file (path blueprint) temp) 83 | (restart-case (load-blueprint-file blueprint temp) 84 | (abort () 85 | :report "Ignore the failed load" 86 | NIL) 87 | (remove () 88 | :report "Remove the blueprint" 89 | (setf (blueprint (path blueprint)) NIL) 90 | NIL))))) 91 | 92 | (defmethod load-blueprint ((path pathname) &key force) 93 | (let ((blueprint (gethash path *blueprints*))) 94 | (unless blueprint 95 | (setf blueprint (make-instance 'blueprint :path path :hash ""))) 96 | (load-blueprint blueprint :force force))) 97 | 98 | (defun add-blueprint-search-path (path &key discover if-exists) 99 | (loop for existing in *blueprint-search-paths* 100 | do (when (pathname-utils:subpath-p path existing) 101 | (ecase if-exists 102 | ((NIL) (return-from add-blueprint-search-path NIL)) 103 | (:error (error 'blueprint-search-path-exists :path path :existing existing))))) 104 | (push path *blueprint-search-paths*) 105 | (when discover 106 | (load-blueprints (discover-blueprints (list path)))) 107 | path) 108 | 109 | (defun discover-blueprint-files (&optional (paths *blueprint-search-paths*)) 110 | (let ((paths ())) 111 | (dolist (path paths paths) 112 | (scan-directory (truename path) "blueprint" (lambda (path) (push path paths)))))) 113 | 114 | (defun load-blueprints (&key (paths (discover-blueprint-files)) force) 115 | (loop for path in paths 116 | for value = (load-blueprint path :force force) 117 | when value collect value)) 118 | 119 | (defun reload-blueprints (&key force) 120 | (loop for blueprint being the hash-values of *blueprints* 121 | do (load-blueprint blueprint :force force))) 122 | 123 | (defun make-blueprint-package () 124 | (let ((package (make-package (format NIL "ORG.SHIRAKUMO.FORGE.BLUEPRINT.~a" (random-id)) :use ()))) 125 | (sb-ext:add-package-local-nickname "FORGE" #.*package* package) 126 | package)) 127 | 128 | (defgeneric handle-blueprint-form (operator args)) 129 | -------------------------------------------------------------------------------- /modules/lisp/lisp.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.modules.lisp) 2 | 3 | (stealth-mixin:define-stealth-mixin client () forge:client 4 | ((load-tracking :initform (make-hash-table :test 'equal) :accessor load-tracking))) 5 | 6 | (forge:define-module lisp () 7 | ()) 8 | 9 | (defmethod forge:default-project-type ((module lisp)) 10 | 'project) 11 | 12 | (defmethod forge:on-client-connect ((module lisp) (client forge:client)) 13 | (promise:then 14 | (forge:with-client-eval (client) 15 | `(let ((intern (intern "ORG.SHIRAKUMO.FORGE.MODULES.LISP.LOAD-TRACKING" "CL-USER"))) 16 | (if (boundp intern) 17 | (symbol-value intern) 18 | (set intern (make-hash-table :test 'equal))))) 19 | (lambda (cached) 20 | (clrhash (load-tracking client)) 21 | (loop for k being the hash-keys of cached 22 | do (setf (gethash k (load-tracking client)) T))))) 23 | 24 | (defun implementation-version-string () 25 | (load-time-value 26 | (format NIL "~a-~a-~a-~a" 27 | (software-type) 28 | (machine-type) 29 | (lisp-implementation-type) 30 | (lisp-implementation-version)))) 31 | 32 | (defclass compile-effect (forge:effect) ()) 33 | (defclass load-effect (forge:effect) ()) 34 | 35 | (defclass file (forge:child-component forge:dependencies-component forge:file-component) 36 | ()) 37 | 38 | (defmethod forge:supported-operations append ((file file)) 39 | '(load-operation compile-file-operation load-fasl-operation)) 40 | 41 | (defmethod forge:normalize-dependency-spec ((file file) dep) 42 | (let ((component (gethash dep (forge:children (forge:parent file))))) 43 | (unless component 44 | (error "Fuck")) 45 | (forge:normalize-dependency-spec file component))) 46 | 47 | (defmethod forge:normalize-dependency-spec ((file file) (dependency file)) 48 | (forge: dependency)) 49 | 50 | (defclass lisp-source-operation (forge:operation) 51 | ((verbose :initarg :verbose :initform NIL :accessor verbose))) 52 | 53 | (defmethod forge:dependencies append ((op lisp-source-operation) (component file)) 54 | (loop for dependency in (forge:depends-on component) 55 | collect (forge:depend 'load-effect dependency :version (forge:version component)))) 56 | 57 | (defclass load-operation (lisp-source-operation) 58 | ()) 59 | 60 | (defmethod forge:make-effect ((op load-operation) (component file)) 61 | (forge:ensure-effect op component 'load-effect (forge:artefact component))) 62 | 63 | (defmethod forge:perform ((op load-operation) (component file) client) 64 | (let ((path (forge:artefact-pathname component client)) 65 | (time (forge:mtime (forge:artefact component)))) 66 | (promise:then (forge:with-client-eval (client) 67 | `(progn (load ,path 68 | :verbose ,(verbose op) 69 | :print ,(verbose op)) 70 | (setf (gethash ,path 'cl-user::org.shirakumo.forge.modules.lisp.load-tracking) ,time))) 71 | (lambda (_) 72 | (setf (gethash path (load-tracking client)) time))))) 73 | 74 | (defclass compile-file-operation (lisp-source-operation) 75 | ()) 76 | 77 | (defmethod forge:make-effect ((op compile-file-operation) (component file)) 78 | (call-next-method) 79 | (forge:ensure-effect op component 'compile-effect (forge:artefact component))) 80 | 81 | (defmethod forge:output-file-type ((op compile-file-operation) (component file)) 82 | "fasl") 83 | 84 | (defmethod forge:perform ((op compile-file-operation) (component file) client) 85 | (let ((output (forge:artefact-pathname (forge:realize-artefact (forge:output-artefact op component) op) client))) 86 | (forge:with-client-eval (client) 87 | `(compile-file ,(forge:artefact-pathname component client) 88 | :output-file (ensure-directories-exist ,output) 89 | :verbose ,(verbose op) 90 | :print ,(verbose op))))) 91 | 92 | (defmethod forge:perform :before ((step forge:step) (op compile-file-operation) client) 93 | (setf (forge:forced-p step) T)) 94 | 95 | (defclass load-fasl-operation (forge:compiler-input-operation lisp-compiler-operation) 96 | ()) 97 | 98 | (defmethod forge:make-effect ((op load-fasl-operation) (component file)) 99 | (forge:ensure-effect op component 'load-effect (forge:artefact component))) 100 | 101 | (defmethod forge:input-file-type ((op load-fasl-operation) (component file)) 102 | "fasl") 103 | 104 | (defmethod forge:perform ((op load-fasl-operation) (component file) client) 105 | (let ((path (forge:artefact-pathname component client)) 106 | (time (forge:mtime (forge:artefact component)))) 107 | (promise:then (forge:with-client-eval (client) 108 | `(progn (load ,(forge:artefact-pathname (forge:realize-artefact (forge:input-artefact op component) op) client)) 109 | (setf (gethash ,path 'cl-user::org.shirakumo.forge.modules.lisp.load-tracking) ,time))) 110 | (lambda (_) 111 | (setf (gethash path (load-tracking client)) time))))) 112 | 113 | (defclass load-into-image-operation (forge:operation) 114 | ()) 115 | 116 | (defclass project (forge:artefact-project) 117 | ()) 118 | 119 | (defmethod forge:supported-operations append ((project project)) 120 | '(load-operation load-into-image-operation)) 121 | 122 | (defmethod forge:make-effect ((op load-into-image-operation) (project project)) 123 | (forge:ensure-effect op project 'forge::build-effect (forge:name project))) 124 | 125 | (defmethod forge:normalize-dependency-spec ((project project) spec) 126 | (let ((spec (forge::enlist spec))) 127 | (flet ((parse-project-spec (name &key (effect 'load-effect) (version T) weak) 128 | (forge:depend effect 129 | (string-downcase name) 130 | :version (forge:parse-constraint version) 131 | :hard (not weak))) 132 | (parse-effect-spec (type parameters &key (version T) (hard T)) 133 | (forge:depend type 134 | parameters 135 | :version (forge:parse-constraint version) 136 | :hard hard))) 137 | (case (first spec) 138 | (:effect 139 | (apply #'parse-effect-spec (rest spec))) 140 | (:project 141 | (apply #'parse-project-spec (rest spec))) 142 | (T 143 | (apply #'parse-project-spec spec)))))) 144 | 145 | (defmethod forge:dependencies append ((op load-into-image-operation) (project project)) 146 | (forge:depends-on project)) 147 | 148 | (defmethod forge:make-effect ((op load-operation) (project project)) 149 | (forge:ensure-effect op project 'load-effect (forge:name project))) 150 | 151 | (defmethod forge:in-order-to ((effect forge::build-effect) (project project)) 152 | (forge:find-effect T 'load-effect (forge:name project) (forge:version project))) 153 | 154 | (defmethod forge:dependencies append ((op load-operation) (project project)) 155 | (loop for component being the hash-values of (forge:children project) 156 | collect (forge:depend 'load-effect (forge:artefact component) 157 | :version (forge:version component)))) 158 | 159 | (defmethod forge:default-component-type ((project project)) 160 | 'file) 161 | 162 | (defmethod forge:perform ((op load-operation) (project project) client) 163 | (promise:pend)) 164 | -------------------------------------------------------------------------------- /version.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file defines a protocol for the manipulation of version designators 3 | ;;; as well as a variety of commonly encountered versions designator types. 4 | ;;; It also allows parsing versions from a string representation, though due 5 | ;;; to variations in the notation this may not always work as expected. 6 | 7 | (in-package #:org.shirakumo.forge) 8 | 9 | (defclass version () 10 | ()) 11 | 12 | (define-print-object-method* version 13 | "~a" to-string) 14 | 15 | (defgeneric version= (a b)) 16 | (defgeneric version< (a b)) 17 | (defgeneric to-string (version)) 18 | (defgeneric parse-version (thing)) 19 | 20 | (defgeneric version<= (a b) 21 | (:method ((a version) (b version)) 22 | (or (version= a b) 23 | (version< a b)))) 24 | 25 | (defgeneric version-min (a b) 26 | (:method ((a version) (b version)) 27 | (if (version< a b) a b))) 28 | 29 | (defgeneric version-max (a b) 30 | (:method ((a version) (b version)) 31 | (if (version< a b) b a))) 32 | 33 | (defmethod support:generic< ((a version) (b version)) 34 | (version<= a b)) 35 | 36 | (defmethod parse-version ((version version)) 37 | version) 38 | 39 | (defclass unknown-version (version) 40 | ()) 41 | 42 | (defmethod version= ((a unknown-version) b) NIL) 43 | (defmethod version= (b (a unknown-version)) NIL) 44 | (defmethod version< ((a unknown-version) b) T) 45 | (defmethod version< (b (a unknown-version)) NIL) 46 | (defmethod to-string ((v unknown-version)) "?") 47 | 48 | (defvar *unknown-version* (make-instance 'unknown-version)) 49 | 50 | (defmethod parse-version ((version (eql NIL))) 51 | *unknown-version*) 52 | 53 | (defclass maximal-version (version) 54 | ()) 55 | 56 | (defmethod version= ((a maximal-version) (b maximal-version)) T) 57 | (defmethod version= ((a maximal-version) (b version)) NIL) 58 | (defmethod version= ((b version) (a maximal-version)) NIL) 59 | (defmethod version< ((b version) (a maximal-version)) T) 60 | (defmethod version< ((a maximal-version) (b version)) NIL) 61 | (defmethod to-string ((v maximal-version)) "+∞") 62 | 63 | (defmethod parse-version ((version (eql :max))) 64 | *maximal-version*) 65 | 66 | (defvar *maximal-version* (make-instance 'maximal-version)) 67 | 68 | (defclass minimal-version (version) 69 | ()) 70 | 71 | (defmethod version= ((a minimal-version) (b minimal-version)) T) 72 | (defmethod version= ((a minimal-version) (b version)) NIL) 73 | (defmethod version= ((b version) (a minimal-version)) NIL) 74 | (defmethod version< ((b version) (a minimal-version)) NIL) 75 | (defmethod version< ((a minimal-version) (b version)) T) 76 | (defmethod to-string ((v minimal-version)) "-∞") 77 | 78 | (defmethod parse-version ((version (eql :min))) 79 | *minimal-version*) 80 | 81 | (defvar *minimal-version* (make-instance 'minimal-version)) 82 | 83 | (defclass integer-version (version) 84 | ((value :initarg :value :initform 0 :accessor value))) 85 | 86 | (defmethod version= ((a integer-version) (b integer-version)) 87 | (= (value a) (value b))) 88 | 89 | (defmethod version< ((a integer-version) (b integer-version)) 90 | (< (value a) (value b))) 91 | 92 | (defmethod to-string ((v integer-version)) 93 | (princ-to-string (value v))) 94 | 95 | (defmethod parse-version ((version integer)) 96 | (make-instance 'integer-version :value version)) 97 | 98 | (defclass hashed-version (version) 99 | ((value :initarg :value :initform 0 :accessor value))) 100 | 101 | (defmethod version= ((a hashed-version) (b hashed-version)) 102 | (string= (value a) (value b))) 103 | 104 | (defmethod version< ((a hashed-version) (b hashed-version)) 105 | NIL) 106 | 107 | (defmethod to-string ((v hashed-version)) 108 | (value v)) 109 | 110 | (defmethod parse-version ((version string)) 111 | (make-instance 'hashed-version :value version)) 112 | 113 | (defclass separated-version (version) 114 | ((value :initarg :value :initform '(1) :accessor value))) 115 | 116 | (defmethod version= ((a separated-version) (b separated-version)) 117 | (loop for (ai ar) on (value a) 118 | for (bi br) on (value b) 119 | always (and (= ai bi) 120 | (or (and ar br) 121 | (and (null ar) (null br)))))) 122 | 123 | (defmethod version< ((a separated-version) (b separated-version)) 124 | (loop for ai in (value a) 125 | for bi in (value b) 126 | do (cond ((< ai bi) (return T)) 127 | ((< bi ai) (return NIL))))) 128 | 129 | (defmethod to-string ((v separated-version)) 130 | (format NIL "~{~d~^.~}" (value v))) 131 | 132 | (defmethod parse-version ((version cons)) 133 | (make-instance 'separated-version :value version)) 134 | 135 | (defclass compound-version (version) 136 | ((versions :initarg :versions :initform (support:arg! :versions) :reader versions))) 137 | 138 | (defmethod version= ((a compound-version) (b compound-version)) 139 | (loop for (ai ar) on (versions a) 140 | for (bi br) on (versions b) 141 | always (and (version= ai bi) 142 | (or (and ar br) 143 | (and (null ar) (null br)))))) 144 | 145 | (defmethod version< ((a compound-version) (b compound-version)) 146 | (loop for ai in (versions a) 147 | for bi in (versions b) 148 | do (cond ((version< ai bi) (return T)) 149 | ((version< bi ai) (return NIL))))) 150 | 151 | (defmethod to-string ((v compound-version)) 152 | (format NIL "~{~a~^-~}" (mapcar #'to-string (versions v)))) 153 | 154 | (defun version-from-string (version) 155 | (flet ((alpha-p (char) 156 | (or (<= (char-code #\a) (char-code char) (char-code #\z)) 157 | (<= (char-code #\A) (char-code char) (char-code #\Z))))) 158 | (cond ((find #\- version) 159 | (make-instance 'compound-version :versions (mapcar #'version-from-string (cl-ppcre:split "[-]+" version)))) 160 | ((find #\. version) 161 | (let* ((hashes (loop for part in (cl-ppcre:split "[.]+" version) 162 | collect (value (version-from-string part)))) 163 | (integers (loop for part = (car hashes) 164 | while (integerp part) 165 | collect (pop hashes))) 166 | (version (make-instance 'separated-version :value integers))) 167 | (if hashes 168 | (make-instance 'compound-version :versions (list* version (mapcar #'parse-version hashes))) 169 | version))) 170 | ((every #'digit-char-p version) 171 | (make-instance 'integer-version :value (parse-integer version))) 172 | ((and (= 1 (length version)) (alpha-p (char version 0))) 173 | (make-instance 'integer-version :value (- (char-code (char-downcase (char version 0))) (char-code #\a)))) 174 | (T 175 | (make-instance 'hashed-version :value version))))) 176 | 177 | (defclass versioned-object () 178 | ((version :initform *unknown-version* :accessor version))) 179 | 180 | (defmethod shared-initialize ((object versioned-object) slots &key version) 181 | (call-next-method) 182 | (when version 183 | (setf (version object) 184 | (typecase version 185 | (version version) 186 | (null *unknown-version*) 187 | (T (parse-version version)))))) 188 | 189 | (defmethod version= ((a versioned-object) b) 190 | (version= (version a) b)) 191 | 192 | (defmethod version= (a (b versioned-object)) 193 | (version= a (version b))) 194 | 195 | (defmethod version< ((a versioned-object) b) 196 | (version< (version a) b)) 197 | 198 | (defmethod version< (a (b versioned-object)) 199 | (version< a (version b))) 200 | -------------------------------------------------------------------------------- /communication/communication.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.communication) 2 | 3 | (defvar *version* 0) 4 | (defvar *id-counter* 0) 5 | 6 | (support:define-condition* connection-failed (error) 7 | (host report) ("Connection to~% ~a~%failed~@[:~% ~a~]" host report)) 8 | 9 | ;; Init to something hopefully unique on this machine 10 | (defun init-id-counter (&optional (machine-id (machine-instance))) 11 | (let ((*random-state* (make-random-state T))) 12 | (setf *id-counter* (+ (ash (ldb (byte 32 0) (sxhash machine-id)) 32) 13 | (ash (ldb (byte 16 0) (get-universal-time)) 16) 14 | (ash (ldb (byte 16 0) (random #xFFFF)) 0))))) 15 | 16 | (defun next-id () 17 | (incf *id-counter*)) 18 | 19 | (defclass host () ()) 20 | (defgeneric connect (host machine &key id timeout)) ; => CONNECTION 21 | (defgeneric serve (host)) ; => CONNECTION 22 | (defgeneric connections (host)) ; => (CONNECTION) 23 | 24 | (defclass connection () ()) 25 | (defgeneric host (connection)) ; => HOST 26 | (defgeneric alive-p (connection)) ; => BOOLEAN 27 | (defgeneric send (message connection)) 28 | (defgeneric receive (connection &key timeout)) ; => MESSAGE | NIL 29 | (defgeneric handle (message connection)) 30 | 31 | (defun send! (connection type &rest args) 32 | (send (apply #'make-instance type args) connection)) 33 | 34 | (define-compiler-macro send! (connection type &rest args) 35 | `(send (make-instance ,type ,@args) ,connection)) 36 | 37 | (defun reply! (connection message type &rest args) 38 | (send (apply #'make-instance type :id (id message) args) connection)) 39 | 40 | (define-compiler-macro reply! (connection message type &rest args) 41 | `(send (make-instance ,type :id (id ,message) ,@args) ,connection)) 42 | 43 | (defclass client-connection (connection) 44 | ((name :initarg :name :initform (support:arg! :name) :reader name))) 45 | (defclass server-connection (connection) ()) 46 | 47 | (defclass message () 48 | ((id :initarg :id :initform (next-id) :reader id))) 49 | 50 | (defmethod print-object ((message message) stream) 51 | (print-unreadable-object (message stream :type T) 52 | (format stream "~a" (id message)))) 53 | 54 | (defmacro define-message-printer (class (instance stream) &body body) 55 | `(defmethod print-object ((,instance ,class) ,stream) 56 | (print-unreadable-object (,instance ,stream :type T) 57 | ,@body 58 | (format ,stream " #~a" (id ,instance))))) 59 | 60 | (defclass reply (message) 61 | ()) 62 | 63 | (defmethod handle ((reply reply) (connection connection))) 64 | 65 | (defclass connection-lost (message) ()) 66 | 67 | (defmethod handle ((message connection-lost) (connection connection))) 68 | 69 | (defclass command (message) ()) 70 | (defclass ok (reply) ()) 71 | 72 | (defclass exit (command) ()) 73 | 74 | (defmethod handle ((request exit) (connection connection)) 75 | (invoke-restart 'exit-command-loop)) 76 | 77 | (defclass ping (command) 78 | ((clock :initform (get-universal-time) :reader clock))) 79 | 80 | (defclass pong (reply) 81 | ((clock :initform (get-universal-time) :reader clock))) 82 | 83 | (defmethod handle ((request ping) (connection connection)) 84 | (reply! connection request 'pong)) 85 | 86 | (defclass connect (command) 87 | ((machine :initarg :machine :initform (support:arg! :machine) :reader machine) 88 | (client-id :initarg :client-id :initform NIL :reader client-id) 89 | (version :initarg :version :initform *version* :reader version))) 90 | 91 | (define-message-printer connect (request stream) 92 | (format stream "~s~@[ ~s~]" (machine request) (client-id request))) 93 | 94 | (defclass error-message (reply) 95 | ((condition-type :initarg :condition-type :initform (support:arg! :condition-type) :reader condition-type) 96 | (arguments :initarg :arguments :initform () :reader arguments) 97 | (report :initarg :report :initform NIL :reader report))) 98 | 99 | (define-message-printer error-message (request stream) 100 | (format stream "~s" (condition-type request))) 101 | 102 | (defclass warning-message (reply) 103 | ((condition-type :initarg :condition-type :initform (support:arg! :condition-type) :reader condition-type) 104 | (arguments :initarg :arguments :initform () :reader arguments) 105 | (report :initarg :report :initform NIL :reader report))) 106 | 107 | (define-message-printer warning-message (request stream) 108 | (format stream "~s" (condition-type request))) 109 | 110 | (defun esend (connection condition &optional message) 111 | (send (make-instance (etypecase condition 112 | (error 'error-message) 113 | (T 'warning-message)) 114 | :condition-type (type-of condition) 115 | :arguments (support:arguments condition) 116 | :report (princ-to-string condition) 117 | :id (if message (id message) (next-id))) 118 | connection)) 119 | 120 | (defclass eval-request (command) 121 | ((form :initarg :form :initform (support:arg! :form) :reader form))) 122 | 123 | (define-message-printer eval-request (request stream) 124 | (format stream "~s" (form request))) 125 | 126 | (defmethod handle ((request eval-request) (connection connection)) 127 | (let ((values (multiple-value-list (eval (form request))))) 128 | (reply! connection request 'return-message :value values))) 129 | 130 | (defclass return-message (reply) 131 | ((value :initarg :value :initform (support:arg! :value) :reader value))) 132 | 133 | (define-message-printer return-message (request stream) 134 | (format stream "~s" (value request))) 135 | 136 | ;; Class for a client to request a plan and execution. 137 | (defclass effect-request (command) 138 | ((effect-type :initarg :effect-type :initform (support:arg! :effect-type) :reader effect-type) 139 | (parameters :initarg :parameters :initform (support:arg! :parameters) :reader parameters) 140 | (version :initarg :version :initform (support:arg! :version) :reader version) 141 | (execute-on :initarg :execute-on :initform :self :reader execute-on))) 142 | 143 | (define-message-printer effect-request (request stream) 144 | (format stream "~a ~s" (effect-type request) (parameters request))) 145 | 146 | (defstruct (file 147 | (:constructor make-file (source target)) 148 | (:copier NIL) 149 | (:predicate NIL)) 150 | (source NIL :type pathname :read-only T) 151 | (target NIL :type pathname :read-only T)) 152 | 153 | (defstruct (dummy-object 154 | (:constructor make-dummy-object (description)) 155 | (:copier NIL) 156 | (:predicate NIL)) 157 | (description NIL :type string :read-only T)) 158 | 159 | (defstruct (dummy-symbol 160 | (:constructor make-dummy-symbol (package name)) 161 | (:copier NIL) 162 | (:predicate NIL)) 163 | (package NIL :type string :read-only T) 164 | (name NIL :type string :read-only T)) 165 | 166 | (defstruct (artefact 167 | (:constructor make-artefact (registry path &optional (machine :server))) 168 | (:copier NIL) 169 | (:predicate NIL)) 170 | (registry NIL :type T :read-only T) 171 | (path NIL :type string :read-only T) 172 | (machine NIL :type T :read-only T)) 173 | 174 | (defgeneric encode-message (message stream)) 175 | (defgeneric decode-message (type stream)) 176 | 177 | (defun handshake (connection machine &key id timeout) 178 | (let ((message (send! connection 'connect :machine machine :client-id id))) 179 | (let ((message (receive connection :timeout timeout))) 180 | (etypecase message 181 | (ok 182 | connection) 183 | (null 184 | (error 'connection-failed :host (host connection) :report "Timeout reached.")) 185 | (error-message 186 | (error 'connection-failed :host (host connection) :report (report message))) 187 | (warning-message 188 | (warn "Trouble connecting: ~a" (report message))))))) 189 | -------------------------------------------------------------------------------- /toolkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge) 2 | 3 | (defun prototype (thing) 4 | (etypecase thing 5 | (symbol 6 | (c2mop:class-prototype (c2mop:ensure-finalized (find-class thing)))) 7 | (class 8 | (c2mop:class-prototype (c2mop:ensure-finalized thing))) 9 | (object 10 | thing))) 11 | 12 | (defun pophash (key table &optional default) 13 | (let ((value (gethash key table default))) 14 | (remhash key table) 15 | value)) 16 | 17 | (defun wait-for-thread-exit (thread) 18 | (loop for i from 0 19 | do (unless (bt:thread-alive-p thread) 20 | (return)) 21 | (when (<= 10 i) 22 | (restart-case (error "Message thread is not shutting down!") 23 | (interrupt (&optional (function #'break)) 24 | :report "Try to interrupt the thread." 25 | (bt:interrupt-thread thread function)) 26 | (abort () 27 | :report "Kill and forget the thread." 28 | (bt:destroy-thread thread)) 29 | (continue () 30 | :report "Continue waiting."))) 31 | (sleep 0.1))) 32 | 33 | (defmacro with-event-loop (bindings &body body) 34 | (let ((last-check (gensym "LAST-CHECK"))) 35 | `(let ((,last-check (get-internal-real-time)) 36 | ,@bindings) 37 | (loop ,@body 38 | ;; Backoff to make sure we don't overheat 39 | (let* ((new-time (get-internal-real-time)) 40 | (seconds-passed (/ (- new-time ,last-check) internal-time-units-per-second))) 41 | (when (< seconds-passed 0.01) 42 | (sleep (- 0.01 seconds-passed))) 43 | (setf ,last-check new-time)))))) 44 | 45 | (defmacro with-retry ((&optional (restart-report "Retry the operation.")) &body body) 46 | (let ((retry (gensym "RETRY"))) 47 | `(block NIL 48 | (tagbody 49 | ,retry 50 | (flet ((retry () 51 | (go ,retry))) 52 | (restart-case 53 | (return 54 | (progn 55 | ,@body)) 56 | (retry () 57 | :report ,restart-report 58 | (retry)))))))) 59 | 60 | (defmacro with-cleanup-on-unwind (cleanup &body body) 61 | (let ((clean (gensym "CLEAN"))) 62 | `(let ((,clean NIL)) 63 | (unwind-protect 64 | (multiple-value-prog1 65 | (progn ,@body) 66 | (setf ,clean T)) 67 | (unless ,clean 68 | ,cleanup))))) 69 | 70 | (defmacro define-print-object-method (class (instance stream &key identity) &body body) 71 | `(defmethod print-object ((,instance ,class) ,stream) 72 | (print-unreadable-object (,instance ,stream :type T :identity ,identity) 73 | ,@body))) 74 | 75 | (defmacro define-print-object-method* (class format-string &rest args) 76 | `(define-print-object-method ,class (,class stream) 77 | (format stream ,format-string ,@(loop for arg in args 78 | collect (if (listp arg) arg `(,arg ,class)))))) 79 | 80 | (defun unsafe-path-char-p (char) 81 | (or (find char "/\\<>:|?*\"") 82 | (<= 0 (char-code char) 31))) 83 | 84 | (defun tempdir () 85 | (pathname 86 | (format NIL "~a/" 87 | #+windows 88 | (or (support:envvar "TEMP") 89 | "~/AppData/Local/Temp") 90 | #+darwin 91 | (or (support:envvar "TMPDIR") 92 | "/tmp") 93 | #+linux 94 | (or (support:envvar "XDG_RUNTIME_DIR") 95 | "/tmp") 96 | #-(or windows darwin linux) 97 | "/tmp"))) 98 | 99 | (defun random-id () 100 | (format NIL "~8,'0x-~8,'0x" (random #xFFFFFFFF) (get-universal-time))) 101 | 102 | (defun tempfile (&key name type) 103 | (loop for path = (make-pathname :name (or name (random-id)) 104 | :type (or type "tmp") 105 | :defaults (tempdir)) 106 | do (unless (probe-file path) (return path)))) 107 | 108 | (defun hash-file (file) 109 | (etypecase file 110 | ((or string pathname) 111 | (ironclad:digest-file :sha256 file)) 112 | (stream 113 | (ironclad:digest-stream :sha256 file)))) 114 | 115 | (defun removef (plist &rest fields) 116 | (loop for (k v) on plist by #'cddr 117 | for found = (find k fields) 118 | unless found collect k 119 | unless found collect v)) 120 | 121 | (defun ensure-instance (designator type &optional default) 122 | (cond ((null designator) 123 | (if default 124 | (make-instance default) 125 | (error "Need a~% ~s" type))) 126 | ((typep designator 'symbol) 127 | (ensure-instance (make-instance designator) type)) 128 | ((typep designator type) 129 | designator) 130 | (T 131 | (error "Don't know what to do with~% ~s" designator)))) 132 | 133 | (defun enlist (a &rest args) 134 | (if (listp a) a (list* a args))) 135 | 136 | (defun delist (a &optional (n 0)) 137 | (if (listp a) (nth n a) a)) 138 | 139 | 140 | #+linux 141 | (progn ; Much faster scanning on linux using the d_type and direct byte comparisons. 142 | (cffi:defcstruct (dirent :class dirent :conc-name dirent-) 143 | (inode :size) 144 | (offset :size) 145 | (length :uint16) 146 | (type :uint8) 147 | (name :char :count 256)) 148 | 149 | (defun scan-directory (dir filename callback) 150 | (cffi:with-foreign-string (blueprint filename) 151 | (cffi:with-foreign-object (path :char 4096) 152 | (cffi:lisp-string-to-foreign (pathname-utils:native-namestring dir) path 4096) 153 | (labels ((scan (fd) 154 | (let ((handle (cffi:foreign-funcall "fdopendir" :int fd :pointer))) 155 | (unless (cffi:null-pointer-p handle) 156 | (unwind-protect 157 | (loop for entry = (cffi:foreign-funcall "readdir" :pointer handle :pointer) 158 | until (cffi:null-pointer-p entry) 159 | do (let* ((name (cffi:foreign-slot-pointer entry '(:struct dirent) 'name)) 160 | (namelen (cffi:foreign-funcall "strlen" :pointer name :size))) 161 | (when (or (< 2 namelen) 162 | (and (/= (char-code #\.) (cffi:mem-aref name :char 0)) 163 | (/= (char-code #\.) (cffi:mem-aref name :char 1)))) 164 | (flet ((dir (fd) 165 | (unwind-protect (scan fd) 166 | (cffi:foreign-funcall "close" :int fd :int))) 167 | (file (fd) 168 | (when (= 0 (cffi:foreign-funcall "strcmp" :pointer name :pointer blueprint :int)) 169 | (funcall callback (format NIL "~a/~a" 170 | (sb-posix:readlink (format NIL "/proc/self/fd/~d" fd)) 171 | filename))))) 172 | (case (dirent-type entry) 173 | (0 ; Unknown 174 | (let ((inner (cffi:foreign-funcall "openat" :int fd :pointer name :int 592128 :int))) 175 | (if (= -1 inner) 176 | (file fd) 177 | (dir inner)))) 178 | (4 ; Directory 179 | (dir (cffi:foreign-funcall "openat" :int fd :pointer name :int 592128 :int))) 180 | (8 ; Regular 181 | (file fd))))))) 182 | (cffi:foreign-funcall "closedir" :pointer handle :int)))) 183 | T)) 184 | (let ((fd (cffi:foreign-funcall "open" :pointer path :int 592128 :int))) 185 | (unless (= -1 fd) 186 | (scan fd)))))))) 187 | 188 | #-linux 189 | (defun scan-directory (dir filename callback) 190 | (dolist (path (directory (merge-pathnames (merge-pathnames filename "**/") dir))) 191 | (funcall callback path))) 192 | -------------------------------------------------------------------------------- /README.mess: -------------------------------------------------------------------------------- 1 | [ image logo.svg ] 2 | # AAAAAAAAAAAAAAAAAAAAAAAAa 3 | This is still in flux 4 | 5 | ## User Manual 6 | This section describes an overview on how to use Forge to perform builds and set your project up to build with it. Do note however that since Forge is a generic build system, you will also need to refer to documentation for the specific kind of project you're building to get the full picture. 7 | 8 | ### Building 9 | If you have ``forge`` in your path, performing the default build can be done simply by invoking ``forge`` from a directory that contains a ``blueprint`` file. It will automatically discover the blueprint and run the default build task. 10 | 11 | You can discover more about forge's command line arguments by running ``forge help``, which among other information will show you all the possible subcommands, including each command's arguments. Nevertheless, here's some other common uses: 12 | 13 | - ``forge -c ~/path/to/project/`` 14 | Invoke forge from a different directory than the blueprint file. 15 | - ``forge -t project`` 16 | Execute the default effect for ``project``, discovering the project's location automatically. 17 | - ``forge effect parameter...`` 18 | Execute a plan to reach the described effect. 19 | - ``forge --force`` 20 | Force the plan execution to disregard caching. 21 | 22 | By default Forge will try to discover a running server and use that as build host if it can be found. If not, it will act as server and spin up a local client to perform the build. Please see the configuration section on how to change this behaviour. 23 | 24 | ### Writing Blueprints 25 | In order to write project descriptions, you have to create a file called ``blueprint`` and place it somewhere that Forge can find it. A blueprint file can define a number of projects at once, and can potentially be located anywhere in relation to other source files or components necessary for the build. 26 | 27 | What exactly the blueprint file should contain will depend on the type of projects you are defining, but generally each project definition will look something like this: 28 | 29 | :: 30 | (forge:define-project (project-type) 31 | :name "project-name" 32 | :version 0 33 | :components ("some-file.x" "*.thing")) 34 | :: 35 | 36 | A more rigorous specification of the grammar is as follows: 37 | 38 | :: 39 | definition ::= (forge:define-project (module+) karg*) 40 | karg ::= name 41 | | version 42 | | components 43 | | project-type-specific-argument 44 | name ::= :name string 45 | version ::= :version version-designator 46 | components ::= :components (component-specification*) 47 | module --- A symbol naming a module that needs to be loaded to parse this project 48 | definition. The first module specified also determines the type of project 49 | that is defined. 50 | project-type-specific-argument 51 | --- An argument specific to the project type used. However, each argument still 52 | follows the key value format. 53 | :: 54 | 55 | Note that most of the definition will be specific to the type of project you're defining, so please refer to that specific module's documentation on how exactly to write a project definition. 56 | 57 | #### Version Designators 58 | Forge supports a number of different version specification schemes: 59 | 60 | - **Hash** 61 | A simple string that designates a hash of a version. If you use a hash, Forge will not be able to determine whether a version is newer or older than another. 62 | - **Integer** 63 | A single, increasing positive integer version. There's no constraints on the range of the integer. 64 | - **Separated** 65 | A list of integer versions, in descending order of importance. Meaning a version of ``(1 2 3)`` is newer than ``(1 3 2)``. 66 | - **Compound** 67 | A combination of multiple of the previous schemes, again with the earlier scheme taking precedence for the ordering. 68 | 69 | Each of these versions can also be parsed from a string if you prefer to specify them that way: 70 | 71 | - ``"1"`` - Integer 72 | - ``"1.2"`` - Separated 73 | - ``"1.2-a"`` - Compound (Separated + Hash) 74 | - ``"1.2-32"`` - Compound (Separated + Integer) 75 | - ``"a"`` - Hash 76 | 77 | Additional modules may extend the types of versions supported. 78 | 79 | #### Component Specifications 80 | Each component can be specified as either a singular pattern for files to match, or as a list of the following structure: 81 | 82 | :: 83 | component ::= (name karg*) 84 | karg ::= type 85 | | component-type-specific-argument 86 | type ::= :type component-type-name 87 | name --- A string naming the component. Must be unique within the project. 88 | component-type-specific-argument 89 | --- An argument specific to the component type used. However, each argument still 90 | follows the key value format. 91 | component-type-name 92 | --- A symbol naming the type of component to construct. If not specified, a default 93 | type will be chosen based on the project type. 94 | :: 95 | 96 | Again, most of the arguments permissible will be specific to the type of component used. Please refer to the appropriate documentation for further instructions. 97 | 98 | ### Configuration 99 | ; TODO 100 | 101 | ## Internals 102 | This section discusses the internals of the Forge system. You should read this if you plan to contribute to Forge itself or would like to extend it in some way, be that by supporting a new language target, or adding other support functionality. 103 | 104 | ### Concepts 105 | Forge employs a strict separation model in two ways: 106 | 107 | 1. The planning phase is required to be entirely deterministic and **must not** touch the file system or other variable parts. A fully generated plan can then be executed via a number of different execution strategies, at which point steps in the plan may be elided to avoid unnecessary work, and may be distributed across multiple clients that perform the work. 108 | 2. Execution should not happen on the same process as planning and management. This ensures that side-effects from plan execution are isolated from the planner, and also that needed libraries for planning and such are not needed on an executing client. 109 | 110 | Being separated as such, we will go over the concepts in separation as well, first looking at planning, then at execution, and finally at the distribution and file system aspects. 111 | 112 | #### Planning 113 | Plans are oriented around ``effect``s, which are an abstract description of some kind of change that we would like to achieve. Effects are caused by ``perform``ing some kind of ``operation`` on some kind of ``compononent``. Both operations, components, and effects are entirely abstract in this, though they will often be used to represent something like: performing compilation on file A produces a fragment B, with the B output being the effect, file A being the component, and compilation being the operation. 114 | 115 | An effect may be produced by different combinations of operations and components. To resolve this ambiguity, computing a plan takes a ``policy`` object. The policy has effects both on the selection of which effective operation and component are used to achieve any effect, and they also influence the exact parameters of each operation object, allowing the influence of things such as compilation parameters. 116 | 117 | Any operation and component pair will have a list of ``dependencies``, each of which should be a ``dependency`` object that describes applicable effects that, if achieved, satisfy the dependency. In order to perform the operation on the component, all hard dependencies must first be resolved. A dependency may also be weak, in which case the dependent effect must only be achieved first if it is already included elsewhere as a hard dependency. 118 | 119 | In order to resolve a dependency, a database is first searched for effects that match the dependency's ``effect-type``, ``parameters``, and ``version`` constraints. Possible effects are then gathered into sets of effects across the whole plan. Once all possible sets are computed, a single effects set is selected via the policy using ``select-effect-set``. 120 | 121 | Once the graph of effects has been computed, it is transformed into a graph of ``steps`` to form a ``plan``. Each ``step`` retains the exact effect, operation, and component selected by the planner, and holds a list of ``predecessors`` and ``successors`` steps. 122 | 123 | #### Execution 124 | Since a ``plan`` is completely independent of any filesystem or client, before a ``plan`` can be executed, it must first be ``realize``d. During realization, the set of clients that will execute steps is selected, individual steps are allocated to the clients, and the steps are transformed into ``local-step``s, which contain information that is localised to a specific client. 125 | 126 | During realization the ``executor`` may also already mark steps as ``complete``, if it can determine that the client has performed the operation before and can instead re-use a cached version. 127 | 128 | One important detail is that ``execute`` and ``perform`` both must return a ``promise`` object, and the executor must ensure that ``perform`` is not called eagerly or synchronously, as the communication with clients requires that the execution of a step happen asynchronously. 129 | -------------------------------------------------------------------------------- /project.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file describes the project protocol, which is the top-level 3 | ;;; entry point by which users define their components and dependencies. 4 | ;;; A project is typically defined via a source expression in a blueprint 5 | ;;; file, but is not necessarily so. 6 | 7 | (in-package #:org.shirakumo.forge) 8 | 9 | (support:define-condition* no-such-project (error) 10 | (name version) ("Could not find a project with name~% ~a~%and matching version~% ~a" name (to-string (version condition)))) 11 | 12 | (support:define-condition* project-source-path-changed (warning) 13 | (new old project) ("The blueprint source path for~% ~a~%would be changed from~% ~a~%to~% ~a" project old new)) 14 | 15 | (defvar *projects* (make-hash-table :test 'equal)) 16 | 17 | (defclass build-effect (effect) 18 | ()) 19 | 20 | (defclass project (dependencies-component parent-component) 21 | ((blueprint :initarg :blueprint :initform *blueprint* :reader blueprint) 22 | metadata)) 23 | 24 | (defmethod shared-initialize :after ((project project) slots &key (components NIL components-p)) 25 | (when components-p 26 | (flet ((find-or-init (type initargs) 27 | (let ((existing (gethash (getf initargs :name) (children project)))) 28 | (if existing 29 | (if (eql type (class-name (class-of existing))) 30 | existing 31 | (change-class existing type)) 32 | (setf existing (apply #'make-instance (find-class type) initargs))) 33 | (setf (slot-value existing 'name) (getf initargs :name)) 34 | existing))) 35 | ;; First, parse all specs 36 | (let ((specs (loop for spec in components 37 | append (loop for spec in (normalize-component-spec project spec) 38 | collect (parse-component project spec)))) 39 | (old-table (children project)) 40 | (children (make-hash-table :test 'equal))) 41 | ;; Next update/allocate the entire table, this should avoid triggering 42 | ;; shared-initialize on any passed initargs. 43 | (loop for (type . initargs) in specs 44 | for component = (find-or-init type initargs) 45 | do (setf (gethash (name component) children) component)) 46 | (setf (children project) children) 47 | ;; Finally now that all component objects are known, reinitialize to 48 | ;; trigger shared-initialize methods on initargs that might need to resolve. 49 | ;; FIXME: How do we also undo effects created in the db? 50 | ;; Need some kinda transactioning... 51 | ;; Generally also need to clean up leftover effects when a project is 52 | ;; redefined though, wonder how to do that nicely. 53 | (with-cleanup-on-unwind (setf (children project) old-table) 54 | (loop for spec in specs 55 | for prior = NIL then component 56 | for component = (gethash (getf (rest spec) :name) children) 57 | do (apply #'reinitialize-instance component :prior prior (rest spec)))))))) 58 | 59 | (defmethod make-step ((operation operation) (project project) (effect build-effect)) 60 | (make-instance 'compound-step 61 | :operation operation 62 | :component project 63 | :effect effect 64 | :inner-effect (in-order-to effect project))) 65 | 66 | (defgeneric ensure-version (version-ish)) 67 | (defgeneric parse-project (module project-definition)) 68 | (defgeneric find-project (name &key version if-does-not-exist)) 69 | (defgeneric register-project (project blueprint)) 70 | (defgeneric delete-project (project)) 71 | (defgeneric in-order-to (operation project)) 72 | (defgeneric build (project &key policy executor)) 73 | (defgeneric normalize-component-spec (project spec)) 74 | (defgeneric parse-component (project spec)) 75 | (defgeneric default-component-type (project)) 76 | (defgeneric default-project-type (module)) 77 | 78 | (defmethod path ((project project)) 79 | (when (blueprint project) 80 | (path (blueprint project)))) 81 | 82 | (defmethod normalize-component-spec ((project project) spec) 83 | (enlist spec)) 84 | 85 | (defmethod parse-component ((project project) spec) 86 | (destructuring-bind (name . args) spec 87 | (let ((type (getf args :type (default-component-type project)))) 88 | (remf args :type) 89 | (list* type :name name args)))) 90 | 91 | (defun list-projects (&key name) 92 | (if name 93 | (copy-list (gethash name *projects*)) 94 | (let ((projects ())) 95 | (loop for versions being the hash-values of *projects* 96 | do (loop for project in versions 97 | do (push project projects))) 98 | projects))) 99 | 100 | (defmethod ensure-version ((version version)) 101 | version) 102 | 103 | (defmethod ensure-version ((version string)) 104 | (version-from-string version)) 105 | 106 | (defmethod ensure-version (version-ish) 107 | (parse-version version-ish)) 108 | 109 | (defmethod ensure-version ((file pathname)) 110 | (version-from-string (alexandria:read-file-into-string file))) 111 | 112 | (defmethod find-project ((name string) &key (version (parse-constraint T)) (if-does-not-exist :error)) 113 | (let* ((name (string-downcase name)) 114 | (versions (gethash name *projects*))) 115 | (or (loop for project in versions 116 | when (version-match-p (version project) version) 117 | return project) 118 | (ecase if-does-not-exist 119 | ((NIL) (return-from find-project NIL)) 120 | (:error (error 'no-such-project :name name :version version)))))) 121 | 122 | (defmethod find-project ((name symbol) &rest args) 123 | (apply #'find-project (string name) args)) 124 | 125 | (defmethod register-project :around ((project project) source) 126 | (with-simple-restart (abort "Don't register the new project.") 127 | (call-next-method))) 128 | 129 | (defmethod register-project ((project project) source) 130 | (let* ((name (string-downcase (name project))) 131 | (versions (gethash name *projects*))) 132 | (pushnew project versions) 133 | (setf (gethash name *projects*) versions) 134 | project)) 135 | 136 | (defmethod register-project :before ((project project) (blueprint blueprint)) 137 | (when (and (blueprint project) (not (eq blueprint (blueprint project)))) 138 | (warn 'project-source-path-changed :project project :old (blueprint project) :new blueprint)) 139 | (pushnew project (projects blueprint))) 140 | 141 | (defmethod delete-project (name) 142 | (remhash (string-downcase name) *projects*) 143 | name) 144 | 145 | (defmethod delete-project ((project project)) 146 | (let* ((name (string-downcase (name project))) 147 | (versions (remove project (gethash name *projects*)))) 148 | (remhash project *projects*) 149 | (if versions 150 | (setf (gethash name *projects*) versions) 151 | (remhash name *projects*)) 152 | name)) 153 | 154 | (defmethod delete-project ((all (eql T))) 155 | (loop for versions being the hash-values of *projects* 156 | do (mapc #'delete-project versions))) 157 | 158 | (defmethod handle-blueprint-form ((operator (eql 'define-project)) args) 159 | (funcall (compile NIL `(lambda () (,operator ,@args))))) 160 | 161 | (defmacro define-project (modules &body args) 162 | (let ((module (or (first (mapcar #'load-module modules)) (find-module 'forge))) 163 | (versiong (gensym "VERSION")) 164 | (instance (gensym "INSTANCE"))) 165 | (destructuring-bind (type name version initargs) (parse-project module args) 166 | `(let* ((*blueprint* ,*blueprint*) 167 | (,versiong (ensure-version ,version)) 168 | (,instance (or (find-project ',name :version ,versiong :if-does-not-exist NIL) 169 | (make-instance ',type :name ,name :version ,versiong)))) 170 | (reinitialize-instance ,instance ,@initargs) 171 | (register-project ,instance *blueprint*))))) 172 | 173 | (defmethod build (project &rest args) 174 | (apply #'build (find-project project :if-does-not-exist :error) args)) 175 | 176 | (defmethod build ((project project) &key (policy 'basic-policy) (executor 'linear-executor) (effect-type 'build-effect)) 177 | (let* ((effect (find-effect *database* effect-type (name project) (version project) T)) 178 | (plan (compute-plan effect (ensure-instance policy 'policy))) 179 | (executor (ensure-instance executor 'executor))) 180 | (execute (realize plan executor) executor))) 181 | 182 | (defmethod parse-project ((module module) project-definition) 183 | (let ((type (getf project-definition :type (default-project-type module))) 184 | (name (getf project-definition :name))) 185 | (check-type type (and symbol (not null))) 186 | (check-type name string) 187 | (list type 188 | name 189 | (or (getf project-definition :version) 0) 190 | (loop for (key val) on (removef project-definition :type :name :version) by #'cddr 191 | do (check-type key symbol) 192 | collect key collect `',val)))) 193 | 194 | (define-module forge () 195 | ()) 196 | 197 | (defmethod default-project-type ((module forge)) 198 | 'project) 199 | -------------------------------------------------------------------------------- /plan.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file defines the general planning protocol and algorithm. 3 | ;;; The planning system is responsible for taking abstract definitions of 4 | ;;; operations, components, effects, and versions of each of them and 5 | ;;; computing a tree (plan) of required operations on components to achieve 6 | ;;; a desired end-effect. 7 | 8 | (in-package #:org.shirakumo.forge) 9 | 10 | (support:define-condition* dependency-cycle-detected (error) 11 | (effect) ("Dependency cycle detected around~% ~a" effect)) 12 | 13 | (support:define-condition* unsatisfiable-dependency (warning) 14 | (dependency operation component) ("Cannot find any effects that satisfy~% ~a~%of~% ~a ~a" dependency operation component)) 15 | 16 | (support:define-condition* unsatisfiable-effect (error) 17 | (effect) ("Cannot compute a plan to reach~% ~a~%no possible solutions found to resolve all constraints!" effect)) 18 | 19 | (defvar *database*) 20 | 21 | (defclass database () 22 | ()) 23 | 24 | (defgeneric map-effects (function database &optional type parameters version)) 25 | (defgeneric list-effects (database &optional type parameters version)) 26 | (defgeneric find-effect (database type parameters version &optional error)) 27 | (defgeneric register-effect (database effect)) 28 | (defgeneric achieved-version (database effect)) 29 | (defgeneric (setf achieved-version) (version database effect)) 30 | 31 | (defmethod map-effects (function (database (eql T)) &optional type parameters version) 32 | (map-effects function *database* type parameters version)) 33 | 34 | (defmethod list-effects ((database (eql T)) &optional type parameters version) 35 | (list-effects *database* type parameters version)) 36 | 37 | (defmethod list-effects ((database database) &optional type parameters version) 38 | (let ((effects ())) 39 | (map-effects (lambda (e) (push e effects)) database type parameters version) 40 | effects)) 41 | 42 | (defmethod find-effect ((database (eql T)) type parameters version &optional (error T)) 43 | (find-effect *database* type parameters version error)) 44 | 45 | (defmethod find-effect ((database database) type parameters version &optional (error T)) 46 | (map-effects (lambda (e) (return-from find-effect e)) database type parameters version) 47 | (when error 48 | (error "No ~s effect of version ~a in database matching~% ~s" 49 | type (to-string version) parameters))) 50 | 51 | (defmethod achieved-version ((database (eql T)) effect) 52 | (achieved-version *database* effect)) 53 | 54 | (defmacro do-effects ((effect database &optional type parameters version) &body body) 55 | (let ((thunk (gensym "THUNK"))) 56 | `(block NIL 57 | (flet ((,thunk (,effect) 58 | ,@body)) 59 | (map-effects #',thunk ,database ,type ,parameters ,version))))) 60 | 61 | (defclass component (versioned-object) 62 | ((name :initarg :name :initform (support:arg! :name) :reader name))) 63 | 64 | (define-print-object-method* component 65 | "~s ~a" name (to-string (version component))) 66 | 67 | (defgeneric supported-operations (component) 68 | (:method-combination append)) 69 | 70 | (defmethod supported-operations append ((component component)) 71 | ()) 72 | 73 | (defmethod shared-initialize :after ((component component) slots &key) 74 | (dolist (op (supported-operations component)) 75 | (make-effect op component))) 76 | 77 | (defclass operation () 78 | ()) 79 | 80 | (defgeneric dependencies (operation component) 81 | (:method-combination append)) 82 | (defgeneric perform (operation component client)) 83 | (defgeneric make-effect (operation component)) 84 | (defgeneric ensure-effect (operation component type parameters)) 85 | 86 | (defmethod dependencies append ((operation operation) (component component)) 87 | ()) 88 | 89 | (defmethod make-effect ((operation symbol) (component component)) 90 | (make-effect (prototype operation) component)) 91 | 92 | (defmethod ensure-effect (operation (component component) type parameters) 93 | (let* ((version (version component)) 94 | (effect (or (find-effect *database* type parameters version NIL) 95 | (register-effect *database* (make-instance type :parameters parameters :version version))))) 96 | (add-source operation component effect) 97 | effect)) 98 | 99 | (defclass dependency () 100 | ((effect-type :initarg :effect-type :initform (support:arg! :effect-type) :reader effect-type) 101 | (parameters :initarg :parameters :initform (support:arg! :parameters) :reader parameters) 102 | (version :initarg :version :initform (parse-constraint T) :reader version) 103 | (hard :initarg :hard :initform T :reader hard-p))) 104 | 105 | (defun depend (type parameters &key (version (parse-constraint T)) (hard T)) 106 | (make-instance 'dependency 107 | :effect-type type 108 | :parameters parameters 109 | :version version 110 | :hard hard)) 111 | 112 | (defmethod print-object ((dependency dependency) stream) 113 | (print-unreadable-object (dependency stream :type T) 114 | (format stream "~s ~s ~a ~@[HARD~]" 115 | (effect-type dependency) (parameters dependency) (to-string (version dependency)) (hard-p dependency)))) 116 | 117 | (defclass effect (versioned-object) 118 | ((sources :initarg :sources :initform () :accessor sources) 119 | (parameters :reader parameters))) 120 | 121 | (defgeneric sources (effect)) 122 | (defgeneric add-source (operation component effect)) 123 | (defgeneric parameters (effect)) 124 | (defgeneric normalize-parameters (effect parameters)) 125 | (defgeneric variant-p (effect-1 effect-2)) 126 | 127 | (defmethod initialize-instance ((effect effect) &key parameters) 128 | (call-next-method) 129 | (setf (slot-value effect 'parameters) (normalize-parameters effect parameters))) 130 | 131 | (defmethod print-object ((effect effect) stream) 132 | (print-unreadable-object (effect stream :type T) 133 | (format stream "~s" (parameters effect)))) 134 | 135 | (defmethod add-source ((operation operation) (component component) (effect effect)) 136 | (add-source (type-of operation) component effect)) 137 | 138 | (defmethod add-source ((operation symbol) (component component) (effect effect)) 139 | (let ((source (list operation component))) 140 | (pushnew source (sources effect) :test #'equal) 141 | source)) 142 | 143 | (defmethod normalize-parameters ((effect symbol) parameters) 144 | (normalize-parameters (prototype effect) parameters)) 145 | 146 | (defmethod normalize-parameters ((effect effect) parameters) 147 | parameters) 148 | 149 | (defmethod variant-p ((a effect) (b effect)) 150 | (and (eq (type-of a) (type-of b)) 151 | (equal (parameters a) (parameters b)))) 152 | 153 | (defmethod achieved-version ((database database) (effect effect)) 154 | *unknown-version*) 155 | 156 | (defmethod (setf achieved-version) ((current (eql T)) (database database) (effect effect)) 157 | (setf (achieved-version database effect) (version effect))) 158 | 159 | (defclass compiler (versioned-object) 160 | ((name :initarg :name :initform (support:arg! :name) :reader name) 161 | (cache-directory :initarg :cache-directory :initform NIL :accessor cache-directory))) 162 | 163 | (defmethod initialize-instance :after ((compiler compiler) &key) 164 | (unless (cache-directory compiler) 165 | (setf (cache-directory compiler) (remove-if #'unsafe-path-char-p 166 | (format NIL "~(~a-~a~)" 167 | (name compiler) 168 | (to-string (version compiler))))))) 169 | 170 | (defclass policy () 171 | ((compiler :initarg :compiler :initform NIL :accessor compiler))) 172 | 173 | (defgeneric in-order-to (effect policy)) 174 | (defgeneric select-source (policy effect sources)) 175 | (defgeneric select-effect-set (policy sets)) 176 | (defgeneric compute-plan (effect policy)) 177 | (defgeneric make-operation (operation policy)) 178 | (defgeneric select-compiler (effect policy)) 179 | 180 | (defmethod in-order-to ((effect effect) (policy policy)) 181 | (select-source policy effect (sources effect))) 182 | 183 | (defmethod make-operation ((operation symbol) (policy policy)) 184 | (make-operation (make-instance operation) policy)) 185 | 186 | (defmethod make-operation ((operation operation) (policy policy)) 187 | operation) 188 | 189 | (defmethod compute-plan :before ((effect effect) (policy policy)) 190 | (unless (compiler policy) 191 | (setf (compiler policy) (select-compiler effect policy)))) 192 | 193 | (defclass plan () 194 | ((first-steps :initarg :first-steps :initform #() :reader first-steps) 195 | (final-steps :initarg :final-steps :initform #() :reader final-steps))) 196 | 197 | (defgeneric make-step (operation component effect)) 198 | (defgeneric effect-achieved-p (effect policy)) 199 | 200 | (defmethod effect-achieved-p ((effect effect) (policy policy)) 201 | ;; v This feels wrong 202 | (version= effect (achieved-version T effect))) 203 | 204 | (defmethod make-step ((operation operation) (component component) (effect effect)) 205 | (make-instance 'step 206 | :operation operation 207 | :component component 208 | :effect effect)) 209 | 210 | (defclass step () 211 | ((operation :initarg :operation :initform (support:arg! :operation) :reader operation) 212 | (component :initarg :component :initform (support:arg! :compoenent) :reader component) 213 | (effect :initarg :effect :initform (support:arg! :effect) :reader effect) 214 | (predecessors :initarg :predecessors :initform () :accessor predecessors) 215 | (successors :initarg :successors :initform () :accessor successors))) 216 | 217 | (define-print-object-method* step 218 | "~s ~s" (type-of (operation step)) (type-of (component step))) 219 | 220 | (defclass compound-step (step) 221 | ((inner-effect :initarg :inner-effect :initform (support:arg! :inner-effect) :reader inner-effect))) 222 | 223 | (defgeneric connect (from to)) 224 | 225 | (defmethod connect ((from step) (to step)) 226 | (pushnew to (successors from)) 227 | (pushnew from (predecessors to))) 228 | 229 | (defmethod disconnect ((from step) (to step)) 230 | (setf (successors from) (delete to (successors from))) 231 | (setf (predecessors to) (delete from (predecessors to)))) 232 | 233 | ;; FIXME: way of declaring "latest version" of known set 234 | ;;; WORKAROUND: always pick latest version if multiple possible. 235 | -------------------------------------------------------------------------------- /constraints.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file defines a protocol to describe version constraints 3 | ;;; and a way to test and unify such constraints. These constraint 4 | ;;; mechanisms are used in the planning system to ensure that we 5 | ;;; only allow permutations of compatible parts. 6 | 7 | (in-package #:org.shirakumo.forge) 8 | 9 | (define-condition constraints-incompatible (error) 10 | ((a :initarg :a :reader a) 11 | (b :initarg :b :reader b)) 12 | (:report (lambda (c s) (format s "The two constraints~% ~a~% and~% ~a~%are mutually exclusive and cannot be unified." 13 | (a c) (b c))))) 14 | 15 | (defgeneric %parse-constraint (comp args)) 16 | 17 | (defun parse-constraint (constraint) 18 | (if (listp constraint) 19 | (destructuring-bind (constraint-type . args) constraint 20 | (%parse-constraint constraint-type args)) 21 | (%parse-constraint constraint ()))) 22 | 23 | (defmacro define-constraint-parser (constraint args &body body) 24 | `(defmethod %parse-constraint ((_ (eql ',constraint)) args) 25 | (destructuring-bind ,args args 26 | ,@body))) 27 | 28 | (defmethod constraint ((spec cons)) 29 | (parse-constraint spec)) 30 | 31 | (defclass version-constraint () 32 | ()) 33 | 34 | (defgeneric version-match-p (version constraint)) 35 | (defgeneric constraint-subset-p (sub sup)) 36 | (defgeneric unify (a b)) 37 | (defgeneric widen (a b)) 38 | 39 | (defmethod print-object ((constraint version-constraint) stream) 40 | (print-unreadable-object (constraint stream) 41 | (format stream "CONSTRAINT ~a" (to-string constraint)))) 42 | 43 | (defmethod version-match-p ((a version) (b version)) 44 | (version= a b)) 45 | 46 | (defun unify* (&rest constraints) 47 | (if constraints 48 | (let ((constraint (first constraints))) 49 | (dolist (other (rest constraints) constraint) 50 | (setf constraint (unify constraint other)))) 51 | (make-instance 'version-unspecific-constraint))) 52 | 53 | (defun match-constraint (versions constraint &key key) 54 | (let ((key (etypecase key 55 | (null #'identity) 56 | (symbol (fdefinition key)) 57 | (function key)))) 58 | (loop for version in versions 59 | when (version-match-p (funcall key version) constraint) 60 | collect version))) 61 | 62 | (defclass version-unspecific-constraint (version-constraint) 63 | ()) 64 | 65 | (defmethod version-match-p ((version version) (constraint version-unspecific-constraint)) 66 | T) 67 | 68 | (defmethod constraint-subset-p ((sub version-unspecific-constraint) (sup version-unspecific-constraint)) 69 | T) 70 | 71 | (defmethod constraint-subset-p ((sub version-constraint) (sup version-unspecific-constraint)) 72 | T) 73 | 74 | (defmethod constraint-subset-p ((sub version-unspecific-constraint) (sup version-constraint)) 75 | NIL) 76 | 77 | (defmethod unify ((a version-unspecific-constraint) (b version-constraint)) 78 | b) 79 | 80 | (defmethod unify ((b version-constraint) (a version-unspecific-constraint)) 81 | b) 82 | 83 | (defmethod widen ((a version-unspecific-constraint) (b version-constraint)) 84 | a) 85 | 86 | (defmethod widen ((b version-constraint) (a version-unspecific-constraint)) 87 | a) 88 | 89 | (defmethod to-string ((constraint version-unspecific-constraint)) 90 | "T") 91 | 92 | (define-constraint-parser T () 93 | (load-time-value (make-instance 'version-unspecific-constraint))) 94 | 95 | (defclass version-equal-constraint (version-constraint) 96 | ((version :initarg :version :initform *unknown-version* :reader version))) 97 | 98 | (defmethod version-match-p ((version version) (constraint version-equal-constraint)) 99 | (version= version (version constraint))) 100 | 101 | (defmethod constraint-subset-p ((sub version-equal-constraint) (sup version-equal-constraint)) 102 | (version= (version sub) (version sup))) 103 | 104 | (defmethod unify ((a version-equal-constraint) (b version-equal-constraint)) 105 | (unless (version= (version a) (version b)) 106 | (error 'constraints-incompatible :a a :b b)) 107 | a) 108 | 109 | (defmethod widen ((a version-equal-constraint) (b version-equal-constraint)) 110 | (when (version= (version a) (version b)) 111 | a)) 112 | 113 | (defmethod to-string ((constraint version-equal-constraint)) 114 | (format NIL "=~a" (to-string (version constraint)))) 115 | 116 | (define-constraint-parser = (version) 117 | (make-instance 'version-equal-constraint :version (parse-version version))) 118 | 119 | (defclass version-range-constraint (version-constraint) 120 | ((min-version :initarg :min-version :initform *minimal-version* :reader min-version) 121 | (max-version :initarg :max-version :initform *maximal-version* :reader max-version))) 122 | 123 | (defmethod initialize-instance :after ((constraint version-range-constraint) &key) 124 | (when (version<= (max-version constraint) (min-version constraint)) 125 | (error "Versions do not form a valid range: [~a, ~a]" (min-version constraint) (max-version constraint)))) 126 | 127 | (defmethod version-match-p ((version version) (constraint version-range-constraint)) 128 | (and (version<= (min-version constraint) version) 129 | (version<= version (max-version constraint)))) 130 | 131 | (defmethod constraint-subset-p ((sub version-range-constraint) (sup version-range-constraint)) 132 | (and (version<= (min-version sup) (min-version sub)) 133 | (version<= (max-version sub) (max-version sup)))) 134 | 135 | (defmethod constraint-subset-p ((sub version-equal-constraint) (sup version-range-constraint)) 136 | (and (version<= (min-version sup) (version sub)) 137 | (version<= (version sub) (max-version sup)))) 138 | 139 | (defmethod constraint-subset-p ((sub version-range-constraint) (sup version-equal-constraint)) 140 | NIL) 141 | 142 | (defmethod unify ((a version-range-constraint) (b version-range-constraint)) 143 | (let ((min (version-max (min-version a) (min-version b))) 144 | (max (version-min (max-version a) (max-version b)))) 145 | (cond ((version= min max) 146 | (make-instance 'version-equal-constraint :version min)) 147 | ((version< min max) 148 | (make-instance 'version-range-constraint :min-version min :max-version max)) 149 | (T 150 | (error 'constraints-incompatible :a a :b b))))) 151 | 152 | (defmethod unify ((a version-range-constraint) (b version-equal-constraint)) 153 | (unless (and (version<= (min-version a) (version b)) 154 | (version<= (version b) (max-version a))) 155 | (error 'constraints-incompatible :a a :b b)) 156 | b) 157 | 158 | (defmethod unify ((b version-equal-constraint) (a version-range-constraint)) 159 | (unify a b)) 160 | 161 | (defmethod widen ((a version-range-constraint) (b version-range-constraint)) 162 | (cond ((constraint-subset-p a b) b) 163 | ((constraint-subset-p b a) a) 164 | ((or (and (version<= (min-version a) (max-version b)) 165 | (version<= (max-version b) (max-version a))) 166 | (and (version<= (min-version a) (min-version b)) 167 | (version<= (min-version b) (max-version a)))) 168 | (make-instance 'version-range-constraint 169 | :min-version (version-min (min-version b) (min-version a)) 170 | :max-version (version-max (max-version b) (max-version a)))))) 171 | 172 | (defmethod widen ((a version-range-constraint) (b version-equal-constraint)) 173 | (when (constraint-subset-p b a) 174 | a)) 175 | 176 | (defmethod widen ((b version-equal-constraint) (a version-range-constraint)) 177 | (widen a b)) 178 | 179 | (defmethod to-string ((constraint version-range-constraint)) 180 | (format NIL "[~a,~a]" (to-string (min-version constraint)) (to-string (max-version constraint)))) 181 | 182 | (define-constraint-parser <= (version) 183 | (make-instance 'version-range-constraint :max-version (parse-version version))) 184 | (define-constraint-parser >= (version) 185 | (make-instance 'version-range-constraint :min-version (parse-version version))) 186 | (define-constraint-parser [ (min max) 187 | (make-instance 'version-range-constraint :min-version (parse-version min) 188 | :max-version (parse-version max))) 189 | 190 | (defclass constraint-union (version-constraint) 191 | ((constraints :initarg :constraints :reader constraints))) 192 | 193 | (defmethod initialize-instance :after ((union constraint-union) &key) 194 | (let ((constraints ())) 195 | (flet ((add (new) 196 | (etypecase new 197 | (version-unspecific-constraint 198 | (setf constraints (list new))) 199 | (version-equal-constraint 200 | (loop for other in constraints 201 | do (when (constraint-subset-p new other) 202 | (return)) 203 | finally (push new constraints))) 204 | (version-range-constraint 205 | (loop with cons = constraints 206 | while cons 207 | do (let ((wider (widen (car cons) new))) 208 | (cond ((null wider) 209 | (setf cons (cdr cons))) 210 | ((cdr cons) 211 | (setf (car cons) (cadr cons)) 212 | (setf (cdr cons) (cddr cons)) 213 | (setf new wider)) 214 | (T 215 | (setf (car cons) wider) 216 | (return)))) 217 | finally (push new constraints)))))) 218 | (dolist (constraint (constraints union)) 219 | (etypecase constraint 220 | (constraint-union 221 | (dolist (sub constraint) 222 | (add sub))) 223 | (version-constraint 224 | (add constraint))))) 225 | (cond ((rest constraints) 226 | (setf (slot-value union 'constraints) constraints)) 227 | (constraints 228 | (etypecase (first constraints) 229 | (version-unspecific-constraint 230 | (change-class union 'version-unspecific-constraint)) 231 | (version-equal-constraint 232 | (change-class union 'version-equal-constraint 233 | :version (version (first constraints)))) 234 | (version-range-constraint 235 | (change-class union 'version-range-constraint 236 | :min-version (min-version (first constraints)) 237 | :max-version (max-version (first constraints)))))) 238 | (T 239 | (error "Can't construct a constraint union: set is empty."))))) 240 | 241 | (defmethod version-match-p ((version version) (constraint constraint-union)) 242 | (loop for constraint in (constraints constraint) 243 | thereis (version-match-p version constraint))) 244 | 245 | (defmethod constraint-subset-p ((a constraint-union) (b constraint-union)) 246 | (loop for constraint in (constraints a) 247 | always (constraint-subset-p a b))) 248 | 249 | (defmethod constraint-subset-p ((a version-constraint) (b constraint-union)) 250 | (loop for constraint in (constraints b) 251 | thereis (constraint-subset-p a constraint))) 252 | 253 | (defmethod constraint-subset-p ((a constraint-union) (b version-equal-constraint)) 254 | NIL) 255 | 256 | (defmethod constraint-subset-p ((a constraint-union) (b version-range-constraint)) 257 | (loop for constraint in (constraints a) 258 | always (constraint-subset-p constraint b))) 259 | 260 | (defmethod unify ((a constraint-union) (b constraint-union)) 261 | (let ((constraints ())) 262 | (dolist (ac (constraints a)) 263 | (dolist (bc (constraints b)) 264 | (handler-case (push (unify ac bc) constraints) 265 | (constraints-incompatible ())))) 266 | (cond ((rest constraints) 267 | (make-instance 'constraint-union :constraints constraints)) 268 | (constraints 269 | (first constraints)) 270 | (T 271 | (error 'constraints-incompatible :a a :b b))))) 272 | 273 | (defmethod unify ((a constraint-union) (b version-equal-constraint)) 274 | (loop for constraint in (constraints a) 275 | do (when (constraint-subset-p b constraint) 276 | (return b)) 277 | finally (error 'constraints-incompatible :a a :b b))) 278 | 279 | (defmethod unify ((a constraint-union) (b version-range-constraint)) 280 | (loop for constraint in (constraints a) 281 | do (cond ((constraint-subset-p b constraint) 282 | (return b)) 283 | ((constraint-subset-p constraint b) 284 | (return constraint))) 285 | finally (error 'constraints-incompatible :a a :b b))) 286 | 287 | (defmethod unify ((b version-range-constraint) (a constraint-union)) 288 | (unify a b)) 289 | 290 | (defmethod unify ((b version-equal-constraint) (a constraint-union)) 291 | (unify a b)) 292 | 293 | (defmethod widen ((a constraint-union) (b constraint-union)) 294 | (make-instance 'constraint-union :constraints (append (constraints a) (constraints b)))) 295 | 296 | (defmethod widen ((a constraint-union) (b version-constraint)) 297 | (make-instance 'constraint-union :constraints (list* b (constraints a)))) 298 | 299 | (defmethod widen ((b version-constraint) (a constraint-union)) 300 | (widen a b)) 301 | 302 | (defmethod to-string ((constraint constraint-union)) 303 | (with-output-to-string (stream) 304 | (format stream "{") 305 | (loop for (constraint rest) on (constraints constraint) 306 | do (write-string (to-string constraint) stream) 307 | (when rest (write-char #\, stream))) 308 | (format stream "}"))) 309 | 310 | (define-constraint-parser or (&rest constraints) 311 | (make-instance 'constraint-union :constraints (mapcar #'parse-constraint constraints))) 312 | -------------------------------------------------------------------------------- /communication/binary.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.forge.communication) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (defvar *encoding-type-id-map* (make-hash-table :test 'eq)) 5 | (defvar *encoding-type-id-counter* 0) 6 | 7 | (defun ensure-encoding-type-id (type) 8 | (or (gethash type *encoding-type-id-map*) 9 | (setf (gethash type *encoding-type-id-map*) 10 | (incf *encoding-type-id-counter*)))) 11 | 12 | (defun encoding-type-id (type) 13 | (or (gethash type *encoding-type-id-map*) 14 | (error "The type ~s is not assigned an ID." type))) 15 | 16 | (defun (setf encoding-type-id) (id type) 17 | (setf (gethash type *encoding-type-id-map*) id))) 18 | 19 | (defmacro define-binary-accessor (size) 20 | `(progn 21 | (defun ,(intern (format NIL "WU~d" size)) (int stream) 22 | (declare (type (unsigned-byte ,size) int)) 23 | (declare (type stream stream)) 24 | (declare (optimize speed (safety 1))) 25 | ,@(loop for i from 0 below size by 8 26 | collect `(write-byte (ldb (byte 8 ,i) int) stream))) 27 | (defun ,(intern (format NIL "RU~d" size)) (stream) 28 | (declare (type stream stream)) 29 | (declare (optimize speed (safety 1))) 30 | (the (unsigned-byte ,size) 31 | (+ ,@(loop for i from 0 below size by 8 32 | collect `(ash (the (unsigned-byte 8) (read-byte stream)) ,i))))) 33 | (defun ,(intern (format NIL "RI~d" size)) (stream) 34 | (declare (type stream stream)) 35 | (declare (optimize speed (safety 1))) 36 | (let ((bits (the (unsigned-byte ,size) 37 | (+ ,@(loop for i from 0 below size by 8 38 | collect `(ash (the (unsigned-byte 8) (read-byte stream)) ,i)))))) 39 | (declare (type (unsigned-byte ,size) bits)) 40 | (the (signed-byte ,size) 41 | (dpb bits (byte ,size 0) 42 | (if (logbitp ,(1- size) bits) -1 0))))))) 43 | 44 | ;; FIXME: circularity, references 45 | 46 | (define-binary-accessor 8) 47 | (define-binary-accessor 16) 48 | (define-binary-accessor 32) 49 | (define-binary-accessor 64) 50 | 51 | (defmethod encode-message (value (pathname pathname)) 52 | (with-open-file (stream pathname :direction :output :element-type '(unsigned-byte 8) 53 | :if-exists :supersede) 54 | (encode-message value stream))) 55 | 56 | (defmethod decode-message (type (pathname pathname)) 57 | (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8)) 58 | (decode-message type stream))) 59 | 60 | (defmethod decode-message ((type (eql T)) (stream stream)) 61 | (decode-message (ru16 stream) stream)) 62 | 63 | (defmethod decode-message (type source) 64 | (if (typep type 'integer) 65 | (no-applicable-method #'decode-message type source) 66 | (decode-message (encoding-type-id type) source))) 67 | 68 | (defmacro define-encoding (class (value stream) &body en/de) 69 | (destructuring-bind (encoder decoder) en/de 70 | (let ((id (ensure-encoding-type-id class))) 71 | `(flet ((encode (,value ,stream) 72 | (flet ((encode (,value) 73 | (encode-message ,value ,stream)) 74 | (encode* (,value) 75 | (encode-payload ,value ,stream))) 76 | (declare (ignorable #'encode #'encode*)) 77 | ,encoder))) 78 | (setf (encoding-type-id ',class) ,id) 79 | (defmethod encode-message ((,value ,class) (,stream stream)) 80 | (wu16 ,id ,stream) 81 | (encode ,value ,stream)) 82 | (defmethod encode-payload ((,value ,class) (,stream stream)) 83 | (encode ,value ,stream)) 84 | (defmethod decode-message ((id (eql ,id)) (,stream stream)) 85 | (flet ((decode (&optional (,value (ru16 ,stream))) 86 | (decode-message ,value ,stream))) 87 | (declare (ignorable #'decode)) 88 | ,decoder)))))) 89 | 90 | (defmacro define-slot-coder (class slots) 91 | `(define-encoding ,class (value stream) 92 | (progn 93 | ,@(loop for slot in slots 94 | collect `(encode (slot-value value ',slot)))) 95 | (let ((value (allocate-instance (find-class ',class)))) 96 | ,@(loop for slot in slots 97 | collect `(setf (slot-value value ',slot) (decode))) 98 | value))) 99 | 100 | (define-encoding null (value stream) 101 | () 102 | NIL) 103 | 104 | (define-encoding cons (value stream) 105 | (progn (encode (car value)) 106 | (encode (cdr value))) 107 | (cons (decode) (decode))) 108 | 109 | (define-encoding symbol (value stream) 110 | (progn (encode (if (symbol-package value) 111 | (package-name (symbol-package value)) 112 | "")) 113 | (encode (symbol-name value))) 114 | (let ((package (decode)) 115 | (name (decode))) 116 | (if (string= package "") 117 | (make-symbol name) 118 | (or (let ((maybe-package (find-package package))) 119 | (when maybe-package 120 | (find-symbol name maybe-package))) 121 | (make-dummy-symbol package name))))) 122 | 123 | ;; FIXME: Bignum support 124 | (define-encoding integer (value stream) 125 | (progn 126 | (check-type value (signed-byte 64)) 127 | (wu64 value stream)) 128 | (ri64 stream)) 129 | 130 | (define-encoding ratio (value stream) 131 | (progn (encode* (numerator value)) 132 | (encode* (denominator value))) 133 | (/ (decode (encoding-type-id 'integer)) 134 | (decode (encoding-type-id 'integer)))) 135 | 136 | (define-encoding complex (value stream) 137 | (progn (encode (realpart value)) 138 | (encode (imagpart value))) 139 | (complex (decode) 140 | (decode))) 141 | 142 | ;; KLUDGE: Base CL gives us only very inefficient means of doing this. 143 | (define-encoding single-float (value stream) 144 | (multiple-value-bind (m e s) (integer-decode-float value) 145 | (wu32 m stream) 146 | (wu8 e stream) 147 | (wu8 s stream)) 148 | (let ((m (ru32 stream)) 149 | (e (ri8 stream)) 150 | (s (ri8 stream))) 151 | (float (* m s (expt 2 (abs e))) 0f0))) 152 | 153 | (define-encoding double-float (value stream) 154 | (multiple-value-bind (m e s) (integer-decode-float value) 155 | (wu64 m stream) 156 | (wu16 e stream) 157 | (wu8 s stream)) 158 | (let ((m (ru64 stream)) 159 | (e (ri16 stream)) 160 | (s (ri8 stream))) 161 | (float (* m s (expt 2 (abs e))) 0f0))) 162 | 163 | (define-encoding character (value stream) 164 | (wu32 (char-code value) stream) 165 | (code-char (ru32 stream))) 166 | 167 | (macrolet ((stringgen () 168 | (let ((base-id (ensure-encoding-type-id 'base-string)) 169 | (gen-id (ensure-encoding-type-id 'string))) 170 | `(progn 171 | (setf (encoding-type-id 'base-string) ,base-id) 172 | (setf (encoding-type-id 'string) ,gen-id) 173 | (defmethod encode-message ((value string) (stream stream)) 174 | (etypecase value 175 | (base-string 176 | (wu16 ,base-id stream) 177 | (wu32 (length value) stream) 178 | (loop for element across value 179 | do (wu8 (char-code element) stream))) 180 | (string 181 | (wu16 ,gen-id stream) 182 | (wu32 (length value) stream) 183 | (loop for element across value 184 | do (wu32 (char-code element) stream))))) 185 | (defmethod decode-message ((id (eql ,base-id)) (stream stream)) 186 | (let ((arr (make-array (ru32 stream) :element-type 'base-char))) 187 | (dotimes (i (length arr) arr) 188 | (setf (aref arr i) (code-char (ru8 stream)))) 189 | arr)) 190 | (defmethod decode-message ((id (eql ,gen-id)) (stream stream)) 191 | (let ((arr (make-array (ru32 stream) :element-type 'character))) 192 | (dotimes (i (length arr) arr) 193 | (setf (aref arr i) (code-char (ru32 stream)))))))))) 194 | (stringgen)) 195 | 196 | ;; FIXME: compressed bit vector support 197 | ;; FIXME: fill-pointer support 198 | (macrolet ((vecgen () 199 | (let ((ub8-id (ensure-encoding-type-id 'ub8-vector)) 200 | (gen-id (ensure-encoding-type-id 'vector))) 201 | `(progn 202 | (setf (encoding-type-id 'ub8-vector) ,ub8-id) 203 | (setf (encoding-type-id 'vector) ,gen-id) 204 | (defmethod encode-message ((value vector) (stream stream)) 205 | (etypecase value 206 | ((vector (unsigned-byte 8)) 207 | (wu16 ,ub8-id stream) 208 | (wu32 (length value) stream) 209 | (loop for element across value 210 | do (wu8 element stream))) 211 | (vector 212 | (wu16 ,gen-id stream) 213 | (wu32 (length value) stream) 214 | (loop for object across value 215 | do (encode-message object stream))))) 216 | (defmethod decode-message ((id (eql ,ub8-id)) (stream stream)) 217 | (let ((arr (make-array (ru32 stream) :element-type '(unsigned-byte 8)))) 218 | (read-sequence arr stream) 219 | arr)) 220 | (defmethod decode-message ((id (eql ,gen-id)) (stream stream)) 221 | (let ((arr (make-array (ru32 stream)))) 222 | (dotimes (i (length arr) arr) 223 | (setf (aref arr i) (decode-message (ru16 stream) stream))))))))) 224 | (vecgen)) 225 | 226 | (define-encoding array (value stream) 227 | (let ((dimensions (array-dimensions value))) 228 | (wu8 (length dimensions) stream) 229 | (dolist (dimension dimensions) 230 | (wu32 dimension stream)) 231 | (dotimes (i (array-total-size value)) 232 | (encode (row-major-aref value i)))) 233 | (let ((dimensions ())) 234 | (dotimes (i (ru8 stream)) 235 | (push (ru32 stream) dimensions)) 236 | (let ((array (make-array (nreverse dimensions)))) 237 | (dotimes (i (array-total-size array) array) 238 | (setf (row-major-aref array i) (decode)))))) 239 | 240 | (define-encoding hash-table (value stream) 241 | (progn (wu32 (hash-table-count value) stream) 242 | (wu8 (ecase (hash-table-test value) 243 | (eq 0) 244 | (eql 1) 245 | (equal 2) 246 | (equalp 3)) 247 | stream) 248 | (loop for k being the hash-keys of value 249 | for v being the hash-values of value 250 | do (encode k) 251 | (encode v))) 252 | (let* ((size (ru32 stream)) 253 | (table (make-hash-table :size size 254 | :test (ecase (ru8 stream) 255 | (0 'eq) 256 | (1 'eql) 257 | (2 'equal) 258 | (3 'equalp))))) 259 | (loop repeat size 260 | for k = (decode) 261 | for v = (decode) 262 | do (setf (gethash k table) v)) 263 | table)) 264 | 265 | (labels ((unspecific-p (component) 266 | (or (eq component NIL) 267 | (eq component :unspecific) 268 | (and (stringp component) 269 | (= 0 (length component))))) 270 | (maybe-component (component) 271 | (if (unspecific-p component) NIL component)) 272 | (normalize-directory-spec (dir) 273 | (etypecase dir 274 | (string `(:absolute ,dir)) 275 | ((member :wild :wild-inferiors) `(:relative ,dir)) 276 | (cons 277 | (if (member (first dir) '(:absolute :relative)) 278 | dir 279 | #+gcl `(:relative ,dir) 280 | #-gcl (error "Invalid directory component ~s" dir))) 281 | (T (unless (unspecific-p dir) 282 | dir))))) 283 | (define-encoding pathname (value stream) 284 | ;; We ignore the host as it cannot typically be encoded portably. 285 | (progn (encode (maybe-component (pathname-device value))) 286 | (encode (maybe-component (pathname-name value))) 287 | (encode (maybe-component (pathname-type value))) 288 | (encode (maybe-component (pathname-version value))) 289 | (encode (normalize-directory-spec (pathname-directory value)))) 290 | (make-pathname :device (decode) 291 | :name (decode) 292 | :type (decode) 293 | :version (decode) 294 | :directory (decode)))) 295 | 296 | (define-encoding package (value stream) 297 | (encode (package-name value)) 298 | (let ((name (decode))) 299 | (or (find-package name) 300 | (error "Package was transferred that does not exist: ~% ~s" name)))) 301 | 302 | ;; KLUDGE: round-trip through print/read since we can't read these values out normally. 303 | (define-encoding random-state (value stream) 304 | (encode (with-standard-io-syntax (prin1-to-string value))) 305 | (with-standard-io-syntax (read-from-string (decode)))) 306 | 307 | ;; What we can't do: functions, readtables, restarts, streams. 308 | 309 | (define-slot-coder ok (id)) 310 | (define-slot-coder exit (id)) 311 | (define-slot-coder connect (id machine client-id version)) 312 | (define-slot-coder ping (id clock)) 313 | (define-slot-coder pong (id clock)) 314 | (define-slot-coder error-message (id condition-type arguments report)) 315 | (define-slot-coder warning-message (id condition-type arguments report)) 316 | (define-slot-coder eval-request (id form)) 317 | (define-slot-coder return-message (id value)) 318 | (define-slot-coder effect-request (id effect-type parameters version execute-on)) 319 | 320 | (define-encoding file (value stream) 321 | (progn 322 | (encode (file-target value)) 323 | (with-open-file (input (file-source value) :direction :input 324 | :element-type '(unsigned-byte 8)) 325 | (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8)))) 326 | (declare (dynamic-extent buffer)) 327 | (loop for read = (read-sequence buffer input) 328 | while (< 0 read) 329 | do (write-sequence buffer stream :end read))))) 330 | (let ((target (decode))) 331 | (with-open-file (output target :direction :output 332 | :element-type '(unsigned-byte 8) 333 | :if-exists :supersede) 334 | (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8)))) 335 | (declare (dynamic-extent buffer)) 336 | (loop for read = (read-sequence buffer stream) 337 | while (< 0 read) 338 | do (write-sequence buffer output :end read)))) 339 | target)) 340 | 341 | (define-encoding artefact (value stream) 342 | (progn 343 | (encode (artefact-registry value)) 344 | (encode (artefact-path value)) 345 | (encode (artefact-machine value))) 346 | (make-artefact 347 | (decode) (decode) (decode))) 348 | 349 | ;; Flex to make dummy-symbols appear as symbols on the wire, as the symbol 350 | ;; decode takes care of restructuring them as dummies if not found. 351 | (defmethod encode-message ((value dummy-symbol) (stream stream)) 352 | (wu16 #.(encoding-type-id 'symbol) stream) 353 | (encode-payload value stream)) 354 | 355 | (defmethod encode-payload ((value dummy-symbol) (stream stream)) 356 | (encode-message (dummy-symbol-package value) stream) 357 | (encode-message (dummy-symbol-name value) stream)) 358 | 359 | (define-encoding dummy-object (value stream) 360 | (encode (dummy-object-description value)) 361 | (make-dummy-object (decode))) 362 | 363 | (defmethod encode-message (object (stream stream)) 364 | (wu16 #.(encoding-type-id 'dummy-object) stream) 365 | (encode-payload object stream)) 366 | 367 | (defmethod encode-payload (object (stream stream)) 368 | (encode-message (princ-to-string object) stream)) 369 | -------------------------------------------------------------------------------- /network.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file defines the protocol for the distributed computing system used in 3 | ;;; Forge. Machines define physical setups that contain files, peers define 4 | ;;; programs that run on a machine and are connected to the network, and finally 5 | ;;; the server and clients define operators that can receive and issue requests. 6 | 7 | (in-package #:org.shirakumo.forge) 8 | 9 | (defvar *server* NIL) 10 | 11 | (support:define-condition* no-such-client (error) 12 | (name server) ("No client with the name~% ~s~%is registered on~% ~a" name server)) 13 | 14 | (support:define-condition* no-such-machine (error) 15 | (name server) ("No machine with the name~% ~s~%is registered on~% ~a" name server)) 16 | 17 | (defclass machine () 18 | ((name :initarg :name :initform (support:arg! :name) :reader name))) 19 | 20 | (defclass peer () 21 | ((name :initarg :name :initform (support:arg! :name) :reader name) 22 | (machine :initarg :machine :initform (support:arg! :machine) :reader machine) 23 | (connection :initarg :connection :initform (support:arg! :connection) :reader connection))) 24 | 25 | (defmethod print-object ((peer peer) stream) 26 | (print-unreadable-object (peer stream :type T) 27 | (format stream "~s ~:[DEAD~;ALIVE~]" (name peer) (communication:alive-p peer)))) 28 | 29 | (defmethod communication:alive-p ((peer peer)) 30 | (communication:alive-p (connection peer))) 31 | 32 | (defclass server (peer) 33 | ((name :initform :server) 34 | (machine :initform NIL) 35 | (connection :initform NIL) 36 | 37 | (machines :initform (make-hash-table :test 'equal) :reader machines) 38 | (clients :initform (make-hash-table :test 'equal) :reader clients) 39 | (on-existing-client :initarg :on-existing-client :initform :replace :accessor on-existing-client) 40 | (message-thread :initform NIL :accessor message-thread) 41 | (promise-thread :initform NIL :accessor promise-thread) 42 | (running-p :initform T :accessor running-p))) 43 | 44 | (defmethod initialize-instance :after ((server server) &key) 45 | (unless (machine server) 46 | (setf (slot-value server 'machine) (find-machine (machine-instance) server :if-does-not-exist :create))) 47 | (setf *server* server)) 48 | 49 | (defgeneric start (server &key)) 50 | (defgeneric stop (server)) 51 | (defgeneric list-clients (server)) 52 | (defgeneric find-machine (name server &key if-does-not-exist)) 53 | (defgeneric (setf find-machine) (machine name server &key if-exists)) 54 | (defgeneric delete-machine (name server)) 55 | (defgeneric message-loop (server)) 56 | (defgeneric promise-loop (server)) 57 | 58 | (defmethod start ((default (eql T)) &rest initargs &key &allow-other-keys) 59 | (let ((start-args ()) (init-args ())) 60 | (loop for (key value) on initargs by #'cddr 61 | do (cond ((find key '(:listen :address :port :if-exists)) 62 | (push value start-args) 63 | (push key start-args)) 64 | (T 65 | (push value init-args) 66 | (push key init-args)))) 67 | (unless *server* 68 | (apply #'make-instance 'server init-args)) 69 | (apply #'start *server* start-args))) 70 | 71 | (defmethod start ((server server) &key (listen :tcp) (address "127.0.0.1") (port tcp:DEFAULT-PORT) (if-exists :error)) 72 | (case (communication:alive-p server) 73 | ((T) 74 | (ecase if-exists 75 | (:error (error "server is already running.")) 76 | ((NIL) (return-from start NIL)) 77 | (:supersede (stop server)))) 78 | ((NIL) (v:info :forge.network "Starting ~a..." server))) 79 | (unless (and (connection server) (communication:alive-p (connection server))) 80 | (setf (slot-value server 'connection) 81 | (communication:serve 82 | (ecase listen 83 | (:tcp 84 | (v:info :forge.network "Listening on ~a:~a" address port) 85 | (make-instance 'tcp:host :address address :port port)) 86 | (:in-process 87 | (v:info :forge.network "Starting in-process communication") 88 | (make-instance 'in-process:host)))))) 89 | (setf (running-p server) T) 90 | (unless (and (message-thread server) (bt:thread-alive-p (message-thread server))) 91 | (setf (message-thread server) 92 | (bt:make-thread (lambda () (message-loop server)) 93 | :name (format NIL "forge-~(~a~)-message-thread" (name server))))) 94 | (unless (and (promise-thread server) (bt:thread-alive-p (promise-thread server))) 95 | (setf (promise-thread server) 96 | (bt:make-thread (lambda () (promise-loop server)) 97 | :name (format NIL "forge-~(~a~)-promise-thread" (name server))))) 98 | server) 99 | 100 | (defmethod stop ((default (eql T))) 101 | (stop *server*)) 102 | 103 | (defmethod stop ((server server)) 104 | (when (communication:alive-p server) 105 | (v:info :forge.network "Stopping ~a..." server) 106 | (setf (running-p server) NIL) 107 | (unwind-protect 108 | (progn 109 | (when (message-thread server) (wait-for-thread-exit (message-thread server))) 110 | (when (promise-thread server) (wait-for-thread-exit (promise-thread server)))) 111 | (close (connection server)) 112 | (setf (slot-value server 'connection) NIL))) 113 | server) 114 | 115 | (defmethod list-clients ((server server)) 116 | (alexandria:hash-table-values (clients server))) 117 | 118 | (defmethod communication:alive-p ((server server)) 119 | (let ((message (and (message-thread server) (bt:thread-alive-p (message-thread server)))) 120 | (promise (and (promise-thread server) (bt:thread-alive-p (promise-thread server))))) 121 | (cond ((and message promise) T) 122 | ((or message promise) :weird) 123 | (T NIL)))) 124 | 125 | (defmethod find-machine (name (server server) &key (if-does-not-exist :error)) 126 | (or (gethash name (machines server)) 127 | (ecase if-does-not-exist 128 | ((NIL) NIL) 129 | (:error (error 'no-such-machine :server server :name name)) 130 | (:create (setf (gethash name (machines server)) (make-instance 'machine :name name)))))) 131 | 132 | (defmethod (setf find-machine) ((machine machine) name (server server) &key (if-exists :error)) 133 | (when (gethash name *machines*) 134 | (ecase if-exists 135 | ((NIL) (return-from find-machine NIL)) 136 | (:error (error 'machine-already-exists :name name)) 137 | (:replace))) 138 | (setf (gethash name (machines server)) machine)) 139 | 140 | (defmethod delete-machine ((machine machine) (server server)) 141 | (delete-machine (name machine) (server server))) 142 | 143 | (defmethod delete-machine (name (server server)) 144 | (remhash name *machines*) 145 | name) 146 | 147 | (defmethod handshake ((server server) (connection communication:connection) (message communication:connect)) 148 | (case (communication:version message) 149 | (0 150 | (let* ((name (list (communication:machine message) (or (communication:client-id message) (random #xFFFF)))) 151 | (machine (find-machine (communication:machine message) server)) 152 | (existing (gethash name (clients server)))) 153 | (v:debug :forge.network "Attempted connection establishment for ~a" name) 154 | (setf (slot-value connection 'communication:name) name) 155 | (if existing 156 | (ecase (on-existing-client server) 157 | (:replace 158 | (v:debug :forge.network "Replacing connection of duplicate client ~a" name) 159 | (close existing :abort T) 160 | (communication:esend connection (make-condition 'client-replaced :name name) message)) 161 | (:error 162 | (error 'client-already-exists :name name))) 163 | (communication:reply! connection message 'communication:ok)) 164 | (let ((client (make-instance 'client :connection connection :server server :name name :machine machine))) 165 | (v:info :forge.network "Established new client connection ~a" client) 166 | (setf (gethash name (clients server)) client) 167 | (on-client-connect T client) 168 | client))) 169 | (T 170 | (error 'unsupported-protocol-version :version (communication:version message))))) 171 | 172 | (defmethod message-loop ((server server)) 173 | (v:debug :forge.network "Entering message loop for ~a" server) 174 | (macrolet ((with-message ((message connection) &body body) 175 | `(let ((,message (communication:receive ,connection :timeout 0.0))) 176 | (when ,message 177 | ,@body)))) 178 | (unwind-protect 179 | (with-event-loop ((connection (connection server)) 180 | (pending ())) 181 | (unless (running-p server) 182 | (return)) 183 | ;; Check for incoming connection requests 184 | (with-message (new-connection connection) 185 | (v:debug :forge.network "New incoming connection at ~a" connection) 186 | (push (list new-connection (get-universal-time)) pending)) 187 | ;; Process pending connections to see if we can upgrade them 188 | (loop for (connection start-time) in pending 189 | do (support:handler-case* 190 | (with-message (message connection) 191 | (setf pending (remove connection pending :key #'first)) 192 | (handler-case 193 | (handshake server connection message) 194 | (error (e) 195 | (v:debug :forge.network "Encountered error during handshake: ~a" e) 196 | (v:trace :forge.network e) 197 | (communication:esend connection e message) 198 | (close connection)))) 199 | (error (e) 200 | (v:debug :forge.network "Encountered weird message during connection establishment.") 201 | (v:trace :forge.network e) 202 | (ignore-errors (close connection)) 203 | (setf pending (remove connection pending)))) 204 | ;; Drop connections that are just dos-ing us. 205 | (when (< 30 (- (get-universal-time) start-time)) 206 | (v:debug :forge.network "Dropping connection ~a: handshake timeout" connection) 207 | (close connection) 208 | (setf pending (remove connection pending :key #'first)))) 209 | ;; Process established client messages 210 | (loop for client being the hash-values of (clients server) 211 | do (support:handler-case* 212 | (with-message (message client) 213 | (handle message client)) 214 | (error (e) 215 | (v:debug :forge.network "Encountered error handling message: ~a" e) 216 | (v:trace :forge.network e) 217 | (ignore-errors (close client)))) 218 | (maintain-connection client))) 219 | (v:debug :forge.network "Leaving message loop for ~a" server)))) 220 | 221 | (defmethod promise-loop ((server server)) 222 | (v:debug :forge.network "Entering promise loop for ~a" server) 223 | (unwind-protect 224 | (with-event-loop () 225 | (unless (running-p server) 226 | (return)) 227 | (with-simple-restart (abort "Abort ticking") 228 | (support:handler-case* 229 | (promise:tick-all (get-universal-time)) 230 | (error (e) 231 | (v:debug :forge.network "Encountered error ticking promises: ~a" e) 232 | (v:trace :forge.network e))))) 233 | (v:debug :forge.network "Leaving promise loop for ~a" server))) 234 | 235 | (defmacro with-promise ((server) &body body) 236 | `(promise:then (promise:pend :success T) 237 | (lambda (_) 238 | (declare (ignore _)) 239 | ,@body))) 240 | 241 | (defclass client (peer) 242 | ((server :initarg :server :initform (support:arg! :server) :reader server) 243 | (callback-table :initform (make-hash-table :test 'eql) :reader callback-table) 244 | (last-message :initform (cons (get-universal-time) 0) :accessor last-message))) 245 | 246 | (defmethod initialize-instance :after ((client client) &key server) 247 | (unless (typep (machine client) 'machine) 248 | (setf (slot-value client 'machine) (find-machine (machine-client) server)))) 249 | 250 | (defgeneric handle (message client)) 251 | 252 | (defmethod communication:send (message (client client)) 253 | (v:trace :forge.network "~a <-- ~a" (name client) message) 254 | (communication:send message (connection client))) 255 | 256 | (defmethod communication:receive ((client client) &key timeout) 257 | (let ((message (communication:receive (connection client) :timeout timeout))) 258 | (when message 259 | (v:trace :forge.network "~a --> ~a" (name client) message)) 260 | message)) 261 | 262 | (defmethod handle :before ((message communication:message) (client client)) 263 | (setf (last-message client) (cons (get-universal-time) 0))) 264 | 265 | (defmethod handle ((message communication:reply) (client client)) 266 | (let ((callback (pophash (communication:id message) (callback-table client)))) 267 | (etypecase callback 268 | (null) 269 | (function (funcall callback message)) 270 | (promise:promise 271 | (etypecase message 272 | (communication:error-message 273 | (promise:fail callback (apply #'make-condition 274 | (communication:condition-type message) 275 | (communication:arguments message)))) 276 | (T 277 | (promise:succeed callback message))))))) 278 | 279 | (defmethod handle ((message communication:effect-request) (client client)) 280 | (promise:-> (with-promise ((server client)) 281 | (handler-bind ((error #'invoke-debugger)) 282 | (let* ((effect (find-effect *database* 283 | (communication:effect-type message) 284 | (communication:parameters message) 285 | (parse-constraint (communication:version message)))) 286 | (plan (compute-plan effect (make-instance 'basic-policy))) 287 | (executor (ecase (communication:execute-on message) 288 | (:self (make-instance 'linear-executor :client client)) 289 | (:any (make-instance 'linear-executor :client (alexandria:random-elt (clients (server client))))) 290 | (:all (make-instance 'parallel-executor))))) 291 | (execute plan executor)))) 292 | (:then () (communication:reply! client message 'communication:ok)) 293 | (:handle (e) (communication:esend client e message)))) 294 | 295 | (defmethod handle ((message communication:exit) (client client)) 296 | (close client)) 297 | 298 | (defun promise-reply (message client &key (lifetime 120) send values-list) 299 | (let ((promise (promise:pend :lifetime lifetime))) 300 | (setf (gethash (communication:id message) (callback-table client)) promise) 301 | (when send (communication:send message client)) 302 | (promise:then promise (lambda (v) (promise:pend :success (if values-list 303 | (communication:value v) 304 | (first (communication:value v)))))))) 305 | 306 | (defmacro with-client-eval ((client &key (lifetime 120) values-list) &body body) 307 | `(promise-reply (make-instance 'communication:eval-request :form (progn ,@body)) 308 | ,client :lifetime ,lifetime :values-list ,values-list :send T)) 309 | 310 | (defmethod maintain-connection ((client client)) 311 | (let ((timeout (- (get-universal-time) (car (last-message client))))) 312 | (cond ((< 30 timeout) 313 | (when (< (cdr (last-message client)) 1) 314 | (setf (cdr (last-message client)) 1) 315 | (communication:send! client 'communication:ping))) 316 | ((< 75 timeout) 317 | (v:debug :forge.network "Connection unstable: no reply in 75 seconds for ~a..." client) 318 | (when (< (cdr (last-message client)) 2) 319 | (setf (cdr (last-message client)) 2) 320 | (communication:send! client 'communication:ping))) 321 | ((< 120 timeout) 322 | (v:warn :forge.network "Dropping client ~a as we have not received a message in 2 minutes." client) 323 | (close client))))) 324 | 325 | (defmethod close ((client client) &key abort) 326 | (v:info :forge.network "Closing connection to ~a" client) 327 | (remhash (name client) (clients (server client))) 328 | (close (connection client) :abort abort)) 329 | -------------------------------------------------------------------------------- /basic.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Description: 2 | ;;; This file defines common mixin classes and behaviours that are generally 3 | ;;; useful outside of a specific language module. Most notably it defines the 4 | ;;; standard plan computation algorithm with the BASIC-POLICY. 5 | 6 | (in-package #:org.shirakumo.forge) 7 | 8 | (defclass basic-database (database) 9 | ((effects :initform (make-hash-table :test 'eq) :reader effects) 10 | (version-cache :initform (make-hash-table :test 'eq) :reader version-cache))) 11 | 12 | ;; Storage as follows: 13 | ;; Effects: TYPE -> PARAMETERS -> [ EFFECT ] 14 | 15 | (defmethod map-effects (function (database basic-database) &optional type parameters version) 16 | (let ((function (etypecase function 17 | (function function) 18 | (symbol (fdefinition function))))) 19 | (cond (version 20 | (let ((tables (gethash type (effects database)))) 21 | (when tables 22 | (let ((effects (gethash (normalize-parameters type parameters) tables))) 23 | (loop for effect in effects 24 | do (when (version-match-p (version effect) version) 25 | (funcall function effect))))))) 26 | (parameters 27 | (let ((tables (gethash type (effects database)))) 28 | (when tables 29 | (let ((effects (gethash (normalize-parameters type parameters) tables))) 30 | (loop for effect in effects 31 | do (funcall function effect)))))) 32 | (type 33 | (let ((tables (gethash type (effects database)))) 34 | (when tables 35 | (loop for effects being the hash-values of tables 36 | do (loop for effect in effects 37 | do (funcall function effect)))))) 38 | (T 39 | (loop for tables being the hash-values of (effects database) 40 | do (loop for effects being the hash-values of tables 41 | do (loop for effect in effects 42 | do (funcall function effect)))))))) 43 | 44 | (defmethod register-effect ((database basic-database) (effect effect)) 45 | (let* ((tables (or (gethash (type-of effect) (effects database)) 46 | (setf (gethash (type-of effect) (effects database)) 47 | (make-hash-table :test 'equal)))) 48 | (effects (gethash (parameters effect) tables)) 49 | (existing (find effect effects :test #'version=))) 50 | (cond ((eq existing effect)) 51 | ((null existing) 52 | (push effect (gethash (parameters effect) tables))) 53 | (T 54 | (error "Different effect with same parameters and version already exists!"))))) 55 | 56 | (defmethod achieved-version ((database basic-database) (effect effect)) 57 | (gethash effect (version-cache effect) *unknown-version*)) 58 | 59 | (defmethod (setf achieved-version) ((version version) (database basic-database) (effect effect)) 60 | (setf (gethash effect (version-cache effect)) version)) 61 | 62 | (defclass parameter-plist-effect (effect) 63 | ()) 64 | 65 | (defmethod normalize-parameters ((effect parameter-plist-effect) parameters) 66 | (let ((alist (loop for (k v) on parameters by #'cddr 67 | collect (cons k v)))) 68 | (setf alist (sort alist (lambda (a b) 69 | (if (string= (car a) (car b)) 70 | (support:generic< (cdr a) (cdr b)) 71 | (support:generic< (car a) (car b)))))) 72 | (loop for (k . v) in alist 73 | collect k collect v))) 74 | 75 | (defclass parameter-alist-effect (effect) 76 | ()) 77 | 78 | (defmethod normalize-parameters ((effect parameter-alist-effect) parameters) 79 | (sort parameters (lambda (a b) 80 | (if (string= (car a) (car b)) 81 | (support:generic< (cdr a) (cdr b)) 82 | (support:generic< (car a) (car b)))))) 83 | 84 | (defclass basic-policy (policy) 85 | ((operation-cache :initform (make-hash-table :test 'eq) :accessor operation-cache))) 86 | 87 | (defmethod select-source ((policy basic-policy) (effect effect) sources) 88 | (first sources)) 89 | 90 | (defmethod make-operation ((operation symbol) (policy basic-policy)) 91 | (or (gethash operation (operation-cache policy)) 92 | (setf (gethash operation (operation-cache policy)) 93 | (make-operation (make-instance operation) policy)))) 94 | 95 | (defmethod select-effect-set ((policy basic-policy) sets) 96 | ;; FIXME: This is not stable as the order of effects within a set is not stable. 97 | (flet ((set> (a b) 98 | (loop for ae in a 99 | for be in b 100 | do (cond ((eq ae be)) 101 | ((version= (version ae) (version be))) 102 | ((version< (version ae) (version be)) 103 | (return NIL)) 104 | (T 105 | (return T)))))) 106 | (let ((min (first sets))) 107 | (dolist (set (rest sets) min) 108 | (when (set> set min) 109 | (setf min set)))))) 110 | 111 | (defun unify-dependency-sets (a b) 112 | (flet ((try-unify (a b) 113 | (let ((table (make-hash-table :test 'eq))) 114 | (dolist (b-effect b) 115 | (setf (gethash b-effect table) T)) 116 | (dolist (a-effect a) 117 | (setf (gethash a-effect table) T) 118 | (dolist (b-effect b) 119 | (cond ((eq a-effect b-effect) 120 | (return)) 121 | ((variant-p a-effect b-effect) 122 | (return-from try-unify ()))))) 123 | (loop for k being the hash-keys of table 124 | collect k)))) 125 | (cond ((null a) ()) 126 | ((null b) ()) 127 | ((eql T a) b) 128 | ((eql T b) a) 129 | (T 130 | (let ((set ())) 131 | (dolist (choice a set) 132 | (dolist (candidate b) 133 | (let ((result (try-unify choice candidate))) 134 | (when result (push result set)))))))))) 135 | 136 | (defmethod compute-plan ((effect effect) (policy basic-policy)) 137 | (with-retry ("Retry computing the plan") 138 | (let ((visit (make-hash-table :test 'equal))) 139 | ;; Note: We first compute the set of possible version constraints for all involved effects. If this set turns 140 | ;; out to be empty for the root effect, we know it's unsatisfiable overall. Most likely though we are 141 | ;; going to get a huge set of possible alternatives to pick from. We actually resolve this set in a second 142 | ;; step where we compute the actual plan. 143 | (labels ((visit (effect) 144 | (etypecase (gethash effect visit :none) 145 | ((eql :tentative) 146 | (error 'dependency-cycle-detected :effect effect)) 147 | (list 148 | (gethash effect visit :none)) 149 | ((eql :none) 150 | (setf (gethash effect visit) :tentative) 151 | ;; Note: We eagerly select the source here, which can lead to an unsatisfiable plan even when 152 | ;; another source might provide a satisfiable plan. However, for a first attempt, and for 153 | ;; my own sanity's sake, I'm going to ignore this for the time being. 154 | (let* ((source (select-source policy effect (sources effect))) 155 | (component (second source)) 156 | (operation (make-operation (first source) policy)) 157 | ;; Note: We only consider hard dependencies here. Optionals are pulled in in another phase 158 | ;; once we have already settled on a version set for everything else. This means we 159 | ;; potentially don't select optionals that might be possible in another set, but it 160 | ;; massively simplifies the plan computation, and at this point I'm too tired of trying 161 | ;; to come up with a holistic solution to continue doing the "absolutely right thing". 162 | (dependencies (remove-if-not #'hard-p (dependencies operation component))) 163 | (depchoices T)) 164 | (dolist (dependency dependencies) 165 | (let ((choices ())) 166 | (with-retry ("Retry resolving the dependency.") 167 | (do-effects (effect *database* (effect-type dependency) (parameters dependency) (version dependency)) 168 | (dolist (choice (visit effect)) 169 | (push choice choices))) 170 | (unless choices 171 | (restart-case 172 | (warn 'unsatisfiable-dependency :dependency dependency :operation operation :component component) 173 | (use-value (effect) 174 | :report "Specify an effect to use." 175 | (check-type effect effect) 176 | (dolist (choice (visit effect)) 177 | (push choice choices)))))) 178 | ;; This is where the combinatorial explosion happens 179 | (setf depchoices (unify-dependency-sets depchoices choices)))) 180 | (setf (gethash effect visit) 181 | (if (eql T depchoices) (list (list effect)) 182 | (loop for choice in depchoices 183 | collect (list* effect choice))))))))) 184 | (unless (visit effect) 185 | (error 'unsatisfiable-effect :effect effect))) 186 | ;; Note: Next we select one set of the viable effects set and traverse the graph again. We now select the effect 187 | ;; that matches our dependency directly from the set that we used and don't bother with checking cycles. 188 | ;; We also now check optional dependencies and see if all of their dependencies are already contained in 189 | ;; our set. If so, we pull their steps in. Once we have constructed steps for each effect, we can then 190 | ;; figure out the head and tail steps and construct the actual plan object. 191 | (let ((effects (select-effect-set policy (gethash effect visit))) 192 | (step-table (make-hash-table :test 'eq))) 193 | (labels ((find-effect (dependency) 194 | ;; FIXME: This seems slow as balls? Surely there's a better way... 195 | (let ((type (effect-type dependency)) 196 | (parameters (parameters dependency))) 197 | (dolist (effect effects (error "WTF?")) 198 | (when (and (eql (type-of effect) type) 199 | (equal (parameters effect) parameters)) 200 | (return effect))))) 201 | (maybe-visit (dependency) 202 | (do-effects (effect *database* (effect-type dependency) (parameters dependency) (version dependency)) 203 | (let* ((source (select-source policy effect (sources effect))) 204 | (component (second source)) 205 | (operation (make-operation (first source) policy)) 206 | (dependencies (dependencies operation component))) 207 | (when (loop for dependency in dependencies 208 | always (find-effect dependency)) 209 | (return (visit effect)))))) 210 | (visit (effect) 211 | (or (gethash effect step-table) 212 | (let* ((source (select-source policy effect (sources effect))) 213 | (component (second source)) 214 | (operation (make-operation (first source) policy)) 215 | (step (make-step operation component effect)) 216 | (dependencies (dependencies operation component))) 217 | (dolist (dependency dependencies) 218 | (let ((predecessor (if (hard-p dependency) 219 | (visit (find-effect dependency)) 220 | (maybe-visit dependency)))) 221 | (when predecessor 222 | (connect predecessor step)))) 223 | (setf (gethash effect step-table) step))))) 224 | (visit effect)) 225 | ;; Note: Now we do the additional step of "expanding" compound steps to allow broad-phasing of plans. We 226 | ;; then replace the original broad steps by tying up the successors and predecessors. 227 | (loop for key being the hash-keys of step-table 228 | for step being the hash-values of step-table 229 | do (when (typep step 'compound-step) 230 | ;; Unhook the step from the plan 231 | (remhash key step-table) 232 | (dolist (predecessor (predecessors step)) 233 | (setf (successors predecessor) (delete step (successors predecessor)))) 234 | (dolist (successor (successors step)) 235 | (setf (predecessors successor) (delete step (predecessors successor)))) 236 | ;; Compute the inner plan and tie the steps together 237 | (let ((plan (compute-plan (inner-effect step) policy))) 238 | (loop for first across (first-steps plan) 239 | do (setf (gethash first step-table) first) 240 | (dolist (predecessor (predecessors step)) 241 | (connect predecessor first))) 242 | (loop for final across (final-steps plan) 243 | do (setf (gethash final step-table) final) 244 | (dolist (successor (successors step)) 245 | (connect final successor)))))) 246 | ;; Note: Finally we figure out the heads and tails of the whole plan by searching through all known steps 247 | ;; for ones without any successors or predecessors. This concludes the full plan. 248 | (let ((first-steps (make-array 0 :adjustable T :fill-pointer T)) 249 | (final-steps (make-array 0 :adjustable T :fill-pointer T))) 250 | (loop for step being the hash-values of step-table 251 | do (cond ((null (predecessors step)) 252 | (vector-push-extend step first-steps)) 253 | ((null (successors step)) 254 | (vector-push-extend step final-steps)))) 255 | (make-instance 'plan 256 | :first-steps first-steps 257 | :final-steps final-steps)))))) 258 | 259 | (defclass dummy-executor (executor) 260 | ()) 261 | 262 | (defmethod execute ((plan plan) (executor dummy-executor)) 263 | plan) 264 | 265 | (defclass linear-executor (executor) 266 | ((force :initarg :force :initform NIL :accessor force) 267 | (client :initarg :client :initform (or (and *server* (first (list-clients *server*))) 268 | (support:arg! :client)) 269 | :accessor client))) 270 | 271 | (defun compute-step-sequence (plan) 272 | (let ((visit (make-hash-table :test 'eq)) 273 | (sequence ())) 274 | (labels ((visit (step) 275 | (unless (gethash step visit) 276 | (dolist (successor (successors step)) 277 | (visit successor)) 278 | (push step sequence) 279 | (setf (gethash step visit) T)))) 280 | (loop for step across (first-steps plan) 281 | do (visit step)) 282 | sequence))) 283 | 284 | (defmethod execute ((plan plan) (executor linear-executor)) 285 | (promise:do-promised (step (compute-step-sequence plan)) 286 | (handler-bind ((error #'invoke-debugger)) 287 | (execute step executor)))) 288 | 289 | (defclass file-component (component) 290 | ((path :initarg :path :accessor path))) 291 | 292 | (define-print-object-method* file-component 293 | "~s ~a ~a" name path (to-string (version file-component))) 294 | 295 | (defmethod full-path ((component file-component)) 296 | (path component)) 297 | 298 | (defmethod version ((component file-component)) 299 | (let ((version (call-next-method)) 300 | (hash (make-instance 'hashed-version :value (hash-file (path component))))) 301 | (if (typep version 'unknown-version) 302 | hash 303 | (make-instance 'compound-version :versions (list version hash))))) 304 | 305 | (defmethod hash ((component file-component)) 306 | (hash-file (path component))) 307 | 308 | (defclass parent-component (component) 309 | ((children :initform (make-hash-table :test 'equal) :accessor children))) 310 | 311 | (defclass child-component (component) 312 | ((parent :initarg :parent :initform (support:arg! :parent) :reader parent))) 313 | 314 | (defmethod full-path ((component child-component)) 315 | (merge-pathnames (call-next-method) 316 | (path (parent component)))) 317 | 318 | (defclass dependencies-component (component) 319 | ((depends-on :initform () :accessor depends-on))) 320 | 321 | (defmethod shared-initialize :after ((component dependencies-component) slots &key (depends-on NIL dependencies-p) prior) 322 | (cond (dependencies-p 323 | (setf (depends-on component) 324 | (loop for dependency in depends-on 325 | collect (normalize-dependency-spec component dependency)))) 326 | (prior 327 | (setf (depends-on component) 328 | (list (normalize-dependency-spec component prior)))))) 329 | 330 | (defgeneric normalize-dependency-spec (component dependency)) 331 | --------------------------------------------------------------------------------