server.scm 5.47 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 30 31 32
         "../eavdb/entity-get.ss"
         "../eavdb/entity-sync.ss"
         "../eavdb/entity-csv.ss"
         "../eavdb/eavdb.ss"
Dave Griffiths's avatar
Dave Griffiths committed
33
         "scripts/txt.ss"
Dave Griffiths's avatar
Dave Griffiths committed
34
         "scripts/server-sync.ss"
Dave Griffiths's avatar
Dave Griffiths committed
35 36 37
;         "scripts/input.ss"
	 )

Dave Griffiths's avatar
Dave Griffiths committed
38 39 40 41 42 43 44 45 46 47 48 49
(define (db-open db-name)
  (cond
    ((file-exists? (string->path db-name))
     (display "open existing db")(newline)
     (open (string->path db-name)))
    (else
     (display "making new db")(newline)
     (let ((db (open (string->path db-name))))
       ;; todo, dynamically create these tables
       (setup db "sync")
       (setup db "stream")
       db))))
dave griffiths's avatar
dave griffiths committed
50

Dave Griffiths's avatar
Dave Griffiths committed
51 52 53 54 55
; 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
56
(define db-name "client/htdocs/symbai.db")
Dave Griffiths's avatar
Dave Griffiths committed
57 58 59 60 61
(define db (db-open db-name))
(open-log "log.txt")

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

dave griffiths's avatar
dave griffiths committed
62
;(msg (csv db "sync" "individual"))
dave griffiths's avatar
dave griffiths committed
63 64


Dave Griffiths's avatar
Dave Griffiths committed
65 66 67 68 69
(define registered-requests
  (list

   (register
    (req 'ping '())
dave griffiths's avatar
dave griffiths committed
70
    (lambda (req)
Dave Griffiths's avatar
Dave Griffiths committed
71 72
      (pluto-response (scheme->txt '("hello")))))

dave griffiths's avatar
dave griffiths committed
73 74 75 76
   (register
    (req 'upload '())
    (lambda (req)
      (match (bindings-assq #"binary" (request-bindings/raw req))
Dave Griffiths's avatar
Dave Griffiths committed
77 78
	     ((struct binding:file (id filename headers content))
	      (with-output-to-file
dave griffiths's avatar
dave griffiths committed
79 80 81 82 83
		  (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
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
      (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
109

110
   ;; returns a table of all entities and their corresponding versions
Dave Griffiths's avatar
Dave Griffiths committed
111 112
   (register
    (req 'entity-versions '(table))
dave griffiths's avatar
dave griffiths committed
113
    (lambda (req table)
Dave Griffiths's avatar
Dave Griffiths committed
114 115 116 117
      (pluto-response
       (scheme->txt
        (entity-versions db table)))))

118 119
   ;; 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
120 121
   (register
    (req 'entity '(table unique-id))
dave griffiths's avatar
dave griffiths committed
122
    (lambda (req table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
123 124 125 126 127 128
      (pluto-response
       (scheme->txt
        (send-entity db table unique-id)))))

   (register
    (req 'entity-types '(table))
dave griffiths's avatar
dave griffiths committed
129
    (lambda (req table)
Dave Griffiths's avatar
Dave Griffiths committed
130 131 132 133 134 135
      (pluto-response
       (scheme->txt
        (get-all-entity-types db table)))))

   (register
    (req 'entity-csv '(table type))
dave griffiths's avatar
dave griffiths committed
136
    (lambda (req table type)
Dave Griffiths's avatar
Dave Griffiths committed
137 138 139 140 141 142 143 144 145
      (let ((r (csv db table type)))
	(msg "--------------------------------------- csv request for" type "[" r "]")
	(pluto-response
	 r))))

   ))

(define (start request)
  (let ((values (url-query (request-uri request))))
146
    (msg values)
Dave Griffiths's avatar
Dave Griffiths committed
147 148 149 150 151 152 153 154 155
    (if (not (null? values))   ; do we have some parameters?
        (let ((name (assq 'fn values)))
          (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
156 157
		     values))
	       request)
Dave Griffiths's avatar
Dave Griffiths committed
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
	      (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
179
 #:servlet-path "/symbai"
Dave Griffiths's avatar
Dave Griffiths committed
180 181
 #:server-root-path
 (build-path "client"))