assboard/engine.lisp

(in-package :cl-user)
(defpackage #:assboard.engine
  (:use :cl :assboard.utils)
  (:export #:command-error
           #:process-command
           #:format-new-posting
           #:format-update-posting
           #:format-close-posting
           #:format-delete-posting))
(in-package #:assboard.engine)

(defvar *posting-hash-salt* "[TEST]" "Key for HMAC for new post to get id-hash")
(defvar *posting-hash-length* 8 "id-hash length")
(defvar *command-valid-for* 600 "Seconds of validity for command timestamp")

(defun sync-keys-with-trustlist ()
  (let ((keys (assboard.pgp:list-fingerprints))
        (trustlist (assboard.wot:get-trustlist)))
    ;; Drop no-longer-trusted keys
    (loop for fgp in keys
       unless (find fgp trustlist :test #'equal :key #'car)
       do (assboard.pgp:delete-key fgp))
    ;; Download new trusted keys
    (loop for (fgp . username) in trustlist
       unless (find fgp keys :test #'equal)
       do (assboard.pgp:recv-key fgp))))

(define-condition command-error (error) ())
(define-condition not-valid-pgp-error (command-error) ())
(define-condition not-valid-command-error (command-error) ())
(define-condition not-valid-signature-error (command-error) ())
(define-condition not-valid-timestamp-error (command-error) ())
(define-condition not-valid-hash-error (command-error) ())

(defun get-post-hash (body author)
  "Get part of body+author HMAC to use id-hash."
  (let ((hmac (crypto:make-hmac
               (trivial-utf-8:string-to-utf-8-bytes *posting-hash-salt*)
               :sha512)))
    (crypto:update-hmac
     hmac
     (trivial-utf-8:string-to-utf-8-bytes (concatenate 'string body author)))
    (subseq (cl-base64:usb8-array-to-base64-string
             (crypto:hmac-digest hmac) :uri t)
            0 *posting-hash-length*)))

(defun get-author (raw)
  (let ((fgp (data::raw-fingerprint raw)))
    (or (cdr (assoc fgp
                    assboard.wot:*trustlist-cache*
                    :test #'equal))
        fgp)))

(defun cmd/new-post (cmd raw)
  (let* ((author (get-author raw))
         (title-end (position #\Newline cmd))
         (title (subseq cmd 10 title-end))
         (body (subseq cmd (+ title-end 2)))
         (hash (get-post-hash body author))
         (posting
          (pomo:make-dao 'data::posting
                         :author author
                         :hash hash
                         :title title
                         :body body))
         (posting-edition
          (pomo:make-dao 'data::posting-edition
                         :posting-id (data::posting-id posting)
                         :title title
                         :body body
                         :raw-id (data::raw-id raw))))
    (values posting posting-edition)))

(defun find-users-posting (hash author)
  (first (pomo:select-dao
          'data::posting
          (:and
           (:= 'hash hash)
           (:= 'author author)))))

(defun cmd/update-post (cmd raw)
  (let* ((author (get-author raw))
         (hash-end (position #\Colon cmd))
         (hash (subseq cmd 12 hash-end))
         (posting (find-users-posting hash author)))
    (unless posting
      (error 'not-valid-hash-error))
    (let* ((title-end (position #\Newline cmd))
           (title (subseq cmd (+ hash-end 2) title-end))
           (body (subseq cmd (+ title-end 2)))
           (posting-edition
            (pomo:make-dao 'data::posting-edition
                           :posting-id (data::posting-id posting)
                           :title title
                           :body body
                           :raw-id (data::raw-id raw))))
      (setf (data::posting-title posting) title
            (data::posting-body posting) body
            (data::posting-status posting) "open"
            (data::posting-updated-on posting) (local-time:now))
      (pomo::save-dao posting)
      (values posting posting-edition))))

(defun cmd/close-post (cmd raw)
  (let* ((hash-end (position #\Newline cmd))
         (hash (subseq cmd 11 hash-end))
         (posting (find-users-posting hash (get-author raw))))
    (unless posting
      (error 'not-valid-hash-error))
    (setf (data::posting-status posting) "closed"
          (data::posting-updated-on posting) (local-time:now))
    (pomo::save-dao posting)
    (values posting nil)))

(defun cmd/delete-post (cmd raw)
  (let* ((hash-end (position #\Newline cmd))
         (hash (subseq cmd 12 hash-end))
         (posting (find-users-posting hash (get-author raw))))
    (unless posting
      (error 'not-valid-hash-error))
    (setf (data::posting-status posting) "deleted"
          (data::posting-updated-on posting) (local-time:now))
    (pomo::save-dao posting)
    (values posting nil)))

(defun format-new-posting (title body)
  (format nil "NEW POST: ~A~%~%~A" title body))

(defun format-update-posting (post title body)
  (format nil "UPDATE POST ~A: ~A~%~%~A" (data::posting-hash post) title body))

(defun format-close-posting (post)
  (format nil "CLOSE POST ~A" (data::posting-hash post)))

(defun format-delete-posting (post)
  (format nil "DELETE POST ~A" (data::posting-hash post)))

(defparameter +commands+
  (list (cons "NEW POST: " #'cmd/new-post)
        (cons "CLOSE POST " #'cmd/close-post)
        (cons "UPDATE POST " #'cmd/update-post)
        (cons "DELETE POST " #'cmd/delete-post)))

(defun get-command-handler (command)
  (cdr (find command +commands+ :key #'car
             :test #'(lambda (s w) (starts-with w s)))))

(defun process-command (clearsigned)
  ;; Remove possible CRLF
  (setq clearsigned (replace-all clearsigned
                                 '(#\Return #\Linefeed)
                                 (string #\Linefeed)))
  ;; Simple vanity check
  (unless (starts-with "-----BEGIN PGP SIGNED MESSAGE-----" clearsigned)
    (error 'not-valid-pgp-error))
  (handler-case
      (let* ((start (+ 2 (search '(#\Newline #\Newline) clearsigned)))
             (end (1- (search "-----BEGIN PGP SIGNATURE-----" clearsigned)))
             (command (subseq clearsigned start end))
             (handler (get-command-handler command)))
        ;; Command check
        (unless handler
          (error 'not-valid-command-error))
        ;; Signature validation
        (multiple-value-bind (fgp unixtime)
            (assboard.pgp:verify clearsigned)
          (unless fgp
            (error 'not-valid-signature-error))
          (let ((timestamp (local-time:unix-to-timestamp unixtime)))
            ;; Timestamp check
            (unless (< (abs (local-time:timestamp-difference
                             (local-time:now)
                             timestamp))
                       *command-valid-for*)
              (error 'not-valid-timestamp-error))
            ;; All checks performed, store raw command text and process it
            (let ((raw (pomo:make-dao 'data::raw
                                      :clearsigned clearsigned
                                      :fingerprint fgp
                                      :timestamp timestamp)))
              (funcall handler command raw)))))
    (type-error (e)
      (log:error e)
      (error 'not-valid-command-error))))