<commit_before>;;; Copyright 2012-2013 CommonGoods Network, Inc.
;;;
;;; This file is part of Kindista.
;;;
;;; Kindista is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as published
;;; by the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Kindista 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 Affero General Public
;;; License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public License
;;; along with Kindista.  If not, see <http://www.gnu.org/licenses/>.

(in-package :kindista)

;(declaim (optimize (speed 0) (safety 3) (debug 3)))

(setf (cl-who:html-mode) :sgml)

(setf hunchentoot:*show-lisp-backtraces-p* nil)
(setf hunchentoot:*show-lisp-errors-p* nil)

(defvar *flashes* (make-hash-table :synchronized t :size 500 :rehash-size 1.25))

(defvar *base-url* "/")

(defun flash (message &key error)
  (with-locked-hash-table (*flashes*)
    (push
      (format nil
              (if error
                "<div class=\"flash err\">~a</div>"
                "<div class=\"flash\">~a</div>")
              message)
      (gethash *token* *flashes*))))

(defun flashes ()
  (with-locked-hash-table (*flashes*)
    (prog1
      (delete-duplicates (gethash *token* *flashes*) :test #'string=)
      (remhash *token* *flashes*))))

(defun not-found ()
  (flash "The page you requested could not be found." :error t)
  (if (equal (fourth (split "/" (referer) :limit 4)) (subseq (script-name*) 1))
    (see-other "/home")
    (see-other (or (referer) "/home"))))

(defun permission-denied ()
  (flash "The page you requested is private." :error t)
  (if (equal (fourth (split "/" (referer) :limit 4)) (subseq (script-name*) 1))
    (see-other "/home")
    (see-other (or (referer) "/home"))))

(defun login-required ()
  (flash "The page you requested is only available when you are logged in to Kindista." :error t)
  (see-other (s+ "/login?next=" (script-name*))))

(defun active-status-required ()
  (flash "Sorry, you must reactivate your account to perform that action." :error t)
  (if (equal (fourth (split "/" (referer) :limit 4)) (subseq (script-name*) 1))
    (see-other "/home")
    (see-other (or (referer) "/home"))))

;;; routing and jcceptor {{{

(setf *methods-for-post-parameters* '(:post :put))

(defvar *routes* ())

(defparameter *route-param-scanner*
  (create-scanner "<((\\w+):)?([-\\w]+)>"))

(defun make-path-scanner (path)

  (let ((names ())
        (newpath path))

    (do-scans (s e reg-starts reg-ends *route-param-scanner* path)
      (let* ((values (map 'vector
                          (lambda (rs re)
                            (if rs
                              (subseq path rs re)
                              nil))
                          reg-starts
                          reg-ends))
             (pattern nil)
             (param-type (elt values 1)))

        (setf names (append names (list (make-keyword
                                          (string-upcase
                                           (elt values 2))))))

        (cond
          ((string= param-type "int")
           (setf pattern "(\\d+)"))
          ((string= param-type "email")
           (setf pattern "(^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,6})"))
          (t
           (setf pattern "([^\/]+)")))

        (setf newpath (regex-replace *route-param-scanner* newpath pattern))))

    (create-scanner (s+ "^" newpath "$"))))


(defmacro routes (&body routes)
  `(setf *routes* (list ,@(iter (for route in routes)
                                (collect `(list (make-path-scanner ,(first route))
                                                (quote ,(rest route))))))))

; }}}

;; globals


;; special variables

(defvar *token* nil) ; current token (session)
(defvar *donate-info* nil) ; current donation page data
(defvar *user* nil) ; current user
(defvar *userid* nil) ; current user
(defvar *latitude* 0.0)
(defvar *longitude* 0.0)

(defun random-password (length)
  (declare (type fixnum length))
  (string-downcase
    (with-output-to-string (stream)
      (let ((*print-base* 36))
        (loop repeat length do (princ (random 36) stream))))))

(defun crypt-password (password salt)
  (s+ salt ":"
    (ironclad:byte-array-to-hex-string
      (ironclad:digest-sequence :sha256 (ironclad:ascii-string-to-byte-array
                                          (s+ salt password))))))

(defun new-password (password)
  (let ((salt (random-password 10)))
    (crypt-password password salt)))

(defun password= (password crypted-password)
  (let* ((salt (first (ppcre:split ":" crypted-password :limit 2)))
         (crypted-password2 (crypt-password password salt)))
    (string= crypted-password crypted-password2)))

(defun password-match-p (id password)
  (let ((crypted-password (getf (db id) :pass)))
    (if crypted-password
      (password= password crypted-password)
      nil)))

