;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               props.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Implement a props client to fgfs.
;;;;    fgfs --telnet 5401
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@ogamita.com>
;;;;MODIFICATIONS
;;;;    2011-04-16 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 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 General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************


(defpackage "COM.OGAMITA.FGFS.PROPS"
  (:use "COMMON-LISP" "USOCKET")

  (:export

   )
  (:documentation "
Implement a props client to fgfs.
GPL
Copyright Pascal J. Bourguignon 2011 - 2011
"))
(in-package "COM.OGAMITA.FGFS.PROPS")



(defstruct props-node
  (name nil :type symbol)) ; we will intern all the property names into KEYWORD.

(defstruct (props-leaf
             (:include props-node))
  value)

(defstruct (props-directory
             (:include props-node))
  (children (make-hash-table)))




(defstruct (props
             (:constructor make-props (host port))
             (:constructor %make-props))
  (state :need-fetch :type (member :need-fetch))
  connection
  host port
  nodes)


(define-condition props-error (error)
  ((message :initarg :message :accessor props-error-message))
  (:report (lambda (condition stream)
             (format stream "Error from the props server: ~A"
                     (props-error-message condition)))))


(defun writeln (stream format-string &rest arguments)
  (format stream "~?~A~A" format-string arguments (code-char 13) (code-char 10))
  (force-output stream))

(defun readln (stream)
  (let ((line (string-right-trim #(#\return) (read-line stream))))
    (if (and (<= 4 (length line))
             (string= "-ERR" line :end2 4))
        (error props-error :message (read-from-string line nil "" :start 4))
        line)))


(defun connect-props (props)
  (unless (props-connection props)
    (setf (props-connection props)
          (socket-connect (props-host props) (props-port props)
                          :protocol :stream
                          :element-type 'character))
    (let ((stream (socket-stream (props-connection props))))
      (writeln stream "data"))))


(defun close-props (props)
  (when (props-connection props)
    (let ((stream (socket-stream (props-connection props))))
      (writeln stream "quit"))
    (socket-close (props-connection props))
    (setf (props-connection props) nil)))







(defun read-x-lines (stream)
  (let ((line1 (readln stream)))
    (if (zerop (length line1))
        (values "" nil)
        (let ((line2 (readln stream)))
          (if (zerop (length line2))
              (values (subseq line1 1) nil)
              (values (with-output-to-string (out)
                        (write-line (subseq line1 1) out)
                        (write-line (subseq line2 1) out)
                        (loop
                           :for line = (readln stream)
                           :while (plusp (length line))
                           :do (write-line (subseq line 1) out)))
                      t))))))

(defun rematch (pattern string index)
  (cond
    ((eql pattern '$)  (values (= index (length string))
                               index))
    ((stringp pattern) (if (< index (length string))
                           (values (find (aref string index) pattern)
                                   (1+ index))
                           (values nil (length string))))
    ((atom pattern)    (error "Unexpected atom in pattern: ~S" pattern))
    (t (ecase (first pattern)
         (seq
          (loop
             :with matchp
             :for subpat :in (rest pattern)
             :do (multiple-value-setq (matchp index) (rematch subpat string index))
             :while matchp
             :finally (return (values matchp index))))
         (alt
          (loop
             :with matchp
             :with subindex
             :for subpat :in (rest pattern)
             :do (multiple-value-setq (matchp subindex) (rematch subpat string index))
             :until matchp
             :finally (return (values matchp subindex))))
         (?
          (assert (null (cddr pattern)) (pattern) "? takes a single subpattern argument")
          (multiple-value-bind (matchp subindex) (rematch (second pattern) string index)
            (if matchp
                (values matchp subindex)
                (values ""     index))))
         (+
          (assert (null (cddr pattern)) (pattern) "+ takes a single subpattern argument")
          (loop
             :with matchp
             :with subindex
             :for newindex = index :then subindex
             :do (multiple-value-setq (matchp subindex) (rematch (second pattern) string newindex))
             :while matchp
             :count 1 :into occurences
             :finally (return (if (zerop occurences)
                                  (values nil newindex)
                                  (values occurences newindex)))))
         (*
          (assert (null (cddr pattern)) (pattern) "* takes a single subpattern argument")
          (loop
             :with matchp
             :with subindex
             :for newindex = index :then subindex
             :do (multiple-value-setq (matchp subindex) (rematch (second pattern) string newindex))
             :while matchp
             :count 1 :into occurences
             :finally (return (values occurences newindex))))))))


(defparameter *number-pattern*
  (let* ((digits "0123456789")
         (expo   `(seq "eEfFdDlL" (?  "-+") (+ ,digits))))
    `(seq (? "-+")
          (alt
           (seq (+ ,digits) (? (seq "." (* ,digits))) (? ,expo))
           (seq "." (+ ,digits) (?  ,expo)))
          $)))


(defun fetch-value (stream relpath)
  (writeln stream "getx ~A" relpath)
  (flet ((string-or-bool (line)
           (cond
             ((string= line "false") nil)
             ((string= line "true")  t)
             (t                      line))))
    (multiple-value-bind (text multilinep) (read-x-lines stream)
      (if (or multilinep (zerop (length text)))
          text
          (if (rematch *number-pattern* text 0)
              (read-from-string text)
              (string-or-bool text))))))


#-(and)
(mapcar (lambda (text)
          (print
           (cons text
                 (multiple-value-list
                  (rematch '(seq (? "-+")
                             (alt
                              (seq
                               (+ "1234567890")
                               (? (seq "."
                                       (* "1234567890")))
                               (? (seq "eEfFdDlL" (?  "-+") (+ "1234567890"))))
                              (seq
                               "." (+ "1234567890")
                               (? (seq "eEfFdDlL" (?  "-+") (+ "1234567890")))))
                             $)
                           text 0)))))

        '(""
          "a"
          "abc"
          "1" "1x" "1e" "1e+" "1e2" "1e-2" "1+" "1+2" "1+e+1"
          "1234" "1234x"
          "1234." "1234.xyz"
          "1234.e" "1234.e+" "1234.e42" "1234.e-42" "1234.e+42"  "1234.+" "1234.+e" "1234.+e42" "1234.+e-42"
          "1234.5678" "1234.5678xyz"
          "1234.5678e90" "1234.5678e90xyz"

          ".1234" ".1234xyz" ".1234e"
          ".1234e+" ".1234exyz" ".1234e123" ".1234e+123" ".1234e-123" ".1234e123xyz" ".1234e123+"

          "+1" "+1x" "+1e" "+1e+"  "+1e2" "+1e-2" "+1+" "+1+2" "+1+e+1"
          "+1234" "+1234x"
          "+1234." "+1234.xyz"
          "+1234.e" "+1234.e+" "+1234.e42" "+1234.e-42" "+1234.e+42"  "+1234.+" "+1234.+e" "+1234.+e42" "+1234.+e-42"
          "+1234.5678" "+1234.5678xyz"
          "+1234.5678e90" "+1234.5678e90xyz"
          "+.1234e+" "+.1234exyz" "+.1234e123" "+.1234e+123" "+.1234e-123" "+.1234e123xyz" "+.1234e123+"


          "-1" "-1x" "-1e" "-1e+" "-1e2" "-1e-2" "-1+" "-1+2" "-1+e+1"
          "-1234" "-1234x"
          "-1234." "-1234.xyz"
          "-1234.e" "-1234.e-" "-1234.e42" "-1234.e-42" "-1234.e-42"  "-1234.-" "-1234.-e" "-1234.-e42" "-1234.-e-42"
          "-1234.5678" "-1234.5678xyz"
          "-1234.5678e90" "-1234.5678e90xyz"
          "-.1234e-" "-.1234exyz" "-.1234e123" "-.1234e-123" "-.1234e-123" "-.1234e123xyz" "-.1234e123-"

          "++1" "++1x" "++1e" "++1e+" "++1e2" "++1e-2" "++1+" "++1+2" "++1+e+1"
          "++1234" "++1234x"
          "++1234.e" "++1234.e++" "++1234.e42" "++1234.e++42" "++1234.e++42"  "++1234.++" "++1234.++e" "++1234.++e42" "++1234.++e++42"
          "++1234." "++1234.xyz"
          "++1234.5678" "++1234.5678xyz"
          "++1234.5678e90" "++1234.5678e90xyz"
          "++.1234e++" "++.1234exyz" "++.1234e123" "++.1234e++123" "++.1234e++123" "++.1234e123xyz" "++.1234e123++"

          "+.e2"))


(defun fetch-directory-contents (stream)
  (writeln stream "lsx")
  (loop
     :for line = (readln stream)
     :while (plusp (length line))
     :collect line))



(defun directory-props-p (prop-name)
  (char= #\/ (aref prop-name (1- (length prop-name)))))

(defun fetch-props-tree (stream path)
  (writeln stream "cd ~A" path)
  (with-simple-restart (continue-with-next-node
                        "Continue with node following ~A" path)
    (handler-case
        (mapcar (lambda (item)
                  (let ((path (concatenate 'string
                                path
                                (if (directory-props-p path) "" "/")
                                item)))
                    (if (directory-props-p item)
                        (fetch-props-tree stream path)
                        (cons item (fetch-value stream path)))))
                (fetch-directory-contents stream))
      (props-error (err)
        (let ((message (props-error-message err)))
          (if (and (string= "node " message :end2 5)
                   (string= " not found" message :start2 (- (length message) 10)))
              '()
              (error err)))))))


(defun fetch-props (props)
  (connect-props props)
  (let ((stream (socket-stream (props-connection props))))
    (fetch-directory-contents stream "/")

    ))



(defparameter *props* (make-props "localhost" 5580))

#||

(close-props *props*) (connect-props *props*)
(fetch-props-tree (socket-stream (props-connection *props*)) "/")


(writeln (socket-stream (props-connection *props*)) "cd /")
(fetch-value (socket-stream (props-connection *props*)) "null")

(setf *read-default-float-format* 'double-float)
||#

;; cd <dir>           cd to a directory, '..' to move back
;; data               switch to raw data mode
;; dump               dump current state (in xml)
;; get <var>          show the value of a parameter
;; help               show this help message
;; ls [<dir>]         list directory
;; prompt             switch to interactive mode (default)
;; pwd                display your current path
;; quit               terminate connection
;; run <command>      run built in command
;; set <var> <val>    set <var> to a new <val>



;;;; THE END ;;;;
ViewGit