fewdea

Basic user and session functionality

... ... @@ -190,3 +190,78 @@
(:table-name "resource-type-attribute-units")
(:keys id)
(:metaclass dao-class))
(defclass user ()
((id :reader id
:initarg :id
:col-type serial)
(email :accessor email
:initarg :email
:col-type string)
(password :accessor password
:initarg :password
:col-type string)
(name :accessor name
:initarg :name
:col-type string))
(:table-name "users")
(:keys id)
(:metaclass dao-class))
(defclass user-resource-index ()
((id :reader id
:initarg :id
:col-type serial)
(user-id :accessor user-id
:initarg :user-id
:col-type integer)
(instance-id :accessor instance-id
:initarg :instance-id
:col-type integer))
(:table-name "user-resources-index")
(:keys id)
(:metaclass dao-class))
(defclass user-session ()
((id :reader id
:initarg :id
:col-type serial)
(user-id :accessor user-id
:initarg :user-id
:col-type (or db-null integer))
(session-id :accessor session-id
:initarg :session-id
:col-type string)
(ip-address :accessor ip-address
:initarg :ip-address
:col-type string)
(user-agent :accessor session-user-agent
:initarg :user-agent
:col-type string)
(idle-expire :accessor idle-expire
:initarg :idle-expire
:col-type timestamp)
(hard-expire :accessor hard-expire
:initarg :hard-expire
:col-type timestamp)
(is-invalid :accessor is-invalid
:initarg :is-invalid
:col-type boolean
:initform nil)
(messages :accessor messages
:initarg :messages
:initform '())
;; Stuff for hunchentoot
(session-start :accessor session-start
:initarg :session-start)
(remote-addr :accessor session-remote-addr
:initarg :session-remote-addr)
(session-string :reader session-string))
;:initarg :session-string
;:initform ""))
(:table-name "user-sessions")
(:keys id)
(:metaclass dao-class))
\ No newline at end of file
... ...
... ... @@ -21,12 +21,20 @@
(in-package :pr0nage)
;; Sessions
;; Timeout lengths in minutes
(defvar *session-idle-timeout* 60)
(defvar *session-hard-timeout* (* 60 24 7))
(defvar *session-secret* (random-salt))
(defvar *rewrite-for-session-urls* nil)
(defvar *MESSAGES* nil)
;; Debugging -
(defvar *debug-on* t)
;; Web root - be nice, include trailing slash
(defvar *web-root-path* "/home/pr0nage/common-lisp/pr0nage/")
(defvar *base-url* "http://pr0nage.com/")
(defvar *base-url* "https://pr0nage.com/")
(setf *web-root-path* (pathname *web-root-path*))
(defvar *internal-port* 1337)
... ...
... ... @@ -32,138 +32,143 @@
(in-package :pr0nage)
(defun action-item-view-redirect ()
(control-wrap
"Allow for the usage of /objective/1 to resolve to /objective/1/view"
(redirect (concatenate 'string (request-uri* *REQUEST*) "/view")))
(redirect (concatenate 'string (request-uri* *REQUEST*) "/view"))))
(defun action-item-view-page ()
(let ((uri-params)
(item-id)
(item-obj)
(parent-obj)
(parent-name))
(no-cache)
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
;; Ensure our 2nd URI param is a valid integer
(handler-case (setf item-id (parse-integer (nth 1 uri-params)))
(error () (redirect "/objectives")))
;; Ensure that our item ID is a valid action-item
(handler-case (setf item-obj (action-item-get-by-id item-id))
(error () (redirect "/objectives")))
;; Check if objective has a valid parent item
(setf parent-obj (action-item-get-by-id (parent-id item-obj)))
(if (eq nil parent-obj)
(setf parent-name "")
(setf parent-name (name parent-obj)))
(action-item-view-view
(id item-obj)
(name item-obj)
(priority item-obj)
(parent-id item-obj)
(details item-obj)
parent-name
(action-items-list-tree-by-root item-id)
(action-item-status-types-list-all)
(human-text (action-item-status-type-get-by-id (status-id item-obj)))
(resource-instances-list-by-action-item-id item-id))))
(control-wrap
(let ((uri-params)
(item-id)
(item-obj)
(parent-obj)
(parent-name))
(no-cache)
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
;; Ensure our 2nd URI param is a valid integer
(handler-case (setf item-id (parse-integer (nth 1 uri-params)))
(error () (redirect "/objectives")))
;; Ensure that our item ID is a valid action-item
(handler-case (setf item-obj (action-item-get-by-id item-id))
(error () (redirect "/objectives")))
;; Check if objective has a valid parent item
(setf parent-obj (action-item-get-by-id (parent-id item-obj)))
(if (eq nil parent-obj)
(setf parent-name "")
(setf parent-name (name parent-obj)))
(action-item-view-view
(id item-obj)
(name item-obj)
(priority item-obj)
(parent-id item-obj)
(details item-obj)
parent-name
(action-items-list-tree-by-root item-id)
(action-item-status-types-list-all)
(human-text (action-item-status-type-get-by-id (status-id item-obj)))
(resource-instances-list-by-action-item-id item-id)))))
(defun action-item-update-page ()
(let ((uri-params)
(item-id)
(item-obj)
(menu-items)
(new-parents)
(infinite-loops))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
;; Check parse integer
(handler-case (setf item-id (parse-integer (nth 1 uri-params)))
(error () (redirect "/objectives")))
;; Is valid objective
(handler-case (setf item-obj (action-item-get-by-id item-id))
(error () (redirect "/objectives")))
;; Fetch list of potential new parent items
(setf new-parents (action-items-list-all))
;; Fetch list of items which, if reparented to, would cause infinite loop.
(setf infinite-loops (action-item-list-child-ids item-id))
;; Someone on IRC was nice enough to tell me how to do this efficiently
;; but I failed to write it down. Inefficiency is my punishment.
(setf menu-items
(remove-if
#'(lambda (x) (or (position (id x) infinite-loops) (eq item-id (id x))))
new-parents))
(action-item-update-view
item-id
(name item-obj)
(priority item-obj)
(parent-id item-obj)
(status-id item-obj)
(details item-obj)
menu-items
;; This should not be a list of objects, but rather a list of id->human-text pairs
(action-item-status-types-list-all))))
(control-wrap
(let ((uri-params)
(item-id)
(item-obj)
(menu-items)
(new-parents)
(infinite-loops))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
;; Check parse integer
(handler-case (setf item-id (parse-integer (nth 1 uri-params)))
(error () (redirect "/objectives")))
;; Is valid objective
(handler-case (setf item-obj (action-item-get-by-id item-id))
(error () (redirect "/objectives")))
;; Fetch list of potential new parent items
(setf new-parents (action-items-list-all))
;; Fetch list of items which, if reparented to, would cause infinite loop.
(setf infinite-loops (action-item-list-child-ids item-id))
;; Someone on IRC was nice enough to tell me how to do this efficiently
;; but I failed to write it down. Inefficiency is my punishment.
(setf menu-items
(remove-if
#'(lambda (x) (or (position (id x) infinite-loops) (eq item-id (id x))))
new-parents))
(action-item-update-view
item-id
(name item-obj)
(priority item-obj)
(parent-id item-obj)
(status-id item-obj)
(details item-obj)
menu-items
;; This should not be a list of objects, but rather a list of id->human-text pairs
(action-item-status-types-list-all)))))
(defun action-item-create-page ()
(let ((uri-params)
(c-item-id)
(item-list))
(control-wrap
(let ((uri-params)
(c-item-id)
(item-list))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
(handler-case (setf c-item-id (parse-integer (nth 2 uri-params)))
(error () (setf c-item-id nil)))
(handler-case (setf c-item-id (parse-integer (nth 2 uri-params)))
(error () (setf c-item-id nil)))
(setf item-list (action-items-list-all))
(action-item-create-view item-list c-item-id)))
(setf item-list (action-items-list-all))
(action-item-create-view item-list c-item-id))))
(defun action-item-set-priority-data ()
(let ((uri-params)
(item-id)
(old-priority)
(new-priority)
(item-obj))
(control-wrap
(let ((uri-params)
(item-id)
(old-priority)
(new-priority)
(item-obj))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
;; Ensure argument ID is an integer
(handler-case (setf item-id (parse-integer (nth 1 uri-params)))
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; Ensure argument ID is an integer
(handler-case (setf item-id (parse-integer (nth 1 uri-params)))
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; Ensure that new priority is an integer
(handler-case (setf new-priority (parse-integer (nth 3 uri-params)))
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; Ensure that new priority is an integer
(handler-case (setf new-priority (parse-integer (nth 3 uri-params)))
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; Ensure the provided objective ID is valid
(handler-case (setf item-obj (action-item-get-by-id item-id))
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; Ensure the provided objective ID is valid
(handler-case (setf item-obj (action-item-get-by-id item-id))
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; 0 < new-priority < max-priority
(if (or
(< new-priority 1)
(> new-priority (get-max-priority (parent-id item-obj))))
(smart-redirect (referer *REQUEST*) "/objectives"))
;; 0 < new-priority < max-priority
(if (or
(< new-priority 1)
(> new-priority (get-max-priority (parent-id item-obj))))
(smart-redirect (referer *REQUEST*) "/objectives"))
(setf old-priority (priority item-obj))
(setf old-priority (priority item-obj))
;; Do nothing if old-priority == new-priority
(if (equal new-priority old-priority)
(smart-redirect (referer *REQUEST*) "/objectives"))
;; Do nothing if old-priority == new-priority
(if (equal new-priority old-priority)
(smart-redirect (referer *REQUEST*) "/objectives"))
;; I don't know why this is a handler-case
(handler-case (setf (priority item-obj) new-priority)
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; I don't know why this is a handler-case
(handler-case (setf (priority item-obj) new-priority)
(error () (smart-redirect (referer *REQUEST*) "/objectives")))
;; TODO: Set session message for successs/failure
(action-item-set-priority item-obj old-priority)
(smart-redirect (referer *REQUEST*) "/objectives")))
;; TODO: Set session message for successs/failure
(action-item-set-priority item-obj old-priority)
(smart-redirect (referer *REQUEST*) "/objectives"))))
(defun action-items-list-filter-page ()
"Param 0: objectives
... ... @@ -171,232 +176,236 @@ Param 1+: Any parameter that is an integer will be selected as
a root objective and displayed as such.
Any status-type in the param list will be used to filter
the list. A '!' prefix explicitly excludes the status-type"
(let ((uri-params)
(item-list)
(item-ids '())
(status-types)
(status-types-text '())
(in-status-types '())
(ex-status-types '())
(h-title "Filtered Objectives List"))
;; Don't cache this page
(no-cache)
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
(setf status-types (action-item-status-types-list-all))
;; Create a list of name properties from our status types object list
(dolist (sti status-types)
(push (name sti) status-types-text))
;; Our first uri parameter is 'objectives', so get rid of it
(pop uri-params)
;; Iterate the remaining list of uri parameters
(dolist (param uri-params)
;; If we successfully parse an integer, add it to our IDs list
(if (not (eq nil (handler-case (parse-integer param) (error () nil))))
(push param item-ids)
;; Otherwise, strip off leading ~ if there is one, and see if it's in
;; our list of status type names.
;; Our data types are incompatible, so reduce the contstraint with ":test #'equal"
(if (position (remove #\~ param) status-types-text :test #'equal)
;; If the leading character is a ~ then push it onto our exclude list
(if (char= (char param 0) #\~)
(push (remove #\~ param) ex-status-types)
;; Otherwise push it on our includes list
(push param in-status-types)))))
;; If our URI doesn't contain any filters, just grab the whole tree by root = 0
(cond
((and (eq nil item-ids)
(eq nil in-status-types)
(eq nil ex-status-types))
(setf h-title "All Objectives")
(setf item-list
(action-items-list-tree-by-root 0)))
;; Otherwise, build our select query with the URI filters
((or (> (length item-ids) 0)
(> (length in-status-types) 0)
(> (length ex-status-types) 0))
(setf item-list
(action-items-build-select
0 ;; Start at parent-id = 0
item-ids
in-status-types
ex-status-types))))
(action-items-list-view
"List Objectives :: pr0nage"
:custom
h-title
item-list
status-types)))
(control-wrap
(let ((uri-params)
(item-list)
(item-ids '())
(status-types)
(status-types-text '())
(in-status-types '())
(ex-status-types '())
(h-title "Filtered Objectives List"))
;; Don't cache this page
(no-cache)
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
(setf status-types (action-item-status-types-list-all))
;; Create a list of name properties from our status types object list
(dolist (sti status-types)
(push (name sti) status-types-text))
;; Our first uri parameter is 'objectives', so get rid of it
(pop uri-params)
;; Iterate the remaining list of uri parameters
(dolist (param uri-params)
;; If we successfully parse an integer, add it to our IDs list
(if (not (eq nil (handler-case (parse-integer param) (error () nil))))
(push param item-ids)
;; Otherwise, strip off leading ~ if there is one, and see if it's in
;; our list of status type names.
;; Our data types are incompatible, so reduce the contstraint with ":test #'equal"
(if (position (remove #\~ param) status-types-text :test #'equal)
;; If the leading character is a ~ then push it onto our exclude list
(if (char= (char param 0) #\~)
(push (remove #\~ param) ex-status-types)
;; Otherwise push it on our includes list
(push param in-status-types)))))
;; If our URI doesn't contain any filters, just grab the whole tree by root = 0
(cond
((and (eq nil item-ids)
(eq nil in-status-types)
(eq nil ex-status-types))
(setf h-title "All Objectives")
(setf item-list
(action-items-list-tree-by-root 0)))
;; Otherwise, build our select query with the URI filters
((or (> (length item-ids) 0)
(> (length in-status-types) 0)
(> (length ex-status-types) 0))
(setf item-list
(action-items-build-select
0 ;; Start at parent-id = 0
item-ids
in-status-types
ex-status-types))))
(action-items-list-view
"List Objectives :: pr0nage"
:custom
h-title
item-list
status-types))))
(defun action-item-create-data ()
(let ((new-item-obj)
(new-item-name)
(new-item-date)
(new-item-details)
(new-item-status)
(parent-id))
(setf new-item-name (escape-string (post-parameter "obj-name" *REQUEST*)))
(handler-case (setf parent-id (parse-integer (post-parameter "parent-id")))
(error () (setf parent-id nil)))
(setf new-item-date (escape-string (post-parameter "target-date" *REQUEST*)))
(setf new-item-details (escape-string (post-parameter "obj-details" *REQUEST*)))
(setf new-item-status (action-item-status-type-get-id-by-name "incomplete"))
(if (eq nil new-item-status)
;; Invalid status type (db not populated!)
(redirect "/objectives"))
(unless (or (null new-item-name) (zerop (length new-item-name)))
(setf new-item-obj
(action-item-create
new-item-name
parent-id
new-item-date
new-item-status
new-item-details))
(redirect (format nil "/objective/~A/view" (id new-item-obj))))
(redirect "/objectives")))
(control-wrap
(let ((new-item-obj)
(new-item-name)
(new-item-date)
(new-item-details)
(new-item-status)
(parent-id))
(setf new-item-name (escape-string (post-parameter "obj-name" *REQUEST*)))
(handler-case (setf parent-id (parse-integer (post-parameter "parent-id")))
(error () (setf parent-id nil)))
(setf new-item-date (escape-string (post-parameter "target-date" *REQUEST*)))
(setf new-item-details (escape-string (post-parameter "obj-details" *REQUEST*)))
(setf new-item-status (action-item-status-type-get-id-by-name "incomplete"))
(if (eq nil new-item-status)
;; Invalid status type (db not populated!)
(redirect "/objectives"))
(unless (or (null new-item-name) (zerop (length new-item-name)))
(setf new-item-obj
(action-item-create
new-item-name
parent-id
new-item-date
new-item-status
new-item-details))
(redirect (format nil "/objective/~A/view" (id new-item-obj))))
(redirect "/objectives"))))
(defun action-item-update-data ()
(let ((item-id)
(old-item-obj)
(priority)
(item-name)
(item-details)
(status-id)
(parent-id)
(max-pri))
;; Parse action-item id integer
(setf item-id
(handler-case (parse-integer (post-parameter "item-id"))
(error () (redirect "/objectives"))))
;; Escape item details from post
(setf item-details (escape-string (post-parameter "item-details")))
;; Check valid action-item id
(handler-case (setf old-item-obj (action-item-get-by-id item-id))
(error () (redirect "/objectives")))
;; Parse priority integer
(setf priority
(handler-case (parse-integer (post-parameter "item-pri"))
(error () (redirect "/objectives"))))
;; Parse status-id from post param
(setf status-id
(handler-case (parse-integer (post-parameter "item-status"))
(error () (redirect "/objectives"))))
;; Check for valid status-id
(if (eq nil
(handler-case (action-item-status-type-get-by-id status-id)
(error () nil)))
(redirect "/objectives"))
;; Parse parent id from post
(setf parent-id
(handler-case (parse-integer (post-parameter "parent-id"))
(error () (redirect "/objectives"))))
;; Check for attempted infinite loop
(if (position parent-id (action-item-list-child-ids item-id))
(redirect "/objectives"))
;; Check valid parent-id
(if (and
(not (zerop parent-id))
(eq nil
(handler-case (action-item-get-by-id parent-id)
(error () (redirect "/objectives")))))
(redirect "/objectives"))
;; Set item name from post
(setf item-name (escape-string (post-parameter "item-name")))
;; Handle the case when reparenting to a leaf node which won't
;; have any priority values, thus get-max-priority returns 0.
;; Otherwise, check for valid priority value.
(setf max-pri (get-max-priority parent-id))
(if (zerop max-pri)
(setf priority 1)
(if (or (< priority 1) (> priority max-pri))
(redirect "/objectives")))
(if (or (null item-name) (zerop (length item-name)))
(redirect "/objectives"))
;; Do session messaging update here for update success status
(handler-case
(action-item-update
item-id
item-name
item-details
priority
parent-id
status-id)
(error () (redirect "/objectives")))
(control-wrap
(let ((item-id)
(old-item-obj)
(priority)
(item-name)
(item-details)
(status-id)
(parent-id)
(max-pri))
;; Parse action-item id integer
(setf item-id
(handler-case (parse-integer (post-parameter "item-id"))
(error () (redirect "/objectives"))))
;; Escape item details from post
(setf item-details (escape-string (post-parameter "item-details")))
;; Check valid action-item id
(handler-case (setf old-item-obj (action-item-get-by-id item-id))
(error () (redirect "/objectives")))
;; Parse priority integer
(setf priority
(handler-case (parse-integer (post-parameter "item-pri"))
(error () (redirect "/objectives"))))
;; Parse status-id from post param
(setf status-id
(handler-case (parse-integer (post-parameter "item-status"))
(error () (redirect "/objectives"))))
;; Check for valid status-id
(if (eq nil
(handler-case (action-item-status-type-get-by-id status-id)
(error () nil)))
(redirect "/objectives"))
;; Parse parent id from post
(setf parent-id
(handler-case (parse-integer (post-parameter "parent-id"))
(error () (redirect "/objectives"))))
;; Check for attempted infinite loop
(if (position parent-id (action-item-list-child-ids item-id))
(redirect "/objectives"))
;; Check valid parent-id
(if (and
(not (zerop parent-id))
(eq nil
(handler-case (action-item-get-by-id parent-id)
(error () (redirect "/objectives")))))
(redirect "/objectives"))
;; Set item name from post
(setf item-name (escape-string (post-parameter "item-name")))
;; Handle the case when reparenting to a leaf node which won't
;; have any priority values, thus get-max-priority returns 0.
;; Otherwise, check for valid priority value.
(setf max-pri (get-max-priority parent-id))
(if (zerop max-pri)
(setf priority 1)
(if (or (< priority 1) (> priority max-pri))
(redirect "/objectives")))
(if (or (null item-name) (zerop (length item-name)))
(redirect "/objectives"))
;; Do session messaging update here for update success status
(handler-case
(action-item-update
item-id
item-name
item-details
priority
parent-id
status-id)
(error () (redirect "/objectives")))
(redirect (format nil "/objective/~A/view" item-id))))
(redirect (format nil "/objective/~A/view" item-id)))))
(defun action-items-text-summary-page ()
(let ((item-list))
(setf item-list (action-items-list-tree-by-root 0))
(action-items-list-text-view item-list)))
(control-wrap
(let ((item-list))
(setf item-list (action-items-list-tree-by-root 0))
(action-items-list-text-view item-list))))
(defun action-item-set-status-data ()
(let ((uri-params)
(set-marked)
(status-id)
(status-type nil)
(item-id)
(item-obj))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
(setf set-marked (nth 3 uri-params))
(setf item-id
(handler-case (parse-integer (nth 1 uri-params))
(error () (redirect "/objectives"))))
(setf item-obj (action-item-get-by-id item-id))
(if (eq nil item-obj)
(redirect "/objectives"))
(dolist (s-type (action-item-status-types-list-all))
(if (equalp set-marked (name s-type))
(setf status-type s-type)))
(if (eq nil status-type)
(redirect "/objectives"))
(setf status-id (id status-type))
(setf (status-id item-obj) status-id)
(action-item-update
(id item-obj)
(name item-obj)
(details item-obj)
(priority item-obj)
(parent-id item-obj)
(status-id item-obj)))
;(smart-redirect (request-uri* *REQUEST*) "/objectives"))
(redirect "/objectives"))
(control-wrap
(let ((uri-params)
(set-marked)
(status-id)
(status-type nil)
(item-id)
(item-obj))
(setf uri-params (parse-uri-params (request-uri* *REQUEST*)))
(setf set-marked (nth 3 uri-params))
(setf item-id
(handler-case (parse-integer (nth 1 uri-params))
(error () (redirect "/objectives"))))
(setf item-obj (action-item-get-by-id item-id))
(if (eq nil item-obj)
(redirect "/objectives"))
(dolist (s-type (action-item-status-types-list-all))
(if (equalp set-marked (name s-type))
(setf status-type s-type)))
(if (eq nil status-type)
(redirect "/objectives"))
(setf status-id (id status-type))
(setf (status-id item-obj) status-id)
(action-item-update
(id item-obj)
(name item-obj)
(details item-obj)
(priority item-obj)
(parent-id item-obj)
(status-id item-obj)))
;(smart-redirect (request-uri* *REQUEST*) "/objectives"))
(redirect "/objectives")))
... ...
... ... @@ -16,4 +16,18 @@
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;; This file is for things shared by all controllers
(in-package :pr0nage)
\ No newline at end of file
(in-package :pr0nage)
(defmacro control-wrap (&body body)
`(block wrap
(start-session)
(no-cache)
(setf *MESSAGES* (session-list-messages))
(print *MESSAGES*)
(print 'bar)
,@body))
(defun index-page ()
(control-wrap
(index-view)))
\ No newline at end of file
... ...
;;; pr0nage :: PR0ject maNAGEment
;;; Copyright (C) 2016 Aaron E Krohn
;;;
;;; 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 2
;;; 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
(in-package :pr0nage)
(defun user-login-page ()
(control-wrap
(start-session)
(user-login-view)))
(defun user-registration-page ()
(control-wrap
(start-session)
(user-registration-view)))
(defun user-authenticate-data ()
(control-wrap
(let ((user-name)
(user-pass)
(user-obj))
(setf user-name (post-parameter "user" *REQUEST*))
(setf user-pass (post-parameter "pass" *REQUEST*))
(setf user-obj
(handler-case (user-get-by-name user-name)
(error () nil)))
(if (eq nil user-obj)
(redirect "/"))
(if (check-password user-pass (password user-obj))
(progn
(print user-obj)
(print *SESSION*)
(print 'foo)
(setf (user-id *SESSION*) (id user-obj))
(regenerate-session-cookie-value *SESSION*)
(session-set-message "Authenticated!")
(redirect "/objectives"))
(redirect "/")))))
(defun user-registration-data ()
(control-wrap
(let ((user-name)
(user-pass)
(user-mail)
(user-obj))
(setf user-name (escape-string (post-parameter "user" *REQUEST*)))
(setf user-pass (post-parameter "pass" *REQUEST*))
(setf user-mail (post-parameter "email" *REQUEST*))
(setf user-obj
(handler-case (user-create user-name user-pass user-mail)
(error () nil)))
(redirect "/login"))))
(defun user-logout-data ()
(control-wrap
(start-session)
(remove-session *SESSION*)
(redirect "/login")))
\ No newline at end of file
... ...
... ... @@ -196,4 +196,18 @@
'resource-type-attribute-unit
'rtau-index
resource-type-attribute-units
"id")
(make-db-table
"users"
users-table
'user
'users-index
users
"id")
(make-db-table
"user_sessions"
user-sessions-table
'user-session
'user-sessions-index
user-sessions
"id")))
\ No newline at end of file
... ...
;;; pr0nage :: PR0ject maNAGEment
;;; Copyright (C) 2016 Aaron E Krohn
;;;
;;; 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 2
;;; 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
(in-package :pr0nage)
(defun user-session-get-if-active (session-id)
(let ((query-str))
(setf query-str
"SELECT * FROM user_sessions
WHERE session_id = $1
AND is_invalid = false
AND idle_expire > NOW()
AND hard_expire > NOW()")
(query query-str session-id (:dao user-session :single))))
(defun user-sessions-list-active ()
(let ((query-str))
(setf query-str
"SELECT * FROM user_sessions
WHERE is_invalid = false
AND idle_expire > NOW()
AND hard_expire > NOW()")
(query query-str (:dao user-session))))
(defun user-session-create (session-id ip-address browser-string &optional (user-id :null))
(let ((query-str))
(setf query-str
"INSERT INTO user_sessions
(user_id, session_id, ip_address, user_agent, idle_expire, hard_expire, is_invalid)
VALUES
($1, $2, $3, $4, NOW() + ($5 || ' minutes')::INTERVAL, NOW() + ($6 || ' minutes')::INTERVAL, false)
RETURNING *")
(query
query-str user-id session-id ip-address browser-string
*session-idle-timeout* *session-hard-timeout*
(:dao user-session :single))))
(defun user-session-destroy (session-id)
(let ((query-str))
(setf query-str
"UPDATE user_sessions
SET is_invalid = true
WHERE session_id = $1")
(query query-str session-id)))
(defun user-session-modify (user-session-obj)
;; Postmodern converts timestamp columns to universal time (epoch 1/1/1900)
;; on the way out, but doesn't convert them back on the way in.
;; So we're going to ignore it and just do a relative update of idle_expir
(let ((query-str))
(setf query-str
"UPDATE user_sessions
SET user_id = $1,
session_id = $2,
idle_expire = NOW() + ($3 || ' minutes')::INTERVAL
WHERE id = $4")
(query query-str
(user-id user-session-obj)
(session-id user-session-obj)
*session-idle-timeout*
(id user-session-obj))))
\ No newline at end of file
... ...
;;; pr0nage :: PR0ject maNAGEment
;;; Copyright (C) 2016 Aaron E Krohn
;;;
;;; 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 2
;;; 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
(in-package :pr0nage)
(defun user-create (name password email)
(if (eq nil email)
(setf email :null))
(insert-dao
(make-instance 'user
:name name
:password (hash-password password)
:email email)))
(defun user-get-by-name (user-name)
(car (select-dao 'user (:= 'name user-name))))
\ No newline at end of file
... ...
... ... @@ -23,6 +23,7 @@
:license "GPL v2"
:depends-on ("hunchentoot"
; "swank"
"ironclad"
"postmodern"
"local-time"
"split-sequence"
... ... @@ -30,11 +31,15 @@
"cl-who")
:components ((:file "packages")
(:file "config" :depends-on ("packages"))
(:file "classes" :depends-on ("packages"))
(:file "init" :depends-on ("classes"))
(:file "utils" :depends-on ("config" "init"))
(:file "router" :depends-on ("init" "utils"))
(:file "utils/crypto")
(:file "config" :depends-on ("packages" "utils/crypto"))
(:file "classes" :depends-on ("packages"))
(:file "init" :depends-on ("classes"))
(:file "utils/general" :depends-on ("config" "init"))
(:file "router" :depends-on ("init"
"utils/general"
"controller/user"))
(:file "utils/sessions" :depends-on ("utils/crypto" "model/user-session"))
(:file "view/action-item"
:depends-on ("router"
... ... @@ -103,10 +108,19 @@
"controller/base-controller"
"model/action-item"))
(:file "model/user-session")
(:file "view/user" :depends-on ("view/base-view"))
(:file "model/user" :depends-on ("utils/crypto"))
(:file "controller/user" :depends-on ("view/user"
"model/user"
"utils/sessions"
"controller/base-controller"))
(:file "view/resource-type" :depends-on ("router" "view/base-view"))
(:file "model/resource-type" :depends-on ("router" "model/base-model"))
(:file "controller/resource-type" :depends-on ("router" "controller/base-controller"))
(:file "view/base-view" :depends-on ("router"))
(:file "model/base-model" :depends-on ("router"))
(:file "controller/base-controller" :depends-on ("router"))))
(:file "view/base-view")
(:file "model/base-model" :depends-on ("init"))
(:file "controller/base-controller" :depends-on ("view/base-view" "utils/sessions"))))
... ...
... ... @@ -40,7 +40,13 @@
(create-folder-dispatcher-and-handler "/css/" (web-rp-str "css/"))
;; Fixed URL dispatchers... except for the first one.
(create-regex-dispatcher "^/$" 'action-items-list-filter-page)
(create-regex-dispatcher "^/$" 'index-page)
(create-regex-dispatcher "^/login$" 'user-login-page)
(create-regex-dispatcher "^/logout$" 'user-logout-data)
(create-regex-dispatcher "^/register$" 'user-registration-page)
(create-regex-dispatcher "^/user/register" 'user-registration-data)
(create-regex-dispatcher "^/user/authenticate" 'user-authenticate-data)
(create-regex-dispatcher "^/objectives$" 'action-items-list-filter-page)
(create-regex-dispatcher "^/objectives/.*" 'action-items-list-filter-page)
(create-regex-dispatcher "^/objectives/report$" 'action-items-text-summary-page)
... ...
;;; pr0nage :: PR0ject maNAGEment
;;; Copyright (C) 2016 Aaron E Krohn
;;;
;;; 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 2
;;; 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
(in-package :pr0nage)
(defvar *prng* (crypto:make-prng :fortuna :seed :urandom))
(defun hash-password (password)
(ironclad:pbkdf2-hash-password-to-combined-string
(ironclad:ascii-string-to-byte-array password)
:salt (ironclad:ascii-string-to-byte-array (random-salt))
:digest :sha256
:iterations 12000))
(defun check-password (password combo-string)
(ironclad:pbkdf2-check-password
(ironclad:ascii-string-to-byte-array password)
combo-string))
(defun random-salt (&optional (num-bits 64))
"Returns a 16 character random salt"
(ironclad:byte-array-to-hex-string
(ironclad:integer-to-octets
(crypto:random-bits num-bits *prng*))))
\ No newline at end of file
... ...
... ... @@ -50,7 +50,11 @@
(setf out-list (list db user pass host))
(with-open-file (out file-name :direction :output :if-exists :supersede)
(with-standard-io-syntax (print out-list out)))))
(defun universal-to-timestring (universal)
(format-timestring t
(universal-to-timestamp universal)
:format +iso-8601-format+))
;;;;;;;;
;; Print-object definitions
;;;;;;;;
... ... @@ -59,28 +63,7 @@
;;; human readable manner. Those functions go here
;;; Note: the slots names here are the actual slot names, not reader/accessor names
;; Action Item class
(defmethod print-object ((object action-item) stream)
(print-unreadable-object (object stream :type t)
(with-slots (name id) object
(format stream "~s ~d" name id))))
(defmethod print-object ((object action-item-attr) stream)
(print-unreadable-object (object stream :type t)
(with-slots (name value) object
(format stream "~s ~s" name value))))
(defmethod print-object ((object action-item-status-type) stream)
(print-unreadable-object (object stream :type t)
(with-slots (name utf8-html-mark) object
(format stream "~s ~s" name utf8-html-mark))))
(defmethod print-object ((object resource) stream)
(print-unreadable-object (object stream :type t)
(with-slots (id name) object
(format stream "~A ~A" id name))))
(defmethod print-object ((object resource-type) stream)
(defmethod print-object ((object user-session) stream)
(print-unreadable-object (object stream :type t)
(with-slots (id human-text) object
(format stream "~A ~A" id human-text))))
\ No newline at end of file
(with-slots (id) object
(format stream "~s" id))))
\ No newline at end of file
... ...
;;; pr0nage :: PR0ject maNAGEment
;;; Copyright (C) 2016 Aaron E Krohn
;;;
;;; 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 2
;;; 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
(in-package :pr0nage)
(defun cookie-get-value (key-name)
(cdr (assoc key-name (cookies-in *REQUEST*) :test #'string=)))
(defmethod next-session-id ((acceptor t))
(let ((digester))
(setf digester (ironclad:make-digest :sha256))
(ironclad:byte-array-to-hex-string
(ironclad:digest-sequence
digester
(ironclad:ascii-string-to-byte-array
(random-salt))))))
(defun start-session ()
(let ((session-id)
(user-session-obj))
(if (eq nil *SESSION*)
;; If no session is active, make a fresh, cryptographically secure one.
(progn
(setf session-id (next-session-id *ACCEPTOR*))
(format nil "Next ID: ~A" session-id)
;; Here we insert a new session into the DB and receive a user-session object
;; The user-session object has our expiration to be used in the cookie.
(setf user-session-obj
(user-session-create session-id (real-remote-addr *REQUEST*) (user-agent *REQUEST*)))
;; Update our global session database
(setf (session-db *acceptor*)
(acons (session-id user-session-obj) user-session-obj (session-db *acceptor*)))
;; Bake a cookie
(set-cookie (session-cookie-name *ACCEPTOR*)
:value (session-id user-session-obj)
:expires (hard-expire user-session-obj)
:domain *base-url*
:path "/"
:secure t
:http-only t)
;; Do this here because hunchentoot's session class is defined
;; after the *REQUEST* object already exists. My session class