(defun check-token-cookie ()
  (let ((token-id (cookie-in "token")))
    (when token-id
      (let ((token (check-token token-id)))
        (when (and (not token) token-id)
          (delete-token-cookie))
        token))))

(defmacro with-token (&body body)
  `(let ((*token* (or *token* (check-token-cookie) (start-token))))
     ,@body))

(defmacro with-user (&body body)
  `(with-token
    (let* ((*userid* (or *userid* (token-userid *token*)))
           (*user* (or *user* (db *userid*))))
       ,@body)))

(defmacro with-location (&body body)
  `(let ((*latitude* (or (getf *user* :lat) 44.028297))
         (*longitude* (or (getf *user* :long) -123.076065)))
     ,@body))

(defmacro with-donate-info (&body body)
  `(with-user
     (let ((*donate-info* (or (token-donate-info *token*)
                              (setf (token-donate-info *token*)
                                    (make-donate-info :address (getf *user* :street)
                                                      :city (getf *user* :city)
                                                      :state (getf *user* :state)
                                                      :email (car (getf *user* :emails))
                                                      :zip (getf *user* :zip)
                                                      :name (getf *user* :name))))))
       ,@body)))

(defmacro require-user (&body body)
  `(with-user
     (pprint *userid*)
     
     (if *userid*
       (if (getf *user* :banned)
         (progn
           (flash "This account has been suspended for posting inappropriate content or otherwise violating Kindista's Terms of Use.  If you believe this to be an error please email us so we can resolve this issue." :error t)
           (get-logout))
         (progn ,@body))
       (login-required))))

(defmacro require-active-user (&body body)
  `(with-user
     (if *userid*
       (if (eq (getf *user* :active) t) 
         (progn ,@body)
         (active-status-required))
       (login-required))))

