brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Rename member-record to brmember.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-11 21:45:34 +02:00
parent 8a92187a45
commit 2a9b04d8d6
2 changed files with 15 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

422
src/brmember.scm Normal file
View file

@ -0,0 +1,422 @@
;;
;; member-record.scm
;;
;; Procedures working with complete member record (as loaded by the
;; members-base).
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.
;;
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;
(declare (unit member-record))
(module
member-record
(
make-member-record
member-file-name
member-file-path
member-record-input-file
member-record-set
member-record-add-highlight
member-record-sub-ref
member-record-sub-set
member-record-sub-prepend
member-record-sub-has-key?
member-record-sub-ensure
member-source
member-record-info
member-missing-keys
member-has-highlights?
member-record-usable?
member-has-problems?
member-destroyed?
member-suspended?
member-active?
member-student?
member-existing?
member-flags
member-nick
member-id
member-suspended-months
member<?
member-record-add-payment
member-payments
member-mailman
member-add-mailman
member-record-tests!
)
(import scheme
(chicken base)
(chicken keyword)
(chicken irregex)
(chicken string)
(chicken format)
util-dict-list
testing
month
period
configuration
primes
util-list
bank-account)
;; Checks whether given string is a 4-digit decimal number.
(define (is-4digit-string? s)
(if (irregex-search (irregex "^[0-9]{4}$") s)
#t
#f))
;; checks whether given symbol is a 4-digit one.
(define (is-4digit-symbol? s)
(is-4digit-string?
(symbol->string s)))
;; Returns the first 4-digit symbol from the list.
(define (get-4digit-symbol-from-list lst)
(let loop ((lst lst))
(if (null? lst)
#f
(if (is-4digit-symbol? (car lst))
(car lst)
(loop (cdr lst))))))
;; Creates new member record based on the file and symlinks
;; information received from the members directory. Any keyword
;; arguments are converted to respective symbols in the dictionary.
(define (make-member-record file-name file-path symlinks . args)
(let loop ((args args)
(pairs `((file-name . ,file-name)
(file-path . ,file-path)
(symlinks . ,symlinks)
(id . ,(string->number
(symbol->string
(get-4digit-symbol-from-list (cons file-name symlinks))))))))
(if (null? args)
(make-ldict pairs)
(if (not (keyword? (car args)))
(error 'make-member-record "Optional arguments must be keywords" (car args))
(if (null? (cdr args))
(error 'make-member-record "Each optional keyword argument must have a value" (car args))
(loop (cddr args)
(cons (cons (string->symbol (keyword->string (car args)))
(cadr args))
pairs)))))))
;; File name without directory
(define (member-file-name mr)
(ldict-ref mr 'file-name))
;; Convenience accessor for file name with directory
(define (member-file-path mr)
(ldict-ref mr 'file-path))
;; Returns opened input file for this record (used by parser).
(define (member-record-input-file mr)
(open-input-file
(ldict-ref mr 'file-path)))
;; Sets pairs of keys/values for given member record.
(define (member-record-set mr . args)
(let loop ((args args)
(mr mr))
(if (null? args)
mr
(if (not (keyword? (car args)))
(error 'member-record-set "Needs argument keyword" (car args))
(if (null? (cdr args))
(error 'member-record-set "Argument needs value" (car args))
(loop (cddr args)
(ldict-set mr (string->symbol (keyword->string (car args)))
(cadr args))))))))
;; Adds highlight identified by line number, message, pass number and
;; type (error, warning, info).
(define (member-record-add-highlight mr line-number message pass type)
(ldict-set mr 'highlights
(cons (list line-number message pass type)
(ldict-ref mr 'highlights '()))))
;; Returns a key from particular section
(define (member-record-sub-ref mr sec key . defaults)
(let ((sec-dict (ldict-ref mr sec)))
(if (null? defaults)
(ldict-ref sec-dict key)
(ldict-ref sec-dict key (car defaults)))))
;; Sets a key in particular section
(define (member-record-sub-set mr sec key val)
(let ((sec-dict (ldict-ref mr sec)))
(ldict-set mr sec
(ldict-set sec-dict key val))))
;; Prepends value to given subkey
(define (member-record-sub-prepend mr sec key val)
(member-record-sub-set mr sec key
(cons val
(member-record-sub-ref mr sec key '()))))
;; Returns true if given section contains given key
(define (member-record-sub-has-key? mr sec key)
(ldict-contains? (ldict-ref mr sec) key))
;; Returns new member record with section updated by defaults, the
;; section must already exist.
(define (member-record-sub-ensure mr sec . kvs)
(let loop ((kvs kvs)
(sd (ldict-ref mr sec)))
(if (null? kvs)
(ldict-set mr sec sd)
(if (null? (cdr kvs))
(error 'member-record-sub-ensure "Needs pairs of keys and values" kvs)
(let ((key (car kvs))
(val (cadr kvs)))
(loop (cddr kvs)
(if (ldict-contains? sd key)
sd
(ldict-set sd key val))))))))
;; Returns source lines
(define (member-source mr)
(ldict-ref mr 'source '()))
;; Returns member info key value
(define (member-record-info mr key . defaults)
(let ((info (ldict-ref mr 'info)))
(if (null? defaults)
(ldict-ref info key)
(ldict-ref info key (car defaults)))))
;; Return mandatory keys with #f as value
(define (member-missing-keys mr)
(ldict-reduce '()
(lambda (acc k v)
(if v acc (cons k acc)))
(ldict-ref mr 'info)))
;; True if there are any source highlights
(define (member-has-highlights? mr)
(ldict-contains? mr 'highlights))
;; Returns true if there is at least one highlight of given type
(define (member-highlights-has-type? mr type)
(let loop ((hls (ldict-ref mr 'highlights '())))
(if (null? hls)
#f
(if (eq? (cadddr (car hls)) type)
#t
(loop (cdr hls))))))
;; Returns true if there is at least one highlight with error type
(define (member-has-errors? mr)
(member-highlights-has-type? mr 'error))
;; Absolutely required
(define (member-record-usable? mr)
(ldict-contains? (ldict-ref mr 'info) 'member))
;; True if member record is OK
(define (member-has-problems? mr)
(or (member-has-errors? mr)
(not (member-record-usable? mr))
(not (is-4digit-prime? (member-id mr)))))
;; Returns true if the member record represents non-existing
;; member. The *current-month* is a global parameter from period
;; module.
(define (member-destroyed? mr)
(and (not (member-existing? mr))
(let ((member (member-record-info mr 'member)))
(if (null? member)
#f
(month>=? (*current-month*)
(period-since (car member)))))))
;; Generic period-based predicate
(define ((member-period-predicate? key) mr)
(let ((periods (member-record-info mr key #f)))
(and periods
(month-in-periods? periods))))
;; Returns true if the member is now suspended
(define member-is-suspended?
(member-period-predicate? 'suspend))
;; Suspended must not be destroyed
(define (member-suspended? mr)
(and (member-is-suspended? mr)
(not (member-destroyed? mr))))
;; True if the member is student
(define member-is-student?
(member-period-predicate? 'student))
;; Only active members can be students.
(define (member-student? mr)
(and (member-active? mr)
(member-is-student? mr)))
;; Returns true if the member is active (not suspended or destroyed).
(define (member-active? mr)
(and (month-in-periods? (member-record-info mr 'member))
(not (member-suspended? mr))))
;; Returns true if the member is currently a member
(define (member-existing? mr)
(month-in-periods?
(member-record-info mr 'member)))
;; Returns a list of flags of given member record.
(define (member-flags mr)
(filter identity
(list (if (member-student? mr) 'student #f)
(if (member-suspended? mr) 'suspended #f)
(if (member-active? mr) 'active #f)
(if (member-destroyed? mr) 'destroyed #f)
(if (member-existing? mr) 'existing #f))))
;; Nickname as string
(define (member-nick mr)
(member-record-info mr 'nick))
;; Returns member id
(define (member-id mr)
(ldict-ref mr 'id))
;; Returns the number of months the user is suspended. Zero if not
;; suspended.
(define (member-suspended-months mr)
(if (member-suspended? mr)
(let ((period (periods-match (member-record-info mr 'suspend))))
(if period
(month-diff (car period) (*current-month*))
0))
0))
;; Comparator of member records based on nickname.
(define (member<? a b)
(string-ci<? (member-nick a)
(member-nick b)))
;; Prepends new payment to given member record payments
(define (member-record-add-payment mr pt)
(ldict-set mr 'payments
(cons pt
(ldict-ref mr 'payments '()))))
;; Returns alist of member payments
(define (member-payments mr)
(filter (lambda (tr)
(let* ((isodate (bank-transaction-date tr))
(month (iso-date->month isodate)))
(month<=? month (*current-month*))))
(ldict-ref mr 'payments '())))
;; Returns a list of MLs this member is subscribed to
(define (member-mailman mr)
(ldict-ref mr 'mailman '()))
;; Adds given ML to given member record
(define (member-add-mailman mr ml)
(ldict-set mr 'mailman
(cons ml
(member-mailman mr))))
;; Self-tests
(define (member-record-tests!)
(run-tests
member-record
(test-true make-member-record
(ldict-equal?
(make-member-record '|1234| "members/1234" '(|member|))
(make-ldict
'((file-name . |1234|)
(file-path . "members/1234")
(symlinks |member|)
(id . 1234)))))
(test-true make-member-record
(ldict-equal?
(make-member-record '|1234| "members/1234" '(|member|) #:msg "msg")
(make-ldict
'((msg . "msg")
(file-name . |1234|)
(file-path . "members/1234")
(symlinks |member|)
(id . 1234)))))
(test-true member-record-set
(ldict-equal?
(member-record-set (make-ldict) #:id 1234)
(make-ldict
'((id . 1234)))))
(test-true member-record-add-highlight
(ldict-equal?
(member-record-add-highlight (make-ldict) 123 "Interesting..." 0 'info)
(make-ldict
'((highlights . ((123 "Interesting..." 0 info)))))))
(test-true member-destroyed?
(parameterize ((*current-month* (list 2023 2)))
(member-destroyed?
(make-ldict `((info . ,(make-ldict
`((member . (((2010 1) (2010 5))))))))))))
(test-false member-destroyed?
(parameterize ((*current-month* (list 2009 2)))
(member-destroyed?
(make-ldict `((info . ,(make-ldict
`((member . (((2001 1) (2010 5))))))))))))
(test-false member-suspended?
(member-suspended?
(make-ldict `((info . ,(make-ldict
`((member . (((2015 1) #f))))))))))
(test-true member-suspended?
(parameterize ((*current-month* (list 2015 2)))
(member-suspended?
(make-ldict `((info . ,(make-ldict
`((member . (((2015 1) #f)))
(suspend ((2010 1) (2022 4) #f #f))))))))))
(test-true member-suspended?
(parameterize ((*current-month* (list 2015 2)))
(member-suspended?
(make-ldict `((info . ,(make-ldict
`((member . (((2015 1) #f)))
(suspend ((2010 1) #f #f #f))))))))))
(test-false member-suspended?
(parameterize ((*current-month* (list 2023 2)))
(member-suspended?
(make-ldict `((info . ,(make-ldict
`((member . (((2015 1) #f)))
(suspend ((2010 1) (2022 4) #f #f))))))))))
(test-true member-active?
(parameterize ((*current-month* (list 2023 2)))
(member-active?
(make-ldict `((info . ,(make-ldict
`((member . (((2015 1) #f)))
(suspend ((2010 1) (2022 4) #f #f))))))))))
))
)