server.scm 5.96 KB
Newer Older
dave griffiths's avatar
dave griffiths committed
1 2
#!/usr//bin/env racket
#lang racket
Dave Griffiths's avatar
Dave Griffiths committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths
;;
;; 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/>.

dave griffiths's avatar
dave griffiths committed
18
(require racket/system
Dave Griffiths's avatar
Dave Griffiths committed
19 20 21 22 23
         scheme/foreign
         scheme/cmdline
         web-server/servlet
         web-server/servlet-env
         web-server/http/response-structs
Dave Griffiths's avatar
Dave Griffiths committed
24 25
         racket/match
         "scripts/utils.ss"
Dave Griffiths's avatar
Dave Griffiths committed
26 27 28
         "scripts/request.ss"
         "scripts/logger.ss"
         "scripts/json.ss"
Dave Griffiths's avatar
Dave Griffiths committed
29
         "scripts/sql.ss"
Dave Griffiths's avatar
Dave Griffiths committed
30 31 32 33
         "../eavdb/entity-get.ss"
         "../eavdb/entity-sync.ss"
         "../eavdb/entity-csv.ss"
         "../eavdb/eavdb.ss"
Dave Griffiths's avatar
Dave Griffiths committed
34
         "scripts/txt.ss"
Dave Griffiths's avatar
Dave Griffiths committed
35
         "scripts/server-sync.ss"
Dave Griffiths's avatar
Dave Griffiths committed
36 37 38 39 40 41 42 43
;         "scripts/input.ss"
	 )

; a utility to change the process owner,
; assuming mzscheme is called by root.
;;(unsafe!)
;;(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))

dave griffiths's avatar
dave griffiths committed
44
(define db-name "client/htdocs/symbai.db")
Dave Griffiths's avatar
Dave Griffiths committed
45
(define db (db-open db-name setup))
Dave Griffiths's avatar
Dave Griffiths committed
46 47 48 49
(open-log "log.txt")

;(write-db db "sync" "/home/dave/code/mongoose-web/web/input.csv")

dave griffiths's avatar
dave griffiths committed
50
;(msg (csv db "sync" "individual"))
dave griffiths's avatar
dave griffiths committed
51

dave griffiths's avatar
dave griffiths committed
52 53 54 55 56 57 58 59 60 61 62 63 64 65
(define sema (make-semaphore 1))

(define (syncro fn)
  (fn))