(defmacro require-test ((test &optional message) &body body)
  `(if ,test
     (progn ,@body)
     ,(if message
        `(progn
           (flash ,message)
           (see-other "/")) 
        `(see-other "/"))))

;; tokens

(defun start-token ()
  (with-locked-hash-table (*tokens*)
    (do (token)<commit_msg>removed an unnecessary pprint statement<commit_after>;;; Copyright 2012-2013 CommonGoods Network, Inc.
;;;
;;; This file is part of Kindista.
;;;
;;; Kindista is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as published
;;; by the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Kindista 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 Affero General Public
;;; License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public License
;;; along with Kindista.  If not, see <http://www.gnu.org/licenses/>.

(in-package :kindista)

;(declaim (optimize (speed 0) (safety 3) (debug 3)))

(setf (cl-who:html-mode) :sgml)

(setf hunchentoot:*show-lisp-backtraces-p* nil)
(setf hunchentoot:*show-lisp-errors-p* nil)

(defvar *flashes* (make-hash-table :synchronized t :size 500 :rehash-size 1.25))

(defvar *base-url* "/")

(defun flash (message &key error)
  (with-locked-hash-table (*flashes*)
    (push
      (format nil
              (if error
                "<div class=\"flash err\">~a</div>"
                "<div class=\"flash\">~a</div>")
              message)
      (gethash *token* *flashes*))))

(defun flashes ()
  (with-locked-hash-table (*flashes*)
    (prog1
      (delete-duplicates (gethash *token* *flashes*) :test #'string=)
      (remhash *token* *flashes*))))

(defun not-found ()
  (flash "The page you requested could not be found." :error t)
  (if (equal (fourth (split "/" (referer) :limit 4)) (subseq (script-name*) 1))
    (see-other "/home")
    (see-other (or (referer) "/home"))))

(defun permission-denied ()
  (flash "The page you requested is private." :error t)
  (if (equal (fourth (split "/" (referer) :limit 4)) (subseq (script-name*) 1))
    (see-other "/home")
    (see-other (or (referer) "/home"))))

(defun login-required ()
  (flash "The page you requested is only available when you are logged in to Kindista." :error t)
  (see-other (s+ "/login?next=" (script-name*))))

(defun active-status-required ()
  (flash "Sorry, you must reactivate your account to perform that action." :error t)
  (if (equal (fourth (split "/" (referer) :limit 4)) (subseq (script-name*) 1))
    (see-other "/home")
    (see-other (or (referer) "/home"))))

;;; routing and jcceptor {{{

(setf *methods-for-post-parameters* '(:post :put))

(defvar *routes* ())

(defparameter *route-param-scanner*
  (create-scanner "<((\\w+):)?([-\\w]+)>"))

(defun make-path-scanner (path)

  (let ((names ())
        (newpath path))

    (do-scans (s e reg-starts reg-ends *route-param-scanner* path)
      (let* ((values (map 'vector
                          (lambda (rs re)
                            (if rs
                              (subseq path rs re)
                              nil))
                          reg-starts
                          reg-ends))
             (pattern nil)
             (param-type (elt values 1)))

        (setf names (append names (list (make-keyword
                                          (string-upcase
                                           (elt values 2))))))

        (cond
          ((string= param-type "int")
           (setf pattern "(\\d+)"))
          ((string= param-type "email")
           (setf pattern "(^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,6})"))
          (t
           (setf pattern "([^\/]+)")))

        (setf newpath (regex-replace *route-param-scanner* newpath pattern))))

    (create-scanner (s+ "^" newpath "$"))))


(defmacro routes (&body routes)
  `(setf *routes* (list ,@(iter (for route in routes)
                                (collect `(list (make-path-scanner ,(first route))
                                                (quote ,(rest route))))))))

; }}}

;; globals


;; special variables

(defvar *token* nil) ; current token (session)
(defvar *donate-info* nil) ; current donation page data
(defvar *user* nil) ; current user
(defvar *userid* nil) ; current user
(defvar *latitude* 0.0)
(defvar *longitude* 0.0)

(defun random-password (length)
  (declare (type fixnum length))
  (string-downcase
    (with-output-to-string (stream)
      (let ((*print-base* 36))
        (loop repeat length do (princ (random 36) stream))))))

(defun crypt-password (password salt)
  (s+ salt ":"
    (ironclad:byte-array-to-hex-string
      (ironclad:digest-sequence :sha256 (ironclad:ascii-string-to-byte-array
                                          (s+ salt password))))))

(defun new-password (password)
  (let ((salt (random-password 10)))
    (crypt-password password salt)))

(defun password= (password crypted-password)
  (let* ((salt (first (ppcre:split ":" crypted-password :limit 2)))
         (crypted-password2 (crypt-password password salt)))
    (string= crypted-password crypted-password2)))

(defun password-match-p (id password)
  (let ((crypted-password (getf (db id) :pass)))
    (if crypted-password
      (password= password crypted-password)
      nil)))

(defun check-token-cookie ()
  (let ((token-id (cookie-in "token")))
    (when token-id
      (let ((token (check-token token-id)))
        (when (and (not token) token-id)
          (delete-token-cookie))
        token))))

(defmacro with-token (&body body)
  `(let ((*token* (or *token* (check-token-cookie) (start-token))))
     ,@body))

(defmacro with-user (&body body)
  `(with-token
    (let* ((*userid* (or *userid* (token-userid *token*)))
           (*user* (or *user* (db *userid*))))
       ,@body)))

(defmacro with-location (&body body)
  `(let ((*latitude* (or (getf *user* :lat) 44.028297))
         (*longitude* (or (getf *user* :long) -123.076065)))
     ,@body))

(defmacro with-donate-info (&body body)
  `(with-user
     (let ((*donate-info* (or (token-donate-info *token*)
                              (setf (token-donate-info *token*)
                                    (make-donate-info :address (getf *user* :street)
                                                      :city (getf *user* :city)
                                                      :state (getf *user* :state)
                                                      :email (car (getf *user* :emails))
                                                      :zip (getf *user* :zip)
                                                      :name (getf *user* :name))))))
       ,@body)))

(defmacro require-user (&body body)
  `(with-user
     (if *userid*
       (if (getf *user* :banned)
         (progn
           (flash "This account has been suspended for posting inappropriate content or otherwise violating Kindista's Terms of Use.  If you believe this to be an error please email us so we can resolve this issue." :error t)
           (get-logout))
         (progn ,@body))
       (login-required))))

(defmacro require-active-user (&body body)
  `(with-user
     (if *userid*
       (if (eq (getf *user* :active) t) 
         (progn ,@body)
         (active-status-required))
       (login-required))))

(defmacro require-test ((test &optional message) &body body)
  `(if ,test
     (progn ,@body)
     ,(if message
        `(progn
           (flash ,message)
           (see-other "/")) 
        `(see-other "/"))))

;; tokens

(defun start-token ()
  (with-locked-hash-table (*tokens*)
    (do (token)
{'fraction_non_alphanumeric': 0.15970598062145006, 'fraction_numerical': 0.008820581356498497, 'mean_word_length': 2.2198795180722892, 'pattern_counts': {'":': 4, '<': 15, '<?xml version=': 0, '>': 15, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 38, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '612899', 'n_tokens_mistral': 4846, 'n_tokens_neox': 4687, 'n_words': 1403}