;;;; -*- 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)))


#+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 (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 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)



;;; 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"))
 (assert (equalp (relativize-pathname "/tmp/toto/")         #P"tmp/toto/"))
 ;; (assert (equalp (relativize-pathname "/")                  #P""))
 :success)


(defun target (dirpath)
  (merge-pathnames (relativize-pathname dirpath)
                   *target-mount-point*
                   nil))

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

(test/relativize-pathname)
(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
                         :if-does-not-exist :create
                         :if-exists :supersede
                         :element-type 'character)
    (let ((*print-pretty* nil))
      (loop
        :for (device mount-point fs-type options dump pass)
        :in entries
        :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 ()
  (inferior-lisp-script (merge-pathnames "generate-init.lisp" *default-pathname-defaults* nil)))



(defun lepbootstrap ()
  (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


||#
ViewGit