programming/guile/web/web.scm

(add-to-load-path (dirname (current-filename)))

(use-modules (web server)
             (web request)
             (web response)
             (web uri)
             (decode)
             (oop goops)
             (sxml simple))

(define navbar
  '(nav (@ (class "navbar navbar-expand-lg navbar-light bg-light"))
        (a (@ (class "navbar-brand")) "My IFT")
        (button (@ (class "navbar-toggler")
                   (type "button")
                   (data-toggle "collapse")
                   (data-target "#navbarSupportedContent")
                   (aria-controls "navbarSupportedContent")
                   (aria-expanded "false")
                   (aria-label "Toggle navigation"))
                (span (@ (class "navbar-toggler-icon")))
                )
        (div (@ (class "collapse navbar-collapse")
                (id "navbarSupportedcontent"))
             (ul (@ (class ("navbar-nav mr-auto")))
                 (li (@ (class "nav-item active"))
                     (a (@ (class "nav-link")
                           (href "#"))
                        "click me"))
                 (li (@ (class "nav-item"))
                     (a (@ (class "nav-link")
                           (href "#"))
                        "click me"))))))


(define (templatize title body)
  `(html (head (title ,title)
               (head
                (link
                 (@ (rel "stylesheet")
                    ;;(href "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css")
                    (href "localhost:8081/css/bootstrap.min.css"))
                 ))
               (body ,navbar ,@body))))

(define (insert-option-values values)
  (if (null? values) '()
      (let ([value (car values)])
        (cons `(options (@ (value ,value))
                        ,value)
              (insert-option-values (cdr values))))))

(define* (my-select id options
                    #:key
                    (required #t))
  `(select (@ (id ,id)
              (name ,id)
              ,(if (eq? required #t)
                   '(required)
                   '(not-required))
              (class "custom-select"))
           (option (@ (value "")
                      (selected ""))
                   "Choose...")
           ,(let loop ([options options])
              (if (null? options)
                  '()
                  (cons `(option (@ (value ,(car options)))
                                 ,(car options))
                        (loop (cdr options)))))))

;; (define-syntax m-basic-form-group
;;   (syntax-rules ()
;;     [(m-basic-form-group the-label id)
;;      '(div (@ (class "form-row"))
;;            (div (@ (class "col-md-8"))
;;                 (label the-label)
;;                 (input (@ (class "form-control")))
;;                 ))]
;;     [(m-basic-form-group the-label id ...)
;;      (begin
;;        '(div (@ (class "col-md-3"))
;;              (label the-label)
;;              (input (@ (class "form-control"))))
;;        (m-basic-form-group the-label id ...))]))

