config-system.lisp - patch - karik/kursach

config-system.lisp
493 строки20 KB
karik
upload files
22 фев 2026, 14:19
22 фев 2026, 14:19788ed10
;;;; =========================================================
;;;;  Modular Configuration System with Validation
;;;;  Enhanced with: Validators, File Loading, Environments,
;;;;  Documentation, and Type Coercion
;;;; =========================================================


;;;; ===== Errors =====

(define-condition config-error (error)
  ((module
    :initarg :module
    :reader config-error-module)
   (parameter
    :initarg :parameter
    :reader config-error-parameter)
   (reason
    :initarg :reason
    :reader config-error-reason)
   (value
    :initarg :value
    :initform nil
    :reader config-error-value)
   (expected
    :initarg :expected
    :initform nil
    :reader config-error-expected))
  (:report
   (lambda (c s)
     (format s "~%Ошибка конфигурации:~%")
     (when (config-error-module c)
       (format s "  Модуль: ~a~%" (config-error-module c)))
     (when (config-error-parameter c)
       (format s "  Параметр: ~a~%" (config-error-parameter c)))
     (format s "  Причина: ~a~%" (config-error-reason c))
     (when (config-error-value c)
       (format s "  Получено: ~s~%" (config-error-value c)))
     (when (config-error-expected c)
       (format s "  Ожидалось: ~a~%" (config-error-expected c))))))


(defun signal-config-error (&key module parameter reason value expected)
  (error 'config-error
         :module module
         :parameter parameter
         :reason reason
         :value value
         :expected expected))


;;;; ===== Model =====

(defstruct parameter
  name
  type
  default
  required
  validator       ; NEW: функция валидации
  description)    ; NEW: описание параметра

(defstruct config-module
  name
  parameters)


;;;; ===== Registry =====

(defparameter *module-registry* (make-hash-table))
(defparameter *environments* (make-hash-table))        ; NEW: реестр окружений
(defparameter *current-environment* :development)      ; NEW: текущее окружение

(defun register-module (module)
  (setf (gethash (config-module-name module) *module-registry*) module))

(defun find-module (name)
  (gethash name *module-registry*))


;;;; ===== DSL =====

(defmacro defconfig-module (name &body parameter-specs)
  `(register-module
    (make-config-module
     :name ',name
     :parameters
     (list
      ,@(mapcar
         (lambda (spec)
           (destructuring-bind (param-name &rest options) spec
             `(make-parameter
               :name ,param-name
               :type ',(getf options :type)
               :default ,(getf options :default)
               :required ,(getf options :required nil)
               :validator ,(getf options :validator)      ; NEW
               :description ,(getf options :description)))) ; NEW
         parameter-specs)))))


;;;; ===== Type Coercion (NEW) =====

