server.scm

#!/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
         racket/match
         "scripts/utils.ss"
         "scripts/request.ss"
         "scripts/logger.ss"
         "scripts/json.ss"
         "../eavdb/entity-get.ss"
         "../eavdb/entity-sync.ss"
         "../eavdb/entity-csv.ss"
         "../eavdb/eavdb.ss"
         "scripts/txt.ss"
         "scripts/server-sync.ss"
;         "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)))

(define db-name "client/htdocs/symbai.db")
(define db (db-open db-name setup))
(open-log "log.txt")

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

;(msg (csv db "sync" "individual"))


(define registered-requests
  (list

   (register
    (req 'ping '())
    (lambda (req)
      (pluto-response (scheme->txt '("hello")))))

   (register
    (req 'upload '())
    (lambda (req)
      (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")))))

   ;; 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

   ;; all dirty entities are sent to this function from the android in
   ;; general - we shouldn't care about version numbers from this
   ;; point locally they are dirty, and that should be it?
   ;;
   ;; * 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
   (register
    (req 'sync '(table entity-type unique-id dirty version))
    (lambda (req table entity-type unique-id dirty version . data)
      (pluto-response
       (scheme->txt
        (check-for-sync
         db
         table
         entity-type
         unique-id
         (string->number dirty)
         (string->number version) data)))))

   ;; returns a table of all entities and their corresponding versions
   (register
    (req 'entity-versions '(table))
    (lambda (req table)
      (pluto-response
       (scheme->txt
        (entity-versions db table)))))

   ;; returns the entity - the android requests these based on the version numbers
   ;; (request all ones that are newer than it's stored version)
   (register
    (req 'entity '(table unique-id))
    (lambda (req table unique-id)
      (pluto-response
       (scheme->txt
        (send-entity db table unique-id)))))

   (register
    (req 'entity-types '(table))
    (lambda (req table)
      (pluto-response
       (scheme->txt
        (get-all-entity-types db table)))))

   (register
    (req 'entity-csv '(table type))
    (lambda (req table type)
      (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))))
    (msg values)
    (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)))
		     values))
	       request)
	      (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
 #:servlet-path "/symbai"
 #:server-root-path
 (build-path "client"))