#!/usr/bin/env hy

;; Copyright (C) 2019 Jakob L. Kreuze
;;
;; 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/>.

"brisket.hy: Script for interacting with NNTP servers."

(setv __author__ "Jakob L. Kreuze")
(setv __copyright__ "Copyright (C) 2019 Jakob L. Kreuze")
(setv __license__ "GPL")
(setv __version__ "0.1.0 'Kansas City-style'")

(import [binascii [hexlify]])
(import [configparser [ConfigParser]])
(import [nntplib [NNTP-SSL]])
(import [os [getcwd getenv makedirs]])
(import [os.path [dirname expanduser join]])
(import [subprocess [Popen PIPE]])
(import [sys [argv exit stderr stdin]])
(import [time [strftime]])

(require [hy.contrib.walk [let]])

(setv *auth-source* (expanduser "~/.authinfo.gpg"))
(setv *config-path* (expanduser "~/.config/brisket/config.ini"))
(setv *recognized-commands* ["describe-group"
                             "help"
                             "fetch-posts"
                             "list-groups"
                             "list-posts"
                             "post-article"
                             "version"])

(defn help [&rest args]
  "Display the documentation for a command to stdout.

usage: help [command]"
  (unless (= (len args) 1)
    (err (.format "usage: help [command]"))
    (return))

  (let [command (first args)]
    (unless (in command *recognized-commands*)
      (err (.format "unrecognized command: {}" command))
      (exit 1))

    (let [handler (get (globals) (.replace command "-" "_"))]
      (print (. handler __doc__)))))

