server.scm 5.78 KB
Newer Older
Dave Griffiths's avatar
Dave Griffiths committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#!/usr//bin/env mzscheme
#lang scheme/base
;; 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/>.

(require scheme/system
         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
(define registered-requests
  (list

dave griffiths's avatar
dave griffiths committed
70
71
72
   (register
    (req 'upload '())
    (lambda (req)
dave griffiths's avatar
dave griffiths committed
73
74
75
76
77
78
79
80
81
82
      (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
83

Dave Griffiths's avatar
Dave Griffiths committed
84
   ;; 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
85

86
87
   ;; 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
88
   ;; point locally they are dirty, and that should be it?
89
90
91
92
93
94
95
96
   ;;
   ;; * 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
97
98
   (register
    (req 'sync '(table entity-type unique-id dirty version))
dave griffiths's avatar
dave griffiths committed
99
    (lambda (req table entity-type unique-id dirty version . data)
dave griffiths's avatar
dave griffiths committed
100
101
102
103
104
105
106
107
108
109
110
111
      (syncro
       (lambda ()
	 (msg "sync")
	 (pluto-response
	  (scheme->txt
	   (check-for-sync
	    db
	    table
	    entity-type
	    unique-id
	    (string->number dirty)
	    (string->number version) data)))))))
Dave Griffiths's avatar
Dave Griffiths committed
112

113
   ;; returns a table of all entities and their corresponding versions
Dave Griffiths's avatar
Dave Griffiths committed
114
115
   (register
    (req 'entity-versions '(table))
dave griffiths's avatar
dave griffiths committed
116
    (lambda (req table)
dave griffiths's avatar
dave griffiths committed
117
118
119
120
121
122
      (syncro
       (lambda ()
	 (msg "entity-versions")
	 (pluto-response
	  (scheme->txt
	   (entity-versions db table)))))))
Dave Griffiths's avatar
Dave Griffiths committed
123

124
125
   ;; 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
126
127
   (register
    (req 'entity '(table unique-id))
dave griffiths's avatar
dave griffiths committed
128
    (lambda (req table unique-id)
dave griffiths's avatar
dave griffiths committed
129
130
131
132
133
134
      (syncro
       (lambda ()
	 (msg "entity")
	 (pluto-response
	  (scheme->txt
	   (send-entity db table unique-id)))))))
Dave Griffiths's avatar
Dave Griffiths committed
135
136
137

   (register
    (req 'entity-types '(table))
dave griffiths's avatar
dave griffiths committed
138
    (lambda (req table)
dave griffiths's avatar
dave griffiths committed
139
140
141
142
143
144
      (syncro
       (lambda ()
	 (msg "entity-types")
	 (pluto-response
	  (scheme->txt
	   (get-all-entity-types db table)))))))
Dave Griffiths's avatar
Dave Griffiths committed
145
146
147

   (register
    (req 'entity-csv '(table type))
dave griffiths's avatar
dave griffiths committed
148
    (lambda (req table type)
dave griffiths's avatar
dave griffiths committed
149
150
151
152
153
154
155
      (syncro
       (lambda ()
	 (msg "entity-csv")
	 (let ((r (csv db table type)))
	   (msg "--------------------------------------- csv request for" type "[" r "]")
	   (pluto-response
	    r))))))
Dave Griffiths's avatar
Dave Griffiths committed
156

Dave Griffiths's avatar
Dave Griffiths committed
157
158
159
160
161
162
163
164
165
166
167
   (register
    (req 'file-list '())
    (lambda ()
      (syncro
       (lambda ()
         (msg "file-list")
         (pluto-response
          (scheme->txt
           (dbg (directory-list "./htdocs/files/"))))))))


Dave Griffiths's avatar
Dave Griffiths committed
168
169
170
171
172
173
   ))

(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
174
	  (msg "request incoming:" name)
Dave Griffiths's avatar
Dave Griffiths committed
175
176
177
178
179
180
181
          (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
182
183
		     values))
	       request)
Dave Griffiths's avatar
Dave Griffiths committed
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
	      (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
205
 #:servlet-path "/symbai"
Dave Griffiths's avatar
Dave Griffiths committed
206
207
 #:server-root-path
 (build-path "client"))