;; tinmop: an humble gemini kami and pleroma client
;; Copyright © 2022  cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package :gopher-parser)

(defmacro def-line-type-constant (name value documentation)
  `(a:define-constant ,(format-fn-symbol t "+line-type-~a+" name) ,value
     :test #'string=
     :documentation ,documentation))

(defmacro gen-line-constants (name-values-doc-list)
  `(progn
     ,@(loop for data in name-values-doc-list
             collect
             `(def-line-type-constant ,(first  data) ,(second data) ,(third data)))))

(gen-line-constants ((file             "0" "identifier for a file")
                     (dir              "1" "identifier for a directory")
                     (cso              "2" "identifier for a CSO phone-book server")
                     (error            "3" "identifier for an error")
                     (mac-hex-file     "4" "identifier for a BinHexed Macintosh file")
                     (dos-archive-file "5" "identifier for a DOS binary archive of some sort")
                     (uuencoded-file   "6" "identifier for a UNIX uuencoded file")
                     (index-search     "7" "identifier for Index-Search server")
                     (telnet-session   "8" "identifier for a text-based telnet session.")
                     (binary-file      "9" "identifier for a binary file")
                     (redundant-server "+" "identifier for a redundant server")
                     (tn3270-session   "T" "identifier for a tn3270 session")
                     (gif-image-file   "g" "identifier for an image in GIF")
                     (image-file       "I" "identifier for an image file")
                     (info             "i" "information line")
                     (uri              "h" "hyperlink")))

(a:define-constant +gopher-scheme+ "gopher" :test #'string=)

(defun %check-line-type (data reference)
  (string= data reference))

(defmacro %gen-check-line-predicate (name reference)
  (a:with-gensyms (data)
  `(defun ,(format-fn-symbol t "%line-type-~a-p" name) (,data)
     (%check-line-type ,data ,reference))))

(%gen-check-line-predicate file             +line-type-file+)

(%gen-check-line-predicate dir              +line-type-dir+)

(%gen-check-line-predicate cso              +line-type-cso+)

(%gen-check-line-predicate error            +line-type-error+)

(%gen-check-line-predicate mac-hex-file     +line-type-mac-hex-file+)

(%gen-check-line-predicate dos-archive-file +line-type-dos-archive-file+)

(%gen-check-line-predicate uuencoded-file   +line-type-uuencoded-file+)

(%gen-check-line-predicate index-search     +line-type-index-search+)

(%gen-check-line-predicate telnet-session   +line-type-telnet-session+)

(%gen-check-line-predicate binary-file      +line-type-binary-file+)

(%gen-check-line-predicate redundant-server +line-type-redundant-server+)

(%gen-check-line-predicate tn3270-session   +line-type-tn3270-session+)

(%gen-check-line-predicate gif-file         +line-type-gif-image-file+)

(%gen-check-line-predicate image-file       +line-type-image-file+)

(%gen-check-line-predicate info             +line-type-info+)

(%gen-check-line-predicate uri              +line-type-uri+)

(defclass gopher-line ()
  ((line-type-id
    :initarg :line-type-id
    :initform ""
    :accessor line-type-id
    :type     string)
   (username
    :initarg :username
    :initform ""
    :accessor username
    :type     string)
   (selector
    :initarg :selector
    :initform ""
    :accessor selector
    :type     string)
   (host
    :initarg :host
    :initform ""
    :accessor host
    :type     string)
   (port
    :initarg :port
    :initform -1
    :accessor port
    :type     number)))

(defmethod print-object ((object gopher-line) stream)
  (with-accessors ((username username)
                   (selector selector)
                   (host     host)
                   (port     port)) object
    (print-unreadable-object (object stream :type t)
      (format stream
              "username: ~s selector: ~s host: ~s port ~a"
              username selector host port))))

(defmacro gen-selector-class (name)
  `(defclass ,name (gopher-line) ()))

(gen-selector-class line-file)

(gen-selector-class line-dir)

(gen-selector-class line-cso)

(gen-selector-class line-error)

(gen-selector-class line-mac-hex-file)

(gen-selector-class line-dos-archive-file)

(gen-selector-class line-uuencoded-file)

(gen-selector-class line-index-search)

(gen-selector-class line-telnet-session)

(gen-selector-class line-binary-file)

(gen-selector-class line-redundant-server)

(gen-selector-class line-tn3270-session)

(gen-selector-class line-gif-file)

(gen-selector-class line-image-file)

(gen-selector-class line-info)

(gen-selector-class line-uri)

(gen-selector-class line-unknown)

(defun check-line-type (data reference)
  (typep data reference))

(defmacro gen-check-line-predicate (name reference)
  (a:with-gensyms (data)
  `(defun ,(format-fn-symbol t "line-type-~a-p" name) (,data)
     (check-line-type ,data ,reference))))

