;;; -*- Mode: Lisp -*-
;;;
;; FakeMAc calculator & demo responders for server-side
;; Copyright (C) 2021 Gene Michael Stover.  All rights reserved.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program 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 General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https:;;www.gnu.org/licenses/>.
;;
;; Documentation is at https://cybertiggyr.com/fakemac.html
;;
;; Parts of this program are copyrighted by Jean Zee (CmpZ), but
;; Jean Zee is the Second Life in-world name of Gene Stover, so
;; it's really all copyrighted by Gene Stover.
;;

(in-package "GENE-STOVER.CYBERTIGGYR.FAKEMAC")

(defparameter *version* "2022-02-04T18:04:03-0800")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FakeMAC fundamentals
;;;

(defun strcat (&rest strings) (apply 'concatenate 'string strings))

(defun string-to-octets (s)
  (declare (type string s))
  (let ((octets (make-array (length s) :element-type '(unsigned-byte 8))))
    (dotimes (i (length s))
      (setf (elt octets i) (char-code (char s i))))
    octets))

(defun octets-to-hex (octets)
  (with-output-to-string (hex)
    (dotimes (i (length octets))
      (format hex "~(~2,'0X~)" (elt octets i)))))

(defun sha1-string (s)
  (declare (type string s))
  (octets-to-hex (ironclad:digest-sequence :sha1 (string-to-octets s))))

;;;
;;; Calculate the FakeMAC.  Return it.  It's a string.
;;;
;;; KEY is a string.
;;; MESSAGE is a string.
;;;
(defun fakemac (secret message)
  (declare (type string secret message))
  (let ((o-pad (sha1-string (strcat secret "ooo")))
	(i-pad (sha1-string (strcat secret "iii"))))
    (format t "o-pad is ~S~%" o-pad)
    (format t "i-pad is ~S~%" i-pad)
    (sha1-string (strcat o-pad
			 (sha1-string (strcat i-pad message))))))

;;;
;;; True if the FakeMAC we calculate for MESSAGE is equivalent
;;; to the RECEIVED FakeMAC.  Otherwise, false (or an error).
;;;
(defun fakemac-verify (secret message received)
  (let (calculated is-good)
    (setq calculated (fakemac secret message))
    (setq is-good (equal calculated received))
    (unless is-good
      (format *error-output* "In function FAMEKMAC-VERIFY in Lisp ~
        package GENE-STOVER.CYBERTIGGYR.FAKEMAC, the FakeMAC we ~
        calculated differs from the one we received.~%~
        The one we calculated is ~S~%~
        the one we received   is ~S~%" calculated received))
    is-good))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DEMO RESPONDERS
;;;

(defparameter *demo-selector* "/7c6333bf-95a7-4849-af94-3f24358f6981.json")
(defparameter *demo-secret*   "ef30f465-e7b7-4155-9ad6-a42bc4be1fdf")

(defvar *secrets-count* 0)
(defvar *endpoints-count* 0)

(defparameter *quotes*
  '(
    "A risk shared is a risk doubled."
    "By hook or by crook, we will."
    "Doctor Foster went to Gloucester "
    "Five fat sausages frying in a pan"
    "Georgie Porgie, Puddin' and Pie"
    "I can't get no satisfaction."
    "Little Bo Peep has lost her sheep"
    "Mary had a little lamb."
    "Simple Simon met a pieman going to the fair."
    "The early bird gets the worm."
    "The mouse ran up the clock."
    "The sky is falling!"
    "There was an old woman who lived in a shoe."
    "We sleep by the ever-bright hole in the door..."
    "Words cannot describe how speechless I felt."
    "X all the Y!"
    "get lamp"
    ))

;;;
;;; Reply to GET for the *DEMO-SELECTOR*.
;;;
(labels
    (
     ;;
     ;; Write the reply to a temporary file & return the pathname
     ;; of that file.
     (create-reply (b64 mac r)
       (declare (type request r))
       (let (json tmp-pn)
	 (setq json (make-pathname :type "json" :defaults (request-reply r)))
	 (setq tmp-pn (make-unused-pathname :defaults json))
	 (with-open-file (fp tmp-pn :direction :output :if-does-not-exist
			     :create :if-exists :error)
	   (format fp "[~S,~S]~%" b64 mac)
	   (pathname fp))))
     ;;
     ;; Send the reply and return true
     (do-reply2 (b64 mac r)
       (declare (type request r))
       (reply-ok1 r (list :send-and-delete (create-reply b64 mac r)))
       t)
     ;;
     ;; Get the FakeMAC for the base64 payload & start sending those
     ;; in a reply.
     (do-reply3 (b64 r)
       (declare (type request r))
       (do-reply2 b64 (fakemac *demo-secret* b64) r))
     ;;
     ;; Construct the inner reply message.  It's a string of JSON.
     (message ()
       (with-output-to-string (fp)
	 (format fp "{")
	 (format fp "\"quote\":~S," (random-elt *quotes*))
	 (format fp "\"random\":~A," (random 100.0))
	 (format fp "\"integer\":~D," (random 2000000000))
	 (format fp "\"when\":~D" (unix-epoch))
	 (format fp "}")))
     ;;
     ;; Construct the reply message (which is JSON) & return the
     ;; base-64 encoding of it
     (b64-message ()
       (with-output-to-string (fp)
	 (s-base64:encode-base64-bytes (map 'vector 'char-code (message))
				       fp nil)))
     ;;
     ;; Obtain the base64-encoded message & start sending that
     ;; reply.
     (on-for-us (r)
       (declare (type request r))
       (do-reply3 (b64-message) r))
     ;;
     ;; If it's a valid HTTP(S) request, it's for our selector, &
     ;; it's GET, call ON-FOR-US.  Otherwise, return NIL.
     (on-http (r)
       (declare (type request r))
       (cond ((null r) nil) ; wasn't HTTP(S) after all
	     ((not (equal *demo-selector* (path r))) nil) ; not for us
	     ((not (eq :get (verb r))) nil); not for us
	     (t (on-for-us r)))))
  
  (defun try-demo-get (r)
    (declare (type request r))
    (if (or (is-http? r) (is-https? r))
	(on-http (parse-request r))
      ;; else, it's not in HTTP(S), so nothing.
      nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; POST
;;;
;;; When a client POSTs to the selector, its message contains a
;;; guess guess at a secret or a guess at the url.
;;;
;;; As with the GET section, above, I'm prefacing each function
;;; name with an identifier that indicates it's for the POST
;;; responder, but because POST could be confused with an action,
;;; I'll call it XPO.
;;;

;;;
;;; Send a reply with HTTP status 400 Bad Request.
;;;
(defun xpo-reply-bad-request (r)
  (declare (type request r))
  (let ((head-pn (make-unused-pathname))
	(body-pn (make-unused-pathname))
	(cmd-pn  (make-unused-pathname)))
    (with-open-file (body body-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format body "Bad Request~%")
      (format body "The request failed verification.~%")
      (format body "Maybe it didn't decode to a legit message.~%")
      (format body "Maybe the authentication code failed.~%"))
    (with-open-file (head head-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format head "HTTP/1.1 400 Bad Request")               (endln head)
      (format head "Server: CyberTiggyr HTTP 2020 written in Atari BASIC")
                                                             (endln head)
      (multiple-value-bind (se mi ho da mo ye dow)
	  (decode-universal-time (get-universal-time) 0)
	(format head "Date: ~A, ~2,'0D ~A ~D ~2,'0D:~2,'0D:~2,'0D GMT"
		(elt '("Mon" "Tue" "Wed" "Thu" ; day of week
		       "Fri" "Sat" "Sun")
		     dow)
		da                      ; day of month
		(elt '("???" "Jan" "Feb" "Mar" ; month
		       "Apr" "May" "Jun" "Jul"
		       "Aug" "Sep" "Oct" "Nov" "Dec")
		     mo)
		ye                      ; year
		ho mi se))              ; time
                                                                (endln head)
      (format head "Content-type: text/plain")                  (endln head)
      (format head "Connection: close")                         (endln head)
      (format head "Content-length: ~D" (xfile-length body-pn)) (endln head)
                                                                (endln head))
    (with-open-file (cmd cmd-pn :direction :output :if-does-not-exist
			 :create :if-exists :error)
      (format cmd "d~A~%" head-pn)
      (format cmd "d~A~%" body-pn)
      (format cmd "c~%"))
    (rename-file cmd-pn (request-reply r)))
  t)
  
;;;
;;; Send a reply with HTTP status 400 Bad Request
;;; because we cannot decode the base64 encoded message.
;;;
(defun xpo-reply-base64-failure (r)
  (declare (type request r))
  (let ((head-pn (make-unused-pathname))
	(body-pn (make-unused-pathname))
	(cmd-pn  (make-unused-pathname)))
    (with-open-file (body body-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format body "Bad Request~%")
      (format body "Failed when decoding the base64 encoded main message.~%"))
    (with-open-file (head head-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format head "HTTP/1.1 400 Bad Request")               (endln head)
      (format head "Server: CyberTiggyr HTTP 2020 written in Atari BASIC")
                                                             (endln head)
      (multiple-value-bind (se mi ho da mo ye dow)
	  (decode-universal-time (get-universal-time) 0)
	(format head "Date: ~A, ~2,'0D ~A ~D ~2,'0D:~2,'0D:~2,'0D GMT"
		(elt '("Mon" "Tue" "Wed" "Thu" ; day of week
		       "Fri" "Sat" "Sun")
		     dow)
		da                      ; day of month
		(elt '("???" "Jan" "Feb" "Mar" ; month
		       "Apr" "May" "Jun" "Jul"
		       "Aug" "Sep" "Oct" "Nov" "Dec")
		     mo)
		ye                      ; year
		ho mi se))              ; time
                                                                (endln head)
      (format head "Content-type: text/plain")                  (endln head)
      (format head "Connection: close")                         (endln head)
      (format head "Content-length: ~D" (xfile-length body-pn)) (endln head)
                                                                (endln head))
    (with-open-file (cmd cmd-pn :direction :output :if-does-not-exist
			 :create :if-exists :error)
      (format cmd "d~A~%" head-pn)
      (format cmd "d~A~%" body-pn)
      (format cmd "c~%"))
    (rename-file cmd-pn (request-reply r)))
  t)
  
;;;
;;; Send a reply with HTTP status 400 Bad Request
;;; because the decoded main message is improperly
;;; formed.
;;;
(defun xpo-reply-improperly-formed (r)
  (declare (type request r))
  (let ((head-pn (make-unused-pathname))
	(body-pn (make-unused-pathname))
	(cmd-pn  (make-unused-pathname)))
    (with-open-file (body body-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format body "Bad Request~%")
      (format body "The main part of the message passed FakeMAC~%")
      (format body "verification & base64 decoding, but after that, it~%")
      (format body "is unacceptable for some reason.~%"))
    (with-open-file (head head-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format head "HTTP/1.1 400 Bad Request")               (endln head)
      (format head "Server: CyberTiggyr HTTP 2020 written in Atari BASIC")
                                                             (endln head)
      (multiple-value-bind (se mi ho da mo ye dow)
	  (decode-universal-time (get-universal-time) 0)
	(format head "Date: ~A, ~2,'0D ~A ~D ~2,'0D:~2,'0D:~2,'0D GMT"
		(elt '("Mon" "Tue" "Wed" "Thu" ; day of week
		       "Fri" "Sat" "Sun")
		     dow)
		da                      ; day of month
		(elt '("???" "Jan" "Feb" "Mar" ; month
		       "Apr" "May" "Jun" "Jul"
		       "Aug" "Sep" "Oct" "Nov" "Dec")
		     mo)
		ye                      ; year
		ho mi se))              ; time
                                                                (endln head)
      (format head "Content-type: text/plain")                  (endln head)
      (format head "Connection: close")                         (endln head)
      (format head "Content-length: ~D" (xfile-length body-pn)) (endln head)
                                                                (endln head))
    (with-open-file (cmd cmd-pn :direction :output :if-does-not-exist
			 :create :if-exists :error)
      (format cmd "d~A~%" head-pn)
      (format cmd "d~A~%" body-pn)
      (format cmd "c~%"))
    (rename-file cmd-pn (request-reply r)))
  t)
  
;;;
;;; Send a reply with HTTP status 413 Payload Too Large.
;;; Return true.
;;;
(defun xpo-reply-too-long (r)
  (declare (type request r))
  (let ((head-pn (make-unused-pathname))
	(body-pn (make-unused-pathname))
	(cmd-pn  (make-unused-pathname)))
    (with-open-file (body body-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format body "Payload Too Large~%")
      (format body "Maximum is 2,048 octets.~%"))
    (with-open-file (head head-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format head "HTTP/1.1 413 Payload Too Large")            (endln head)
      (format head "Server: CyberTiggyr HTTP 2020 written in Atari BASIC")
                                                                (endln head)
      (multiple-value-bind (se mi ho da mo ye dow)
	  (decode-universal-time (get-universal-time) 0)
	(format head "Date: ~A, ~2,'0D ~A ~D ~2,'0D:~2,'0D:~2,'0D GMT"
		(elt '("Mon" "Tue" "Wed" "Thu" ; day of week
		       "Fri" "Sat" "Sun")
		     dow)
		da                      ; day of month
		(elt '("???" "Jan" "Feb" "Mar" ; month
		       "Apr" "May" "Jun" "Jul"
		       "Aug" "Sep" "Oct" "Nov" "Dec")
		     mo)
		ye                      ; year
		ho mi se))              ; time
                                                                (endln head)
      (format head "Content-type: text/plain")                  (endln head)
      (format head "Connection: close")                         (endln head)
      (format head "Content-length: ~D" (xfile-length body-pn)) (endln head)
                                                                (endln head))
    (with-open-file (cmd cmd-pn :direction :output :if-does-not-exist
			 :create :if-exists :error)
      (format cmd "d~A~%" head-pn)
      (format cmd "d~A~%" body-pn)
      (format cmd "c~%"))
    (rename-file cmd-pn (request-reply r)))
  t)

