(require (lib "unitsig.ss")
         (lib "pregexp.ss")
         (lib "servlet-sig.ss" "web-server")
         (lib "servlet-helpers.ss" "web-server"))

(require "database.ss")
 

;; The scheme code implementing the page layouts was adapted from Ryan
;; Culpepper's SPGSQL demo and various servlet examples provided in
;; the PLT distribution. The database module makes use of Culpepper's
;; SPGSQL code for interacting with PostgreSQL from Scheme.

(unit/sig ()
  (import servlet^)


  ;; make page : string string (string -> xexpr) -> (string -> xexpr)
  ;; Build the basic interface page and add specific content.

  (define (make-page title user body)
    (lambda (url)
      `(html (head (title ,title)
                   (script [(language "JavaScript") 
                            (src "/java/timestamp_picker.js")])
                   (link [(rel "stylesheet")
                          (href "/default.css")
                          (type "text/css")
                          (title "specified")]))
             (body
              (div [(style "background-color: blue; color: white")]
                   (table [(width "100%")]
                          (tr 
                           (td
                            (div [(style "color: white; text-align: center")]
                                 (div
                                  (span [(style "font-size: large")]
                                        "Memories Incorporated")
                                  (span " powered by ")
                                  (span [(style "font-size: large")]
                                        "Scheme and PostgreSQL")))))))
              (div [(style "border-color: blue; border-style: solid")]
                   (table [(width "100%")]
                          (tr [(style "text-align: center")]
                              (td ,(make-main-link 'upload "Upload File" url))
                              (td ,(make-main-link 'search "Search" url))
                              (td ,(make-main-link 'about "About" url))
                              (td ,(if user
                                       (make-main-link 'logout "Log Out" url)
                                       (make-main-link 'login "Log In" url))))))
              (div [(style "padding: 4ex 8ex 4ex 8ex")]
                   ,(body url))
              (div [(style "background-color: blue; color: white; font-weight: bold")]
                   ,(if user
                        `(span "Logged in as " (em ,user))
                        `(span "Not logged in")))))))


  ;; make-main-link : symbol string string -> xexpr
  ;; Create links to basic services.

  (define (make-main-link sym text url)
    (let [(target (format "~a?action=~a" url sym))]
      `(a [(href ,target)] ,text)))


  ;; login-body : -> (string -> xexpr)
  ;; Generates the login form.

  (define (login-body)
    (lambda (url)
      `(div (h2 "Log into your account:")
            (form [(action ,url) (method "post")]
                  (input [(type "hidden") (name "action") (value "checklogin")])
                  (table 
                   (tr (td "Username")
                       (td (input [(type "text") (name "username")])))
                   (tr (td "Password")
                       (td (input [(type "password") (name "password")])))
                   (tr (td (input [(type "submit") (name "submit") 
                                   (value "Log in")]))))))))


  ;; logout-body : -> (string -> xexpr)
  ;; Generates the body after a user logs out.

  (define (logout-body)
    (lambda (url)
      `(div (h2 "Logged out."))))


  ;; failed-login-body : -> (string -> xexpr)
  ;; Generates the body for a failed login attempt.

  (define (failed-login-body)
    (lambda (url)
      `(div (h2 "Login failed!"))))


  ;; search-body : -> (string -> xexpr)
  ;; Generates the body to commence a search.

  (define (search-body)
    (lambda (url)
      `(div (h2 "Search for documents in the database:")
         (form [(name "search") (action ,url) (method "get")]
            (input [(type "hidden") (name "action") (value "listing")])
            (div (p "Enter search keywords: " (br)
                    (input [(name "searchstring") (type "text") (size "48") (value "")]))
                 (p "Start of the search interval: " (br)
                    (input [(name "begin") (type "text") (size "32") (value "")])
                    (a [(href "javascript:show_calendar('document.search.begin',  
                                                              document.search.begin.value)")]
                       (img [(src "/images/cal.gif") (width "16") (height "16") (border "0") 
                             (alt "Click here to pick the start of search interval")])))
                 (p  "End of the search interval: " (br)
                     (input [(name "end") (type "text") (size "32") (value "")])
                     (a [(href "javascript:show_calendar('document.search.end',  
                                                               document.search.end.value)")]
                        (img [(src "/images/cal.gif") (width "16") (height "16") (border "0")
                              (alt "Click here to pick the end of search interval")])))
                 (p (input [(name "submitsearch") (type "submit") (value "Search")])))))))


  ;; about-body : -> (string -> xexpr)
  ;; Generates the body describing the DMS project.

  (define (about-body)
    (lambda (url)
      `(div (h2 "Information about this project:")
            (p "This experimental document management system "
               "is designed to provide a framework for testing "
               "new information retrieval techniques."))))


  ;; upload-body : -> (string -> xexpr)
  ;; Generate the body for adding a document to the database.

  (define (upload-body)
    (lambda (url)
      `(div (h2 "Add a document to the database:")
            (form [(action ,url) (enctype "multipart/form-data") (method "post")]
                  (input [(type "hidden") (name "action") (value "insert")])
                  "Select file: " 
                  (div (input [(name "file") (type "file")
                               (size "32") (maxlength "100000")])) 
                  (br) "File type:" 
                  (div ,(select-mime-type))
                  (br) "Description: "
                  (div (textarea [(name "description") (cols "64") 
                                  (rows "4") (wrap "soft") (value "")]))
                  (div (input [(type "submit") (value "Upload file")]))))))


  ;; select-mime-type : -> xexpr

  (define (select-mime-type)
    `(select [(size "1") (name "mime-type")]
             (option [(value "none")] "NONE")
             ;; varieties of text
             (option [(value "text/html")] "HTML")
             (option [(value "text/plain")] "TEXT")
             ;; "application" types
             (option [(value "application/vnd.ms-excel")] "EXCEL")
             (option [(value "application/x-tex")] "LATEX")
             (option [(value "application/pdf")] "PDF")
             (option [(value "application/postscript")] "POSTSCRIPT")
             (option [(value "application/vnd.ms-powerpoint")] "POWERPOINT")
             (option [(value "application/rtf")] "RTF")
             (option [(value "application/msword")] "WORD")
             ;; image formats
             (option [(value "image/gif")] "GIF")
             (option [(value "image/jpeg")] "JPG")))


  ;; failed-upload-body : -> (string -> xexpr)
  ;; Generates the body in the case of a failed login attempt.

  (define (failed-upload-body)
    (lambda (url)
      `(div (h2 "The system currently only handles HTML files."))))


  ;; failed-display-body : -> (string -> xexpr)
  ;; Generates the body in the case that no selection is made.

  (define (failed-display-body)
    (lambda (url)
      `(div (h2 "No selection!"))))


  ;; listing-body : environment -> (string -> xexpr)
  ;; Generates the search results body.

  (define (listing-body bindings)
    (lambda (url)
      (let* [(searchstring (extract-binding/single 'searchstring bindings))
             (keywords (pregexp-split "\\s+" searchstring))
             (begin (extract-binding/single 'begin bindings))
             (end (extract-binding/single 'end bindings))]
        (if (null? keywords)
            `(div (h2 "No keywords!"))
            `(form [(action ,url) (method "post")]
                   (input [(type "hidden") (name "action") (value "display")])
                   (table [(border "1") (cellpadding "5") (cellspacing "2")]
                          (tr [(style "text-align: left")]
                              (th "View:") 
                              (th "Date:") 
                              (th "Description:") 
                              (th (input [(type "submit")
                                          (name "score")
                                          (value "update")]))
                              (th "Score:"))
                          ,@(process-search-query 
                             keywords 
                             (rationalize-date begin "0001-1-1 00:00:00.00")
                             (rationalize-date end "9999-1-1 00:00:00.00")
                             listing-item)))))))


  ;; listing-item : number string string -> xexpr
  ;; Formats a document record and adds a download and scoring links.

  (define (listing-item id mark description score)
    `(tr [(style "text-align: left")]
         (td (input [(type "submit") 
                     (name "selection") 
                     (value ,(number->string id))]))
         (td ,mark) 
         (td ,description)
         (th (input [(type "checkbox") 
                     (name ,(string-append "OID-" (number->string id)))
                     (value ,(number->string id))]))
         (td ,score)))


  ;; Regular expression for dates that comply with ISO 8601 format (yyyy/mm/dd).

  (define iso-8601-date-pregexp 
    (pregexp 
     (string-append "([[:digit:]]{4}).([[:digit:]]{1,2}).([[:digit:]]{1,2})"
                    "[[:space:]]+([[:digit:]]+[:][[:digit:]]+[:][[:digit:]\\.]+)")))

  ;; Regular expression for a date using prevailing US conventions (dd/mm/yyyy).

  (define american-date-pregexp
    (pregexp 
     (string-append "([[:digit:]]{1,2}).([[:digit:]]{1,2}).([[:digit:]]{4})"
                    "[[:space:]]+([[:digit:]]+[:][[:digit:]]+[:][[:digit:]\\.]+)")))


  ;; Check supplied date, rationalize if possible and substitute alternative otherwise.

  (define (rationalize-date string alternative)
    (cond ((pregexp-match iso-8601-date-pregexp string) string)
          ((pregexp-match american-date-pregexp string) 
           (pregexp-replace american-date-pregexp string "\\3-\\2-\\1 \\4"))
          (else alternative)))


  ;; Find any object identifiers in the supplied environment.

  (define (extract-oids bindings)
    (do [(bindings bindings (cdr bindings)) (oids ())]
        [(null? bindings) oids]
      (if (pregexp-match "(?i:OID-)" 
                         (symbol->string (caar bindings)))
          (set! oids (cons (cdar bindings) oids)))))


  ;; Allow longer delays before allowing sessions to expire.

  (adjust-timeout! 300)


  ;; Initially user is #f, or unknown. Page transitions that change
  ;; the user will call reset with the new username and request.
  ;; All other transitions will use interact with the new request.

  (let [(last-search-bindings #f)]
   (let reset [(user #f) (request initial-request)] 
    (let interact [(request request)]
     (let* [(bindings (request-bindings request)) 
            (action (cond ((exists-binding? 'username bindings) 'checklogin)
                          ((not user) 'login)
                          ((exists-binding? 'action bindings)
                           (string->symbol (extract-binding/single 'action bindings)))
                          (else 'search)))]
       (case action
         [(about)
          (interact (send/suspend (make-page "About" user (about-body))))]

         [(login)
          (interact (send/suspend (make-page "Log in" user (login-body))))]
                                               
         [(checklogin)
          (let* [(username (extract-binding/single 'username bindings))
                 (password (extract-binding/single 'password bindings))]
            (if (login-valid? username password)
                (reset username (send/suspend (lambda (url) (redirect-to url))))
                (interact (send/suspend 
                           (make-page "Login failed" user (failed-login-body))))))]
         [(logout)
          (reset #f (send/suspend (make-page "Logged out" #f (logout-body))))]
         
         [(search)
          (interact (send/suspend (make-page "Search" user (search-body))))]
         
         [(listing)
          (set! last-search-bindings bindings)
          (interact (send/suspend (make-page "Search Results" user
                                             (listing-body bindings))))]
         [(display)
          (let [(selection (if (exists-binding? 'selection bindings)
                               (extract-binding/single 'selection bindings) #f))
                (oids (extract-oids bindings))]
            (cond ((not (null? oids)) 
                   (update-ranking oids)
                   (interact (send/suspend 
                              (make-page "Search Results" user
                                         (listing-body last-search-bindings)))))
                  (selection                
                   (send/back (redirect-to (export-document user selection))))
                  (else (interact (send/suspend 
                                   (make-page "Search" user (failed-display-body)))))))]
         [(upload)
          (interact (send/suspend (make-page "File Upload" user (upload-body))))]
                                                
         [(insert)
          (let [(file-contents (extract-binding/single 'file bindings))
                (description (extract-binding/single 'description bindings))
                (mime-type (extract-binding/single 'mime-type bindings))]
            (if (import-document user mime-type file-contents description)
                (interact (send/suspend (make-page "File Upload" user (upload-body))))
                (interact (send/suspend (make-page "Upload Failed" user
                                                   (failed-upload-body))))))]

))))))