#! /bin/sh
#| Hey Emacs, this is -*-scheme-*- code!
#$Id: 5432 2008-03-01 05:11:58Z erich $
exec mzscheme --no-init-file --mute-banner --version --require "$0"
(module hostinfo mzscheme
(require (lib "" "net")
         (planet "" ("offby1" "offby1.plt"))
         (only (planet "" ("schematics" "port.plt" ))
         (only (lib "" "swindle")
         (lib "")
         (only (planet "" ("dherman" "memoize.plt" )) define/memo*)
         (lib "")
         (lib "")
         (lib "")
         (only (lib "" "srfi")

(define/memo* (get-name . args)
  (apply dns-get-name args))

(define/memo* (get-address . args)
  (apply dns-get-address args))

(define-syntax safely
  (syntax-rules ()
    ((safely _expr)
     (with-handlers ([exn:fail? (lambda (e) #f)])

;; given a string, returns two values: the hostname described by the
;; string, and a guess as to the country in which that host lives.
(define (get-info hostname-or-ip-string)
  ;; These are the four numbers that make up the IP address.
  (define address (safely (string->ip-address  hostname-or-ip-string)))

  (define name (and (not address) hostname-or-ip-string))
  (when (not address)
       (get-address *nameserver* name)))))

  (when (not name)
      (get-name *nameserver* (ip-address->string address)))))

    (let ((address (ip-address->strings address)))
       (apply try address)
       (apply try  "" (reverse address))
       (apply try  "" (cdr (reverse address)))
       (apply try  "" (cddr (reverse address)))
     (geoiplookup (ip-address->string address))
     (guess-country-from-hostname name)

(define (guess-country-from-hostname str)
   [(#px"\\.([[:alpha:]]{2})$" kaching) kaching]
   [else #f]))

;; This should probalby be a parameter, and be provided
(define *nameserver*
  ;;"" ;;
  (dns-find-nameserver)                 ; default

;; find as much information as possible about a machine, given its IP
;; address or host name.  Basically we do lots of name server lookups
;; on the address, like this:

;; Try the IP address as is.
;; Try the address with the octets reversed, and with `'
;; appended.  That is, if the address in question is,
;; we'd try

;; and then
;; and then

(define (split-on-newlines str)
  (let ((ip (open-input-string str)))
    (let loop ((lines '()))
      (let ((one-line (read-line ip)))
        (if (eof-object? one-line)
            (reverse lines)
            (loop (cons one-line lines)))))))

(define (string->ip-address str)
       (lambda args (apply public-make-ip-address (cdr args)))]
   [else (error 'string->ip-address "~s doesn't look like an IP address" str)]))

(define-struct ip-address (a b c d) #f)

(define (ip-address->strings ip)
  (check-type 'ip-address->strings ip-address? ip)
  (map number->string (cdr (vector->list (struct->vector ip)))))

(define (ip-address->string ip)
   (string-join (ip-address->strings ip) "."))

(define (public-make-ip-address a b c d)

  (define (puke datum)
     "Wanted four dot-separated integers 'twixt 0 and 255 inclusive; but one of them was ~s"

   (map (lambda (str)
          (let ((datum (read-from-string str (lambda (e) (puke str)))))
            (when (not (byte? datum)) (puke datum))
        (list a b c d))))

(define-struct (exn:fail:process           exn:fail        ) (                ) #f)
(define-struct (exn:fail:process:exit      exn:fail:process) (status exit-code) #f)
(define-struct (exn:fail:process:not-found exn:fail:process) (                ) #f)

(define (port->string/close ip)
      (port->string ip)
    (close-input-port ip)))

(define (fep . args)
  (apply find-executable-path args))

;; Strange that I had to write this myself.
(define (shell-command->string . args)
  (let ((command
         (let again ((command (car args))
                     (tries 0))
           (let ((found (fep command)))
             (or found
                 (and (< tries 1)
                      (eq? (system-type 'os) 'windows)
                      (again (string-append command ".exe") (add1 tries))))))))

    (when (not command)
      (raise (make-exn:fail:process:not-found
              (format "Subprocess ~s failed: ~a not found"
                      args (car args))

    (match-let ([(stdout stdin pid stderr controller)
                 (apply process*  command (cdr args))])

      (close-output-port stdin)
      (controller 'wait)
      (when (not (eq? 'done-ok (controller 'status)))
        (raise (make-exn:fail:process:exit
                (format "Subprocess ~s failed: status ~a; exit code ~a"
                        (controller 'status)
                        (controller 'exit-code))
                (controller 'status)
                (controller 'exit-code))))
      (port->string/close stdout))))

(define (try . components)
  (let ((got (safely
                (string-join components ".")))))
    (and (not (equal? "" got))

(define/memo* (geoiplookup h)
        (lambda (e) #f)])
     (car (split-on-newlines
           ;; The Debian package 'geoip-bin'
           (let again ((exe "geoiplookup")
                       (tries 1))
                   (lambda (e)
                     (if (= 1 tries)
                         (again "/usr/bin/geoiplookup" (add1 tries))
                         (raise e)))])

               (shell-command->string exe h)))))
     [(#px"GeoIP Country Edition: (..)," iso-code)
         (and (not (equal? iso-code "--"))
     [#t #f])))

(provide get-info)