Add posting, HMACed urls, minor fixes

assboard.asd

@@ -21,13 +21,14 @@
                :restas
                :cl-date-time-parser
                :log4cl
-               :cl-markdown)
+               :cl-markdown
+               :ironclad
+               :trivial-utf-8)
+  :serial t
   :components ((:file "utils")
-               (:file "gpg" :depends-on ("utils"))
-               (:file "asswot" :depends-on ("utils"))
-               (:file "data" :depends-on ("utils"))
-               (:file "web" :depends-on ("utils"
-                                         "data"
-                                         "gpg"
-                                         "asswot")))
+               (:file "pgp")
+               (:file "wot")
+               (:file "data")
+               (:file "engine")
+               (:file "web"))
   :description "assWoT-based job board")

data.lisp

@@ -28,6 +28,7 @@ be reconnected. Returns boolean on whether the global *database* is now connecte
 
 (defclass posting ()
   ((id :col-type serial :reader posting-id)
+   (hash :col-type string :accessor posting-hash :initarg :hash)
    (author :col-type string :accessor posting-author :initarg :author)
    (status :col-type string :accessor posting-status :initarg :status :col-default "open")
    (title :col-type string :accessor posting-title :initarg :title)

engine.lisp

@@ -1,9 +1,13 @@
 (in-package :cl-user)
 (defpackage #:assboard.engine
   (:use :cl :assboard.utils)
-  (:export #:not-valid-pgp-error))
+  (: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 ()
@@ -24,6 +28,18 @@
 (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
@@ -33,9 +49,11 @@
          (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
@@ -46,6 +64,9 @@
                          :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))
@@ -60,6 +81,10 @@
              :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))
@@ -90,5 +115,5 @@
                                       :timestamp timestamp)))
               (funcall handler command raw)))))
     (type-error (e)
-      (princ e)
+      (log:error e)
       (error 'not-valid-command-error))))

pgp.lisp

@@ -13,6 +13,13 @@
   "gpg homedir (key storage)")
 (defvar *gpg-keyserver* "pgpkeys.mit.edu" "Keyserver to use")
 
+
+(defmacro loop-lines (s &body body)
+  `(with-input-from-string (stream ,s)
+     (loop for line = (read-line stream nil :eof nil)
+        until (eq line :eof)
+          ,@body)))
+
 (defun extract-fingerprint (line)
   (let* ((last (1- (length line)))
          (first (1+ (position #\: line :from-end t :end last))))
@@ -20,9 +27,9 @@
 
 (defun run-gpg (args &key input)
   (with-output-to-string (s)
-    (sb-ext:run-program *gnupg-program*
+    (sb-ext:run-program *gpg-program*
                         (append
-                         (list "--homedir" (namestring *gnupg-homedir*)
+                         (list "--homedir" (namestring *gpg-homedir*)
                                "--status-fd" "1"
                                "--logger-fd" "2"
                                "--no-tty")

utils.lisp

@@ -5,7 +5,7 @@
   (:export
    #:+project-path+
    #:starts-with
-   #:loop-lines))
+   #:replace-all))
 (in-package :assboard.utils)
 
 (defmacro aget (key alist)
@@ -22,14 +22,23 @@
     (equal (subseq str 0 len)
            with-what)))
 
+(defun replace-all (string part replacement &key (test #'char=))
+"Returns a new string in which all the occurences of the part
+is replaced with replacement."
+    (with-output-to-string (out)
+      (loop with part-length = (length part)
+            for old-pos = 0 then (+ pos part-length)
+            for pos = (search part string
+                              :start2 old-pos
+                              :test test)
+            do (write-string string out
+                             :start old-pos
+                             :end (or pos (length string)))
+            when pos do (write-string replacement out)
+            while pos)))
+
 (defun vec-to-hash (vec key-fn)
   (loop for val across vec
      with result = (make-hash-table :test #'equal :size (length vec))
      do (setf (gethash (funcall key-fn val) result) val)
      finally (return result)))
-
-(defmacro loop-lines (s &body body)
-  `(with-input-from-string (stream ,s)
-     (loop for line = (read-line stream nil :eof nil)
-        until (eq line :eof)
-          ,@body)))

web.lisp

@@ -1,13 +1,17 @@
 (in-package :cl-user)
 
 (restas:define-module #:assboard.web
-  (:use :cl :hunchentoot :assboard.utils))
+  (:use :cl :hunchentoot :assboard.utils :assboard.engine))
 
 (in-package #:assboard.web)
 
 ;; Parameters
 (setf (who:html-mode) :html5)
 
+(restas:define-route static/css ("css/:file" :content-type "text/css")
+  (let ((css-path (merge-pathnames "css/" +project-path+)))
+    (merge-pathnames file css-path)))
+
 
 (defclass renderer () ())
 (restas::register-pkgmodule-traits
@@ -28,12 +32,13 @@
       (:meta :http-equiv "X-UA-Compatible" :content "IE=edge")
       (:meta :name "viewport" :content "width=device-width, initial-scale=1")
       (:title (who:str (getf data :title)))
-      (:link :rel "stylesheet" :href (restas:genurl 'static/css :file "styles.css")))
+      ;;(:link :rel "stylesheet" :href (restas:genurl 'static/css :file "styles.css"))
+      )
      (:body
       (who:str (getf data :menu))
       (who:str (getf data :content))))))
 
-(defmethod render-route-data (route data)
+(defmethod render-route-data (route (data list))
   (list*
    :title (getf data :title "AssBoard")
    data))
@@ -43,18 +48,21 @@
                                       object)))
     (finalize-page full-data)))
 
