Commit 6f8d34d7 authored by Michael Raskin's avatar Michael Raskin

Syncing from Monotone at 20190330-223524. Last commit message was Add some exports and ignores

parents
[.]fasl$
[.]lx32fsl$
[.]lx64fsl$
MCCME-HELPERS is Copyright (c) 2009-2010 by Moscow Center for Continious
Mathematical Education. It is primarily written y MCCME employee, Michael
Raskin.
Current release of MCCME-HELPERS is licensed under the terms of the
Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html),
known as the LLGPL. The LLGPL consists of a preamble (see above URL) and
the LGPL. Where these conflict, the preamble takes precedence.
MCCME-HELPERS is referenced in the preamble as the "LIBRARY."
MCCME-HELPERS 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.
(mccme-helpers/packages:file mccme-helpers/auth-pages
:use (mccme-helpers/db-auth
mccme-helpers/cookie
)
:export (
#:make-login-pages
#:verify-login
#:*su-allowed-p*
)
)
(mccme-helpers/packages:alias-package hunchentoot ht)
(defvar *su-allowed-p* (constantly nil))
(defun make-login-pages (login-template)
(ht:define-easy-handler (login-form :uri "/user/login") (wrong)
(setf (ht:content-type*) "text/html; charset=utf-8")
(
#+sbcl sb-ext:string-to-octets
#+ccl ccl:encode-string-to-octets
(cl-emb:execute-emb (pathname login-template)
:env `(:wrong ,wrong))
:external-format :utf-8))
(ht:define-easy-handler (login-submit :uri "/user/submit_login") ()
(let* (
(username (ht:post-parameter "login"))
(password (ht:post-parameter "password"))
(match (login-correct-p username password))
(url (or (get-secure-cookie "url") "/"))
)
(if match (progn
(set-secure-cookie "user" username)
(set-secure-cookie "password" password)
(ht:redirect url))
(progn
(with-open-file
(s "fail-login.log"
:if-does-not-exist :create
:if-exists :append
:direction :output)
#+nil(when
nil
(format s
"Failed login check, username [[~a]] password [[~a]].~%"
username password)))
(set-secure-cookie "user" nil)
(set-secure-cookie "password" nil)
(ht:redirect "/user/login?wrong=1")
))
))
(ht:define-easy-handler (user-logout :uri "/user/logout") ()
(set-secure-cookie "user" nil)
(set-secure-cookie "su_user" nil)
(set-secure-cookie "password" nil)
(set-secure-cookie "url" nil)
(ht:redirect "/"))
(ht:define-easy-handler (user-su :uri "/user/su") (to)
(verify-login)
(unless (get-secure-cookie "su_user")
(set-secure-cookie "su_user"
(get-secure-cookie "user")))
(set-secure-cookie "user" to)
(when (equal (get-secure-cookie "su_user")
(get-secure-cookie "user"))
(set-secure-cookie "su_user" nil))
"You tried to su"
)
)
(defun verify-login (&key known-stored-hash known-stored-hash-su)
(let* (
(username (get-secure-cookie "user"))
(password (get-secure-cookie "password"))
(match (login-correct-p username password
:known-stored-hash known-stored-hash))
(url (and (boundp 'ht:*request*) (ht:request-uri*)))
(su-username (get-secure-cookie "su_user"))
(su-match (login-correct-p su-username password
:known-stored-hash known-stored-hash-su))
(su-allowed (and
su-match
(boundp '*su-allowed-p*)
(functionp *su-allowed-p*)
(funcall *su-allowed-p* su-username username)
))
)
(when (and (not match) (not su-allowed))
(set-secure-cookie "url" url)
(ht:redirect "/user/login"))))
This diff is collapsed.
(mccme-helpers/packages:file mccme-helpers/captcha
:use (
mccme-helpers/trivial
mccme-helpers/lisp
)
:export (
#:generate-expression
#:render-expression-html
#:*captcha-bypass-password*
)
)
(defvar *captcha-bypass-password* :none)
(def-and-set-var *legal-operators* '(+ - - *))
(def-and-set-var *legal-range* '(1 9))
(defun generate-expression (size)
(let*
((op (random-of *legal-operators*))
(val (apply 'random-between *legal-range*))
(lhs (truncate (/ (- size 1) 2)))
(rhs (- size 1 lhs))
)
(if
(> size 0)
(list op (generate-expression lhs) (generate-expression rhs))
val
)
))
(defparameter *html-modifiers*
'(:a :b :i :span :font)
)
(defparameter *html-spoilers*
'(
"<span style='display:none'>[это не должно быть видно this should be hidden]</span>"
"<span hidden>[ this should be hidden это не должно быть видно ]</span>"
"<!-- -= > 2+3 -->"
)
)
(defun render-expression-html (expr)
(let*
((modifier (random-of *html-modifiers*))
(spoiler (random-of *html-spoilers*))
)
(if (listp expr)
(format nil "<~a>~a (<~a>~A</~a> ~A ~A<~a>)"
modifier
spoiler
modifier
(render-expression-html (second expr))
modifier
(first expr)
(render-expression-html (third expr))
modifier
)
(format nil "~a" expr)
)
))
(mccme-helpers/packages:file mccme-helpers/comb
:use (
:mccme-helpers/struct
:mccme-helpers/functional
:mccme-helpers/trivial
:iterate
)
:export (
#:aggregate-list
#:direct-product
#:uniq
#:uniq-keyed
#:uniq-stable
#:uniq-stable-keyed
#:uniq-stable-custom
#:transitive-closure
#:recursive-modification
#:list-to-table
#:table-totals-2d
#:group-counts
#:verhoeff
#:verhoeff-check
#:with-verhoeff
#:string-verhoeff
#:string-verhoeff-check
#:string-with-verhoeff
#:okpo
#:list-unroll
)
)
; raw data - list of lists of ...
; rule-list - depth-ordered list of rules
; first element: position of split between key and value
; second element: whether key should be car'ed
; third element: whether value should be car'ed
; fourth element: whether we should push to list instead of setting
(defun aggregate-list (raw-data rule-list &key (test 'equalp))
(let*
(
(result (make-hash-table :test test))
)
(iter
(for el in raw-data)
(iter
(for rule on rule-list)
(for considered-hashtable initially result then next-hash)
(for rest-data initially el then val-subseq)
(for key-subseq := (subseq rest-data 0 (caar rule)))
(for val-subseq := (subseq rest-data (caar rule)))
(for key := (if (second (car rule)) (car key-subseq) key-subseq))
(for val := (if (third (car rule)) (car val-subseq) val-subseq))
(if
(null (cdr rule))
(if (null (fourth (car rule)))
(set-> considered-hashtable key val)
(push-> considered-hashtable key val)
)
(unless (-> considered-hashtable key)
(set-> considered-hashtable
key (make-hash-table :test test)))
)
(for next-hash := (-> considered-hashtable key))
)
)
result))
(defun direct-product (&rest lists)
(if lists
(let (res)
(loop for x in (car lists) do
(loop for xs in (apply 'direct-product (cdr lists)) do
(push (cons x xs) res)
)
)
res
)
'(nil)
))
(defun uniq (l &optional (test 'equal))
(let* (
(ht (make-hash-table :test test))
res
)
(loop for x in l do (setf (gethash x ht) t))
(maphash (lambda (k v) (declare (ignore v)) (push k res)) ht)
res
))
(defun uniq-stable (l &optional (test 'equal))
(let* (
(ht (make-hash-table :test test))
res
)
(loop for x in l
do (unless (gethash x ht) (push x res))
do (setf (gethash x ht) t))
(reverse res)
))
(defun uniq-stable-keyed (l key &optional (test 'equal))
(let* (
(ht (make-hash-table :test test))
res
)
(loop for x in l
for k := (funcall key x)
do (unless (gethash k ht) (push x res))
do (setf (gethash k ht) t))
(reverse res)
))
(defun uniq-keyed (l &key (test 'equal) (key 'identity) (aggregate nil)
use-initial initial-element)
(let* (
(ht (make-hash-table :test test))
res
)
(loop
for x in l do
(if aggregate
(let*
((k (funcall key x)))
(multiple-value-bind
(value present)
(gethash k ht)
(let*
(
(has-value (or present use-initial))
(old-value (if present value initial-element))
(v (if has-value (funcall aggregate x old-value) x))
)
(setf (gethash k ht) v)
)))
(setf (gethash (funcall key x) ht) x)))
(maphash (lambda (k v) (declare (ignore k)) (push v res)) ht)
res
))
(defun uniq-stable-custom (l &key (key 'identity) (test 'equal))
(let* (
res
keys
)
(loop for x in l
for k := (funcall key x)
do (unless (find k keys :test test)
(push x res) (push k keys))
)
(reverse res)
))
(defun transitive-closure (l dep-fn &optional (test 'equal))
(uniq-stable
(apply
'concatenate 'list
(mapcar
(lambda (x)
(concatenate
'list
(transitive-closure (funcall dep-fn x) dep-fn test)
(list x)))
l))))
(defun recursive-modification (tree pred fn)
(mapcar
(lambda (x)
(cond
((funcall pred x) (funcall fn x))
((consp x) (recursive-modification x pred fn))
(t x)
)
)
tree))
(defun list-to-table
(data keys value-key
&key
(mk-level (constantly nil))
(less-than 'uni-<)
)
(iter
(with data-table := (funcall mk-level))
(with key-lists :=
(progn
(make-array (length keys)
:initial-element nil)))
(for entry in data)
(for value := (-> entry value-key))
(for key-set-raw :=
(mapcar
(lambda (x) (-> entry x))
keys))
(for key-set :=
(mapcar
(lambda (x) (format nil "~a" x))
key-set-raw))
(setf data-table
(with-deep-update
data-table
key-set
value
mk-level))
(iter
(for n upfrom 0)
(for val in key-set-raw)
(push-> key-lists n val)
)
(finally
(return
(append
(list data-table)
(map 'list
(lambda (x)
(mapcar
(lambda (y)
(format nil "~a" y))
(sort
(uniq x)
less-than
)))
key-lists
)
)))
))
(defun table-totals-2d
(table range params group-by)
(iter
(with total-table := (make-hash-table :test 'equal))
(for k in params)
(set-> total-table k
(apply
'+
(mapcar
(cond
((eq group-by :first)
(lambda (x) (--> table 0 x k)))
((eq group-by :second)
(lambda (x) (--> table 0 k x)))
(t (constantly 0)))
range
)
))
(finally
(return
total-table
))
)
)
(defun group-counts (l &key (key 'identity) (weight (constantly 1)))
(let*
(
(ht (make-hash-table :test 'equal))
)
(loop for x in l do (incf-> ht (funcall key x) (funcall weight x)))
(map-generic ht 'identity)))
(defparameter verhoeff-d
`(
(0 1 2 3 4 5 6 7 8 9)
(1 2 3 4 0 6 7 8 9 5)
(2 3 4 0 1 7 8 9 5 6)
(3 4 0 1 2 8 9 5 6 7)
(4 0 1 2 3 9 5 6 7 8)
(5 9 8 7 6 0 4 3 2 1)
(6 5 9 8 7 1 0 4 3 2)
(7 6 5 9 8 2 1 0 4 3)
(8 7 6 5 9 3 2 1 0 4)
(9 8 7 6 5 4 3 2 1 0)
))
(defparameter verhoeff-p
`(
(0 1 2 3 4 5 6 7 8 9)
(1 5 7 6 2 8 3 0 9 4)
(5 8 0 3 7 9 6 1 4 2)
(8 9 1 6 0 4 3 5 2 7)
(9 4 5 3 1 2 6 8 7 0)
(4 2 8 6 5 7 3 9 0 1)
(2 7 9 3 8 0 6 4 1 5)
(7 0 4 6 9 1 3 2 5 8)
))
(defparameter verhoeff-inv `(0 4 3 2 1 5 6 7 8 9))
(defun verhoeff (arr &optional (shift 0))
(loop
with c = 0
for i upfrom 1
for n in (reverse arr)
do (setf c (--> verhoeff-d 0 c (--> verhoeff-p 0 (mod (+ i shift) 8) n)))
finally (return (-> verhoeff-inv c))
))
(defun verhoeff-check (arr) (equal (verhoeff arr -1) 0))
(defun with-verhoeff (arr) (append arr (list (verhoeff arr))))
(defun string-verhoeff (str &optional (shift 0))
(format
nil "~a"
(verhoeff (map 'list (lambda (ch)
(- (char-code ch) 48)) str)
shift)))
(defun string-with-verhoeff (str)
(concatenate 'string str (string-verhoeff str)))
(defun string-verhoeff-check (str)
(equal "0" (string-verhoeff str -1)))
(or
(and
(equal (verhoeff '(7 5 8 7 2 )) 2)
(equal (verhoeff '(7 5 8 7 2 2 ) -1) 0)
(equal (verhoeff '(1 2 3 4 5 )) 1)
(equal (verhoeff '(1 2 3 4 5 1 ) -1) 0)
(equal (verhoeff '(1 4 2 8 5 7 )) 0)
(equal (verhoeff '(1 4 2 8 5 7 0 ) -1) 0)
(equal (verhoeff '(1 2 3 4 5 6 7 8 9 0 1 2 )) 0)
(equal (verhoeff '(1 2 3 4 5 6 7 8 9 0 1 2 0 ) -1) 0)
(equal (verhoeff '(8 4 7 3 6 4 3 0 9 5 4 8 3 7 2 8 4 5 6 7 8 9 )) 2)
(equal (verhoeff '(8 4 7 3 6 4 3 0 9 5 4 8 3 7 2 8 4 5 6 7 8 9 2 ) -1) 0)
(equal (with-verhoeff '(1 2 3 4 5)) '(1 2 3 4 5 1))
(verhoeff-check '(1 2 3 4 5 1))
(not (verhoeff-check '(1 2 2 4 5 1)))
(not (verhoeff-check '(1 2 8 4 5 1)))
(equal (string-verhoeff "75872") "2")
(equal (string-verhoeff "758722" -1) "0")
(equal (string-with-verhoeff "12345") "123451")
(string-verhoeff-check "123451")
(not (string-verhoeff-check "122451"))
)
(error "Verhoeff checksum testing failure"))
(defun okpo (arr)
(let*
(
(first-cs (mod (loop for k upfrom 0 for n in arr sum (* (1+ (mod k 10)) n)) 11))
(second-cs (mod (loop for k upfrom 2 for n in arr sum (* (1+ (mod k 10)) n)) 11))
)
(cond
((< first-cs 10) first-cs)
((< second-cs 10) second-cs)
(t 0)
)
))
(or
(and
(= (okpo '( 0 9 8 0 8 1 1 )) 7)
(= (okpo '( 3 8 2 7 0 9 5 )) 1)
)
(error "OKPO checksum testing failure"))
(defun list-unroll (l)
(let
((res nil)
(lf (find-if (lambda (x) (and (listp x) x)) l)))
(if lf
(loop
for n upfrom 0
for d in lf
do (push (loop for e in l
collect
(if (listp e)
(nth n e)
e)) res))
(push l res)
)
(reverse res)))
(mccme-helpers/packages:file mccme-helpers/cookie
:use (mccme-helpers/parsetype
mccme-helpers/password
local-time
)
:export (
#:with-cookie-key
#:save-value-cookie
#:load-value-cookie
#:set-secure-cookie
#:get-secure-cookie
)
)
(mccme-helpers/packages:alias-package hunchentoot ht)
(defvar *cookie-key* "00000000000000000")
(defmacro with-cookie-key (key &body body)
`(progv
'(*cookie-key*)
(list ,key)
,@body))
(defun crypto-key (password)
(let* (
(hasher (make-instance 'ironclad:pbkdf2 :digest :sha1))
(key (ironclad:derive-key hasher
(
#+sbcl sb-ext:string-to-octets
#+ccl ccl:encode-string-to-octets
password :external-format :utf-8)
(make-array 8 :initial-element 32 :element-type '(unsigned-byte 8))
1
32)))
key
))
(defun random-iv (length)
(let ((res (make-array length :element-type '(unsigned-byte 8)
:initial-element 0)))
(if (probe-file "/dev/urandom")
(with-open-file (f "/dev/urandom" :element-type '(unsigned-byte 8))
(read-sequence res f))
(loop for k from 0 to length do (setf (elt res k) (random 256))))
res))
(defun unencrypt-aes (x key)
(let* (
(iv-text (subseq x 0 32))
(iv (base16-string-to-octet-array iv-text))
(cipher (ironclad:make-cipher :aes :key key :mode :ofb
:initialization-vector iv))
(ciphertext (subseq x 32))
(byte-arr (base16-string-to-octet-array ciphertext))
(buffer (make-array (length byte-arr) :initial-element 32 :element-type '(unsigned-byte 8)))
(dummy (ironclad:decrypt cipher byte-arr buffer))
(output (
#+sbcl sb-ext:octets-to-string
#+ccl ccl:decode-string-from-octets
buffer :external-format :utf-8))
)
(declare (ignorable dummy))
output
))
(defun encrypt-aes (x key)
(let* (
(iv (random-iv 16))
(iv-text (octet-array-to-base16-string iv))
(cipher (ironclad:make-cipher :aes :key key :mode :ofb
:initialization-vector iv))
(byte-arr (
#+sbcl sb-ext:string-to-octets
#+ccl ccl:encode-string-to-octets
x :external-format :utf-8))
(buffer (make-array (length byte-arr) :initial-element 32 :element-type '(unsigned-byte 8)))
(dummy (ironclad:encrypt cipher byte-arr buffer))
(output-text (octet-array-to-base16-string buffer))
(output (concatenate 'string iv-text output-text))
)
(declare (ignorable dummy))
output
))
(defun save-value-cookie (value)
(let* (
(hash (hash "sha512" (concatenate 'string *cookie-key* value *cookie-key*)))
(hash-str (octet-array-to-base16-string (subseq hash 0 16)))
(timestamp-str (format nil "~12,'0d" (timestamp-to-unix (now))))
(string-to-save (concatenate 'string timestamp-str value hash-str))
(key-salt (format nil "~10,10,'0r" (random 999999999)))
(password (concatenate 'string key-salt *cookie-key*))
(real-key (crypto-key password))
)
(concatenate 'string
key-salt
(encrypt-aes string-to-save
real-key))
))
(defun load-value-cookie (cookie &optional timeout)
(ignore-errors
(let* (
(timeout (or timeout 86400))
(key-salt (subseq cookie 0 10))
(password (concatenate 'string key-salt *cookie-key*))
(real-key (crypto-key password))
(ciphertext (subseq cookie 10))
(plaintext (unencrypt-aes ciphertext real-key))
(text-length (length plaintext))
(checkhash (subseq plaintext (- text-length 32)))
(output (subseq plaintext 12 (- text-length 32)))
(timestamp-old (parse-integer (subseq plaintext 0 12)))
(timestamp-fresh (timestamp-to-unix (now)))
(hash (hash "sha512" (concatenate 'string *cookie-key* output *cookie-key*)))
(hash-str (octet-array-to-base16-string (subseq hash 0 16)))
)
(when
(and
(equalp checkhash hash-str)
(< (- timestamp-fresh timestamp-old) timeout)
)
output)
)))
(defun set-secure-cookie (name value)
(when ht:*request*
(if value (ht:set-cookie name
:value (save-value-cookie value)
:path "/")
(ht:set-cookie name :value "" :path "/"))))
(defun get-secure-cookie (name &optional timeout)
(load-value-cookie (and (boundp 'ht:*request*) (ht:cookie-in name))
timeout))
This diff is collapsed.
This diff is collapsed.
(mccme-helpers/packages:file mccme-helpers/db-auth
:use (mccme-helpers/basic-db
:iterate
)
:export (
#:login-correct-p
#:*db-auth-schema*
#:create-user
#:create-user-case-insensitive
#:edit-user
#:login-to-user-id
)
)
(defun login-correct-p (username password &key known-stored-hash)
#.(sql-on)
(and
username
password
(let* (
(stored-hash
(or
known-stored-hash
(with-db (caar (clsql:select [password] :from [account] :where [= [account login] username])))))