<commit_before>;;;; hunchentoot.lisp
;;;;
;;;; This file is part of the RESTAS library, released under Lisp-LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: <NAME> <<EMAIL>>

(in-package :restas)

(setf hunchentoot:*hunchentoot-default-external-format* hunchentoot::+utf-8+)

(defun request-full-uri (&optional (request hunchentoot:*request*))
  (let ((uri (puri:parse-uri (hunchentoot:request-uri request))))
    (setf (puri:uri-scheme uri)
          (if (hunchentoot:acceptor-ssl-p (hunchentoot:request-acceptor request))
              :https
              :http))
    (ppcre:register-groups-bind  (host port) ("([^:]+)(?=:(.+))?" (hunchentoot:host request))
      (setf (puri:uri-host uri)
            host)
      (unless (or (null port)
                  (= (parse-integer port) 80))
        (setf (puri:uri-port uri)
              port)))
    uri))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; redirect
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun apply-format-aux (format args)
  (if (symbolp format)
      (apply #'restas:genurl format args)
      (if args
          (apply #'format nil (cons format args))
          format)))

(defun redirect (route-symbol &rest args)
  (hunchentoot:redirect 
   (hunchentoot:url-decode
    (apply-format-aux route-symbol
                      (mapcar #'(lambda (s)
                                  (if (stringp s)
                                      (hunchentoot:url-encode s)
                                      s))
                              args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; restas-acceptor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass restas-request (hunchentoot:request)
  ((substitutions :initarg substitutions :initform routes:+no-bindings+ :accessor restas-request-bindings)))

(defmethod hunchentoot:header-in ((name (eql :host)) (request restas-request))
  (or (hunchentoot:header-in :x-forwarded-host request)
      (call-next-method)))

(defclass vhost ()
  ((host :initarg :host :reader vhost-host)
   (mapper :initform (make-instance 'routes:mapper))
   (modules :initform nil)))

(defclass restas-acceptor (hunchentoot:acceptor) 
  ((vhosts :initform nil :accessor restas-acceptor-vhosts)))

(defmethod shared-initialize :after ((acceptor restas-acceptor) slot-names &rest initargs &key)
  (declare (ignore slot-names initargs))
  (setf (hunchentoot:acceptor-request-dispatcher acceptor) 'restas-dispatcher
        (hunchentoot:acceptor-request-class acceptor) 'restas-request))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dispatcher
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *default-host-redirect* nil)

(defvar *request-pool*)

(defun header-host (request)
  (cdr (assoc :host (hunchentoot:headers-in request))))

(defun restas-dispatcher (req &aux (host (header-host req)))
  (let ((vhost (or (find (if (find #\: host)
                             host
                             (format nil "~A:80" host))
                         (restas-acceptor-vhosts hunchentoot:*acceptor*)
                         :key #'vhost-host
                         :test #'string=)
                   (find-if #'null
                            (restas-acceptor-vhosts hunchentoot:*acceptor*)
                            :key #'vhost-host)))
        (hunchentoot:*request* req))
    (when (and (not vhost)
               *default-host-redirect*)
      (hunchentoot:redirect (hunchentoot:request-uri*)
                            :host *default-host-redirect*))
    (when vhost
      (with-memoization 
        (multiple-value-bind (route bindings) (routes:match (slot-value vhost 'mapper)
                                                (hunchentoot:request-uri*))
          (if route
              (gp:with-garbage-pool (*request-pool*)
                (process-route route
                               bindings))
              (setf (hunchentoot:return-code*)
                    hunchentoot:+HTTP-NOT-FOUND+)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; start
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun reconnect-all-routes ()
  (iter (for acceptor in *acceptors*)
        (iter (for vhost in (restas-acceptor-vhosts acceptor))
              (let ((mapper (slot-value vhost 'mapper)))
                (routes:reset-mapper mapper)
                (iter (for module in (slot-value vhost 'modules))
                      (reinitialize-instance module)
                      (connect-submodule module mapper))))))


(defun start (module &key hostname (port 80) (context (make-context))
              &aux (hostname/port (if hostname (format nil "~A:~A" hostname port))))
  (let* ((package (or (find-package module)
                      (error "Package ~A not found" module)))
         (acceptor (or (find port
                            *acceptors*
                            :key #'hunchentoot:acceptor-port)
                      (car (push (hunchentoot:start (make-instance 'restas-acceptor
                                                                   :port port))
                                 *acceptors*))))
         (vhost (or (if hostname/port
                        (find hostname/port
                              (restas-acceptor-vhosts acceptor)
                              :key #'vhost-host
                              :test #'string=)
                        (find-if #'null
                                 (restas-acceptor-vhosts acceptor)
                                 :key #'vhost-host))
                    (car (push (make-instance 'vhost
                                              :host hostname/port)
                               (restas-acceptor-vhosts acceptor))))))
    (push (make-instance 'submodule<commit_msg>function start now return nothing<commit_after>;;;; hunchentoot.lisp
;;;;
;;;; This file is part of the RESTAS library, released under Lisp-LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: <NAME> <<EMAIL>>

(in-package :restas)

(setf hunchentoot:*hunchentoot-default-external-format* hunchentoot::+utf-8+)

(defun request-full-uri (&optional (request hunchentoot:*request*))
  (let ((uri (puri:parse-uri (hunchentoot:request-uri request))))
    (setf (puri:uri-scheme uri)
          (if (hunchentoot:acceptor-ssl-p (hunchentoot:request-acceptor request))
              :https
              :http))
    (ppcre:register-groups-bind  (host port) ("([^:]+)(?=:(.+))?" (hunchentoot:host request))
      (setf (puri:uri-host uri)
            host)
      (unless (or (null port)
                  (= (parse-integer port) 80))
        (setf (puri:uri-port uri)
              port)))
    uri))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; redirect
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun apply-format-aux (format args)
  (if (symbolp format)
      (apply #'restas:genurl format args)
      (if args
          (apply #'format nil (cons format args))
          format)))

(defun redirect (route-symbol &rest args)
  (hunchentoot:redirect 
   (hunchentoot:url-decode
    (apply-format-aux route-symbol
                      (mapcar #'(lambda (s)
                                  (if (stringp s)
                                      (hunchentoot:url-encode s)
                                      s))
                              args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; restas-acceptor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass restas-request (hunchentoot:request)
  ((substitutions :initarg substitutions :initform routes:+no-bindings+ :accessor restas-request-bindings)))

(defmethod hunchentoot:header-in ((name (eql :host)) (request restas-request))
  (or (hunchentoot:header-in :x-forwarded-host request)
      (call-next-method)))

(defclass vhost ()
  ((host :initarg :host :reader vhost-host)
   (mapper :initform (make-instance 'routes:mapper))
   (modules :initform nil)))

(defclass restas-acceptor (hunchentoot:acceptor) 
  ((vhosts :initform nil :accessor restas-acceptor-vhosts)))

(defmethod shared-initialize :after ((acceptor restas-acceptor) slot-names &rest initargs &key)
  (declare (ignore slot-names initargs))
  (setf (hunchentoot:acceptor-request-dispatcher acceptor) 'restas-dispatcher
        (hunchentoot:acceptor-request-class acceptor) 'restas-request))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dispatcher
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *default-host-redirect* nil)

(defvar *request-pool*)

(defun header-host (request)
  (cdr (assoc :host (hunchentoot:headers-in request))))

(defun restas-dispatcher (req &aux (host (header-host req)))
  (let ((vhost (or (find (if (find #\: host)
                             host
                             (format nil "~A:80" host))
                         (restas-acceptor-vhosts hunchentoot:*acceptor*)
                         :key #'vhost-host
                         :test #'string=)
                   (find-if #'null
                            (restas-acceptor-vhosts hunchentoot:*acceptor*)
                            :key #'vhost-host)))
        (hunchentoot:*request* req))
    (when (and (not vhost)
               *default-host-redirect*)
      (hunchentoot:redirect (hunchentoot:request-uri*)
                            :host *default-host-redirect*))
    (when vhost
      (with-memoization 
        (multiple-value-bind (route bindings) (routes:match (slot-value vhost 'mapper)
                                                (hunchentoot:request-uri*))
          (if route
              (gp:with-garbage-pool (*request-pool*)
                (process-route route
                               bindings))
              (setf (hunchentoot:return-code*)
                    hunchentoot:+HTTP-NOT-FOUND+)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; start
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun reconnect-all-routes ()
  (iter (for acceptor in *acceptors*)
        (iter (for vhost in (restas-acceptor-vhosts acceptor))
              (let ((mapper (slot-value vhost 'mapper)))
                (routes:reset-mapper mapper)
                (iter (for module in (slot-value vhost 'modules))
                      (reinitialize-instance module)
                      (connect-submodule module mapper)))))
  (values))


(defun start (module &key hostname (port 80) (context (make-context))
              &aux (hostname/port (if hostname (format nil "~A:~A" hostname port))))
  (let* ((package (or (find-package module)
                      (error "Package ~A not found" module)))
         (acceptor (or (find port
                            *acceptors*
                            :key #'hunchentoot:acceptor-port)
                      (car (push (hunchentoot:start (make-instance 'restas-acceptor
                                                                   :port port))
                                 *acceptors*))))
         (vhost (or (if hostname/port
                        (find hostname/port
                              (restas-acceptor-vhosts acceptor)
                              :key #'vhost-host
                              :test #'string=)
                        (find-if #'null
                                 (restas-acceptor-vhosts acceptor)
                                 :key #'vhost-host))
                    (car (push (make-instance 'vhost
                                              :host hostname/port)
                               (restas-acceptor-vhosts acceptor))))))
    (push (make-instance 'submodule
{'fraction_non_alphanumeric': 0.23854545454545453, 'fraction_numerical': 0.0011313131313131313, 'mean_word_length': 2.1539245667686036, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 24, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5483918', 'n_tokens_mistral': 4050, 'n_tokens_neox': 3535, 'n_words': 712}