#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do wcat)' -s $0 "$@" # -*- scheme -*-
!#
;;; wcat

;; Copyright (C) 2001, 2003, 2004, 2005, 2006,
;;   2007, 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: wcat [--headers | -h] [--zcat | -z] [URL ...]
;;
;; Cat out web arguments.  Modelled after wwwcat in the guile-www
;; distribution, but distinctly better (supports --help and --version :-).
;;
;; Optional arg --headers (or -h for short) means use HEAD instead
;; of GET, and output the header (no body) using the format:
;;
;;   PROTOCOL/VERSION RESPONSE-CODE RESPONSE-MESSAGE
;;   HEADER-NAME: HEADER-VALUE
;;   ...
;;
;; Optional arg --zcat (or -z for short) means filter output
;; through "gzip -d -c -f".

;;; Code:

(define-module (ttn-do wcat)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((www http) #:select (http:connect
                                     http:message-version
                                     http:message-status-code
                                     http:message-status-text
                                     http:message-headers))
  #:use-module ((www main) #:select (www:get www:http-head-get))
  #:use-module ((srfi srfi-13) #:select ((substring/shared . subs)
                                         string-take
                                         string-drop-right))
  #:use-module ((ice-9 popen) #:select (open-output-pipe
                                        close-pipe))
  #:use-module ((ice-9 rdelim) #:select (read-line write-line))
  #:use-module ((ice-9 regex) #:select (string-match
                                        match:substring
                                        match:prefix
                                        match:suffix
                                        match:end))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE fso make-fso)))

(define (http:make-message version statcode stattext headers body)
  (vector version statcode stattext headers body))

(define (parse-status-line statline)
  ;; Handle:     VERSION CODE
  ;; as well as: VERSION CODE TEXT
  ;; For the former, use the null string for TEXT.
  (let* ((first (string-index statline #\space))
         (second (string-index statline #\space (1+ first))))
    (list (string-take statline first)
          (subs statline (1+ first) (or second (string-length statline)))
          (if second
              (subs statline (1+ second))
              ""))))

(define header-regex (make-regexp ": *"))

(define (http:header-parse hd)
  (let ((match (regexp-exec header-regex hd)))
    (cons (string->symbol
           (apply string
                  (map char-downcase
                       (string->list (match:prefix match)))))
          (match:suffix match))))

(define (unix-maybe method url)
  (and=> (string-match "^(/[^,]+)," url)
         (lambda (m)
           (let* ((p (http:connect PF_UNIX AF_UNIX (match:substring m 1)))
                  (fp (make-fso p)))
             (define (next)
               (let ((obj (read-line p)))
                 (if (eof-object? obj)
                     obj
                     ;; Omit trailing ‘#\cr’.
                     (string-drop-right obj 1))))
             (fp "~A ~A HTTP/1.0\r~%\r~%"
                 method (substring url (1+ (match:end m 1))))
             (let* ((f1 (next))
                    (parsed (parse-status-line f1))
                    (headers (accumulator)))
               (let loop ((line (next)))
                 (or (eof-object? line)
                     (string-null? line)
                     (begin
                       (headers (http:header-parse line))
                       (loop (next)))))
               (case method
                 ((HEAD)
                  (http:make-message (list-ref parsed 0)
                                     (list-ref parsed 1)
                                     (list-ref parsed 2)
                                     (headers)
                                     ""))
                 ((GET)
                  (let loop ((line (read-line p 'concat)))
                    (cond ((eof-object? line))
                          (else
                           (display line)
                           (loop (read-line p 'concat))))))))))))

(define (display-header url)
  (let ((res (or (unix-maybe 'HEAD url)
                 (www:http-head-get url))))
    (write-line (http:message-status-text res))
    (fso "~A ~A ~A~%"
         (http:message-version res)
         (http:message-status-code res)
         (http:message-status-text res))
    (FE (reverse (http:message-headers res))
        (lambda (pair)
          (fso "~A: ~A~%" (car pair) (cdr pair))))))

(define (display-entity url)
  (or (unix-maybe 'GET url)
      (display (www:get url))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.4")
                   (help . commentary)))
  (let* ((qop (qop<-args args '((headers (single-char #\h))
                                (zcat (single-char #\z)))))
         (urls (qop '())))
    (if (null? urls)
        (error "wcat: no url specified")
        (let ((zp (and (qop 'zcat) (open-output-pipe "gzip -d -c -f"))))
          (cond (zp (set-current-output-port zp)))
          (FE urls (if (qop 'headers)
                       display-header
                       display-entity))
          (cond (zp (force-output zp)
                    (close-pipe zp)))))))

;;; wcat ends here