5.3. Functions

5.3.1. Session Instances

`Session Instances' provide a means of reusing objects within unique sessions.

(defun session-instance (class &rest initargs)
  (let ((instance (funcall #'ensure-session-instance class initargs)))
    (apply #'reinitialize-instance instance initargs)))

5.3.2. Rendering Elements

(defgeneric render-html (t t))

5.3.3. Methods

Methods are made available to clients using define-wm:

(defmacro define-wm (method-name method-ll &body method-body)
  `(labels ((wm-args (arglist)
	     (values (mapcar #'car arglist)
		     (mapcar #'cadr arglist)))
	    ;; Should we install new objects into the session here?
	    (wm-lambda (args &rest body)
	     (compile nil (coerce `(lambda ,args ,@body) 'function))))
    (destructuring-bind (type &rest args)
	',method-ll
      (let ((name (string-downcase (symbol-name ',method-name))))
	(multiple-value-bind (arg-vars arg-types)
	    (wm-args args)
	  (let ((body-func (wm-lambda (cons (car type) arg-vars) '(progn ,@method-body))))
	    (setf (gethash name *methods*)
		  (make-wmethod :name name :type type
				:arguments arg-types :body body-func))))))))


(defun process-wm-args (method-args request-args)
  (flet ((process (method-arg ext-arg)
	   (case method-arg
	     ('string
	      ext-arg)
	     (t
	      (intern-ref method-arg ext-arg)))))
    (mapcar #'process method-args request-args)))

(defvar *methods* (make-hash-table :test #'equal))

(defun lookup-wm (name &optional default)
  (or (gethash name *methods*)
      (and default (gethash default *methods*))))

(defmacro undefine-wm (method)
  `(setf (gethash (string-downcase (symbol-name ,method)) *methods*) nil))

(defmacro refer-wm (method &rest args)
  `(let ((method (lookup-wm (string-downcase (symbol-name ',method))))
	 (argv (list ,@args)))
    (format t ";; Args: ~s~%" (list ,@args))
    (if (not method)
	(error "No reference for method ~s" ',method))
    (let ((name (wmethod-name method)))
      (if argv
	  (progn
	    (setf name (concatenate 'string *active-url* "0/" name "?"))
	    (mapc (lambda (arg)
		    (format t ";; Arg: ~s~%" arg)
		    (setf name (concatenate 'string name (extern-ref arg)))
		    )
		  argv)))
      name)))

5.3.4. Passing arguments to Methods

In order to pass arguments to methods, ther must be a means of allowign the client to uniquely identify objects which exist on the server; this is done using the intern-ref/exter-ref pair of functions.

(defgeneric intern-ref (t t))

(defmethod intern-ref (object arg)
  (error "No default internalizer for objects of type '~s'" object))

(defgeneric extern-ref (t))

;; A string externalizes as itself, mutatis mutandis URI escaping.

(defmethod extern-ref ((string string))
  string)

5.3.5. Starting and stopping apps

The init/application function takes a keyword argument of :start, :stop, :restart, or :report. To start an IMHO application, type: * (init/application 'foo-app :start)

And to stop it: * (init/application 'foo-app :stop)

;; ------------------------------------------------------------
;; function passed to export-url

(defun init/application (app-class state)
  (let* ((app (make-instance app-class))
         (url (base-url app)))
    (ecase state
      (:start
       (unless (gethash url *imho-active-apps*)
         (setf (gethash url *imho-active-apps*) app)
         (application-startup app)
         (init/imho :start)))
      (:stop
       (when-bind (app (gethash url *imho-active-apps*))
         (application-shutdown app)
         (remhash url *imho-active-apps*)))
      (:restart
       (init/application app-class :stop)
       (init/application app-class :start))
      (:report
       (gethash url *imho-active-apps*))))
  (values))

5.3.6. Generating SGML markup

;; Functions for programmatically generating SGML markup
;;

;; with-tag - A macro that wraps some code inside an SGML tag.
;;
;; example:
;;
;; (with-tag (:tag "P")
;;   (with-tag (:tag "I")
;;     (format t "It was a dark and stormy night.")))
;;
;; expands to code that writes:
;;
;; <P><I>It was a dark and stormy night.</I></P>
;;
;; the body is optional, and if you want to omit the close tag, say:
;;
;; (with-tag (:tag "IMG" :noclose t :attr '(("SRC" . "http://localhost/gif.jpg"))))
;;
;; which produces
;;
;; <IMG SRC="http://localhost/gif.jpg">

(defmacro with-tag ((&key tag (stream '*standard-output*)
			  (attr nil) (noclose nil)) &body body)
  `(locally
    (let ((stream ,stream))
      (format stream "<~A" ,tag)
      (if ,attr
	  (dolist (pair ,attr)
	    (if (null (cdr pair))
		(progn
		  (write-char #\  stream)
		  (write-string (car pair) stream))
		(format stream " ~A=\"~A\"" (car pair) (cdr pair)))))
      (format stream ">~%")
      ,@body
      (if (not ,noclose)
	  (format stream "</~A>~%" ,tag)))))

(defmacro param-tag (stream name value)
  `(with-tag (:stream ,stream
	      :tag "PARAM"
	      :noclose t
	      :attr `(("NAME" . ,,name)
		      ("VALUE" . ,,value)))))

(defmacro with-reference ((reference stream) &body rest)
  `(with-tag (:stream ,stream
	      :tag "A"
	      :attr `(("HREF" . ,,reference)))
    ,@rest))

;; Now, rather than
;; 
;; (with-tag (:stream stream :tag "A" :attr `(("HREF" . (refer-wm frob widget))))
;;   (write-string "Frob the Widget" stream))
;; 
;; you say
;; 
;; (with-action (stream frob widget)
;;   (write-string "Frob the Widget" stream))

(defmacro with-action ((stream method &rest args) &body body)
  `(with-reference ((refer-wm ,method ,@args) ,stream)
    ,@body))

;; Someone make this work, wah!

(defun image-tag-attributes (url text size spacing border)
  (labels ((itoa (i)
	     (format nil "~d" i)))
    (let ((atts (list (cons "ALTTEXT" text)
		      (cons "SRC" url))))
      (if size
	  (setq atts (cons (cons "WIDTH" (itoa (car size)))
			   (cons (cons "HEIGHT" (itoa (cadr size)))
				 atts))))
      (cons (cons "BORDER" (itoa border))
	    (cons (cons "HSPACE" (itoa spacing))
		  (cons (cons "VSPACE" (itoa spacing))
			atts))))))

(defmacro image-tag (stream url text &key (size nil) (spacing 0) (border 0))
  `(with-tag (:stream ,stream :tag "IMG" :noclose t
	      :attr (image-tag-attributes ,url ,text ,size ,spacing ,border))))

5.3.7. Logging


(defvar *imho-log-path* #p"/var/log/imho/*.log")

(defvar *imho-log-file* "imho")

(defvar *imho-log-stream* nil)

(defun log-event (event)
  "Write an event to IMHO's event log"
  (handler-case
      (let ((log-stream (ensure-log))
            (remote-ip "unknown"))
        (if *active-request*
            (setf remote-ip (client-ip)))
        (format log-stream
                "~12s - user - [~a] ~a~%"
                remote-ip
                #-cmu "print-time"
                #+cmu (ext:format-universal-time nil (get-universal-time))
                event)
        (force-output log-stream))
    (error (c)
      (format t "~&;; IMHO: unable to write log: ~s~%" c))))

5.3.8. Communicating With Client-side Java

;; ============================================================
;; Stuff for writing Java types to a stream or a file
;;
;; 

(defvar *string-svid* #xadd256e7e91d7b47)

(defvar *object-stream-magic* #xaced)
(defvar *object-stream-default-version* #x0005)

(defconstant +os-null+		#x70)
(defconstant +os-ref+		#x71)
(defconstant +os-class-desc+	#x72)
(defconstant +os-obj+		#x73)
(defconstant +os-string+	#x74)
(defconstant +os-array+		#x75)
(defconstant +os-class+		#x76)
(defconstant +os-blockdata+	#x77)
(defconstant +os-endblockdata+	#x78)
(defconstant +os-reset+		#x79)
(defconstant +os-blockdatalong+	#x7a)
(defconstant +os-exception+	#x7b)

(defclass object-output-stream ()
  ((handle
    :initform 0)
   (binary-stream
    :initarg :stream))
  )

(defun make-object-output-stream (stream)
  (let ((oos (make-instance 'object-output-stream :stream stream)))
    (write-object-stream-header oos)
    oos))
  
(defmethod write-object-stream-header ((stream object-output-stream))
  (with-slots (binary-stream)
    stream
    (write-int16 *object-stream-magic* binary-stream)
    (write-int16 *object-stream-default-version* binary-stream)))

(defgeneric write-java-object (t t)
  (:documentation
   "Write an object onto an object output stream, barf if you don't
know how to do it."))

(defmethod write-java-object ((type t) (stream object-output-stream))
  (error "Don't know how to serialize a ~s for Java" (type-of type)))

(defun write-java-utf (string stream)
  (let ((len (length string)))
    (write-int16 len stream)
    (do ((x 0 (incf x)))
	((= x len))
      (write-byte (char-code (aref string x)) stream))))

(defmethod write-java-object ((string string) (stream object-output-stream))
  (with-slots (binary-stream)
    stream
    (write-byte +os-string+ binary-stream)
    (write-java-utf string binary-stream)))

(defun write-java-class-desc (classname binary-stream)
  (write-byte +os-class-desc+ binary-stream)
  (write-java-utf classname binary-stream)
  serialVersionUID
  newHandle
  classDescInfo)

(defmethod write-java-object ((string-array simple-vector) (stream object-output-stream))
  (with-slots (binary-stream)
    stream
    (let ((len (length string-array)))
      (write-byte +os-array+ binary-stream)
      (write-byte +os-class-desc+ binary-stream)
      (write-java-utf "[Ljava.lang.String;" binary-stream)
      (write-int64 *string-svid* binary-stream)
      (write-byte #x02 binary-stream)
      (write-int16 #x0000 binary-stream)
      (write-byte +os-endblockdata+ binary-stream)
      (write-byte +os-null+ binary-stream)

      (write-int len binary-stream)
      (do ((x 0 (incf x)))
	  ((= x len))
	(write-java-object (aref string-array x) stream)))))

(defmacro with-java-stream ((stream file) &rest body)
  `(with-open-file (bs ,file :direction :output :element-type 'unsigned-byte)
    (let ((,stream (make-object-output-stream bs)))
      (with-slots (binary-stream)
	,stream
	,@body))))

(defun test ()
  (with-java-stream (stream "/tmp/string-array-l.bin")
    (write-java-object #("Uno" "Ena whena booda poo" "The REPL Who Loved Me" "From Symbolics With Love") stream)
;;    (write-java-object "Live and Let Cons" stream)
    ))