(define* (my-input input-type label id
                   #:optional values
                   #:key
                   (placeholder "")
                   (required #t))
  (let ([input-type input-type])
    (if (eq? input-type "select")
        (my-select id values #:required required)
        `(input (@ (id ,id)
                   (name ,id)
                   (type ,input-type)
                   (class "form-control")
                   ,(if (eq? required #t)
                        '(required)
                        '(not-required))
                   (placeholder ,placeholder))))))

(define* (basic-form-group label id
                           #:key
                           (input-type "text")
                           (placeholder "")
                           (required #t)
                           values
                           (width 8))
  `(div (@ (class ,(string-append "form-group col-md-"
                                  (number->string width))))
        (label ,label)
        ,(my-input input-type label id values #:required required)
        ;;(input (@ (class "form-control") (placeholder ,placeholder)))
        ))

(define* (horizontal-form-group label id
                                #:key
                                (form-class "row")
                                placeholder
                                (input-type "text")
                                (required #t)
                                values
                                )
  `(div (@ (class "form-group row"))
        (label (@ (class "col-md-2")
                  (for ,id))
               ,label)
        (div (@ (class "col-md-6"))
             ,(my-input input-type label id values #:required required)
             (div (@ (class "valid-feedback"))
                  "Looks good!"))))

(define* (respond #:optional body #:key
                  (status 200)
                  (title "My IFT")
                  (doctype "<!DOCTYPE html>\n")
                  (content-type-params '((charset . "utf-8")))
                  (content-type 'text/html)
                  (extra-headers '())
                  (sxml (and body (templatize title body))))
  (values (build-response
           #:code status
           #:headers `((content-type
                        . (,content-type ,@content-type-params))
                       ,@extra-headers))
          (lambda (port)
            (if sxml
                (begin
                  (if doctype (display doctype port))
                  (sxml->xml sxml port))))))

(define (request-path-components request)
  (split-and-decode-uri-path (uri-path (request-uri request))))

;; Paste this in your REPL
(define (not-found request)
  (values (build-response #:code 404)
          (string-append "Resource not found: "
                         (uri->string (request-uri request)))))

(define (test-form)
  (respond
   `((div (@ (class "container"))
          (div (@ (class "row")))
          (div (@ (class "col-md-12"))
               (form (@ (method "post")
                        (action "submit1")
                        (id "test-form"))
                     ,(horizontal-form-group "Your first name" "first-name"
                                             #:placeholder "Jason"
                                             #:required #t)
                     ,(horizontal-form-group "Your last name" "last-name"
                                             #:placeholder "Jason"
                                             #:required #f)
                     (div (@ (class "row"))
                          (div (@ (class "col-md-2"))
                               (button (@ (class "btn btn-primary"))
                                       "Submit")))
                     ))))))

(define (main-page)
  (respond
   `((div (@ (class "container"))
          (div (@ (class "row"))
               (div (@ (class "col-md-12"))
                    (h1 "Apply for a loan")
                    (form (@ (method "get")
                             (action "submit"))
                          ,(horizontal-form-group "Your first name" "first-name"
                                                  #:placeholder "James")
                          ,(horizontal-form-group "Your last name" "last-name"
                                                  #:placeholder "Jones")
                          ,(horizontal-form-group "Your number" "number"
                                                  #:placeholder "765 293 4930")
                          ,(horizontal-form-group "Your email" "email"
                                                  #:placeholder "youremail@gmail.com"
                                                  #:input-type "email")
                          ,(horizontal-form-group "Address" "address1"
                                                  #:placeholder "123 Main Street")
                          ,(horizontal-form-group "Address Line 2" "address1"
                                                  #:placeholder "123 Main Street")
                          (div (@ (class "form-row"))
                               ,(basic-form-group "City" "city" #:width 4)
                               ,(basic-form-group "State" "state" #:width 2)
                               ,(basic-form-group "Zip" "zip" #:width 2)
                               )
                          ,(horizontal-form-group "Are you a U.S. Citizen?" "state"
                                                  #:input-type "select"
                                                  #:values '("No" "Yes"))
                          ,(basic-form-group "Borrower's Fico Score? (Please list all borrowers scores)"
                                             "fico")

                          ,(basic-form-group "Company name the borrower is closing in? (must close in a corporate entity)"
                                             "company")

                          ,(basic-form-group "Who makes up the entity and what are their percentages of ownership?"
                                             "percentages")
                          (div (@ (class "form-row"))
                               ,(basic-form-group "Do you own any other investment properties?"
                                                  "own"
                                                  #:width 6)

                               ,(basic-form-group "If yes, how many?"
                                                  "own-number"
                                                  #:width 2
                                                  #:required #f))

                          ,(basic-form-group
                            "Does the borrower have any Tax liens, judgments, past bankruptcies, past chapter filings, past foreclosures, recent or pending lawsuits against them?"
                            "past-problems"
                            #:input-type "select"
                            #:values '("No" "Yes"))
                          (div (@ (class "row"))
                               (div (@ (class "col-md-2"))
                                    (button (@ (class "btn btn-primary"))
                                            "Submit")))
                          )))))))

(define (verify-body body)
  (let ([post-data (decode body)]
        [data-integrity? #t])
    (map (lambda (element)
           (let ([name (car element)]
                 [value (car (cdr element))])
             (display "body is \n")
             (display post-data)
             (display "\nelement is \n")
             (display element)
             (display "\nname is \n")
             (display name)
             (display "\n value is \n")
             (display value)
             (display "\n cdr of element is \n")
             (display (cdr element))
             (display "\n length of element is\n")
             (display (length element))
             (display "\ntype of value is\n")
             (display (class-of (cdr element)))
             (when (> 1 (length element))
               (display "it is nil!")
               (set! data-integrity? #f)
               )))
         post-data)
    ))

(define (run-page request body)
  ;;(display (request-path-components request))
  (let ([current-page (request-path-components request)])
    (cond [(equal? current-page '())
           (main-page)]
          [(equal? current-page '("hacker"))
           (respond '((h1 "Hello Hacker!")))]
          [(equal? current-page '("submit"))
           (if (eq? (verify-request (request)) #t)
               (respond '((h1 "Submit page")))
               (main-page))]
          [(equal? current-page '("test-form"))
           (test-form)]
          [(equal? current-page '("submit1"))
           (verify-body body)
           (respond '((h1 "Testing")))]
          [(equal? current-page '("css" "bootstrap.min.css"))
           (values '((content-type . (text/plain)))
                   "css")]
          [(equal? current-page '("hello"))
           (values '((content-type . (text/plain)))
                   "Hello hacker!")]
          [else
           (respond `((h1 "Page not found.")
                      (h1 ,(let loop ([current-page current-page])
                             (if (null? current-page) ""
                                 (string-append (car current-page) "/"
                                                (loop (cdr current-page))))))))])))


(run-server run-page 'http '(#:port 8081) ; '(#:host="localhost")
            )