jbranso
/
autoassign


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

(use-modules
 (ice-9 textual-ports)
 (ice-9 regex)
 (html-elements)
 ;;(dbi dbi)
 (decode)
 (web server)
 (web request)
 (web response)
 (web uri)
 (oop goops)
 (sxml simple)
 ;; (srfi srfi-19)
 )

(define navbar
  '(nav (@ (class "navbar navbar-expand-lg navbar-light bg-light"))
        (a (@ (class "navbar-brand")) "Auto Assign")
        (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 "about"))
                        "About"))
                 (li (@ (class "nav-item"))
                     (a (@ (class "nav-link")
                           (href "login"))
                        "Log In"))
                 (li (@ (class "nav-item"))
                     (a (@ (class "nav-link")
                           (href "sign-up"))
                        "Sign Up"))
                 ))))

(define* (templatize title body
                     #:key
                     (js-files #f))
  `(html (head (title ,title)
               (head
                (link (@ (type "text/css") (href "css/style.min.css") (rel "stylesheet")) "")
                ,(if js-files
                     `(script (@ (async) (src ,(string-append "js/" js-files))) " ")
                     `(link (@ (type "text/css") (href "#")) ""))
                )
               (body ,navbar ,@body))
         (footer (p "@c copyright 2020."))))

(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 '())
                  (js-files #f)
                  (sxml (and body (if js-files
                                      (templatize title body #:js-files js-files)
                                      (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 (main-page)
  (respond
   `((div (@ (class "container"))
          (div (@ (class "row"))
               (div (@ (class "col-md-12"))
                    (h1 "Assign copyright to GNU today!")
                    (p "AutoAssign lets you digitally assign copyright
to the GNU project!  Let's keep free software libre!")
                    (p "Assigning copyright is as easy as creating an
account, and digitally signing your signature!")))))))

(define (about)
  (respond
   `((div (@ (class "container"))
          (div (@ (class "row"))
               (div (@ (class "col-md-12"))
                    (h3 "What is GNU AutoAssign?")
                    (p "GNU AutoAssign lets you digitally assign
copyright to the Free Software Foundation (FSF).  Developers have an easy
way of assigning copyright, and maintainers of GNU software can easily
verify who has copyright on file.")

                    (h3 "What is the GNU Project?")
                    (p "The " (a (@ (href "#")) "GNU Project") " was
started by Richard Stallman in the early 80s to create an ethical
operating system, that preserves your software freedom.  The goal of
the GNU project has largely been realized, and further work is
ongoing. Many such distributions "
                       (a (@ (href "#")) "exist today.")
                       " You should try one!")

                    (h3 "What is the Free Software Foundation?")
                    (p "The " (a (@ (href "#")) "Free Software
Foundation") " (FSF) is the legal entity behind the GNU project.  They are
the non-profit that is responsible for running various freedom
software campaigns and occasion legal enforcement of the GNU General
Public License, which is an ethical software license.")

                    (h3 "Why should I assign copyright to the FSF?")
                    (p "Because the GNU General Public License is not
magic fairy dust.  In order to preserve software freedom, you
occasionally need to legally enforce it.  This can only be done by
those who hold the copyright to the source code.  The best way to
enforce the GNU GPL, is having one entity that enforces copyright.
The best non-profit to do that has always been and will always be the
Free Software Foundation, which is the legal entity behind the GNU
project.")
                    (h3 "But I prefer non-copyleft licenses. Like the MIT license.")
                    (p "You are always free to use non-copyleft
licenses, but non-copyleft licenses always produce some proprietary
software.  Take a look at EXAMPLE, EXAMPLE, and EXAMPLE.  Since these
programs are \"open source\" and not free software, but there exist
proprietary versions.  Only copyleft software liberates user
freedom.")

                    (h3 "But you can't make money with the GPL!")
                    (p "Take a look at NextCloud, RedHat, and EXAMPLE.
These businesses all use GPL licensed software.  They are successful
businesses.")))))
   ))

;; currently using a cope pen for the signature
;; https://codepen.io/dus7/pen/qGQbVP
(define (sign-up)
  (respond
   `((div (@ (class "container"))
          (div (@ (class "row"))
               (div (@ (class "col-md-12"))
                    (p "Assign now")
                    (form (@ (action "sign-up-process") (method "post"))
                          (ul
                           ,(form-item "First name")
                           ,(form-item "Middle Name")
                           ,(form-item "Last Name")
                           ,(form-item "email" #:input-type "email")
                           (fieldset
                            (legend "Assign to one GNU program.")
                            ,(form-item "Program to Assign" #:input-type "select" #:options '("Emacs" "Gimp" "Sed")))
                           (fieldset
                            (legend "I love GNU!  Let me assign all my code to all GNU programs!")
                            ,(form-item "Assign copyright to all GNU programs" #:input-type "checkbox"))

                           (fieldset
                            (legend "Your current employer")
                            ,(form-item "Are you currently employed?" #:input-type "checkbox")
                            ,(form-item "Do you work for the software industry?"
                                        #:input-type "checkbox")
                            ,(form-item "Might your employer claim credit
for the software or documentation you produce?"
                                        #:input-type "checkbox")
                            (p "The next few questions need to be
answered by your current employeer.  You will need to talk to someone
from licensing from your company, or your companies lawyers.")
                            ;;                             ,(form-item "Do you consent to waive all copyright claims to the
                            ;; developer?"  #:input-type ("radio"))
                            )

                           (li (@ (for "sig-canvas"))
                               "Signature"
                               (canvas (@ (id "sig-canvas") (width "850") (height "260")) (span)))
                           (li (button (@ (type "sumbit") (id "sig-submitBtn")) "Submit"))
                           (li (button (@ (type "sumbit") (id "sig-clearBtn")) "Clear Signature"))))))))
   #:js-files "signature.js"))

(define (login)
  (respond
   `((div (@ (class "container"))
          (div (@ (class "row"))
               (div (@ (class "col-md-12"))
                    (section
                     (h3 "Login"
                         (form (@ (action "login-process") (method "post"))
                               (ul
                                ,(form-item "email" #:input-type "email" #:placeholder "rodgerpirate@dismail.de")
                                ,(form-item "password" #:input-type "password" #:placeholder "aVerySecretPassword?")
                                ,(my-input "honeypot" #:input-type "hidden")
                                ,(my-input "timestamp" #:input-type "hidden"
                                           #:value (string-append
                                                    (number->string (car (gettimeofday)))
                                                    " "
                                                    (number->string (cdr (gettimeofday)))))
                                (li (button (@ (type "submit")) "Submit"))))))
                    ))))))


(define (login-process bv)
  (respond
   `((div (@ (class "container"))
          (div (@ (class "row"))
               (div (@ (class "col-md-12"))
                    ,(let* ([alist (decode bv)]
                            [form-timestamp-pair
                             (string-split (car (assoc-ref alist "timestamp")) #\space)]
                            [form-timestamp-seconds (car form-timestamp-pair)]
                            [form-timestamp-microseconds (car (cdr form-timestamp-pair))]
                            [timestamp (gettimeofday)]
                            [timestamp-seconds (car timestamp)]
                            [timestamp-microseconds (cdr timestamp)]
                            [form-completion-time-seconds
                             (- (current-time) (string->number form-timestamp-seconds))]
                            [form-completion-time-microseconds
                             (abs (- timestamp-microseconds
                                     (string->number form-timestamp-microseconds)))]
                            [honeypot (car (assoc-ref alist "honeypot"))]
                            )
                       ;; if this form was completed in under 200000 microseconds, then this may be a computer trying to log in
                       ;; don't let them log in.  OR if the honeypot had any value in it...
                       (if (or (and (= 0 form-completion-time-seconds)
                                    (> 200000 form-completion-time-microseconds))
                               (not (string= honeypot "")))
                           '(p "We're having issues...please try again later.")
                           `(p ,(string-append
                                 "It took you "
                                 (number->string form-completion-time-seconds)
                                 " seconds and "
                                 (number->string form-completion-time-microseconds)
                                 " microseconds to complete the form.\n")))
                       )))))))

(define (output-file file-name)
  (call-with-input-file file-name
    (lambda (port)
      (string-append
       ""
       (let loop ([string (get-line port)])
         (if (eof-object? string)
             ""
             (string-append
              string "\n" (loop (get-line port)))))))))

(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 '("about"))
           (about)]
          [(equal? current-page '("login"))
           (login)]
          [(equal? current-page '("login-process"))
           (login-process body)]
          [(equal? current-page '("sign-up"))
           (sign-up)]
          [(equal? current-page '("css" "style.min.css"))
           (values `((content-type . (text/css)))
                   (output-file "css/style.min.css"))]
          [(equal? current-page '("js" "signature.js"))
           (values `((content-type . (text/javascript)))
                   (output-file "js/signature.js"))]
          [(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))))))
                      (h2 ,current-page)))])))


(run-server run-page 'http '(#:port 8081))