fasttrack.lisp

   1 (in-package #:phoros-fasttrack)
   2
   3 (defvar *postgresql-aux-credentials* nil
   4   "A list: (database user password host &key (port 5432) use-ssl).")
   5
   6 (defun main ()
   7
   8   (with-tk ((make-instance 'ffi-tk))
   9     (let ((c ".c"))
  10       (tcl "package" "require" "Img")
  11       (tcl "option" "add" "*tearOff" 0)
  12       (tcl "wm" "title" "." "Conway's life")
  13       (tcl "menu" ".menubar")
  14       (tcl "." "configure" :menu ".menubar")
  15       (tcl "menu" ".menubar.file")
  16       (tcl ".menubar" "add" "cascade" :label "File" :menu ".menubar.file" :underline 0)
  17       (tcl ".menubar.file" "add" "command" :label "Kaputt" :command (tcl{ "destroy" "."))
  18       (tcl ".menubar.file" "add" "command" :label "Do Stuff" :command (event-handler* (print "doing stuff") (print "doing more stuff") (tcl "set" "feet" 500)))
  19
  20       (bind-event ".menubar.file" "<<check.blah>>" ((ddd #\d)) (print (list "ddd" ddd)))
  21       (tcl ".menubar.file" "add" "checkbutton" :label "Check" :variable "check" :onvalue 1 :offvalue 0 :command (tcl{ "event" "generate" ".menubar.file" "<<check.blah>>" :data (lit "$check")))
  22
  23       (tcl "grid" (tcl[ "ttk::frame" ".c" :padding "3 3 12 12") :column 0 :row 0 :sticky "nwes")
  24       ;;       (tcl "grid" "columnconfigure" "." 0 :weight 1)
  25       ;;       (tcl "grid" "rowconfigure" "." 0 :weight 1)
  26 ;      (tcl "event" "generate" "." "<<boom>>" :data "Blahbla")
  27       (tcl "grid" (tcl[ "canvas" ".c.c" :bg "grey") :column 4 :row 1 :sticky "we")
  28
  29       (tcl "image" "create" "photo" "imgobj" :file "270970851.png")
  30       (tcl "grid" (tcl[ "label" ".c.l" :bg "grey") :column 1 :row 4 :sticky "we")
  31       ;; (tcl ".c.l" "configure" :image "imgobj")
  32       (tcl ".c.c" "create" "image" 100 100 :image "imgobj")
  33
  34
  35       (tcl "grid" (tcl[ "ttk::entry" ".c.feet" :width 7 :textvariable "feet") :column 2 :row 1 :sticky "we")
  36 ;;       (tcl "grid" (tcl[ "ttk::label" ".c.meters" :textvariable "meters") :column 2 :row 2 :sticky "we")
  37 ;;       (tcl "grid" (tcl[ "ttk::button" ".c.calc" :text "Calculate" :command "calculate") :column 3 :row 3 :sticky "w")
  38 ;;       (tcl "grid" (tcl[ "ttk::label" ".c.flbl" :text "feet") :column 3 :row 1 :sticky "w")
  39 ;;       (tcl "grid" (tcl[ "ttk::label" ".c.islbl" :text "is equivalent to") :column 1 :row 2 :sticky "e")
  40 ;;       (tcl "grid" (tcl[ "ttk::label" ".c.mlbl" :text "meters") :column 3 :row 2 :sticky "w")
  41 ;;       (tcl "foreach w [ winfo children .c ] {grid configure $w -padx 5 -pady 5}")
  42 ;;       (tcl "focus" ".c.feet")
  43 ;;       (tcl "bind" "." "<Return>" "{calculate}")
  44 ;;       (tcl "proc calculate {} {
  45       (mainloop)
  46       )))
  47
  48
  49 ;; (with-connection '("phoros_aux" "postgres" "ser,!db" "db2")
  50 ;;   (query (:limit (:select 'vnk 'nnk 'nk-station
  51 ;;                          :from 'bew-landstr-kleinpunkte)
  52 ;;                 10)))
  53
  54 (defun sections (table &key (start 0) (end most-positive-fixnum))
  55   "Return list of distinct pairs of vnk, nnk found in table in
  56 current database."
  57   (query (:limit (:order-by (:select 'vnk 'nnk
  58                                      :from table
  59                                      :group-by 'vnk 'nnk)
  60                             'vnk 'nnk)
  61                  (- end start) start)))
  62
  63 (defun station (table vnk nnk &optional station)
  64   "Return longitude and latitude of point at station between vnk and
  65 nnk, and its station.  Return values of last station if station isn't
  66 given."
  67   (values-list
  68    (if station
  69        (query (:select (:st_x 'the-geom) (:st_y 'the-geom) 'nk-station
  70                        :from table
  71                        :where (:and (:= 'vnk vnk)
  72                                     (:= 'nnk nnk)
  73                                     (:= 'nk-station station)))
  74               :row)
  75        (query (:limit (:order-by (:select (:st_x 'the-geom) (:st_y 'the-geom) 'nk-station
  76                                           :from table
  77                                           :where (:and (:= 'vnk vnk)
  78                                                        (:= 'nnk nnk)))
  79                                  (:desc 'nk-station))
  80                       1)
  81               :row))))
  82
  83 (defun image-data (table vnk nnk station)
  84   "Get from Phoros server image data for location found for vnk, nnk,
  85 station in table in current database."
  86   (multiple-value-bind (longitude latitude)
  87       (station table vnk nnk station)
  88     (phoros-nearest-image-data longitude latitude)))
  89
  90 (define-condition phoros-server-error (error)
  91    ((body :reader body :initarg :body)
  92     (status-code :reader status-code :initarg :status-code)
  93     (headers :reader headers :initarg :headers)
  94     (uri :reader uri :initarg :uri)
  95     (reason-phrase :reader reason-phrase :initarg :reason-phrase))
  96   (:report (lambda (condition stream)
  97              (format stream "Can't connect to Phoros server: ~A (~D)"
  98                      (reason-phrase condition) (status-code condition)))))
  99
 100 (defvar *phoros-cookies* nil)
 101 (defvar *phoros-uri* nil)
 102
 103 (defun phoros-login (url user-name user-password)
 104   "Log into Phoros server; return T if successful.  Try logging out
 105 first."
 106   (setf *phoros-uri* (puri:parse-uri url))
 107   (setf drakma:*allow-dotless-cookie-domains-p* t)
 108   (setf drakma:*text-content-types* (acons "application" "json" drakma:*text-content-types*))
 109   (phoros-logout)
 110   (setf *phoros-cookies* (make-instance 'drakma:cookie-jar))
 111   (multiple-value-bind (body status-code headers uri stream must-close reason-phrase)
 112       (drakma:http-request *phoros-uri* :cookie-jar *phoros-cookies*)
 113     (declare (ignore stream must-close))
 114     (assert (= status-code 200) ()
 115             'phoros-server-error :body body :status-code status-code :headers headers :uri uri :reason-phrase reason-phrase)
 116     (multiple-value-bind (body status-code headers authenticate-uri stream must-close reason-phrase)
 117         (drakma:http-request (phoros-lib-uri *phoros-uri* "authenticate")
 118                              :cookie-jar *phoros-cookies*
 119                              :form-data t
 120                              :method :post
 121                              :parameters (pairlis '("user-name" "user-password")
 122                                                   (list user-name user-password)))
 123       (declare (ignore stream must-close))
 124       (assert (< status-code 400) ()
 125               'phoros-server-error :body body :status-code status-code :headers headers :uri authenticate-uri :reason-phrase reason-phrase)
 126       (= status-code 302))))
 127
 128 (defun phoros-logout ()
 129   (multiple-value-bind (body status-code headers uri stream must-close reason-phrase)
 130       (drakma:http-request (phoros-lib-uri *phoros-uri* "logout")
 131                            :cookie-jar *phoros-cookies*)
 132     (declare (ignore stream must-close))
 133     (assert (= status-code 200) ()
 134             'phoros-server-error :body body :status-code status-code :headers headers :uri uri :reason-phrase reason-phrase)))
 135
 136
 137 (defun phoros-nearest-image-data (longitude latitude)
 138   (multiple-value-bind (body status-code headers uri stream must-close reason-phrase)
 139       (drakma:http-request (phoros-lib-uri *phoros-uri* "nearest-image-data")
 140                            :cookie-jar *phoros-cookies*
 141                            :method :post
 142                            :content-type "text/plain; charset=UTF-8"
 143                            :content (json:encode-json-plist-to-string (list :longitude longitude
 144                                                                         :latitude latitude
 145                                                                         :zoom 11
 146                                                                         :count 1
 147                                                                         :selected-restriction-ids #())))
 148     (declare (ignore stream must-close))
 149     (assert (= status-code 200) ()
 150             'phoros-server-error :body body :status-code status-code :headers headers :uri uri :reason-phrase reason-phrase)
 151     (json:decode-json-from-string body)))