-(defun posts-list (posts)
-  (who:with-html-output-to-string (out)
-    (:ul
-     (loop for post in posts
-        :do (who:htm
-             (:li
-              (:a :href (restas:genurl 'posting :id (data::posting-id post))
-                  (who:str (data::posting-title post)))
-              " by "
-              (:a :href (restas:genurl 'author
-                                       :author (data::posting-author post))
-                  (who:str (data::posting-author post)))))))))
+(defun posts-list (out posts)
+  (who:with-html-output (out)
+    (if posts
+        (who:htm
+         (:ul
+          (loop for post in posts
+             :do (who:htm
+                  (:li
+                   (:a :href (restas:genurl 'posting :hash (data::posting-hash post))
+                       (who:str (data::posting-title post)))
+                   " by "
+                   (:a :href (restas:genurl 'author
+                                            :author (data::posting-author post))
+                       (who:str (data::posting-author post))))))))
+        (who:htm (:ul (:li "No posts yet"))))))
 
 (defmethod render-route-data ((route (eql 'index)) (posts list))
   (list
@@ -62,29 +70,52 @@
    :content
    (who:with-html-output-to-string (out)
      (:h1 "AssBoard open postings")
-     (who:str (posts-list posts)))))
+     (posts-list out posts)
+     (:h2 "Add new posting")
+     (:form :method "POST" :action (restas:genurl 'posting/post)
+            (:input :type "text" :name "title" :placeholder "Title") (:br) (:br)
+            (:textarea :name "body" :cols 80 :rows 10 :placeholder "Body") (:br)
+            (:button :type "submit" "Prepare")))))
 
 (restas:define-route index ("")
   (pomo:query-dao
    'data::posting
-   (:select 'id 'author 'status 'title 'maintainer 'created-on
+   (:select 'hash 'author 'status 'title 'maintainer 'created-on
             :from 'posting)))
 
-(defmethod restas:render-object ((designer renderer) (object data::posting))
-  (finalize-page
-   (list
-    :title (format nil "~A by ~A @ AssBoard"
-                   (data::posting-title object)
-                   (data::posting-author object))
-    :content
-    (who:with-html-output-to-string (out)
-      (:h1 (who:str (data::posting-title object)))
-      (:div (cl-markdown:markdown (data::posting-body object) :stream out))))))
-
-(restas:define-route posting ("posting/:id/")
-  (let ((post (pomo:get-dao 'data::posting id)))
-    (if post post
-        hunchentoot:+HTTP-NOT-FOUND+)))
+(defmethod render-route-data ((route (eql 'posting/post)) (data list))
+  (list
+   :title "Add new posting"
+   :content
+   (who:with-html-output-to-string (out)
+     (:h1 "Add new posting")
+     (if (getf data :error)
+         (who:htm (:h2 "Error adding post:")
+                  (:p (who:str (getf data :error))))
+         (who:htm
+          (:p "To add new posting, clearsign (`gpg --clearsign`) the following text and paste results from '-----BEGIN PGP SIGNED MESSAGE-----' up to '-----END PGP SIGNATURE-----'")
+          (:textarea :disabled t :cols 80 :rows 10
+                     (who:str (getf data :to-sign)))
+          (:form :method "POST"
+                 (:textarea :name "clearsigned" :cols 80 :rows 20 :placeholder "clearsigned") (:br)
+                 (:button :type "submit" "Post")))))))
+
+(restas:define-route posting/post ("posting/" :method :post)
+  (let ((clearsigned (hunchentoot:post-parameter "clearsigned")))
+    (if clearsigned
+        (handler-case
+            (let ((posting (process-command clearsigned)))
+              (restas:redirect 'posting :hash (data::posting-hash posting)))
+          (command-error (err)
+            (log:info "Error processing command ~A" err)
+            (list :error err
+                  :clearsigned clearsigned)))
+        (let ((title (hunchentoot:post-parameter "title"))
+              (body (hunchentoot:post-parameter "body")))
+          (if (or (equal title "") (equal body ""))
+              (restas:redirect 'index)
+              (list
+               :to-sign (format-new-posting title body)))))))
 
 (defmethod render-route-data ((route (eql 'author)) (data list))
   (list
@@ -92,20 +123,30 @@
    :content
    (who:with-html-output-to-string (out)
      (:h1 (who:str (getf data :author)) "'s postings")
-     (who:str (posts-list (getf data :posts))))))
+     (who:str (posts-list out (getf data :posts))))))
 
 (restas:define-route author ("author/:author/")
   (let ((posts (pomo:query-dao
                 'data::posting
-                (:select 'id 'author 'status 'title 'maintainer 'created-on
+                (:select 'hash 'author 'status 'title 'maintainer 'created-on
                          :from 'posting
                          :where (:= 'author author)))))
     (if posts
         (list :author author :posts posts)
         hunchentoot:+HTTP-NOT-FOUND+)))
 
-(restas:define-route static/css ("css/:file" :content-type "text/css")
-  (let ((css-path (merge-pathnames "css/" +project-path+)))
-    (merge-pathnames file css-path)))
-
+(defmethod restas:render-object ((designer renderer) (object data::posting))
+  (finalize-page
+   (list
+    :title (format nil "~A by ~A @ AssBoard"
+                   (data::posting-title object)
+                   (data::posting-author object))
+    :content
+    (who:with-html-output-to-string (out)
+      (:h1 (who:str (data::posting-title object)))
+      (:div (cl-markdown:markdown (data::posting-body object) :stream out))))))
 
+(restas:define-route posting ("posting/:hash/")
+  (let ((post (first (pomo:select-dao 'data::posting (:= 'hash hash)))))
+    (if post post
+        hunchentoot:+HTTP-NOT-FOUND+)))