(gen-check-line-predicate file             'line-file)

(gen-check-line-predicate dir              'line-dir)

(gen-check-line-predicate cso              'line-cso)

(gen-check-line-predicate error            'line-error)

(gen-check-line-predicate mac-hex-file     'line-mac-hex-file)

(gen-check-line-predicate dos-archive-file 'line-dos-archive-file)

(gen-check-line-predicate uuencoded-file   'line-uuencoded-file)

(gen-check-line-predicate index-search     'line-index-search)

(gen-check-line-predicate telnet-session   'line-telnet-session)

(gen-check-line-predicate binary-file      'line-binary-file)

(gen-check-line-predicate redundant-server 'line-redundant-server)

(gen-check-line-predicate tn3270-session   'line-tn3270-session)

(gen-check-line-predicate gif-file         'line-gif-image-file)

(gen-check-line-predicate image-file       'line-image-file)

(gen-check-line-predicate info             'line-info)

(gen-check-line-predicate uri              'line-uri)

(gen-check-line-predicate unknown          'unknown)

(defrule line-separator (and #\Return #\Newline)
  (:constant :line-separator))

(defrule field-separator #\tab
  (:constant :field-separator))

(defrule null-char #\Nul
  (:constant :field-separator))

(defrule unascii (not (or field-separator line-separator null-char))
  (:text t))

(defrule last-line (and #\. line-separator)
  (:constant :last-line))

(defrule line-type unascii
  (:text t))

(defrule red-type (and #\+ #\.)
  (:constant :red-type))

(defrule user-name (* unascii)
  (:text t))

(defrule selector (* unascii)
  (:text t))

(defrule hostname-component (* (not (or field-separator line-separator null-char
                                        #\.)))
  (:text t))

(defrule host (and (* (and hostname-component #\.))
                   hostname-component)
  (:text t))

(defrule digit (character-ranges #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  (:text t))

(defrule digit-sequence (and digit (* digit))
  (:text t))

(defrule port digit-sequence
  (:function parse-integer))

(defrule dir-entity (and line-type user-name field-separator
                         selector field-separator
                         host field-separator
                         port line-separator)
  (:function (lambda (line)
               (list :type (first line)
                     :user-name (second line)
                     :selector  (fourth line)
                     :host      (sixth  line)
                     :port      (elt    line 7)))))

(defrule menu (and (* dir-entity) last-line)
  (:function first))

(defun parse-menu (data)
  (let ((menu (parse 'menu data)))
    (loop for entry in menu
          collect
          (let* ((line-type (getf entry :type))
                 (instance  (cond
                              ((%line-type-file-p line-type)
                               (make-instance 'line-file))
                              ((%line-type-dir-p line-type)
                               (make-instance 'line-dir))
                              ((%line-type-cso-p line-type)
                               (make-instance 'line-cso))
                              ((%line-type-error-p line-type)
                               (make-instance 'line-error))
                              ((%line-type-mac-hex-file-p line-type)
                               (make-instance 'line-mac-hex-file))
                              ((%line-type-dos-archive-file-p line-type)
                               (make-instance 'line-dos-archive-file))
                              ((%line-type-uuencoded-file-p line-type)
                               (make-instance 'line-uuencoded-file))
                              ((%line-type-index-search-p line-type)
                               (make-instance 'line-index-search))
                              ((%line-type-telnet-session-p line-type)
                               (make-instance 'line-telnet-session))
                              ((%line-type-binary-file-p line-type)
                               (make-instance 'line-binary-file))
                              ((%line-type-redundant-server-p line-type)
                               (make-instance 'line-redundant-server))
                              ((%line-type-tn3270-session-p line-type)
                               (make-instance 'line-tn3270-session))
                              ((%line-type-gif-file-p line-type)
                               (make-instance 'line-gif-file))
                              ((%line-type-image-file-p line-type)
                               (make-instance 'line-image-file))
                              ((%line-type-info-p line-type)
                               (make-instance 'line-info))
                              ((%line-type-uri-p line-type)
                               (make-instance 'line-uri))
                              (t
                               (make-instance 'line-unknown)))))
            (setf (line-type-id instance) (getf entry :type)
                  (username     instance) (getf entry :user-name)
                  (selector     instance) (getf entry :selector)
                  (host         instance) (getf entry :host)
                  (port         instance) (getf entry :port))
            instance))))

(defrule text-block (+ (not (and #\Newline #\. #\Return #\Newline)))
  (:text t))

(defrule text-file (and (* text-block) (and #\Newline #\. #\Return #\Newline))
  (:function caar))

(defun parse-text-file (data)
  (parse 'text-file data))

(defun parse-iri (iri)
  (let* ((parsed   (iri:iri-parse iri))
         (host     (uri:host parsed))
         (port     (or (uri:port parsed) 70))
         (path     (uri:path parsed))
         (type     (second (fs:split-path-elements path)))
         (selector (subseq path (+ 2 (length type)))))
    (values host port type selector)))