; Scheme code for Wishforge database

(module db mzscheme

  (provide (all-defined))
  
  (require (planet "spgsql.ss" ("schematics" "spgsql.plt" 1)))
  (require (lib "list.ss"))
  (require (lib "class.ss"))
  (require (lib "match.ss"))
  (require (lib "md5.ss"))
  (require (file "util.ss"))
  (require (file "timestamp.ss"))
  
  ; operations
  
  (define insert-user
    (lambda (login password
		   first_name last_name
                   email phone
                   addr1 addr2
                   city state zip
                   country)
      (let* ([passhash (bytes->string/latin-1 (md5 (string->bytes/latin-1 password)))]
	     [vals-with-commas 
              (splice-commas 
               (map double-quote
                    (list login passhash
                          first_name last_name
                          email phone
                          addr1 addr2
                          city state
                          zip country)))])
	; NB: we specify the field names, even though they're optional
	; that makes code resilient in the face of ALTER TABLEs
        (send db exec 
              (sa "INSERT INTO users ("
		  "login,"
		  "password_hash,"
		  "first_name,"
		  "last_name,"
		  "email,"
		  "telephone,"
		  "address_1,"
		  "address_2,"
		  "city,"
		  "state,"
		  "country,"
		  "zipcode"
		  ") VALUES (" 
		  vals-with-commas ")")))))
  
  (define insert-bid
    (lambda (bidder 
	     login symbol
             number_pledges
	     pledge_amount)
      (let* ([timestamp (get-timestamp)]
	     [vals-with-commas 
	      (splice-commas 
	       (append
		(map double-quote
		     (list bidder 
			   login symbol
			   (get-timestamp)))
	       (list number_pledges pledge_amount)))])
        (send db exec 
              (sa "INSERT INTO bids ("
		  "bidder,"
		  "login,"
		  "symbol,"
		  "bidtime,"
		  "number_pledges,"
		  "pledge_amount"
		  ") VALUES (" 
		  vals-with-commas ")")))))

  (define insert-pledge
    (lambda (pledger
	     login symbol
             num_pledges
	     pledge_amount
             length_of_auction)
      (let* ([timestamp (get-timestamp)]
	     [vals-with-commas 
	      (splice-commas 
	       (map double-quote
		    (list pledger
			  login symbol
			  num_pledges
			  pledge_amount)))])
        (send db exec 
              (sa "INSERT INTO pledges ("
		  "pledger,"
		  "login,"
		  "symbol,"
		  "number_pledges,"
		  "pledge_amount,"
		  ") VALUES (" 
		  vals-with-commas ")")))))

  (define insert-wish
    (lambda (login symbol summary description
	     specification_1 specification_2 
	     specification_3 specification_4
	     specification_5 ; specification_6
;	     specification_7 specification_8 
;	     specification_9 specification_10
	     judge pledge_amount no_of_bonds)
      (let ([vals-with-commas 
	     (splice-commas 
	      (map double-quote
		   (list
		    login symbol summary description
		    specification_1 specification_2 
		    specification_3 specification_4
		    specification_5 ; specification_6
		; specification_7 specification_8 
		; specification_9 specification_10
			    judge)))])
	(send db exec
	      (sa "INSERT INTO wishes ("
		  "login,"
		  "symbol,"
		  "summary,"
		  "description,"
		  "specification_1,"
		  "specification_2,"
		  "specification_3,"
		  "specification_4,"
		  "specification_5,"
;		  "specification_6,"
;		  "specification_7,"
;		  "specification_8,"
;		  "specification_9,"
;		  "specification_10,"
		  "judge"
		  ") VALUES (" 
		  vals-with-commas ")")))))

  (define get-user-data
    (lambda (login)
      (send db query-tuple
            (sa "SELECT * FROM users WHERE login =" (double-quote login)))))

  (define mk-user-get
    (lambda (fld)
      (lambda (login)
	(let ([result (send db query-tuple
			    (sa "SELECT " fld 
				" FROM users WHERE login =" 
				(double-quote login)))])
	  (vector-ref result 0)))))
  
  (define get-user-passhash (mk-user-get "password_hash"))

  (define get-user-last (mk-user-get "last_name"))
  (define get-user-first (mk-user-get "first_name"))

  (define get-user-name 
    (lambda (login)
      (let ([first (get-user-first login)]
	    [last (get-user-last login)])
	(sa first " " last))))

  (define get-wishes
    (lambda (login) 
      (printf "login: ~a~n" login)
      (send db map 
	    (sa "SELECT "
		"symbol,"
	        "summary,"
		"expiration"
		" FROM wishes WHERE login =" 
		(double-quote login))
	    list)))

  (define get-wish-pledges ; TODO - do we need this one?
    (lambda (login symbol) 
      (car 
       (send db map 
	     (sa "SELECT "
		 "number_pledges,"
		 "pledge_amount"
		 " FROM pledges WHERE "
		 "login = " (double-quote login)
		 " AND "
		 "symbol = " (double-quote symbol))
	     list))))

  (define get-all-wishes
    (lambda (login) 
      (send db map 
	    (sa "SELECT "
		"login,"
		"symbol,"
		"summary"
		" FROM wishes")
	    list)))

  (define mk-get-pledges
    (lambda (pred)
      (lambda (login)
	(send db map 
	      (sa "SELECT "
		  "pledger,"
		  "login,"
		  "symbol,"
		  "summary,"
		  "number_pledges,"
		  "pledge_amount"
		  " FROM pledges NATURAL JOIN wishes WHERE " 
		  (pred (double-quote login)))
	    list))))

  (define get-pledges
    (mk-get-pledges 
     (lambda (login)
       (sa "login =" login))))

  (define get-others-pledges
    (mk-get-pledges 
     (lambda (login) 
       (sa "pledger !=" login
	   " AND "
	   "login !=" login))))

  ; TODO -- validate that current holder has 
  (define sell-pledge
    (lambda (login symbol
             pledger
	     sale_price
	     num_to_sell
	     auction_length)
      (let ([vals-with-commas 
	     (splice-commas 
	      (append
	       (map double-quote
		    (list login symbol
			  pledger
			  (get-timestamp)))
	       (list auction_length)))])
	; NB: we specify the field names, even though they're optional
	; that makes code resilient in the face of ALTER TABLEs
        (send db exec 
              (sa "INSERT INTO auctions ("
		  "login,"
		  "symbol,"
		  "pledger,"
		  "start_of_auction,"
		  "length_of_auction"
		  ") VALUES (" 
		  vals-with-commas ")")))))

  (define get-owned-pledges
    (lambda (login) 
      (send db map 
	    (sa "SELECT "
		"pledges.pledger,"
		"wishes.symbol,"
		"wishes.summary,"
		"wishes.login,"
		"pledges.number_pledges,"
		"pledges.pledge_amount,"
		"held_pledges.number_pledges,"
		"held_pledges.pledge_amount"
		" FROM held_pledges,pledges,wishes WHERE "
		; implicit INNER JOIN
		; don't use NATURAL JOIN; don't want to match on pledge amount, number_pledges
		"held_pledges.login=pledges.login AND "
		"pledges.login=wishes.login AND "
		"held_pledges.pledger=pledges.pledger AND "
		"held_pledges.symbol=pledges.symbol AND "
		"pledges.symbol=wishes.symbol AND "
		"holder = " (double-quote login) " AND held='true'")
	    list)))

  (define get-all-auctions
    (lambda ()		
      (send db map 
	    (sa "SELECT "
		"login,"
		"symbol,"
		"pledger,"
	        "number_pledges,"
		"start_of_auction,"
		"length_of_auction"
		" FROM auctions")
	    list)))

(define bids-for-auction
  (lambda (login symbol pledger)
    (send db map
      (sa "SELECT "
	  "login,"
	  "bidtime,"
	  "symbol,"
	  "number_pledges,"
	  "pledge_amount,"
	  "bidder,"
	  "pledger,"
	  "award_time,"
	  "seller"
	  " FROM bids WHERE "
	  "(awarded=false OR awarded is null)"
	  " AND "
	  "login=" (double-quote login)
	  " AND "
	  "symbol=" (double-quote symbol)
          " AND "
	  "pledger=" (double-quote pledger))
      list)))

(define make-bid-held
  (lambda (bid)
    (match bid 
      ((login bidtime symbol number_pledges price bidder pledger award-time seller)
	 ; try to update entry
	 ; on failure, insert new entry; TODO check for proper exn
	 (with-handlers
	  ([void (lambda _ 
		   (let ([vals-with-commas
			  (splice-commas
			   (append
			    (map double-quote
				 (list login symbol number_pledges price "true" award-time))))])
		     (send db map
		       (sa "INSERT INTO held_pledges ("
			   "login,"
			   "symbol,"
			   "number_pledges,"
			   "pledge_amount,"
			   "held,"
			   "win_time"
			   ") VALUES ("
			   vals-with-commas
			   ")"))))])
	  (sa "UPDATE held_pledges SET number_pledges=number_pledges+" (number->string number_pledges))
	  " WHERE "
	  "login=" (double-quote login)
	  " AND "
	  "symbol=" (double-quote symbol)
	  " AND "
	  "holder=" (double-quote bidder))))))

; assume exactly one entry for given holder, login, symbol
; reduce counts by amount awarded - may reduce to zero, or not
; TODO - check that holder has at least number awarded
(define delete-held-pledges 
  (lambda (bid)             
    (match bid 
      ((login bidtime symbol number_pledges price bidder pledger award-time seller)
       (send db map 
         (sa "UPDATE held_pledges SET number_pledges=number_pledges-" (number->string number_pledges))
             " WHERE "
	     "login=" (double-quote login)
	     " AND "
	     "symbol=" (double-quote symbol)
	     " AND "
	     "holder=" (double-quote seller))))))

(define delete-held-pledge-zeros 
  (lambda ()
    (send db exec
      (sa "DELETE FROM held_pledges WHERE "
	  "number_pledges <= 0"))))
	     
(define award-bids
  (lambda (bids)
    ; delete existing held_pledges entries
    (for-each delete-held-pledges bids)
    (delete-held-pledge-zeros)
    ; add entries to held_pledges
    (for-each make-bid-held bids)))

  (define db (connect "localhost" 5432 "crasch" "crasch" "eey2eiW5"))
  
  (define (close-db)
    (send db disconnect))
  
  )