assboard/engine.lisp

(in-package :cl-user)
(defpackage #:assboard.engine
  (:use :cl :assboard.utils)
  (:export #:command-error
           #:process-command
           #:format-new-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) ())

(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 cmd/new-post (cmd raw)
  (let* ((fgp (assboard.data::raw-fingerprint raw))
         (author (or (cdr (assoc fgp
                                 assboard.wot:*trustlist-cache*
                                 :test #'equal))
                     fgp))
         (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 format-new-posting (title body)
  (format nil "NEW POST: ~A~%~%~A" title body))

(defun cmd/close-post (cmd raw))

(defun cmd/update-post (cmd raw))

(defparameter +commands+
  (list (cons "NEW POST: " #'cmd/new-post)
        (cons "CLOSE POST: " #'cmd/close-post)
        (cons "UPDATE POST: " #'cmd/update-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))))