Improved lepbootstrap.lisp

Pascal J. Bourguignon [2013-10-13 02:08]
Improved lepbootstrap.lisp
Filename
README
install/generate-init.lisp
install/lepbootstrap.lisp
diff --git a/README b/README
index 3b708f5..a69157c 100644
--- a/README
+++ b/README
@@ -135,3 +135,8 @@ Building blocks:
     - irc client


+
+TODO
+--------------------------------------------------------------------------------
+
+- mount -o rw,remount root
diff --git a/install/generate-init.lisp b/install/generate-init.lisp
index 4391d13..68b4093 100644
--- a/install/generate-init.lisp
+++ b/install/generate-init.lisp
@@ -1,12 +1,12 @@
 ;;;; -*- mode:lisp;coding:utf-8 -*-
 ;;;;**************************************************************************
-;;;;FILE:               generate-application.lisp
+;;;;FILE:               generate-init.lisp
 ;;;;LANGUAGE:           Common-Lisp
 ;;;;SYSTEM:             Common-Lisp
 ;;;;USER-INTERFACE:     CLI
 ;;;;DESCRIPTION
 ;;;;
-;;;;    Generate the huron (http) server.
+;;;;    Generate the init process.
 ;;;;
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
@@ -34,19 +34,13 @@

 (in-package "COMMON-LISP-USER")

-(setf *load-verbose* t)
+(setf *load-verbose* nil)

 #+ccl (setf ccl:*default-external-format*           :unix
             ccl:*default-file-character-encoding*   :utf-8
             ccl:*default-line-termination*          :unix
             ccl:*default-socket-character-encoding* :utf-8)