(defun coerce-value (value target-type)
  "Преобразует значение к целевому типу"
  (cond
    ((null target-type) value)
    ((typep value target-type) value)
    ((and (eq target-type 'integer) (stringp value))
     (parse-integer value :junk-allowed nil))
    ((and (eq target-type 'boolean) (stringp value))
     (cond
       ((member value '("true" "t" "yes" "1") :test #'string-equal) t)
       ((member value '("false" "nil" "no" "0") :test #'string-equal) nil)
       (t (signal-config-error
           :reason "невозможно преобразовать в boolean"
           :value value
           :expected "true/false/yes/no/1/0"))))
    ((and (eq target-type 'keyword) (stringp value))
     (intern (string-upcase value) :keyword))
    ((and (eq target-type 'string) (symbolp value))
     (string-downcase (symbol-name value)))
    (t value)))


;;;; ===== Validation =====

(defun resolve-parameter-value (module parameter config-alist)
  (let ((entry (assoc (parameter-name parameter) config-alist)))
    (cond
      (entry
       ;; NEW: преобразование типа
       (let ((value (cdr entry)))
         (handler-case
             (coerce-value value (parameter-type parameter))
           (error (e)
             (signal-config-error
              :module (config-module-name module)
              :parameter (parameter-name parameter)
              :reason (format nil "ошибка преобразования типа: ~a" e)
              :value value
              :expected (parameter-type parameter))))))
      ((parameter-required parameter)
       (signal-config-error
        :module (config-module-name module)
        :parameter (parameter-name parameter)
        :reason "обязательный параметр отсутствует"))
      (t
       (parameter-default parameter)))))

(defun validate-parameter (module parameter value)
  ;; Проверка типа
  (when (and value
             (parameter-type parameter)
             (not (typep value (parameter-type parameter))))
    (signal-config-error
     :module (config-module-name module)
     :parameter (parameter-name parameter)
     :reason "значение не соответствует ожидаемому типу"
     :value value
     :expected (parameter-type parameter)))
  ;; NEW: проверка кастомным валидатором
  (when (and value (parameter-validator parameter))
    (handler-case
        (unless (funcall (parameter-validator parameter) value)
          (signal-config-error
           :module (config-module-name module)
           :parameter (parameter-name parameter)
           :reason "значение не прошло валидацию"
           :value value))
      (error (e)
        (signal-config-error
         :module (config-module-name module)
         :parameter (parameter-name parameter)
         :reason (format nil "ошибка в валидаторе: ~a" e)
         :value value)))))

(defun validate-extra-keys (module config-alist)
  (let ((known (mapcar #'parameter-name
                       (config-module-parameters module))))
    (dolist (entry config-alist)
      (unless (member (car entry) known)
        (signal-config-error
         :module (config-module-name module)
         :parameter (car entry)
         :reason "неизвестный параметр")))))


;;;; ===== Build =====

(defun build-module-config (module config-alist)
  (validate-extra-keys module config-alist)
  (mapcar
   (lambda (parameter)
     (let ((value (resolve-parameter-value module parameter config-alist)))
       (validate-parameter module parameter value)
       (cons (parameter-name parameter) value)))
   (config-module-parameters module)))

(defun build-config (input-config)
  (mapcar
   (lambda (entry)
     (let* ((module-name (car entry))
            (config-alist (cdr entry))
            (module (find-module module-name)))
       (unless module
         (signal-config-error
          :module module-name
          :reason "неизвестный модуль"))
       (cons module-name
             (build-module-config module config-alist))))
   input-config))


;;;; ===== File Loading (NEW) =====

(defun load-config-file (filepath)
  "Загружает конфигурацию из Lisp файла"
  (with-open-file (stream filepath :direction :input)
    (read stream)))

(defun parse-json-string (string)
  "Простой парсер JSON строк"
  (if (and (char= (char string 0) #\")
           (char= (char string (1- (length string))) #\"))
      (subseq string 1 (1- (length string)))
      string))

(defun parse-json-number (string)
  "Парсит JSON число"
  (handler-case
      (parse-integer string)
    (error ()
      (read-from-string string))))

(defun parse-json-value (value-str)
  "Упрощенный парсер JSON значений"
  (let ((trimmed (string-trim '(#\Space #\Tab #\Newline) value-str)))
    (cond
      ((string= trimmed "true") t)
      ((string= trimmed "false") nil)
      ((string= trimmed "null") nil)
      ((char= (char trimmed 0) #\") (parse-json-string trimmed))
      ((digit-char-p (char trimmed 0)) (parse-json-number trimmed))
      ((char= (char trimmed 0) #\-) (parse-json-number trimmed))
      (t trimmed))))

(defun load-json-config (filepath)
  "Загружает простую JSON конфигурацию (базовая реализация)"
  (with-open-file (stream filepath :direction :input)
    (let ((content (make-string (file-length stream))))
      (read-sequence content stream)
      ;; Очень упрощенная версия - для демонстрации
      ;; В реальности использовать библиотеку типа cl-json
      (format t "~%ПРИМЕЧАНИЕ: Используйте load-config-file для S-expressions~%")
      (format t "Для полной поддержки JSON установите библиотеку cl-json~%")
      nil)))


;;;; ===== Environments (NEW) =====

(defmacro defconfig-environment (name config)
  "Определяет именованное окружение с конфигурацией"
  `(setf (gethash ',name *environments*) ',config))

(defun activate-environment (env-name)
  "Активирует окружение по имени"
  (unless (gethash env-name *environments*)
    (error "Окружение ~a не определено" env-name))
  (setf *current-environment* env-name))

(defun merge-config-alists (base override)
  "Объединяет два alist, override имеет приоритет"
  (let ((result (copy-alist base)))
    (dolist (entry override)
      (let ((existing (assoc (car entry) result)))
        (if existing
            (setf (cdr existing) (cdr entry))
            (push entry result))))
    result))

(defun merge-configs (base override)
  "Объединяет две конфигурации (списки модулей)"
  (let ((result (copy-alist base)))
    (dolist (module-entry override)
      (let* ((module-name (car module-entry))
             (module-config (cdr module-entry))
             (existing (assoc module-name result)))
        (if existing
            (setf (cdr existing)
                  (merge-config-alists (cdr existing) module-config))
            (push module-entry result))))
    result))

(defun build-config-with-env (&optional additional-config)
  "Строит конфигурацию с учетом текущего окружения"
  (let ((env-config (gethash *current-environment* *environments*)))
    (unless env-config
      (error "Окружение ~a не определено" *current-environment*))
    (build-config
     (if additional-config
         (merge-configs env-config additional-config)
         env-config))))


;;;; ===== Documentation (NEW) =====

(defun print-module-docs (module-name &optional (stream t))
  "Выводит документацию по модулю"
  (let ((module (find-module module-name)))
    (unless module
      (error "Модуль ~a не найден" module-name))
    (format stream "~%╔════════════════════════════════════════╗~%")
    (format stream "║ Модуль: ~a~%" module-name)
    (format stream "╚════════════════════════════════════════╝~%~%")
    (dolist (param (config-module-parameters module))
      (format stream "  ~a~%" (parameter-name param))
      (format stream "    Тип: ~a~%" 
              (or (parameter-type param) "любой"))
      (when (parameter-required param)
        (format stream "    Обязательный: да~%"))
      (when (parameter-default param)
        (format stream "    По умолчанию: ~s~%" (parameter-default param)))
      (when (parameter-validator param)
        (format stream "    Валидатор: есть~%"))
      (when (parameter-description param)
        (format stream "    Описание: ~a~%" (parameter-description param)))
      (format stream "~%"))))

(defun print-all-modules-docs (&optional (stream t))
  "Выводит документацию по всем зарегистрированным модулям"
  (format stream "~%╔═══════════════════════════════════════════════╗~%")
  (format stream "║ ДОКУМЕНТАЦИЯ СИСТЕМЫ КОНФИГУРАЦИИ~%")
  (format stream "╚═══════════════════════════════════════════════╝~%")
  (maphash
   (lambda (name module)
     (declare (ignore module))
     (print-module-docs name stream))
   *module-registry*))


;;;; ===== Demo & Examples =====

;; Определяем модули с новыми возможностями
(defconfig-module database
  (:host :type string :required t
         :description "Адрес сервера базы данных (IP или домен)")
  (:port :type integer :default 5432
         :validator (lambda (v) (and (> v 0) (< v 65536)))
         :description "Порт PostgreSQL (1-65535)")
  (:username :type string :required t
             :description "Имя пользователя для подключения")
  (:password :type string :required t
             :validator (lambda (v) (>= (length v) 8))
             :description "Пароль (минимум 8 символов)")
  (:max-connections :type integer :default 100
                    :validator (lambda (v) (and (> v 0) (<= v 1000)))
                    :description "Максимальное количество соединений"))

(defconfig-module web-server
  (:host :type string :default "0.0.0.0"
         :description "IP-адрес для прослушивания")
  (:port :type integer :required t
         :validator (lambda (v) (and (> v 0) (< v 65536)))
         :description "Порт веб-сервера (1-65535)")
  (:workers :type integer :default 4
            :validator (lambda (v) (and (> v 0) (<= v 32)))
            :description "Количество рабочих процессов (1-32)")
  (:ssl-enabled :type boolean :default nil
                :description "Включить SSL/TLS"))

(defconfig-module logging
  (:level :type keyword :default :info
          :validator (lambda (v) (member v '(:debug :info :warn :error)))
          :description "Уровень логирования (:debug/:info/:warn/:error)")
  (:file :type string :required t
         :description "Путь к файлу логов")
  (:max-file-size :type integer :default 10485760
                  :validator (lambda (v) (> v 0))
                  :description "Максимальный размер файла лога в байтах"))

;; Определяем окружения
(defconfig-environment :development
  ((database . ((:host . "localhost")
                (:username . "dev_user")
                (:password . "dev_pass_12345")))
   (web-server . ((:port . 3000)))
   (logging . ((:level . :debug)
               (:file . "dev.log")))))

(defconfig-environment :production
  ((database . ((:host . "prod-db.example.com")
                (:port . 5433)
                (:username . "prod_user")
                (:password . "super_secret_password_123")
                (:max-connections . 500)))
   (web-server . ((:port . 80)
                  (:workers . 16)
                  (:ssl-enabled . t)))
   (logging . ((:level . :warn)
               (:file . "/var/log/app.log")))))

(defconfig-environment :testing
  ((database . ((:host . "test-db.local")
                (:username . "test_user")
                (:password . "test_pass_99999")))
   (web-server . ((:port . 8080)))
   (logging . ((:level . :info)
               (:file . "test.log")))))


;;;; ===== Примеры использования =====

(format t "~%~%")
(format t "╔═══════════════════════════════════════════════╗~%")
(format t "║ ДЕМОНСТРАЦИЯ ВОЗМОЖНОСТЕЙ v3~%")
(format t "╚═══════════════════════════════════════════════╝~%~%")

;; Пример 1: Документация
(format t "~%===== ПРИМЕР 1: Документация модуля =====~%")
(print-module-docs 'database)

;; Пример 2: Успешная конфигурация с валидаторами
(format t "~%===== ПРИМЕР 2: Успешная конфигурация =====~%")
(let ((config (build-config
               '((database . ((:host . "localhost")
                              (:port . 5432)
                              (:username . "admin")
                              (:password . "secret123456")))))))
  (format t "✓ Конфигурация построена успешно~%")
  (format t "Database host: ~a~%"
          (cdr (assoc :host (cdr (assoc 'database config))))))

;; Пример 3: Ошибка валидации (порт вне диапазона)
(format t "~%===== ПРИМЕР 3: Ошибка валидации (порт) =====~%")
(handler-case
    (build-config
     '((web-server . ((:port . 99999)))))  ; порт > 65535
  (config-error (e)
    (format t "~a~%" e)))

;; Пример 4: Ошибка валидации (короткий пароль)
(format t "~%===== ПРИМЕР 4: Ошибка валидации (пароль) =====~%")
(handler-case
    (build-config
     '((database . ((:host . "localhost")
                    (:username . "admin")
                    (:password . "123")))))  ; < 8 символов
  (config-error (e)
    (format t "~a~%" e)))

;; Пример 5: Преобразование типов
(format t "~%===== ПРИМЕР 5: Автоматическое преобразование типов =====~%")
(let ((config (build-config
               '((web-server . ((:port . "8080")      ; строка -> число
                                (:workers . "8")))))))
  (format t "✓ Строки автоматически преобразованы в числа~%")
  (format t "Port (тип: ~a): ~a~%"
          (type-of (cdr (assoc :port (cdr (assoc 'web-server config)))))
          (cdr (assoc :port (cdr (assoc 'web-server config))))))

;; Пример 6: Использование окружений
(format t "~%===== ПРИМЕР 6: Работа с окружениями =====~%")
(activate-environment :development)
(let ((config (build-config-with-env)))
  (format t "✓ Загружено окружение: :development~%")
  (format t "Database host: ~a~%"
          (cdr (assoc :host (cdr (assoc 'database config)))))
  (format t "Web-server port: ~a~%"
          (cdr (assoc :port (cdr (assoc 'web-server config))))))

(format t "~%Переключаемся на :production~%")
(activate-environment :production)
(let ((config (build-config-with-env)))
  (format t "✓ Загружено окружение: :production~%")
  (format t "Database host: ~a~%"
          (cdr (assoc :host (cdr (assoc 'database config)))))
  (format t "Web-server port: ~a~%"
          (cdr (assoc :port (cdr (assoc 'web-server config)))))
  (format t "Workers: ~a~%"
          (cdr (assoc :workers (cdr (assoc 'web-server config))))))

;; Пример 7: Переопределение параметров окружения
(format t "~%===== ПРИМЕР 7: Переопределение окружения =====~%")
(activate-environment :testing)
(let ((config (build-config-with-env
               '((web-server . ((:port . 9000)))))))  ; переопределяем порт
  (format t "✓ Окружение :testing с переопределенным портом~%")
  (format t "Web-server port: ~a (переопределено с 8080)~%"
          (cdr (assoc :port (cdr (assoc 'web-server config))))))

(format t "~%~%")
(format t "╔═══════════════════════════════════════════════╗~%")
(format t "║ ВСЕ ПРИМЕРЫ ЗАВЕРШЕНЫ~%")
(format t "╚═══════════════════════════════════════════════╝~%~%")