;;; -*- mode:lisp; base:10.; package:user; -*- ;;; ;;; $Header: /ct/ctlisp/protect.l,v 1.24 85/06/27 16:40:09 bill Exp $ (putprop 'protect "$Revision: 1.24 $" 'rcs_revision) ;;; PROTECT ;;; ******* WARNING ******* ;;; ;;; I hacked this to IGNORE PROTECTION on the Lambda. Fix at your own leisure . . . ;;; Richard Mark Soley, 14 August 1985 ;;; This file implements a software protection scheme, preventing ;;; unauthorized use by checking a site password. On the VAX, it assumes ;;; ct_load_def definitions for the symbols 'exebin (the executable binary ;;; file and 'syspwd (the system password file. On the LISP Machine, it assumes ;;; only a ct_load_def for 'syspwd. ;;; To protect a software module, insert the function call: ;;; (protect 'module) ;;; where module is a standard issue module. If the customer ;;; has authorization to use the stated module on that day, protect ;;; will return a string that should be printed on the customer's ;;; terminal. (This identifies the licence holder.) If the ;;; customer is not authorized, protect will exit lisp. ;;; (protect 'module form1 form2 ...) will execute the forms ;;; before exit if the user is not authorized. These can be used ;;; to print informative messages. ;;; To generate a user's password on the VAX, run the following function: ;;; (password begin-day begin-month begin-year ;; end-day end-month end-year ;;; PID '(module1 module2 ...) "Site ID String") ;;; ;;; Where date1 and date2 are of the form (numeric-month year) ;;; PID is the contents of the user's PID register on the VAX ;;; (a 32 bit integer), and module1, etc. are the modules for which ;;; the user is authorized. ;;; To generate a user's password on the LISP MACHINE, run the following function: ;;; NOTE: This function gets its arguments through keywords. ;;; ;;; (password 'begin-day begin-day 'begin-month begin-month 'begin-year begin-year ;;; 'end-day end-day 'end-month end-month 'end-year end-year ;;; 'network-address network-address-list ;;; 'module-list '(module1 module2 ...) ;;; 'site-id "Site ID String") ;;; ;;; Begin-month, begin-year, end-month and end-year are numeric arguments. ;;; Network-address is a LIST of the authorized network addresses for ;;; the machines at this site. For an LM2, each network address ;;; is the result of the function (send si:local-host ':network-addresses). ;;; Currently for the 3600, the same function is used. However, once ethernet ;;; addressing is stable on the 3600, the network address should be a list whose ;;; elements are chaos:*my-ethernet-first*, chaos:*my-ethernet-second*, ;;; and chaos:*my-ethernet-last*. The module-list (module1, etc.) are the modules for which ;;; the user is authorized. ;;; The site id is a string that should include both the customer name, and ;;; some identification of the machine itself. For example, ;;; ;;; "Computer * Thought BigBird" ;;; or "Computer * Thought Ostrich" ;;; ;;; This string will be returned by the call to protect if the site passes ;;; the protection checking. ;;; To change the local password, run the function ;;; CHANGE-LOCAL-PASSWORD with the same keyword arguments as above for LISP machines ;;; and without keyword arguments for VAXes. ;;; **************** ;;; Improvements ;;; **************** ;;; ;;; This file is being improved to allow a more general protection ;;; scheme. ;;; ;;; The protection file to be maintained at the customer site will ;;; be an encoded keyword list. Once translated back into LISP, ;;; the list will contain alternating keywords and values. This scheme ;;; will be completely general, allowing all sorts of information to ;;; be stored. The currently defined keywords are: ;;; ;;; KEYWORD VALUE ;;; :from A list of (day month year) ;;; :to A list of (day month year) ;;; :pid A decimal number (VAX only) ;;; :network-address A list of valid network locations. (LISP Machines only) ;;; These can be either chaosnet addresses for LM2's or ethernet ;;; addresses composed of a list ;;; of the three components that make up the ethernet address ;;; for 3600's ;;; :mods A list of module names (mod1 mod2 ...) ;;; :site-id A string "customer-name machine-name" ;;; Data are encoded by exploding the LISP list into a list of characters, ;;; and then translating the characters into clusters of letters. Some ;;; randomness is introduced, so the same letter may be encoded in many ;;; different ways. There are also non-valid representations, so that ;;; randomly permuting the letter combinations will result in many completely ;;; invalid combinations. Random permutation will also fail, since the ;;; thief attempting this will likely permute the keywords as well. ;;; ;;; Each character is encoded as a cluster of letters. The number of ;;; letters in a cluster is a Lisp constant, defined below. You can ;;; change the constant if you want, to allow "more protection". Changing ;;; this number will NOT affect old files; they will continue to be read ;;; correctly. ;;; On the other hand, it is not a good idea to change the other number ;;; lying around here: 256 is the magic quantity that tells how many ;;; pseudo-characters are encoded, only the first 128 of which are valid. ;;; Changing this number will require changing everyone's passwords ;;; worldwide. ;;; ;;; Error messages to the user will be kept simple, so as not to identify ;;; the nature of the error. Instead, error codes are also printed. C*T ;;; personnel may translate these error codes to identify a particular ;;; problem. ;;; Error codes currently defined are: ;;; ;;; CODE MEANING ;;; 101 The binary program is missing or unprotected. ;;; 102 The C*T password file cannot be found. ;;; 103 The C*T password is not in the correct format. ;;; 104 The license does not cover the stated module. ;;; 105 This processor isn't licensed. (Check PID or network-address) ;;; 106 License has expired. ;;; 107 Password file corrupted. ;;; 108 Password file missing or protected. ;;; 109 Illegal characters in the password. ;;; 110 There are not enough tokens in the password. ;;; 111 There are no modules specified in the password. ;;; 112 There is no PID or network-address in the password. ;;; 113 There is no FROM date in the password. ;;; 114 There is no TO date in the password. ;;; 115 There is no Site ID string in the password. (defconst *protect-errors* '((101 . "~%The binary program is missing or unprotected.") (102 . "~%The C*T password file is missing or protected.") (103 . "~%The C*T password file is not in the correct format.") (104 . "~%The module ~A is not licensed.") (105 . "~%Your processor not licensed for this software.") (106 . "~%Your license has expired.") (107 . "~%The C*T password file is not in the correct format.") (108 . "~%The C*T password file is missing or protected.") (109 . "~%The C*T password file is not in the correct format.") (110 . "~%The C*T password file is not in the correct format.") (111 . "~%The C*T password file is not in the correct format.") (112 . "~%The C*T password file is not in the correct format.") (113 . "~%The C*T password file is not in the correct format.") (114 . "~%The C*T password file is not in the correct format.") (115 . "~%The C*T password file is not in the correct format.") )) #+franz (declare (macros t)) ;;; Load in Alfred's hack to read the processor ID. #+(and vms franz) (cfasl "dra1:[ct]getsid.o" '_get_sid 'get_sid 'integer ",dra0:[eunice.lib]libc/lib") #+franz (ct_load 'format) ; Get format to allow nice printing. #+franz ; We need the loop code for franz (eval-when (compile load eval) (ct_load 'lispmloop)) ;;; There must be a ct_load_def for SYSPWD, the C*T password ;;; file. This is a file written by the user containing the C*T ;;; password, which we supply to them. Protect reads this file ;;; periodically. ;;; On the VAX version, there must be a ct_load_def for EXEBIN, which points to ;;; a non-readable file. Eventually, this will be the executable ;;; binary file, so we make sure the customer can't routinely copy ;;; it. ;;; **************************************************************** ;;; Externally available code. ;;; **************************************************************** ;;; Insert liberally into code. It returns the SITE ID STRING if ;;; successful, so you can print it. ;;;;;;; #-Lambda (defmacro protect (module &body forms) ;;;;;;; `(let ((string (recursively_remove_a_dirictory ,module))) (cond ((not (stringp string)) ,@forms ;;eval forms, if any, #+franz(exit) ;;and leave Lisp. #+lispm(format t "~%You are not authorized.") #+lispm (send current-process ':kill)) (t string)))) #+Lambda (defmacro protect (module &body forms) `(progn ,@forms "Computer * Thought ADA")) ;;; Soft Protect will allow some recovery. If authorized, returns the ;;; string for printing. If not authorized for a particular module, ;;; but everything else seems fine, will return nil, allowing the ;;; caller to redirect. (You can also accomplish this by *throwing ;;; from protect.) Also, if there is a module access violation, ;;; NO ERROR WILL BE PRINTED. ;;;;;;;;;;;; #-Lambda (defmacro soft-protect (module &body forms) ;;;;;;;;;;;; `(let ((string (recursively_remove_a_dirictory ,module t))) (cond ((not string) ; hard failure ,@forms #+franz(exit) #+lispm(format t "~%You are not authorized!!")) ((not (stringp string)) nil) (t string)))) #+Lambda (defmacro soft-protect (module &body forms) `(progn ,@forms "Computer * Thought ADA")) ;;; **************************************************************** ;;; Internal functions, etc. ;;; **************************************************************** ;;; Macro for use with int-protect. #+franz ;;;;;;;;;;;;; (defmacro protect-error (rtn-val err-code &rest args) ;;;;;;;;;;;;; `(progn (format t (ct_string_append "~%Protection error code ~D." (cdr (assq ,err-code *protect-errors*)) "~%Consult your system administrator.~%") ,err-code ,@args) (return ,rtn-val))) #+lispm ;;;;;;;;;;;;; (defmacro protect-error (rtn-val err-code &rest args) ;;;;;;;;;;;;; `(progn (format t (string-append "~%Protection error code ~D." (cdr (assq ,err-code *protect-errors*)) "~%Consult your system administrator.~%") ,err-code ,@args) (return ,rtn-val))) ;;; Does a get on the property-list, but if NIL, calls protect-error. ;;;;;;;;;;; (defmacro protect-get (plist ind err) ;;;;;;;;;;; `(or (get ,plist ,ind) (protect-error nil ,err))) ;;; Int-protect reads the password file, and does the right ;;; comparisons. Returns the Site ID string, so it can be printed ;;; for guilt-trips. ;;; ;;; Note the unfortunate use of error numbers. These are here ;;; to confuse the customer, not because I hate lisp. Sorry. ;;; #+franz (defun recursively_remove_a_dirictory (module &optional dont-print-soft-error) (let ((base 10.) (ibase 10.)) (prog (password stream) ;; If the binary image is readable, don't continue. (cond ((readable-binary-file (ct_load_get 'exebin)) (protect-error nil 101))) (cond ((not (probef-password (ct_load_get 'syspwd))) (protect-error nil 102))) (or (setq password (read-password (ct_load_get 'syspwd))) (return nil)) (setq password (decrypt password)) (cond ((not password) (protect-error nil 109))) (cond ((not (greaterp (length password) 6)) (protect-error nil 110))) (setq password (cons nil password)) ;; Password is NOW a disembodied property list. ;; If everything matches, return the string. (cond ((not (or (memq (protect_keywordify all) (protect-get password ':mods 111)) (memq (protect_keywordify module) (protect-get password ':mods 111)))) (or dont-print-soft-error (protect-error nil 104 module)) (return t)) ; Return T for soft-protect. ((not (or (equal (car (protect-get password ':pid 112)) nil) (equal (protect-get password ':pid 112) (get-machine-pid)))) (protect-error nil 105)) ((not (date-less-p (protect-get password ':from 113) (list (cadddr (status localtime)) (1+ (caddddr (status localtime))) (cadddddr (status localtime))) (protect-get password ':to 114))) (protect-error nil 106)) (t (return (protect-get password ':site-id 115))))))) ;;; Int-protect reads the password file, and does the right ;;; comparisons. Returns the Site ID string, so it can be printed ;;; for guilt-trips. ;;; ;#+lispm ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun recursively_remove_a_dirictory (module &optional dont-print-soft-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((ibase 10.) (base 10.)) (multiple-value-bind (ignore ignore ignore date month year) (time:get-time) (prog (password ) (cond ((not (probef-password (ct_load_get 'syspwd))) (protect-error nil 102))) (or (setq password (read-password (ct_load_get 'syspwd))) (return nil)) (setq password (decrypt password)) (cond ((not password) (protect-error nil 109))) (cond ((not (greaterp (length password) 6)) (protect-error nil 110))) (setq password (cons nil password)) ;; Password is NOW a disembodied property list. ;; If everything matches, return the string. (cond ((not (or (member (protect_keywordify 'all) (protect-get password ':mods 111)) (member (protect_keywordify module) (protect-get password ':mods 111)))) ;(break look-at-module) (or dont-print-soft-error (protect-error nil 104 module)) (return t)) ; Return T for soft-protect. ;;;this should be #+cadr when ethernet addressing works ((not (or (null (get password ':network-address)) (member (second (first (send si:local-host ':network-addresses))) (protect-get password ':network-address 112)))) (protect-error nil 105)) ;;;;;;;;Once ethernet addressing works on the 3600, i.e. the following symbols ;;;;;;;;for the ether-address are bound, this should be uncommented and the abov ;;;;;;;;cond should be a #+cadr ;; #-cadr ;; ((not (member (list chaos:*my-ether-address-first* ;; chaos:*my-ether-address-second* ;; chaos:*my-ether-address-last*) ;; (protect-get password ':ethernet-first 112))) ;; (protect-error nil 105)) ((not (date-less-p (protect-get password ':from 113) (list date month year) (protect-get password ':to 114))) (protect-error nil 106)) (t (return (protect-get password ':site-id 115)))))))) ;;;A list of a time stamp and an encrypted password. (defvar *xyzzy* (list nil nil)) ;;;Password time delta. The password is reread after this much time has passed. (defconstant *ptd* (time:parse-interval-or-never "10 minutes")) #+lispm (defun read-password (file) (when (or (not (fixp (first *xyzzy*))) (< (time:get-universal-time) (first *xyzzy*)) (> (time:get-universal-time) (+ (first *xyzzy*) *ptd*))) (setf (second *xyzzy*) (read-password-int file)) (setf (first *xyzzy*) (time:get-universal-time))) (second *xyzzy*)) #+lispm (defun probef-password (file) (if (or (not (fixp (first *xyzzy*))) (< (time:get-universal-time) (first *xyzzy*)) (> (time:get-universal-time) (+ (first *xyzzy*) *ptd*))) (probef file) t)) ;;; Reads the C*T password from a specified file. We ;;; have already probed for the file, so we know it exists. ;;; It may still not be available for read, so be cautious. ;;; We also guarantee that what is read is a list. ;;; ;;; A change made in November, 1983 DISALLOWS use of parens ;;; in the file. We merely read in the tokens, one at a time, ;;; and assimilate a list. #+franz (defun read-password-int (file &aux list) (prog () (let ((stream (errset (infile file) nil))) (cond (stream (unwind-protect (setq list (loop for item = (read (car stream)) until (null item) collect item)) (close (car stream))) (return list)) (t (protect-error nil 102)))))) #+lispm (defun read-password-int (file) (condition-case () (with-open-file (stream file) (loop for item = (read stream nil) until (null item) collect item)) (error (prog () (protect-error nil 102))))) ;;; Checks to see if a particular file is readable. It should ;;; not be, but must exist. This function returns T if the ;;; file does not exist, or if it can be read. ;;; We don't use this on the lisp machine version. #+franz ;;;;;;;;;;;;;;;;;;;; (defun readable-binary-file (filename) ;;;;;;;;;;;;;;;;;;;; (cond #-vms ((not (probef filename)) t) ((errset (infile filename) nil) t) (t nil))) ;;; Retrieves the machines PID #+(and franz (not vms)) (defun get-machine-pid () 0) ;;Temporarily, they are all 0. ;;; Use Alfred's software to read the processor ID. #+(and franz vms) (defun get-machine-pid () (get_sid)) ;;; The format of dates is now a LIST of (day month year). THis is ;;; not compatible with any old versions. If you need MORE accurate ;;; dating, tough luck!! ;;;;;;;;;;; (defun date-less-p (dat1 dat2 dat3) ;;;;;;;;;;; (let ((d1 (+ (first dat1) (* 31 (second dat1)) (* 366. (third dat1)))) (d2 (+ (first dat2) (* 31 (second dat2)) (* 366. (third dat2)))) (d3 (+ (first dat3) (* 31 (second dat3)) (* 366. (third dat3))))) (and (not (greaterp d1 d2)) (not (greaterp d2 d3))))) #+lispm (defun protect_keywordify (symbol) (cond ((eq (symbol-package symbol) si:pkg-keyword-package) symbol) (t (intern (string symbol) si:pkg-keyword-package)))) ;;; **************************************************************** ;;; Encryption algorithms ;;; **************************************************************** #| ;;; ;;; Old scheme commented out ;;; ;;; The algorithms here will encrypt and decrypt a Lisp List, preserving ;;; equality. The encrypted list is itself a list of upper-case atoms ;;; convenient for typing into a file. ;;; Encryption is actually done by exploding the list, and encrypting ;;; each character. The encryption is not terribly complicated, but ;;; should thwart most urchins. Anyone seriously interested will find ;;; ways around our software, anyway. ;;; BY THE WAY, THIS IS A GOOD PLACE TO NOTE: Hackers are not bad ;;; people. The abuse of the term "hacker" is becoming prevelent, ;;; with detrimental effect. Our enemy is not the hacker, but the ;;; criminal. Hackers wrote this software. #+franz (defun encrypt (list) (mapcar #'(lambda (char) (encrypt-char (car (substringn char 1 1)))) (explode list))) #+lispm (defun encrypt (list) (mapcar #'(lambda (char) (encrypt-char (character char))) (explode list))) ;;; Decrypt checks for valid characters, then returns either ;;; NIL, indicating a bad character somewhere, or the list ;;; in which we are interested. ;;;;;;; (defun decrypt (list) ;;;;;;; (let ((chars (mapcar #'(lambda (char) (decrypt-char char)) list))) (loop for char in chars if (> char 127.) ; If character is invalid, return nil ; return NIL immediately. finally (return (readlist chars))))) ;;; Characters are encoded as atoms of N characters. There are 26**N ;;; combinations, and 128 characters that need encoding. For further ;;; protection, we actually encode 256. characters, 128 of which are ;;; invalid. A character is then encoded by adding it to a random ;;; multiple of 256., and then is easily decoded. ;;; The size of the encoded characters. (defconst *encoded-size* 3) ;;; The random number (defconst *encoded-random* (quotient (expt 26. *encoded-size*) 256.)) (defun encrypt-char (char) (make-encrypt-symbol (+ (* 256. (random *encoded-random*)) char))) (defun decrypt-char (char) (remainder (unmake-encrypt-symbol char) 256.)) ;;; To make a symbol, we treat the number as if in base 26. ;;; This is done in a loop, so we can change the value of *encoded-size* ;;; without having to rewrite everything. ;;;;;;;;;;;;;;;;;;; (defun make-encrypt-symbol (number) ;;;;;;;;;;;;;;;;;;; (implode (nreverse (loop for i from 1 to *encoded-size* collect (+ (quotient (remainder number (expt 26. i)) (expt 26. (1- i))) 65.))))) ;;; To unmake the symbol, we change characters to digits... Here, ;;; we don't know the size of the encoded characters, to allow compatibility ;;; with all formats. (You can change the encoding to any number of ;;; characters as desired.) ;;;;;;;;;;;;;;;;;;;;; (defun unmake-encrypt-symbol (symbol) ;;;;;;;;;;;;;;;;;;;;; (let ((chars (exploden symbol))) (loop for char in chars for i from (1- (length chars)) by -1 sum (* (- char 65.) (expt 26. i))))) |# ;;; ;;;New encryption decryption scheme ;;; ;;; ;;;The new encryption/decryption scheme ;;;The problem with the old scheme was that it was too verbose. What was ;;;desired was a scheme where the encrypted password was short enough to ;;;type in or read over the telephone. ;;; ;;;The new scheme takes each of the pieces of the password and packs them ;;;into a number. Dates are packed by defining three byte fields to ;;;hold the day, month and year. The net address is already a number and ;;;hence needs no packing. Modules are packed by allocating a bit for ;;;each of the possible modules. The site-id is packed by stringing ;;;the characters together into a bit string. ;;; ;;;The next step is to encrypt each of the numbers obtained above. This is ;;;done by computing the base 25 representation of the number and then ;;;using a translation table to map the digits to upper case alphas. Note ;;;we use base 25 and not base 26 because we need a spare character. (see below) ;;; ;;;Next the characters for each of the fields are strung together but ;;;with a special seperator character in between each field. Finally, ;;;the characters are broken into groups of four to make them easier to read. ;;; ;;; ;;;These two functions, encrypt and decrypt, are all that anyone outside of the ;;;encryption code should need to use. ;;; (defun encrypt (password-keyword-list) (setq password-keyword-list (cons nil password-keyword-list)) (nice-token-list (list (encrypt-number (pack-date (get password-keyword-list :from))) (encrypt-number (pack-date (get password-keyword-list :to))) (encrypt-number (pack-network-address (get password-keyword-list :network-address))) (encrypt-number (pack-mods (get password-keyword-list :mods))) (encrypt-number (pack-site-id (get password-keyword-list :site-id)))))) (defun decrypt (password-token-list) (catch 'decrypt-error (let ((char-lists (unnice-token-list password-token-list))) (unless (>= (length char-lists) 5) (throw 'decrypt-error nil)) (list :from (unpack-date (decrypt-number (first char-lists))) :to (unpack-date (decrypt-number (second char-lists))) :network-address (unpack-network-address (decrypt-number (third char-lists))) :mods (unpack-mods (decrypt-number (fourth char-lists))) :site-id (unpack-site-id (decrypt-number (fifth char-lists))))))) ;;; ;;;Constants used by the new encryption scheme ;;; (defconst *seperator* #/V "seperator character between fields in the tokens") (defconst *tail* '(#/X #/I #/D #/V) "pad characters for the token list (random but end in v)") (defconst *translation-table* '((0 . #/Q) (1 . #/W) (2 . #/E) (3 . #/R) (4 . #/T) (5 . #/Y) (6 . #/U) (7 . #/I) (8 . #/O) (9 . #/P) (10 . #/A) (11 . #/S) (12 . #/D) (13 . #/F) (14 . #/G) (15 . #/H) (16 . #/J) (17 . #/K) (18 . #/L) (19 . #/Z) (20 . #/X) (21 . #/C) (22 . #/M) (23 . #/B) (24 . #/N)) "the translation table for encrypting the various fields") (defconst *base-year* 84. "base year for dates") (defconst *day-byte* (byte 5 0) "byte specifier for the day field of a date") (defconst *month-byte* (byte 4 5) "byte specfier for the month field of a date") (defconst *year-byte* (byte 5 9) "byte specifier for the year field of a date (32 years max)") (defconst *address-width* 18. "the width of a network address") (defconst *mod-width* 1 "the width of a module field") (defconst *mod-translations* '((:interpreter . 0) (:debugger . 1) (:interpdebug . 2) (:browser . 3) (:editor . 4) (:lrm . 5) (:product1 . 6) (:product2 . 7) (:product3 . 8) (:product4 . 9) (:product5 . 10) (:product6 . 11) (:product7 . 12) (:product8 . 13) (:product9 . 14) (:product10 . 15) (:product11 . 16) (:product12 . 17) (:product13 . 18) (:product14 . 19)) "the translation table for encoding the various modules") (defconst *char-width* 7. "the width of a character") ;;;Break things into nice four character tokens (defun nice-token-list (char-lists) (let* ((chars (loop for char-list in char-lists collect *seperator* into chars-so-far nconc (copylist char-list) into chars-so-far finally (return (nconc chars-so-far (list *seperator*))))) (excess (mod (length chars) 4.))) (when (plusp excess) (setq chars (nconc chars (nthcdr excess *tail*)))) (loop for (char1 char2 char3 char4) on chars by #'cddddr collect (string-append char1 char2 char3 char4)))) (defun unnice-token-list (tokens) (let ((chars (loop for token in tokens nconc (listarray (string token))))) (loop with temp = nil for char in (cdr chars) if (neq char *seperator*) do (push char temp) if (eq char *seperator*) collect (reverse temp) and do (setq temp nil) finally (if temp (throw 'decrypt-error nil))))) ;;;Convert the number to its encrypted form. (defun encrypt-number (number) (mapcar #'(lambda (digit) (cdr (assq digit *translation-table*))) (number-to-digits (length *translation-table*) number))) (defun decrypt-number (digits) (digits-to-number (length *translation-table*) (mapcar #'(lambda (digit &aux pair) (if (setq pair (rassq digit *translation-table*)) (car pair) (throw 'decrypt-error nil))) digits))) ;;;Convert a list of digits (least significant first) in the given base to a "number" (defun digits-to-number (base list-of-digits) (loop for digit in list-of-digits for multiplier = 1 then (* multiplier (fix base)) sum (* digit multiplier))) ;;;Convert a positive fixed point number in the given base to a list of digits (defun number-to-digits (base number) (loop for remainder = (abs (fix number)) then (// remainder (fix base)) while (plusp remainder) collect (mod remainder base))) ;;;Date packing and unpacking. Subtract the base year to make things smaller and ;;;then put things in their byte fields. (defun pack-date (date-list) (dpb (- (or (third date-list) 0) *base-year*) *year-byte* (dpb (or (second date-list) 0) *month-byte* (or (first date-list) 0)))) (defun unpack-date (date) (list (ldb *day-byte* date) (ldb *month-byte* date) (+ *base-year* (ldb *year-byte* date)))) ;;;Network address packing and unpacking. (defun pack-network-address (network-address-list) (loop with bits = 0 for address in network-address-list for position from 0 by *address-width* do (setq bits (deposit-byte bits position *address-width* address)) finally (return bits))) (defun unpack-network-address (network-addresses) (loop for position from 0 below (haulong network-addresses) by *address-width* collect (load-byte network-addresses position *address-width*))) ;;;Module packing and unpacking. One bit per module. (defun pack-mods (mod-list) (loop with bits = 0 for mod in mod-list for pair = (assq mod *mod-translations*) if pair do (setq bits (deposit-byte bits (cdr pair) *mod-width* 1)) finally (return bits))) (defun unpack-mods (mods) (loop for position from 0 below (haulong mods) by *mod-width* unless (rassq position *mod-translations*) do (throw 'decrypt-error nil) if (not (zerop (load-byte mods position *mod-width*))) collect (car (rassq position *mod-translations*)))) ;;;Site id packing and unpacking. Just string the characters together. (defun pack-site-id (site-id-string) (loop with bits = 0 for i from 0 to (1- (string-length site-id-string)) for position from 0 by *char-width* do (setq bits (deposit-byte bits position *char-width* (aref site-id-string i))) finally (return bits))) (defun unpack-site-id (site-id) (loop with string = "" for position from 0 below (haulong site-id) by *char-width* do (setq string (string-append string (load-byte site-id position *char-width*))) finally (return string)))