(defn version [&rest args]
  "Display the version of Brisket the user is currently running.

usage: version"
  (print (.format "brisket version {}
 ________
< Uhm... >
 --------
        \   ^__^
         \  (oo)\\_______
            (__)\\       )\\/\\
                ||----w |
                ||     ||" __version__)))

(defn list-groups [session &rest args]
  "List groups on the server.

usage: list-groups"
  (let [groups (second (.list session))]
    (for [group groups]
      (print group.group))))

(defn describe-group [session &rest args]
  "Describe the first group whose name matches the pattern.

usage: describe-groups [pattern]"
  (when (< (len args) 1)
    (err "usage: describe-group [group]")
    (return))
  (let [group-name (first args)
        description (.description session group-name)]
    (if (= (len description) 0)
        (err "ERROR: Group does not have a description.")
        (print description))))

(defn list-posts [session &rest args]
  "List posts in the given group.

usage: describe-group [group]"
  (when (< (len args) 1)
    (err "usage: describe-group [group]")
    (return))
  (let [res (.group session (first args))
        first-post (nth res 2)
        last-post (nth res 3)
        overviews (second (.over session [first-post last-post]))]
    (for [[article-id overview] overviews]
      (print (.format "{}: {} by {} on {}"
                      article-id
                      (.get overview "subject")
                      (.get overview "from")
                      (.get overview "date"))))))

(defn fetch-single-article [session dest write-to-stdout group article-id]
  "Fetches ARTICLE-ID in GROUP.

Writes to stdout if WRITE-TO-STDOUT is non-nil, or to a file named after the
post id in DEST otherwise."
  (.group session group)
  (let [info (second (.article session article-id))]
    (if write-to-stdout
        (for [line info.lines]
          (print (.decode line)))
        (with [out (open (join dest info.message-id) "w+")]
          (for [line info.lines]
            (.write out (.decode line))
            (.write out "\n"))))))

(defn fetch-group-articles [session dest write-to-stdout group]
  "Fetches all articles in GROUP.

Writes to stdout if WRITE-TO-STDOUT is non-nil, or to a file named after the
post id in DEST otherwise."
  (let [res (.group session group)
        first-post (nth res 2)
        last-post (nth res 3)]
    (for [i (range first-post (+ 1 last-post))]
      (fetch-single-article session dest write-to-stdout group i))))

(defn fetch-all-articles [session dest write-to-stdout]
    "Fetches all articles on the server.

Writes to stdout if WRITE-TO-STDOUT is non-nil, or to a file named after the
post id in DEST otherwise."
  (let [groups (second (.list session))]
    (for [group groups]
      (let [group group.group
            dest (join dest group)]
        (makedirs dest :exist-ok True)
        (fetch-group-articles session dest write-to-stdout group)))))

(defn fetch-posts [session &rest args]
  "Fetch an article on the server.

Writes to stdout if '-' appears in the list of arguments, or to an file named
after the post id otherwise.

usage: fetch-posts (group [optional]) (article-id [optional])"
  (let [write-to-stdout (in "-" args)
        ;; Consume the "-" argument.
        args (list (filter (fn [arg] (!= arg "-")) args))
        dest (getcwd)
        group (if (> (len args) 0) (first args))
        article-id (if (> (len args) 1) (second args))]
    (cond [article-id (fetch-single-article session dest write-to-stdout group article-id)]
          [group (fetch-group-articles session dest write-to-stdout group)]
          [True (fetch-all-articles session dest write-to-stdout)])))

;; RFC 5536, the Netnews Article Format specifies the following headers as
;; mandatory an article.
;;
;; - Date
;; - From
;; - Message-ID
;; - Newsgroups
;; - Path
;; - Subject
;;
;; The following headers, though not mandatory, are handled as well by brisket.
;;
;; - User-Agent
;; - Mime-Version
;; - Content-Type
;; - Content-Transfer-Encoding
;; - Content-Language

(defn generate-message-id [posting-address]
  (let [random (with [rand (open "/dev/urandom" "rb")]
                 (hexlify (.read rand 16)))
        host (second (.split posting-address "@"))]
    (.format "<brisket-{}@{}>" random host)))

(defn generate-headers [posting-address subject group]
  "Return a list of headers to prepend to an article."
  [(.format "Date: {}" (strftime "%a, %d %b %Y %H:%M:%S %z"))
   (.format "From: {}" posting-address)
   (.format "Message-ID: {}" (generate-message-id posting-address))
   (.format "Newsgroups: {}" group)
   (.format "Path: {}" "not-for-mail")
   (.format "Subject: {}" subject)
   (.format "User-Agent: {} {}" "brisket" __version__)
   (.format "Mime-Version: {}" "1.0")
   (.format "Content-Type: {}" "text/plain; charset=utf-8")
   (.format "Content-Transfer-Encoding: {}" "7bit")
   (.format "Content-Language: {}" "en-US")])

(defn post-article [session &rest args]
  "Post an article to the server.

Reads from stdin if the path of a file is not specified.

usage: post-article [posting-address] [subject] [group] (path [optional])"
  (when (< (len args) 3)
    (err "usage: post-article [posting-address] [subject] [group] (path [optional])")
    (return))
  (let [posting-address (nth args 0)
        subject (nth args 1)
        group (nth args 2)
        headers (generate-headers posting-address subject group)
        path (if (> (len args) 3) (nth args 3))
        content (if path
                    (with [f (open path)]
                      (+ (list (map str.encode headers))
                         (list (map str.encode (.split (.read f) "\n")))))
                    (+ (list (map str.encode headers))
                       (list (map str.encode (.split (.read stdin) "\n")))))]
    (.post session content)))

(defn make-config []
  "Create a default configuration file.

Creates the configuration directory if it does not exist, as well as an INI file
populated with default configuration values."
  (let [config (ConfigParser)]
    (assoc config "Server" {})
    (assoc (get config "Server") "Host" "news.eternal-september.org")
    (makedirs (dirname *config-path*) :exist-ok True)
    (with [out (open *config-path* "w+")]
      (.write config out))
    config))

(defn load-config []
  "Load the configuration file for Brisket.

Returns a default configuration, written to `*config-path*`, if a configuration
file cannot be found."
  (let [config (ConfigParser)]
    (if (= 1 (len (.read config *config-path*)))
        config
        (make-config))))

(defn find-host [config]
  "Returns the host that Brisket should connect to.

The lookup order is:
  - NNTPSERVER environment variable.
  - 'Host' in the 'Server' section of the configuration file."
  (or (getenv "NNTPSERVER")
      (if (and (in "Server" config)
               (in "Host" (get config "Server")))
          (get (get config "Server") "Host"))))

(defn get-user-info [host]
  "Decode *auth-source* and return the line containing HOST."
  (let [process (Popen ["gpg" "-q" "-d" *auth-source*] :stdout PIPE)
        output (.decode (first (.communicate process)))]
    (for [line (.split output "\n")]
      (when (.startswith line (.format "machine {}" host))
        (return line)))))

(defn get-username [host]
  "Return the username for HOST as specified by *auth-source*."
  (let [info (get-user-info host)
        start-index (.find info "login")]
    (unless (= -1 start-index)
      (let [sliced (.split (.join "" (drop start-index info)))]
        (if (> (len sliced) 1)
            (.strip (nth sliced 1) "\""))))))

(defn get-password [host]
  "Return the password for HOST as specified by *auth-source*."
  (let [info (get-user-info host)
        start-index (.find info "password")]
    (unless (= -1 start-index)
      (let [sliced (.split (.join "" (drop start-index info)))]
        (if (> (len sliced) 1)
            (.strip (nth sliced 1) "\""))))))

(defn err [&rest args]
  "Displays ARGS to stderr."
  (.write stderr (+ (first args) "\n") #* (rest args)))

(when (= __name__ "__main__")
  (unless (>= (len argv) 2)
    (err (.format "usage: {} [command] [args]" (first argv)))
    (err "recognized commands:")
    (for [command *recognized-commands*]
      (err (.format "  - {}" command)))
    (exit 1))

  (let [config (load-config)
        host (find-host config)
        command (nth argv 1)]
    (when (is host None)
      (err (.format "no host specified"))
      (exit 1))

    (unless (in command *recognized-commands*)
      (err (.format "unrecognized command: {}" command))
      (exit 1))

    ;; Special case for 'help' and 'version', as the commands doesn't require a
    ;; connection to the NNTP server.
    (cond [(= command "help") (help #* (drop 2 argv))]
          [(= command "version") (version #* (drop 2 argv))]
          [True (let [user (get-username host)
                      password (get-password host)]
                  (with [session (NNTP_SSL host :user user :password password)]
                    ;; Otherwise, pull the function out of the global namespace.
                    (let [handler (get (globals) (.replace command "-" "_"))]
                      (handler session #* (drop 2 argv)))))])))