From 172562eabf10dd0d0fb73f0ba0b80a62399a4d05 Mon Sep 17 00:00:00 2001
From: David Florness <david@florness.com>
Date: Wed, 4 Mar 2020 20:43:06 -0700
Subject: [PATCH] Very basic authentication

---
 bulletin.rkt | 32 +++++++++++++++++++++++++++-----
 client.rkt   | 21 ++++++++++++++-------
 info.rkt     |  2 +-
 3 files changed, 42 insertions(+), 13 deletions(-)

diff --git a/bulletin.rkt b/bulletin.rkt
index d5b7d09..9b24464 100644
--- a/bulletin.rkt
+++ b/bulletin.rkt
@@ -5,6 +5,7 @@
 (require web-server/servlet
          web-server/servlet-env
          json)
+(require simple-http)
 
 (module+ main
   (define _status 'registering)
@@ -16,13 +17,34 @@
   (define (candidates request)
     (response/jsexpr '("Emacs" "Vim" "VSCode")))
 
+  (define (auth username password)
+    (equal? (hash-ref
+             (json-response-body
+              (post (update-ssl (update-host json-requester
+                                             "AUTH-HOST-HERE")
+                                #t)
+                    "/auth/route/here"
+                    #:data
+                    (jsexpr->string (hasheq 'username username
+                                            'password password))))
+             'result)
+            "success"))
+
   (define (register request)
     (if (eq? _status 'registering)
-        (let ([params (bytes->jsexpr (request-post-data/raw request))])
-          (displayln params)
-          (set-add! _peers (hasheq 'name  (hash-ref params 'name)
-                                   'input (hash-ref params 'input)))
-          (response/jsexpr empty))
+        (let* ([params (bytes->jsexpr (request-post-data/raw request))]
+               [username (hash-ref params 'username)]
+               [password (hash-ref params 'password)]
+               [input (hash-ref params 'input)])
+          (if (auth username password)
+              (begin
+                (displayln (format "~a is voting! (~a)" username input))
+                (set-add! _peers (hasheq 'input input))
+                (response/jsexpr empty))
+              (response/jsexpr
+               empty
+               #:code 400
+               #:message #"Bad Login")))
         (response/jsexpr
          empty
          #:code 403
diff --git a/client.rkt b/client.rkt
index 6e01fc2..2d19a8a 100644
--- a/client.rkt
+++ b/client.rkt
@@ -6,6 +6,8 @@
 (require racket/port)
 
 (require (only-in typed/openssl/sha1 bytes->hex-string hex-string->bytes))
+(require/typed get-pass
+  [get-pass (->* () (String #:in Input-Port #:out Output-Port) String)])
 (require net/http-client)
 (require net/uri-codec)
 (require typed/json)
@@ -59,19 +61,24 @@
       f)))
 
 (module+ main
-  (define username (readline "Your name: "))
-
   (define point (gen))
 
   (define bulletin
     (update-port (update-host json-requester "localhost") 1984))
 
-  (displayln "registering...")
   (void
-   (post bulletin "/register"
-         #:data
-         (jsexpr->string (hasheq 'input (integer->hex-string point)
-                                 'name username))))
+   (let ([username (readline "Username: ")]
+         [password (get-pass "Password: ")])
+     (with-handlers ([exn:fail:network:http:error?
+                      (λ (exn)
+                        (newline)
+                        (displayln "Login refused. Wrong credentials, perhaps?")
+                        (exit))])
+       (post bulletin "/register"
+             #:data
+             (jsexpr->string (hasheq 'input (integer->hex-string point)
+                                     'username username
+                                     'password password))))))
 
   (displayln "retrieving candidates...")
   (define candidates (cast (json-response-body
diff --git a/info.rkt b/info.rkt
index ad62add..7c46fbd 100644
--- a/info.rkt
+++ b/info.rkt
@@ -1,6 +1,6 @@
 #lang info
 (define collection "tallyard")
-(define deps '("base" "crypto" "sha" "simple-http" "sugar"))
+(define deps '("base" "crypto" "sha" "simple-http" "sugar" "get-pass"))
 (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib"))
 (define scribblings '(("scribblings/tallyard.scrbl" ())))
 (define pkg-desc "Description Here")
-- 
2.38.4