;;;
;;; Send a reply that says the payload contained prohibited characters.
;;; Return true.
;;;
(defun xpo-reply-prohibited-chars (r)
  (declare (type request r))
  (let ((head-pn (make-unused-pathname))
	(body-pn (make-unused-pathname))
	(cmd-pn  (make-unused-pathname)))
    (with-open-file (body body-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format body "Bad Request~%")
      (format body "POST payload contains prohibited characters.~%"))
    (with-open-file (head head-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format head "HTTP/1.1 400 Bad Request")                  (endln head)
      (format head "Server: CyberTiggyr HTTP 2020 written in Atari BASIC")
                                                                (endln head)
      (multiple-value-bind (se mi ho da mo ye dow)
	  (decode-universal-time (get-universal-time) 0)
	(format head "Date: ~A, ~2,'0D ~A ~D ~2,'0D:~2,'0D:~2,'0D GMT"
		(elt '("Mon" "Tue" "Wed" "Thu" ; day of week
		       "Fri" "Sat" "Sun")
		     dow)
		da                      ; day of month
		(elt '("???" "Jan" "Feb" "Mar" ; month
		       "Apr" "May" "Jun" "Jul"
		       "Aug" "Sep" "Oct" "Nov" "Dec")
		     mo)
		ye                      ; year
		ho mi se))              ; time
                                                                (endln head)
      (format head "Content-type: text/plain")                  (endln head)
      (format head "Connection: close")                         (endln head)
      (format head "Content-length: ~D" (xfile-length body-pn)) (endln head)
                                                                (endln head))
    (with-open-file (cmd cmd-pn :direction :output :if-does-not-exist
			 :create :if-exists :error)
      (format cmd "d~A~%" head-pn)
      (format cmd "d~A~%" body-pn)
      (format cmd "c~%"))
    (rename-file cmd-pn (request-reply r)))
  t)

