; pages.ss -- Web pages for WishForge

; Copyright 2008 Christopher Michael Rasch
;
; This file is part of Wishforge.

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

; Wishforge 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 Wishforge.  If not, see <http://www.gnu.org/licenses/>.

(require (lib "etc.ss"))
(require (lib "xml.ss" "xml"))
(require (file "html.ss"))
(require (file "form.ss"))
(require (file "util.ss"))

(define mk-tag
  (lambda (tag)
    (lambda (s) (list tag s))))

(define mk-ul (mk-tag 'UL))

(define search-tags
  (splice-commas
   '("WishForge" "Software completion bonds")))

(define home-page
  `("wishforge.html"
    ((TITLE "WishForge")
       (META ((http-equiv "Content-Type")
              (content "text/html; charset=iso-8859-1")))
       (META ((NAME "description")
              (CONTENT "WishForge: The Software Completion Bond Market")))
       (META ((NAME "keywords")
              (CONTENT ,search-tags)))
       (META ((NAME "GENERATOR")
              (CONTENT "PLT Scheme"))))
    ((DIV
      (P)
      (H2 "What do you wish for? WishForge can make it happen!")
      (P)
      (H2 "These are the steps you'll take:")
      (P)
      (UL
       ,@(map mk-ul '("Create a wish"
                      "Back a wish with pledges"
                      "Bid on pledges"
                      "Resell your pledges"
                      "A judge rules whether your wish has been fulfilled"
                      "Pay off your pledges")))
      (P)
      (P)
      (FORM ((NAME "login")
             (METHOD "POST")
             (ACTION "/cgi-bin/login.sh"))
	    (TABLE
	     ,(input-line "Login: " "login")
	     (TR (TD "Password: ") (TD ,(mk-passwd "password" 80)))
	     ,(submit-button)))
      (P)
      "New to Wishforge? " (A ((HREF "sign-in.html")) "Create an account")))))


(define countries
  '("United States"
    "--------------"
    "Canada"
    "France"
    "United Kingdom"))

(define mk-option
  (lambda (entry)
    `(OPTION ((VALUE ,entry)) ,entry)))

(define country-options
  (lambda ()
    (map mk-option countries)))

(define country-select
  (lambda ()
    `(SELECT ((NAME "country")) ,@(country-options))))

(define signin-page
  `("sign-in.html"
    ((TITLE "Create WishForge account")
       (META ((http-equiv "Content-Type")
              (content "text/html; charset=iso-8859-1")))
       (META ((NAME "description")
              (CONTENT "WishForge: The Software Completion Bond Market")))
       (META ((NAME "keywords")
              (CONTENT ,search-tags)))
       (META ((NAME "GENERATOR")
              (CONTENT "PLT Scheme"))))
    ((DIV
      (P)
      (FORM ((NAME "new_account")
             (METHOD "POST")
             (ACTION "/cgi-bin/new-account.sh"))
	    (H2 "Enter the details for your new WishForge account:") (BR)
	    (TABLE
	     ,(input-line "Login: " "login")
	     ,(passwd-line "Password: " "password")
	     ,(input-line "Last name: " "last_name")
	     ,(input-line "First name: " "first_name")
	     ,(input-line "Email address: " "email_address")
	     ,(input-line "Telephone: " "telephone")
	     ,(input-line "Address 1: " "address1")
	     ,(input-line "Address 2: " "address2")
	     ,(input-line "City: " "city")
	     ,(input-line "State/Province: " "state")
	     (TR (TD "Country: ") (TD ,(country-select)))
	     ,(input-line "Zip/Post code: " "postcode")
	     ,(submit-button)))))))

(define (make-page page)
  (let* ([filename (car page)]
         [head-items (cadr page)]
         [contents (caddr page)])
    (when (file-exists? filename)
      (delete-file filename))
    (let ([p (open-output-file filename)])
      (write-xml/content 
       (xexpr->xml 
	(apply-html-template head-items contents))
       p)
      (close-output-port p))))

  ; utility
  

(define all-pages
  (list home-page signin-page))

(for-each make-page all-pages)