-(with-open-file (out "out.txt" :direction :output :if-does-not-exist :create :if-exists :supersede)
-  (prin1 'hi out)
-  (print (merge-pathnames #P"init" *default-pathname-defaults* nil) out)
-  (terpri out))
-
-
 #+ccl (ccl::save-application (merge-pathnames #P"init" *default-pathname-defaults* nil)
                              :init-file "/etc/init.lisp"
                              :prepend-kernel t)
diff --git a/install/lepbootstrap.lisp b/install/lepbootstrap.lisp
index 11e21c7..606b149 100644
--- a/install/lepbootstrap.lisp
+++ b/install/lepbootstrap.lisp
@@ -1,40 +1,228 @@
-;;;; -*- mode:lisp;coding:utf-8; -*-
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               lepbootstrap.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This script installs a LEP system on a disk.
+;;;;    It runs sudo.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2013-10-13 <PJB> Added this header.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(in-package :common-lisp-user)
+
+;;; Clean the packages imported into COMMON-LISP-USER:
+
+(mapc (lambda (package) (unuse-package package "COMMON-LISP-USER"))
+      (set-difference
+       (copy-seq (package-use-list "COMMON-LISP-USER"))
+       (delete nil (list ;; A list of all the "CL" packages possible:
+                    (find-package "COMMON-LISP")
+                    (find-package "IMAGE-BASED-COMMON-LISP")))))
+
+;;; parameters
+
+(defparameter *lisp-norc*          '("/data/src/languages/ccl/ccl-1.8-linuxx86/lx86cl64"   "-norc"))
+(defparameter *lisp-norc*          '("/data/src/languages/ccl/ccl-trunk-linuxx86/lx86cl64" "-norc"))
+(defparameter *lisp-sources*         "/data/src/languages/ccl/ccl-trunk-linuxx86/")
+
+(defparameter *sudo-askpass*       '("/usr/bin/sudo" "-A"))
+(defparameter *askpass-binary-path* "/usr/bin/ssh-askpass")
+
+(defparameter *target-device*        "/domU/images/lep.ext3")
+(defparameter *target-mount-options* '("-o" "loop"))
+(defparameter *target-mount-point*   "/tmp/lep/")
+(defparameter *target-mount-point*   "/mnt/lep/")
+
+
+;;; implementation dependent stuff
+
+(defun implement (function-name)
+  (error "Implement ~S for ~A" function-name (lisp-implementation-type)))

-(ql:quickload :cl-ppcre)
-(ql:quickload :com.informatimago.common-lisp)
-(use-package :com.informatimago.common-lisp.cesarum.file)
-(use-package :com.informatimago.common-lisp.interactive.browser)
+
+#+ccl (setf ccl:*default-external-format*           :unix
+            ccl:*default-file-character-encoding*   :utf-8
+            ccl:*default-line-termination*          :unix
+            ccl:*default-socket-character-encoding* :utf-8)
+
+#+ccl (import 'ccl:getenv)
+#+ccl (defsetf getenv ccl:setenv)
+
+#+ccl (import 'ccl::getuid)

 #+ccl (import 'ccl:run-program)
+
 (defun process-output-stream (process)
-  #+ccl (ccl:external-process-output-stream process))
+  #+ccl (ccl:external-process-output-stream process)
+  #-ccl (implement 'process-output-stream))
+
+
+(defun chmod (modes pathname)
+  (run-program "chmod" (list (format nil "~O" modes) (namestring pathname))
+               :input nil :output t :wait t))
+
 (defun dirname (pathname)
   (make-pathname :name nil :type nil :version nil :defaults pathname))

+(defun copy-directory (source-directory target-directory &key test (if-exists :error))
+  #+ccl (ccl::recursive-copy-directory source-directory target-directory
+                                       :test test :if-exists if-exists)
+  #-ccl (implement copy-directory))

-(defun ldd (program-path)
-  (with-open-stream (ldd (process-output-stream
-                          (run-program "ldd" (list program-path)
-                                       :element-type 'character
-                                       :output :stream :input nil :error nil)))
-    (loop
-      :for line = (read-line ldd nil nil)
-      :while line
-      :for libraries = (nth-value 1 (ppcre:scan-to-strings "^[ 	]+((.*) => )?(.*) \\(0x[0-9a-f]+\\)$" line))
-      :unless  (equal "" (aref libraries 2))
-      :collect (aref libraries 2))))

+(defun user-pathname ()
+  "On MS-Windows, it's not the USER-HOMEDIR-PATHNAME."
+  #+(and ccl windows-target) (let ((home (ccl::getenv "HOME")))
+                               (if home
+                                   (pathname (format nil "~A\\" home))
+                                   #P"C:\\cygwin\\home\\pjb\\"))
+  #-(and ccl windows-target) (USER-HOMEDIR-PATHNAME))
+
+(defun make-pathname* (&key (host nil hostp) (device nil devicep) (directory nil directoryp)
+                       (name nil namep) (type nil typep) (version nil versionp)
+                       (defaults nil defaultsp) (case :local casep))
+  (declare (ignorable casep))
+  #+ (or abcl ccl allegro)
+  (labels ((localize (object)
+             (typecase object
+               (list   (mapcar (function localize) object))
+               (string (string-downcase object))
+               (t      object)))
+           (parameter (indicator key value)
+             (when indicator
+               (list key (if (eql case :common)
+                             (localize value)
+                             value)))))
+    (apply (function make-pathname)
+           (append (parameter hostp      :host      host)
+                   (parameter devicep    :device    device)
+                   (parameter directoryp :directory directory)
+                   (parameter namep      :name      name)
+                   (parameter typep      :type      type)
+                   (parameter versionp   :version   version)
+                   (parameter defaultsp  :defaults  defaults)
+                   (list :case :local))))
+  #-(or abcl ccl allegro)
+  (apply (function make-pathname)
+         (append
+          (when hostp      (list :host      host))
+          (when devicep    (list :device    device))
+          (when directoryp (list :directory directory))
+          (when namep      (list :name      name))
+          (when typep      (list :type      type))
+          (when versionp   (list :version   version))
+          (when defaultsp  (list :defaults  defaults))
+          (when casep      (list :case      case)))))
+
+
+;;; quicklisp and libraries
+
+(defparameter *quicklisp*  (merge-pathnames
+                            (make-pathname* :directory '(:relative "QUICKLISP")
+                                            :name "SETUP"
+                                            :type "LISP"
+                                            :version :newest
+                                            :case :common
+                                            :defaults (user-pathname))
+                            (user-pathname)
+                            nil))
+
+(unless (find-package "QL")
+    (if (probe-file *quicklisp*)
+      (load *quicklisp*)
+      (error "Please install quicklisp.  I expect it in ~S" *quicklisp*)))
+
+
+;; libraries:
+
+(ql:quickload :uiop)
+(ql:quickload :cl-ppcre)
+(ql:quickload :split-sequence)
+(ql:quickload :com.informatimago.common-lisp)
+(use-package :com.informatimago.common-lisp.cesarum.file)
+(use-package :com.informatimago.common-lisp.interactive.browser)
+(use-package :split-sequence)
+
+
+;; patches:
+
+(in-package :uiop/stream)

+(defun call-with-temporary-file (thunk &key
+                                         prefix keep (direction :io)
+                                         (element-type *default-stream-element-type*)
+                                         (external-format :default))
+  #+gcl2.6 (declare (ignorable external-format))
+  (check-type direction (member :output :io))
+  (let ((created-pathname nil))
+    (unwind-protect
+         (loop
+           :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
+           :for counter :from (random (ash 1 32))
+           :for pathname = (pathname (format nil "~A~36R" prefix counter))
+           :do
+           ;; TODO: on Unix, do something about umask
+           ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
+           ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
+           (with-open-file (stream pathname
+                                   :direction direction
+                                   :element-type element-type
+                                   #-gcl2.6 :external-format #-gcl2.6 external-format
+                                   :if-exists nil :if-does-not-exist :create)
+             (when stream
+               (setf created-pathname pathname)
+               (return (funcall thunk stream pathname)))))
+      (when(and (not keep) created-pathname)
+        (ignore-errors (delete-file created-pathname))))))

+(in-package :common-lisp-user)

-(defparameter *lisp-binary-path*   "/data/src/languages/ccl/ccl-1.8-linuxx86/lx86cl64")
-(defparameter *target-mount-point* "/tmp/lep/")


+;;; general tools
+
+(defun remove-final-slash (pathname)
+  (let ((path (namestring pathname)))
+    (if (and (plusp (length path))
+             (char= #\/ (aref path (1- (length path)))))
+        (subseq path 0 (1- (length path)))
+        path)))
+
 (defun relativize-pathname (pathname)
   (make-pathname :directory (cons :relative (rest (pathname-directory pathname)))
                  :defaults pathname))

+(defun backup-file-p (pathname)
+  (let ((path (namestring pathname)))
+    (and (plusp (length path))
+         (char= #\~ (aref path (1- (length path)))))))
+
+
 (defun test/relativize-pathname ()
  (assert (equalp (relativize-pathname "/tmp/toto/titi")     #P"tmp/toto/titi"))
  (assert (equalp (relativize-pathname "/tmp/toto/titi.tar") #P"tmp/toto/titi.tar"))
@@ -50,14 +238,117 @@

 (defun test/target ()
   (assert (equalp (let ((*target-mount-point* "/tmp/base/"))
-                    (dir "/toto/titi/"))
+                    (target "/toto/titi/"))
                   #P"/tmp/base/toto/titi/"))
   :success)

 (test/relativize-pathname)
-(test/dir)
+(test/target)
+
+


+;;; unix/linux stuff
+
+;; running commands:
+
+(defmacro with-temporary-stream ((variable) &body body)
+  `(uiop/stream:with-temporary-file (:stream ,variable
+                                              :direction :io
+                                              :element-type 'character
+                                              :prefix "LEP")
+     ,@body))
+
+(defun run-command (word-list &key (input nil) (output *standard-output*) (wait t))
+  (run-program (first word-list) (rest word-list) :input input :output output :wait wait))
+
+(defun inferior-lisp-script (lisp-script)
+  (with-open-file (input lisp-script)
+    (run-command *lisp-norc* :input input)))
+
+(defun inferior-lisp-sexp (sexp)
+  (with-temporary-stream (temp-stream)
+    (print sexp temp-stream)
+    (finish-output temp-stream)
+    (file-position temp-stream 0)
+    (run-command *lisp-norc* :input temp-stream)))
+
+(defun sudo-lisp-script (lisp-script)
+  (setf (getenv "SUDO_ASKPASS") (namestring *askpass-binary-path*))
+  (with-open-file (input lisp-script)
+    (run-command (append *sudo-askpass* *lisp-norc*) :input input)))
+
+(defun sudo-lisp-sexp (sexp)
+  (setf (getenv "SUDO_ASKPASS") (namestring *askpass-binary-path*))
+  (with-temporary-stream (temp-stream)
+    (print sexp temp-stream)
+    (finish-output temp-stream)
+    (file-position temp-stream 0)
+    (run-command (append *sudo-askpass* *lisp-norc*) :input temp-stream)))
+
+
+;; mount points
+
+(defstruct (mount-point
+             (:constructor make-mount-point (device
+                                             directory
+                                             file-system-type
+                                             options
+                                             dump
+                                             check-pass)))
+  device
+  directory
+  file-system-type
+  options
+  dump
+  check-pass)
+
+
+(defun mounts (&key device directory file-system-type)
+  "Returns a list of MOUNT-POINT instances read from /proc/mounts
+When DEVICE, DIRECTORY or FILE-SYSTEM-TYPE are specified, only those mount-points
+that match them are returned."
+  (with-open-file (mounts "/proc/mounts")
+    (loop
+      :with transformers = (list (function identity) (function identity) (function identity)
+                                (lambda (options)
+                                  (split-sequence #\, options))
+                                (function parse-integer)
+                                (function parse-integer))
+      :for line = (read-line mounts nil)
+      :for fields = (ignore-errors
+                      (mapcar (function funcall) transformers (split-sequence #\space line)))
+      :while line
+      :when (and fields
+                 (or (null device)           (string= device           (first fields)))
+                 (or (null directory)        (string= directory        (second fields)))
+                 (or (null file-system-type) (string= file-system-type (third fields))))
+      :collect (apply (function make-mount-point) fields))))
+
+
+(defun mount (device mount-point-directory mount-options)
+  (run-program "mount" (append mount-options (list device mount-point-directory))
+               :input nil :output *standard-output* :wait t))
+
+
+
+;; ldd
+
+(defun ldd (program-path)
+  (with-open-stream (ldd (process-output-stream
+                          (run-program "ldd" (list program-path)
+                                       :element-type 'character
+                                       :output :stream :input nil :error nil)))
+    (loop
+      :for line = (read-line ldd nil nil)
+      :while line
+      :for libraries = (nth-value 1 (ppcre:scan-to-strings "^[ 	]+((.*) => )?(.*) \\(0x[0-9a-f]+\\)$" line))
+      :unless  (equal "" (aref libraries 2))
+      :collect (aref libraries 2))))
+
+
+;; fstab
+
 (defun write-fstab (pathname entries)
   (with-open-file (fstab pathname
                          :direction :output
@@ -71,40 +362,117 @@
         :do (format fstab "~10A ~10A ~10A ~20A ~4D ~4D~%"
                     device mount-point fs-type options dump pass)))))

+
+;; mklost+found
+
+(defun mklost+found ()
+  (let ((dir (target "lost+found/file")))
+    (ensure-directories-exist dir)
+    (loop
+      :for i :below 8192
+      :for path = (make-pathname :name (format nil "~16X" i)
+                                 :defaults dir)
+      :do (open path :direction :probe :if-does-not-exist :create :if-exists :supersede)
+      :finally (map nil (function delete-file)
+                    (reverse (directory (make-pathname :name :wild :defaults dir)))))))
+
+
+
+;;; lep stuff
+
+
 (defun generate-init ()
-  (with-open-file (generate "generate-init.lisp")
-    (run-program *lisp-binary-path* (list "-norc")
-                 :input (merge-pathnames "generate-init.lisp" *default-pathname-defaults* nil)
-                 :output t
-                 :wait t)))
+  (inferior-lisp-script (merge-pathnames "generate-init.lisp" *default-pathname-defaults* nil)))
+


 (defun lepbootstrap ()
-  (cd (dirname (or *load-pathname* #P"~/src/public/lep/install/")))
-
-  (dolist (dir '( "/bin/" "/etc/" "/sbin/" "/lib/" "/tmp/"))
-    (mkdir (target dir)))
-
-  ;;   (generate-init)
-
-  (copy-file "init" (target "/sbin/init")
-             :if-exists :supersede
-             :element-type '(unsigned-byte 8))
-  (dolist (library (ldd *lisp-binary-path*))
-    (let ((destination (target library)))
-      (ensure-directories-exist destination)
-      (copy-file library destination
-                 :if-exists :supersede
-                 :element-type '(unsigned-byte 8))))
-
-  (write-fstab (target "/etc/fstab")
-               '(("/dev/root" "/" "ext3" "defaults,noatime" 0 1))))
+  (let ((target-root (remove-final-slash (target ""))))
+    ;; this sets *default-pathname-defaults*
+    (cd (dirname (or *load-pathname* #P"~/src/public/lep/install/")))
+
+    (unless (mounts :directory target-root)
+      (mount *target-device* target-root *target-mount-options*))
+
+    (unless (mounts :directory target-root)
+      (error "target mount point not available ~S" target-root))
+
+    (mklost+found)
+
+    (dolist (dir '( "/bin/" "/etc/" "/sbin/" "/lib/" "/tmp/" "/dev/" "/proc/" "/sys/" "/root/"
+                   "/system/quicklisp/" "/system/ccl/"
+                   "/services/"
+                   "/home/"))
+      (mkdir (target dir)))
+
+    (generate-init)
+
+    (copy-file "init" (target "/sbin/init")
+               :if-exists :supersede
+               :element-type '(unsigned-byte 8))
+    (chmod #o755 (target "/sbin/init"))
+
+    (with-open-file (init (target "/etc/init.lisp")
+                          :direction :output
+                          :if-exists :supersede
+                          :if-does-not-exist :create)
+      (pprint '(progn
+                (format t "~2%Welcome to the Lisp Empowered Program~2%")
+                (finish-output))
+              init)
+      (terpri init))
+
+
+    (dolist (library (ldd (first *lisp-norc*)))
+      (let ((destination (target library)))
+        (ensure-directories-exist destination)
+        (copy-file library destination
+                   :if-exists :supersede
+                   :element-type '(unsigned-byte 8))
+        (chmod #o755 destination)))
+
+    (write-fstab (target "/etc/fstab")
+                 `(("/dev/root"
+                    "/"
+                    ,(mount-point-file-system-type
+                      (first (mounts :directory target-root)))
+                    "defaults,noatime"
+                    0
+                    1)))
+
+    ;; (copy-directory *lisp-sources* (target "/system/ccl/")
+    ;;                 :if-exists :overwrite
+    ;;                 :test (complement (function backup-file-p)))
+    ;;
+    ;; (copy-directory (dirname *quicklisp*) (target "/system/quicklisp/")
+    ;;                 :if-exists :overwrite
+    ;;                 :test (complement (function backup-file-p)))
+
+    ))
+



+(if (zerop (getuid))
+    (lepbootstrap)
+    (sudo-lisp-sexp `(handler-bind ((error (lambda (condition)
+                                             (declare (ignore condition))
+                                             (funcall (find-symbol "PRINT-BACKTRACE" "UIOP/IMAGE"))
+                                             nil)))
+                       (load  ,(namestring (truename *load-pathname*))))))
+
+#||
+
+mount -o loop /domU/images/lep.ext3 /mnt/lep
+env -i /usr/sbin/chroot /mnt/lep /sbin/init
+


+losetup --offset $(( 63*512 )) /dev/loop0 /domU/images/lep.boot.disk
+mount /dev/loop0 /mnt/lep

+umount /dev/loop0
+losetup --detach /dev/loop0

-(lepbootstrap)

+||#
ViewGit