;  (msg "s-start")
;  (if (semaphore-try-wait? sema)
;      (let ((r (fn)))
;	(msg "s-end")
;	(semaphore-post sema)
;	r)
 ;     (begin
;	(msg "couldn't get lock")
;	(pluto-response (scheme->txt '("fail"))))))
dave griffiths's avatar
dave griffiths committed
66

dave griffiths's avatar
dave griffiths committed
67 68 69 70 71 72 73 74 75
(define (syncro-new fn)
   (msg "s-start")
   (semaphore-wait sema)
   (let ((r (fn)))
     (msg "s-end")
     (semaphore-post sema)
     r))


Dave Griffiths's avatar
Dave Griffiths committed
76 77 78
(define registered-requests
  (list

dave griffiths's avatar
dave griffiths committed
79 80 81
   (register
    (req 'upload '())
    (lambda (req)
dave griffiths's avatar
dave griffiths committed
82 83 84 85 86 87 88 89 90 91
      (syncro
       (lambda ()
	 (msg "upload")
	 (match (bindings-assq #"binary" (request-bindings/raw req))
		((struct binding:file (id filename headers content))
		 (with-output-to-file
		     (string-append "files/" (bytes->string/utf-8 filename)) #:exists 'replace
		     (lambda ()
		       (write-bytes content)))))
	 (pluto-response (scheme->txt '("ok")))))))
dave griffiths's avatar
dave griffiths committed
92

Dave Griffiths's avatar
Dave Griffiths committed
93
   ;; http://localhost:8888/mongoose?fn=sync&table=sync&entity-type=mongoose&unique-id=dave1234&dirty=1&version=0&next:varchar=%22foo%22&blah:int=20
Dave Griffiths's avatar
Dave Griffiths committed
94

95 96
   ;; all dirty entities are sent to this function from the android in
   ;; general - we shouldn't care about version numbers from this
Dave Griffiths's avatar
Dave Griffiths committed
97
   ;; point locally they are dirty, and that should be it?
98 99 100 101 102 103 104 105
   ;;
   ;; * perhaps they are very old changes from a tablet that hasn't
   ;; been updated?
   ;;
   ;; * is this the place to flag problems?
   ;;
   ;; * sometimes this is not called for dirty entities - in the case
   ;; of a full db update thing
Dave Griffiths's avatar
Dave Griffiths committed
106 107
   (register
    (req 'sync '(table entity-type unique-id dirty version))
dave griffiths's avatar
dave griffiths committed
108
    (lambda (req table entity-type unique-id dirty version . data)
dave griffiths's avatar
dave griffiths committed
109 110 111 112 113 114 115 116 117 118 119
      (syncro
       (lambda ()
	 (msg "sync")
	 (pluto-response
	  (scheme->txt
	   (check-for-sync
	    db
	    table
	    entity-type
	    unique-id
	    (string->number dirty)
120
	    (string->number version) (dbg data))))))))
Dave Griffiths's avatar
Dave Griffiths committed
121

122
   ;; returns a table of all entities and their corresponding versions
Dave Griffiths's avatar
Dave Griffiths committed
123 124
   (register
    (req 'entity-versions '(table))
dave griffiths's avatar
dave griffiths committed
125
    (lambda (req table)
dave griffiths's avatar
dave griffiths committed
126 127 128 129 130 131
      (syncro
       (lambda ()
	 (msg "entity-versions")
	 (pluto-response
	  (scheme->txt
	   (entity-versions db table)))))))
Dave Griffiths's avatar
Dave Griffiths committed
132

133 134
   ;; returns the entity - the android requests these based on the version numbers
   ;; (request all ones that are newer than it's stored version)
Dave Griffiths's avatar
Dave Griffiths committed
135 136
   (register
    (req 'entity '(table unique-id))
dave griffiths's avatar
dave griffiths committed
137
    (lambda (req table unique-id)
dave griffiths's avatar
dave griffiths committed
138 139 140 141 142 143
      (syncro
       (lambda ()
	 (msg "entity")
	 (pluto-response
	  (scheme->txt
	   (send-entity db table unique-id)))))))
Dave Griffiths's avatar
Dave Griffiths committed
144 145 146

   (register
    (req 'entity-types '(table))
dave griffiths's avatar
dave griffiths committed
147
    (lambda (req table)
dave griffiths's avatar
dave griffiths committed
148 149 150 151 152 153
      (syncro
       (lambda ()
	 (msg "entity-types")
	 (pluto-response
	  (scheme->txt
	   (get-all-entity-types db table)))))))
Dave Griffiths's avatar
Dave Griffiths committed
154 155 156

   (register
    (req 'entity-csv '(table type))
dave griffiths's avatar
dave griffiths committed
157
    (lambda (req table type)
dave griffiths's avatar
dave griffiths committed
158 159 160 161
      (syncro
       (lambda ()
	 (msg "entity-csv")
	 (let ((r (csv db table type)))
dave griffiths's avatar
dave griffiths committed
162
	   ;;(msg "--------------------------------------- csv request for" type "[" r "]")
dave griffiths's avatar
dave griffiths committed
163 164
	   (pluto-response
	    r))))))
Dave Griffiths's avatar
Dave Griffiths committed
165

Dave Griffiths's avatar
Dave Griffiths committed
166 167
   (register
    (req 'file-list '())
168
    (lambda (req)
Dave Griffiths's avatar
Dave Griffiths committed
169 170 171 172
      (syncro
       (lambda ()
         (msg "file-list")
         (pluto-response
dave griffiths's avatar
dave griffiths committed
173 174
          (scheme->txt
           (map path->string (directory-list "files/"))))))))
Dave Griffiths's avatar
Dave Griffiths committed
175 176


Dave Griffiths's avatar
Dave Griffiths committed
177 178 179 180 181 182
   ))

(define (start request)
  (let ((values (url-query (request-uri request))))
    (if (not (null? values))   ; do we have some parameters?
        (let ((name (assq 'fn values)))
dave griffiths's avatar
dave griffiths committed
183
	  (msg "request incoming:" name)
dave griffiths's avatar
dave griffiths committed
184
	  (msg "arguments:" values)
Dave Griffiths's avatar
Dave Griffiths committed
185 186 187 188 189 190 191
          (if name           ; is this a well formed request?
	      (request-dispatch
	       registered-requests
	       (req (string->symbol (cdr name))
		    (filter
		     (lambda (v)
		       (not (eq? (car v) 'fn)))
dave griffiths's avatar
dave griffiths committed
192 193
		     values))
	       request)
Dave Griffiths's avatar
Dave Griffiths committed
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
	      (pluto-response "could't find a function name")))
        (pluto-response "malformed thingy"))))

(printf "server is running...~n")

; Here we become the user 'nobody'.
; This is a security rule that *only works* if nobody owns no other processes
; than mzscheme. Otherwise better create another dedicated unprivileged user.
; Note: 'nobody' must own the state directory and its files.

;(setuid 65534)

;;

(serve/servlet
 start
 ;; port number is read from command line as argument
 ;; ie: ./server.scm 8080
 #:listen-ip "192.168.2.1"
 #:port (string->number (command-line #:args (port) port))
 #:command-line? #t
Dave Griffiths's avatar
Dave Griffiths committed
215
 #:servlet-path "/symbai"
Dave Griffiths's avatar
Dave Griffiths committed
216 217
 #:server-root-path
 (build-path "client"))