<commit_before>;;; Copyright 2012 <NAME> All Rights Reserved.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(in-package #:orcabot)

(defmodule web web-module ("g" "url")
  (ignored-hosts :accessor ignored-hosts-of :initform nil)
  (urls :accessor urls-of :initform nil)
  (search-cse-id :accessor search-cse-id-of :initform nil)
  (search-api-key :accessor search-api-key-of :initform nil))

(defmethod initialize-module ((module web-module) config)
  ;; load configuration for custom search engine
  (let ((search-config (cdr (assoc 'search config))))
    (when search-config
      (setf (search-api-key-of module) (getf search-config :api-key)
            (search-cse-id-of module) (getf search-config :cse-id))))
  (let ((web-config (cdr (assoc 'web config))))
    (when web-config
      (setf (ignored-hosts-of module)
            (getf web-config :ignored-hosts))))

  (setf (urls-of module) nil)
  (with-open-file (inf (data-path "urls.lisp")
                       :direction :input
                       :if-does-not-exist nil)
    (when inf
      (setf (urls-of module) (read inf)))))

(defun save-urls (module)
  (write-to-file (data-path "urls.lisp")
                 (urls-of module)))

(defun format-snippet (snippet)
  (string-limit
   (string-trim '(#\space)
                (ppcre:regex-replace-all "\\s+" snippet " "))
   100))

(defun find-node-by-path (root tag-names)
  "Returns the node found by traversing a DOM hierarchy by tag names."
  (let ((child-element (find (first tag-names)
                          (plump:child-elements root)
                          :key #'plump:tag-name
                          :test #'string=)))
    (cond
      ((null child-element)
       nil)
      ((endp (rest tag-names))
       child-element)
      (t
       (find-node-by-path child-element (rest tag-names))))))

(defun generic-uri-summary (response content-type)
  (handler-case
      (alexandria:switch (content-type :test #'string=)
        ("text/html"
         (let* ((text (flexi-streams:octets-to-string response :external-format :utf-8))
                (dom (plump:parse text))
                (titles (and dom (find-node-by-path dom '("html" "head" "title"))))
                (title-text-node (and titles (plump:first-child titles))))
           (when title-text-node
             (format-snippet (plump:text title-text-node)))))
        ("text/plain"
         (format-snippet (flexi-streams:octets-to-string response :external-format :utf-8))))
    (flexi-streams:external-format-error ()
      nil)))

(defun retrieve-uri-summary (uri)
  (handler-case
      (multiple-value-bind (response status headers uri)
          (drakma:http-request uri :want-stream t :connection-timeout 2
                               :cookie-jar (make-instance 'drakma:cookie-jar))
        
        (when (= status 200)
          ;; on success read into our buffer
          (let* ((buf (make-array '(32767) :element-type '(unsigned-byte 8)))
                 (uncompressed (if (string= (cdr (assoc :content-encoding headers)) "gzip")
                                   (chipz:make-decompressing-stream 'chipz:gzip response)
                                   response))
                 (len (read-sequence buf uncompressed)))
            (close response)
            (values
             (generic-uri-summary (subseq buf 0 len)
                                  (multiple-value-bind (type subtype)
                                      (drakma:get-content-type headers)
                                    (concatenate 'string type "/" subtype)))
             uri))))
    (usocket:ns-host-not-found-error ()
      "ERROR: Host not found")))

(defmethod examine-message ((module web-module)
                            (message irc:irc-privmsg-message))
  (ppcre:do-matches-as-strings  (uri-string "https?:\\/\\/[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-z]{2,6}\\b[-a-zA-Z0-9@:%_\\+.~#&//=]*\\??[-a-zA-Z0-9@:%_\\+.~#&//=]*" (second (arguments message)) nil :sharedp t)
    (when (< (length uri-string) 2083)
      (log:log-message :info "~a mentioned url ~a" (source message)
                       uri-string)
      ;; save url
      (pushnew uri-string (urls-of module) :test #'string=)
      (save-urls module)
      ;; query url and emit summary
      (handler-case
          (multiple-value-bind (summary uri)
              (retrieve-uri-summary uri-string)
            ;; TODO: maybe cache summary?
            (cond
              ((null summary)
               (log:log-message :info "No summary found for ~a" uri-string))
              ((member (puri:uri-host uri)
                       (ignored-hosts-of module)
                       :test (lambda (a b)
                               (alexandria:ends-with-subseq b a)))
               (log:log-message :info "No summary for ignored host ~a"
                                (puri:uri-host uri)))
              (t
               (log:log-message :info "Summary for ~a : ~a" uri-string summary)
               (reply-to message "[~a] - ~a" summary (puri:uri-host uri)))))
        (puri:uri-parse-error ()
          (log:log-message :error "failed to parse url ~a" uri-string)
          nil)
        (usocket:timeout-error ()
          (log:log-message :error "socket timeout checking parse url ~a" uri-string)
          nil)))))

(defun google-api-search (query cse-id api-key)
  (pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)<commit_msg>Add debug logging to web module<commit_after>;;; Copyright 2012 <NAME> All Rights Reserved.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(in-package #:orcabot)

(defmodule web web-module ("g" "url")
  (ignored-hosts :accessor ignored-hosts-of :initform nil)
  (urls :accessor urls-of :initform nil)
  (search-cse-id :accessor search-cse-id-of :initform nil)
  (search-api-key :accessor search-api-key-of :initform nil))

(defmethod initialize-module ((module web-module) config)
  ;; load configuration for custom search engine
  (let ((search-config (cdr (assoc 'search config))))
    (when search-config
      (setf (search-api-key-of module) (getf search-config :api-key)
            (search-cse-id-of module) (getf search-config :cse-id))))
  (let ((web-config (cdr (assoc 'web config))))
    (when web-config
      (setf (ignored-hosts-of module)
            (getf web-config :ignored-hosts))))

  (setf (urls-of module) nil)
  (with-open-file (inf (data-path "urls.lisp")
                       :direction :input
                       :if-does-not-exist nil)
    (when inf
      (setf (urls-of module) (read inf)))))

(defun save-urls (module)
  (write-to-file (data-path "urls.lisp")
                 (urls-of module)))

(defun format-snippet (snippet)
  (string-limit
   (string-trim '(#\space)
                (ppcre:regex-replace-all "\\s+" snippet " "))
   100))

(defun find-node-by-path (root tag-names)
  "Returns the node found by traversing a DOM hierarchy by tag names."
  (let ((child-element (find (first tag-names)
                          (plump:child-elements root)
                          :key #'plump:tag-name
                          :test #'string=)))
    (cond
      ((null child-element)
       nil)
      ((endp (rest tag-names))
       child-element)
      (t
       (find-node-by-path child-element (rest tag-names))))))

(defun generic-uri-summary (response content-type)
  (handler-case
      (alexandria:switch (content-type :test #'string=)
        ("text/html"
         (let* ((text (flexi-streams:octets-to-string response :external-format :utf-8))
                (dom (plump:parse text))
                (titles (and dom (find-node-by-path dom '("html" "head" "title"))))
                (title-text-node (and titles (plump:first-child titles))))
           (when title-text-node
             (format-snippet (plump:text title-text-node)))))
        ("text/plain"
         (format-snippet (flexi-streams:octets-to-string response :external-format :utf-8))))
    (flexi-streams:external-format-error ()
      nil)))

(defun retrieve-uri-summary (uri)
  (handler-case
      (multiple-value-bind (response status headers uri)
          (drakma:http-request uri :want-stream t :connection-timeout 2
                               :cookie-jar (make-instance 'drakma:cookie-jar))
        
        (when (= status 200)
          ;; on success read into our buffer
          (let* ((buf (make-array '(32767) :element-type '(unsigned-byte 8)))
                 (uncompressed (if (string= (cdr (assoc :content-encoding headers)) "gzip")
                                   (chipz:make-decompressing-stream 'chipz:gzip response)
                                   response))
                 (len (read-sequence buf uncompressed)))
            (close response)
            (values
             (generic-uri-summary (subseq buf 0 len)
                                  (multiple-value-bind (type subtype)
                                      (drakma:get-content-type headers)
                                    (concatenate 'string type "/" subtype)))
             uri))))
    (usocket:ns-host-not-found-error ()
      "ERROR: Host not found")))

(defmethod examine-message ((module web-module)
                            (message irc:irc-privmsg-message))
  (ppcre:do-matches-as-strings  (uri-string "https?:\\/\\/[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-z]{2,6}\\b[-a-zA-Z0-9@:%_\\+.~#&//=]*\\??[-a-zA-Z0-9@:%_\\+.~#&//=]*" (second (arguments message)) nil :sharedp t)
    (when (< (length uri-string) 2083)
      (log:log-message :info "~a mentioned url ~a" (source message)
                       uri-string)
      ;; save url
      (pushnew uri-string (urls-of module) :test #'string=)
      (save-urls module)
      ;; query url and emit summary
      (handler-case
          (multiple-value-bind (summary uri)
              (retrieve-uri-summary uri-string)
            ;; TODO: maybe cache summary?
            (cond
              ((null summary)
               (log:log-message :info "No summary found for ~a" uri-string))
              ((null uri)
               (log:log-message :info "Shouldn't happen - (summary ~s) (uri ~s) (uri-string ~s)" summary uri uri-string))
              ((member (puri:uri-host uri)
                       (ignored-hosts-of module)
                       :test (lambda (a b)
                               (alexandria:ends-with-subseq b a)))
               (log:log-message :info "No summary for ignored host ~a"
                                (puri:uri-host uri)))
              (t
               (log:log-message :info "Summary for ~a : ~a" uri-string summary)
               (reply-to message "[~a] - ~a" summary (puri:uri-host uri)))))
        (puri:uri-parse-error ()
          (log:log-message :error "failed to parse url ~a" uri-string)
          nil)
        (usocket:timeout-error ()
          (log:log-message :error "socket timeout checking parse url ~a" uri-string)
          nil)))))

(defun google-api-search (query cse-id api-key)
  (pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)
{'fraction_non_alphanumeric': 0.14441868168267638, 'fraction_numerical': 0.006624710168930109, 'mean_word_length': 2.0628962718742074, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 10, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '859103', 'n_tokens_mistral': 3760, 'n_tokens_neox': 3651, 'n_words': 989}