server.scm 4.31 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
	 racket/match
Dave Griffiths's avatar
Dave Griffiths committed
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
         "scripts/request.ss"
         "scripts/logger.ss"
         "scripts/json.ss"
         "scripts/sync.ss"
         "scripts/utils.ss"
         "scripts/eavdb.ss"
         "scripts/txt.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)))

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

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

(define registered-requests
  (list

   (register
    (req 'ping '())
dave griffiths's avatar
dave griffiths committed
51
    (lambda (req)
Dave Griffiths's avatar
Dave Griffiths committed
52 53
      (pluto-response (scheme->txt '("hello")))))

dave griffiths's avatar
dave griffiths committed
54 55 56 57 58 59 60 61 62 63 64
   (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")))))

Dave Griffiths's avatar
Dave Griffiths committed
65 66 67 68
   ;; 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

   (register
    (req 'sync '(table entity-type unique-id dirty version))
dave griffiths's avatar
dave griffiths committed
69
    (lambda (req table entity-type unique-id dirty version . data)
Dave Griffiths's avatar
Dave Griffiths committed
70 71 72 73 74 75 76 77 78 79 80 81
      (pluto-response
       (scheme->txt
        (check-for-sync
         db
         table
         entity-type
         unique-id
         (string->number dirty)
         (string->number version) data)))))

   (register
    (req 'entity-versions '(table))
dave griffiths's avatar
dave griffiths committed
82
    (lambda (req table)
Dave Griffiths's avatar
Dave Griffiths committed
83 84 85 86 87 88
      (pluto-response
       (scheme->txt
        (entity-versions db table)))))

   (register
    (req 'entity '(table unique-id))
dave griffiths's avatar
dave griffiths committed
89
    (lambda (req table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
90 91 92 93 94 95
      (pluto-response
       (scheme->txt
        (send-entity db table unique-id)))))

   (register
    (req 'entity-types '(table))
dave griffiths's avatar
dave griffiths committed
96
    (lambda (req table)
Dave Griffiths's avatar
Dave Griffiths committed
97 98 99 100 101 102
      (pluto-response
       (scheme->txt
        (get-all-entity-types db table)))))

   (register
    (req 'entity-csv '(table type))
dave griffiths's avatar
dave griffiths committed
103
    (lambda (req table type)
Dave Griffiths's avatar
Dave Griffiths committed
104 105 106 107 108 109 110 111 112 113 114
      (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))))
    (if (not (null? values))   ; do we have some parameters?
        (let ((name (assq 'fn values)))
dave griffiths's avatar
dave griffiths committed
115
	  (msg values)
Dave Griffiths's avatar
Dave Griffiths committed
116 117 118 119 120 121 122
          (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
123 124
		     values))
	       request)
Dave Griffiths's avatar
Dave Griffiths committed
125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
	      (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
146
 #:servlet-path "/symbai"
Dave Griffiths's avatar
Dave Griffiths committed
147 148
 #:server-root-path
 (build-path "client"))