hackerbase/src/mbase-dir.scm

;;
;; mbase-dir.scm
;;
;; Storage for member files.
;;
;; 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 mbase-dir))

(module
 mbase-dir
 (
  load-mbase-dir
  mbase-dir-load-member
  mbase-dir-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken pathname)
	 (chicken file posix)
	 (chicken file)
	 (chicken format)
	 (chicken irregex)
	 srfi-1
	 testing
	 util-bst-ldict
	 brmember
	 brmember-parser)

 ;; Gets all files and symbolic links from given directory. The
 ;; symbolic links are represented by cons cells with car being the
 ;; name and cdr the link target.
 (define (get-files+symlinks dn)
   (let loop ((fns (directory dn))
	      (rs '()))
     (if (null? fns)
	 rs
	 (let* ((fn (car fns))
		(ffn (make-pathname dn fn)))
	   (loop (cdr fns)
		 (if (symbolic-link? ffn)
		     (cons (cons (string->symbol fn)
				 (string->symbol (read-symbolic-link ffn)))
			   rs)
		     (if (regular-file? ffn)
			 (cons (string->symbol fn) rs)
			 rs)))))))

 ;; Converts a list of symlinks and files in aforementioned format
 ;; into a dictionary of regular files as keys with lists of symlinks
 ;; as values. If the target file does not exist, adds 'error-0 symbol
 ;; as the first alias to this list with the number increasing with
 ;; each nonexistent file encountered. The error record is also
 ;; generated for symlinks pointing outside of the directory.
 (define (files+symlinks->files-dictionary ls)
   (let* ((links (filter pair? ls))
	  (files (filter symbol? ls))
	  (fdict
	   (let loop ((files files)
		      (res (make-ldict)))
	     (if (null? files)
		 res
		 (loop (cdr files)
		       (ldict-set res (car files) '()))))))
     (let loop ((links links)
		(res fdict)
		(errs 0))
       (if (null? links)
	   res
	   (let* ((link (car links))
		  (name (car link))
		  (target (cdr link)))
	     (if (ldict-contains? res target)
		 (loop (cdr links)
		       (ldict-set res target (cons name (ldict-ref res target)))
		       errs)
		 (loop (cdr links)
		       (ldict-set res target
				 (list (string->symbol (sprintf "error-~A" errs))
				       name))
		       (+ errs 1))))))))

 
 ;; 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 true if the list contains at least one 4-digit symbol.
 (define (list-contains-4digit-symbol? lst)
   (let loop ((lst lst))
     (if (null? lst)
	 #f
	 (if (is-4digit-symbol? (car lst))
	     #t
	     (loop (cdr lst))))))

 ;; 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))))))

 ;; Returns dictionary containing only records with either 4-digit
 ;; name or one of its aliases being 4-digit.
 (define (files-dictionary-filter-4digit-symbols d)
   (ldict-filter
    (lambda (k v)
      (list-contains-4digit-symbol? (cons k v)))
    d))

 ;; Loads the members directory as dictionary of files to symlinks
 ;; mapping.
 (define (load-mbase-dir dn)
   (files-dictionary-filter-4digit-symbols
    (files+symlinks->files-dictionary
     (get-files+symlinks dn))))

 ;; Returns a dictionary containing file-name, symlinks, id and info
 ;; keys. The info key contains whatever load-member-file from the
 ;; member-file module returns. The id key contains whatever is the
 ;; first 4-digit symbol in (cons fname aliases) list.
 (define (mbase-dir-load-member mdir fname symlinks)
   (let* ((mr0 (make-brmember fname
			      (make-pathname mdir (symbol->string fname))
			      symlinks)))
     (load-brmember-file mr0)))

 ;; Performs self-tests of this module.
 (define (mbase-dir-tests!)
   (run-tests
    mbase-dir
    (test-equal? files+symlinks->files-dictionary
		 (files+symlinks->files-dictionary
		  '(joe (2803 . joe)))
		 (make-ldict '((joe 2803))))
    (test-equal? files+symlinks->files-dictionary
		 (files+symlinks->files-dictionary
		  '(joe
		    (2803 . joe)
		    (666 . nonexistent)))
		 (make-ldict
		  '((joe 2803)
		    (nonexistent error-0 666))))
    (test-true is-4digit-string? (is-4digit-string? "0000"))
    (test-false is-4digit-string? (is-4digit-string? "AAAA"))
    (test-false is-4digit-string? (is-4digit-string? "666"))
    (test-true is-4digit-symbol? (is-4digit-symbol? '|0000|))
    (test-false is-4digit-symbol? (is-4digit-symbol? '|ABC|))
    (test-true list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|0000| abc |666|)))
    (test-false list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|00000| abc |666|)))
    (test-eq? get-4digit-symbol-from-list
	      (get-4digit-symbol-from-list '(|000| abc |6666| qwer))
	      '|6666|)
    ))

 )