;;;
;;; True if & only if the octet is allowed in a payload.
;;;
;;; What octets are allowed?  Because the paylaod file should
;;; contain base-64 values, we allow that.  It should contain
;;; a hex string (the FakeMAC code), which is a subset of the
;;; character set for base-64.  It could contain ASCII space,
;;;
;;; What's more, if the octet cannot be converted into a character,
;;; the answer is no (false, NIL).  So we wrap the whole body in
;;; IGNORE-ERRORS.
;;;
(defun xpo-is-payload-octet? (octet)
  (declare (type (integer 0 255) octet))
  (ignore-errors
    (let ((c (code-char octet)))
      (or (alphanumericp c)
	  (digit-char-p c)
	  (member c '(#\+ #\= #\/ #\Space))
	  (member octet '(#x0D #x0A))))))

;;;
;;; True if & only if every octet in the payload is allowed.
;;; Assumes that you have already verified that the payload isn't
;;; too long, so it's safe for us now to check every octet.
;;;
;;; What octets are allowed?  Because the paylaod file should
;;; contain base-64 values, we allow that.  It should contain
;;; a hex string (the FakeMAC code), which is a subset of the
;;; character set for base-64.  It could contain ASCII space,
;;; carriage return, & line feed.
(defun xpo-every-payload-octet-allowed? (r)
  (declare (type request r))
  (every 'xpo-is-payload-octet? (load-file-as-octets (request-payload r))))

;;;
;;; Parse the decoded message into its 4 fields.
;;; We assume that the message can be parsed.  If there's a
;;; problem, you'll get an error that might send you into
;;; the debug loop.  Also, we don't validate that each field
;;; is in the correct range.
;;;
;;; Assuming that we can parse the message & the fields are
;;; of the proper types & in the proper ranges, then we return
;;; 4 values:
;;;
;;; 1. WHEN is a universal time close to the current time.  (Not
;;;    more than 10 seconds old & not more than 10 seconds in the
;;;    future.)
;;;
;;; 2. INONCE is an integer, 0 <= INONCE < 1 billion
;;;
;;; 3. JNONCE is an integer, 0 <= JNONCE < 1 billion
;;;
;;; 4. S is a string
;;;
(defun xpo-parse-decoded-message (decoded)
  (declare (type string decoded))
  (let (nonce epoch avatar username displayname guess)
    (with-input-from-string (fp decoded)
      (setq nonce (read fp))
      (setq epoch (read fp))
      (setq avatar (read fp))
      (setq username (read fp))
      (setq displayname (read fp))
      (setq guess (read fp)))
    (values nonce epoch avatar username displayname guess)))

;;;
;;; Does it look like we could parse the message?
;;; We'll cheat.  Instead of checking the message
;;; without parsing it, we'll parse it inside an
;;; IGNORE-ERRORS.  As well as checking that the
;;; fields can be extracted, we'll check that each is
;;; in its proper range.
;;;
(defun is-decoded-message-properly-formed? (decoded)
  (declare (type string decoded))
  (multiple-value-bind (nonce epoch avatar username displayname guess)
      (ignore-errors (xpo-parse-decoded-message decoded))
    (cond ((null nonce)
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the NONCE is NIL.~%")
	   nil)
	  ((null epoch)
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the EPOCH from the ~
             message is NIL.~%")
	   nil)
	  ((null avatar)
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the AVATAR from the ~
             message is NIL.~%")
	   nil)
	  ((null username)
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the USERNAME from the ~
             message is NIL.~%")
	   nil)
	  ((null displayname)
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the DISPLAYNAME ~
             field from the message is NIL.~%")
	   nil)
	  ((null guess)
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the GUESS ~
             field from the message is NIL.~%")
	   nil)
	  ((< epoch (- (unix-epoch) 10))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the EPOCH from the ~
             message is ~D seconds old.  We accept at most 10 seconds.~%"
		   (- (unix-epoch) epoch))
	   nil)
	  ((< (+ (unix-epoch) 10) epoch)
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the EPOCH from the ~
             message is ~D seconds in the future.  We allow at most ~
             10 seconds.~%"
		   (- epoch (unix-epoch)))
	   nil)
	  ((not (stringp avatar))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the AVATAR field ~
             is not a string.~%")
	   nil)
	  ((zerop (length avatar))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the AVATAR field ~
             is empty, doesn't appear to be a UUID.~%")
	   nil)
	  ((not (stringp username))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the USERNAME field ~
             is not a string.~%")
	   nil)
	  ((zerop (length username))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the USERNAME field ~
             is empty string.~%")
	   nil)
	  ((not (stringp displayname))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the DISPLAYNAME field ~
             is not a string.~%")
	   nil)
	  ((zerop (length displayname))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the DISPLAYNAME field ~
             is empty string.~%")
	   nil)
	  ((not (stringp guess))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the GUESS field ~
             is not a string.~%")
	   nil)
	  ((not (plusp (length guess)))
	   (format *error-output* "In function ~
             IS-DECODED-MESSAGE-PROPERLY-FORMED? in package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC, the GUESS field ~
             is empty string.~%")
	   nil)
	  (t t))))                      ; good

;;;
;;;
;;;
(defun xpo-reply-good (guess r)
  (declare (type string guess) (type request r))
  (let ((head-pn (make-unused-pathname))
	(body-pn (make-unused-pathname))
	(cmd-pn  (make-unused-pathname))
	(answer (cond ((equal *demo-secret* guess)
		       "You guessed the secret!")
		      ((equal *demo-selector* guess)
		       "You guess the server's endpoint!")
		      (t "Nope.")))
	encoded)
    (setq encoded (with-output-to-string (stream)
		    (s-base64:encode-base64-bytes
		     (map 'vector 'char-code
			  (format nil "[~A, ~A, ~S, ~A, ~A]"
				  (random 100.0)
				  (unix-epoch)
				  answer
				  *secrets-count*
				  *endpoints-count*))
		     stream             ; input stream
		     nil)))             ; break-lines?
    (with-open-file (body body-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format body "[~S, ~S]" encoded (fakemac *demo-secret* encoded)))
    (with-open-file (head head-pn :direction :output :if-does-not-exist
			  :create :if-exists :error)
      (format head "HTTP/1.1 200 Ok")                           (endln head)
      (format head "Server: CyberTiggyr HTTP 2020 written in Atari BASIC")
                                                                (endln head)
      (multiple-value-bind (se mi ho da mo ye dow)
	  (decode-universal-time (get-universal-time) 0)
	(format head "Date: ~A, ~2,'0D ~A ~D ~2,'0D:~2,'0D:~2,'0D GMT"
		(elt '("Mon" "Tue" "Wed" "Thu" ; day of week
		       "Fri" "Sat" "Sun")
		     dow)
		da                      ; day of month
		(elt '("???" "Jan" "Feb" "Mar" ; month
		       "Apr" "May" "Jun" "Jul"
		       "Aug" "Sep" "Oct" "Nov" "Dec")
		     mo)
		ye                      ; year
		ho mi se))              ; time
                                                                (endln head)
      (format head "Content-type: application/json")            (endln head)
      (format head "Connection: close")                         (endln head)
      (format head "Content-length: ~D" (xfile-length body-pn)) (endln head)
                                                                (endln head))
    (with-open-file (cmd cmd-pn :direction :output :if-does-not-exist
			 :create :if-exists :error)
      (format cmd "d~A~%" head-pn)
      (format cmd "d~A~%" body-pn)
      (format cmd "c~%"))
    (rename-file cmd-pn (request-reply r)))
  t)

;;;
;;; Append the guess to a file.  Very important to save this
;;; so I can see who guessed correctly, and when, & pay them.
;;;
(defun xpo-log-guess (nonce epoch avatar username displayname guess)
  (let ((log-pn (make-pathname :name "fakemac" :type "log"
		      :defaults (GENE-STOVER.CYBERTIGGYR.CFG:log-dir))))
    (with-open-file (fp log-pn :direction :output :if-does-not-exist :create
			:if-exists :append)
      (when (zerop (file-position fp))
	(format fp ";;; -*- Mode: Lisp -*-~%")
	(format fp "~%"))
      (format fp "~S~%" (list (alice-turing.dreambear:timestr)
			      (get-universal-time)
			      nonce epoch avatar username displayname guess
			      (if (equal guess *demo-secret*) :good-secret nil)
			      (if (equal guess *demo-selector*) :good-endpoint nil)))
      (pathname fp))))

;;;
;;;
;;;
(defun xpo-update-counters (guess)
  (cond ((equal guess *demo-secret*) (incf *secrets-count*))
	((equal guess *demo-selector*) (incf *endpoints-count*)))
  'xpo-update-counters)

;;;
;;; We have the base64 encoded message that we received.
;;; We've previously determined that the FakeMAC code that
;;; accompanied it is good, so we don't need that value any
;;; more.  Now, we decode the message.
;;;
;;; We start by decoding the b64 into a string.  We wrap that
;;; inside an IGNORE-ERRORS to prevent us from crashing if
;;; the string, when considered as a base64 value, is malformed,
;;; or if any of the octets that result from decoding cannot
;;; be converted to characters.  If there are any problems, the
;;; IGNORE-ERRORS ensures that we'll get a NIL.  Otherwise, it
;;; worked, & we get a string.
;;;
(defun xpo-with-b64 (b64 r)
  (declare (type request r) (type string b64))
  (let ((decoded (ignore-errors
		   (map 'string 'code-char
			(with-input-from-string (encoded b64)
			  (s-base64:decode-base64-bytes encoded))))))
    (cond ((null decoded)
	   ;; The base64 decode failed.  The encoded string isn't
	   ;; valid base64.
	   (xpo-reply-base64-failure r))
	  ((< 2048 (length decoded)) (xpo-reply-too-long r))
	  ((not (is-decoded-message-properly-formed? decoded))
	   (xpo-reply-improperly-formed r))
	  (t
	   ;; If we reach this point, the message appears legit.
	   ;; Let's reply to it.
	   (multiple-value-bind (nonce epoch avatar username displayname guess)
	       (xpo-parse-decoded-message decoded)
	     (xpo-log-guess nonce epoch avatar username displayname guess)
	     (xpo-reply-good guess r)
	     (xpo-update-counters guess))
	   t))))

;;;
;;; We have the base64 encoded message that we receifed.  We have
;;; the FakeMAC code that the client sent along with it.  Now we
;;; calculate our own FakeMAC value.  If the two FakeMAC values
;;; are equivalent, we continue processing the message.  Otherwise,
;;; we reply with a Bad Request.
;;;
(defun xpo-with-b64-and-remote-fakemac (b64 remote-fakemac r)
  (declare (type request r) (type string b64 remote-fakemac))
  (if (fakemac-verify *demo-secret* b64 remote-fakemac)
      (xpo-with-b64 b64 r)
    ;; else, The calculated FakeMAC differs from the received one,
    ;; so we reply with a 400 Bad Request.
    (xpo-reply-bad-request r)))

;;;
;;; We know that the request is HTTP(S), the verb is POST, & it's
;;; for the selector that we know.  Now we deal with it.  At this
;;; point, we're mostly validating the input & parsing it.
;;;
(defun xpo-on-for-us (r)
  (declare (type request r))
  (format t "Trace in function XPO-ON-FOR-US in Lisp package ~
             GENE-STOVER.CYBERTIGGYR.FAKEMAC...~%   ~
             R's Payload is ~S~%   ~
             Content is ~S~%"
	  (ALICE-TURING.770GOBLINS.TYPES:request-payload r)
	  (load-file-as-octets (ALICE-TURING.770GOBLINS.TYPES:request-payload r)))
  (cond ((< 2048 (xfile-length (request-payload r))) (xpo-reply-too-long r))
	((not (xpo-every-payload-octet-allowed? r)) (xpo-reply-prohibited-chars r))
	(t
	 (let (b64 remote-fakemac)
	   (with-open-file (fp (request-payload r))
	     (format t "In function XPO-ON-FOR-US, read the B64 line.~%")
	     (setq b64 (xread-any-line fp))
	     (format t "In function XPO-ON-FOR-US, read the REMOTE-FAKEMAC line.~%")
	     (setq remote-fakemac (xread-any-line fp)))
	   (format t "In function XPO-ON-FOR-US, call XPO-WITH-B64-AND-REMOTE-FAKEMAC.~%")
	   (xpo-with-b64-and-remote-fakemac b64 remote-fakemac r))))
  ;; Regardless of how we ended up -- good message, bad message,
  ;; we replied to the request, so we return true.
  t)

;;;
;;; If it's a valid HTTP(S) request, it's for our selector, &
;;; it's GET, call ON-FOR-US.  Otherwise, return NIL.
(defun xpo-on-http (r)
  (declare (type request r))
  (cond ((null r) nil) ; wasn't HTTP(S) after all
	((not (equal *demo-selector* (path r))) nil) ; not for us
	((not (eq :post (verb r))) nil); not for us
	(t (xpo-on-for-us r))))

(defun try-demo-post (r)
  (declare (type request r))
  (if (or (is-http? r) (is-https? r))
      (xpo-on-http (parse-request r))
    ;; else, it's not in HTTP(S), so nothing.
    nil))

;;; --- end of file ---