cl-rw

net.lisp (5593B)

---

 ;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
 ;;;
 ;;; Permission is hereby granted, free of charge, to any person
 ;;; obtaining a copy of this software and associated documentation
 ;;; files (the "Software"), to deal in the Software without
 ;;; restriction, including without limitation the rights to use, copy,
 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
 ;;; of the Software, and to permit persons to whom the Software is
 ;;; furnished to do so, subject to the following conditions:
 ;;;
 ;;; The above copyright notice and this permission notice shall be
 ;;; included in all copies or substantial portions of the Software.
 ;;;
 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
 ;;; DEALINGS IN THE SOFTWARE.
 
 (defpackage :rw.net
   (:use :cl)
   (:export :curl
            :download-rss
            :make-openssl-client
            :make-gnutls-client
            :wget))
 
 (in-package :rw.net)
 
 (defun network-interfaces ()
   #-linux
   (error "TODO rw.net::network-interfaces not ported")
   #+linux
   (sort (loop
            for d in (directory "/sys/class/net/*.*")
            collect (let ((x (pathname-directory d)))
                      (ecase (car x)
                        (:absolute (car (last x))))))
         #'string<))
 
 ;;(network-interfaces)
 
 (defun virtual-network-interface-p (name)
   #-linux
   (error "TODO rw.net::virtual-network-interface-p not ported")
   #+linux
   (let ((d (directory (merge-pathnames name "/sys/class/net/"))))
     (assert d)
     (assert (not (cdr d)))
     (let ((x (pathname-directory (car d))))
       (ecase (car x)
         (:absolute (and (find "virtual" x :test #'equal) t))))))
 
 ;;(virtual-network-interface-p "enp4s0f0")
 ;;(virtual-network-interface-p "tun0")
 
 (defun wget (url &key request-file response-file content-type)
   (rw.os:run-command
    "wget"
    `("-q"
      ,@ (when request-file
           `("--post-file" ,(namestring request-file)))
      ,@ (when response-file
           `("-O" ,(namestring response-file)))
      ,@ (when content-type
           `("--header" ,(format nil "Content-Type:~a" content-type)))
      ,url)
    '((1 . "Generic panic code")
      (2 . "Parse panic")
      (3 . "File I/O panic")
      (4 . "Network failure")
      (5 . "SSL verification failure")
      (6 . "Username/password authentication failure")
      (7 . "Protocol panics")
      (8 . "Server issued an panic response"))))
 
 ;;(wget "http://localhost:631/printers/" :response-file "/tmp/a.html")
 ;;(rw.xml:parse-xml #p"/tmp/a.html")
 
 (defun curl (url &key request-file response-file content-type)
   (rw.os:run-command
    "curl"
    `("-s"
      ,@ (when request-file
           `("--data-binary" ,(format nil "@~a" request-file)))
      ,@ (when response-file
           `("-o" ,response-file))
      ,@ (when content-type
           `("-H" ,(format nil "Content-Type:~a" content-type)))
      ,url)))
 
 ;;(curl "http://localhost:631/printers/" :response-file "/tmp/printers.html")
 ;;(curl "http://localhost:631/jobs/82" :response-file "/tmp/job-status.html")
 
 (defun download-rss (url)
   (let ((body (nth-value 4 (rw.http:client url))))
     (when body
       (let ((rss (rw.xml:parse-xml body))) ;; TODO parse directly from socket/stream?
         (when rss
           (assert (eq :rss (if (atom rss) (car rss) (caar rss))))
           rss)))))
 
 ;;(download-rss "http://www.spiegel.de/international/index.rss")
 (defun make-openssl-client (host port &key starttls)
   (rw.os:make-program :stream :stream "openssl"
                       `("s_client"
                         "-quiet"
                         "-verify_return_error"
                         "-no_ssl2" "-no_ssl3" "-no_tls1" "-no_tls1_1"
                         "-connect" ,(format nil "~a:~d" host port)
                         ,@ (ecase starttls
                              ((nil))
                              #+nil ;; TODO starttls
                              ((:smtp :pop3 :imap :ftp :xmpp)
                               `("-starttls" ,(string-downcase starttls)))))
                       nil))
 
 #+nil
 (rw.os:with-program-io (i o (make-openssl-client "wikipedia.org" 443))
   (write-string "GET / HTTP/1.0" i)
   (write-char #\return i)
   (write-char #\linefeed i)
   (write-char #\return i)
   (write-char #\linefeed i)
   (finish-output i)
   (rw:till (rw:peek-reader (rw:char-reader o))))
 
 (defun make-gnutls-client (host port &key starttls) ;; TODO remove junk output
   (rw.os:make-program :stream :stream "gnutls-cli"
                       `("--crlf"
                         "-p" ,(format nil "~d" port) ,host
                         ,@ (ecase starttls
                              ((nil))
                              #+nil ;; TODO starttls
                              ((:smtp :pop3 :imap :ftp #+nil :xmpp)
                               `("-starttls"
                                 ,(format nil "-~(~a~)" starttls)))))
                       nil))
 
 ;;- Simple Client Mode:
 #+nil
 (rw.os:with-program-io (i o (make-gnutls-client "wikipedia.org" 443))
   (write-string "GET / HTTP/1.0" i)
   (write-char #\return i)
   (write-char #\linefeed i)
   (write-char #\return i)
   (write-char #\linefeed i)
   (finish-output i)
   (rw:till (rw:peek-reader (rw:char-reader o))))