geolocate.scm
(module geolocate mzscheme
        (require (planet "bot.scm" ("oesterholt" "webbot.plt" 1 0)))
        (require (planet "xml.scm" ("oesterholt" "ho-utils.plt" 1 0)))
        (require (planet "sutil.scm" ("oesterholt" "ho-utils.plt" 1 0)))
        (require (lib "string.ss" "srfi" "13"))
        (require (lib "dns.ss" "net"))
        (provide geoloc
                 geoloc?
                 geoloc-ok?
                 geoloc-ip
                 geoloc-country
                 geoloc-lat
                 geoloc-long
                 geoloc-city
                 geoloc-documentation
                 )
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Module variables
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define GEOLOC-SERVICE-URL "http://api.hostip.info/")
        
        (define CACHE (make-hash-table))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Support functions
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define (get-cache ip)
          (let ((R (hash-table-get CACHE (string->symbol ip) (lambda () #f))))
            (if (eq? R #f)
                #f
                (let ((s (current-seconds)))
                  (if (>= (- s (car R)) 3600)
                      #f
                      (cdr R))))))
        
        (define (cache! loc)
          (if (string? (geoloc-ip loc))
              (hash-table-put! CACHE (string->symbol (geoloc-ip loc)) (cons (current-seconds) loc))))
        
        (define-struct geoloc-t (ip city country lat long))
        
        (define (make-geoloc)
          (make-geoloc-t '%nil% '%nil% '%nil% '%nil% '%nil%))
        
        (define-syntax geoloc-def
          (syntax-rules ()
            ((_ (function loc . rest) body1 ...)
             (define (function loc . rest)
               (begin
                 (if (geoloc? loc)
                     (begin body1 ...)
                     (error (format "geoloc: '~a' called with an object not of type 'geoloc'" 'function))))))
            ((_ (function loc a1 ...) body1 ...)
             (define (function loc a1 ...)
               (begin
                 (if (geoloc? loc)
                     (begin body1 ...)
                     (error (format "geoloc: '~a' called with an object not of type 'geoloc'" 'function))))))
            ))
               
        
        (define-syntax geoloc-val
          (syntax-rules ()
            ((_ get set loc val)
             (begin
               (if (not (null? val)) (set loc (car val)))
               (get loc)))))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Exported functions
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (spod-module-def)
        (spod-module-add (s= "geolocate - locate IP addresses geographically"))
        
        (spod-module-add 
         (sp "This module provides a geolocation interface for hosts and ip adresses."
             "It will try to locate a host or ip address by querying api.hostip.info."
             "The last results are cached for an hour."))
        
        (spod-module-add
         (s== "Provided functions")
         (s=== (s% "(geoloc? loc:any?) --> boolean?"))
         (sp "Returns #t, if loc is of type geoloc; #f otherwise."))
        (define (geoloc? loc)
          (geoloc-t? loc))
        
        (define (AND . args)
          (letrec ((f (lambda (L)
                        (if (null? L)
                            #t
                            (and (car L) (f (cdr L)))))))
            (f args)))
        
        (spod-module-add
         (s=== (s% "(geoloc-ok? loc:geoloc?) --> boolean?"))
         (sp "Returns #t, if all fields in loc have a value; #f otherwise."))
        (geoloc-def (geoloc-ok? loc)
                    (apply AND
                           (map (lambda (f) (not (eq? (f loc) '%nil%)))
                                (list geoloc-t-country
                                      geoloc-t-lat
                                      geoloc-t-long
                                      geoloc-t-city
                                      geoloc-t-ip))))
        
        (spod-module-add
         (s=== (s% "(geoloc-country loc:geoloc?) --> symbol?"))
         (sp "Returns the country abreviation of the location of the ip address, or #f if not available"))
        (geoloc-def (geoloc-country loc . val)
          (geoloc-val geoloc-t-country set-geoloc-t-country! loc val))
        
        (spod-module-add
         (s=== (s% "(geoloc-ip loc:geoloc?) --> string?"))
         (sp "Returns the ip address of the location."))
        (geoloc-def (geoloc-ip loc . val)
          (geoloc-val geoloc-t-ip set-geoloc-t-ip! loc val))
        
        (spod-module-add
         (s=== (s% "(geoloc-lat loc:geoloc?) --> number?"))
         (sp "Returns the latitude co├Ârdinate of the location, or #f if not available."))
        (geoloc-def (geoloc-lat loc . val)
          (geoloc-val geoloc-t-lat set-geoloc-t-lat! loc val))
        
        (spod-module-add
         (s=== (s% "(geoloc-long loc:geoloc?) --> number?"))
         (sp "Returns the longitude co├Ârdinate of the location, or #f if not available."))
        (geoloc-def (geoloc-long loc . val)
          (geoloc-val geoloc-t-long set-geoloc-t-long! loc val))
        
        (spod-module-add
         (s=== (s% "(geoloc-city loc:geoloc?) --> string?"))
         (sp "Returns the city =of the location, or #f if not available."))
        (geoloc-def (geoloc-city loc . val)
          (geoloc-val geoloc-t-city set-geoloc-t-city! loc val))
        
        (define re-ip (regexp "^[0-9]+[.][0-9]+[.][0-9]+[.][0-9]+$"))

        (spod-module-add
         (s=== (s% "(geoloc ip-or-host:string?) --> geoloc?"))
         (sp "Returns #f, if either ip-or-host could not be resolved, or the api.hostip.info cannot be reached.")
         (sp "Returns a result of type geoloc, when the ip-or-host could be resolved and queried to api.hostip.info"))
        (define (geoloc ip-or-host)
          (if (not (string? ip-or-host))
              (error "geoloc: '~a' expects ip of type string?")
              (let ((bot (form-data))
                    (ip  (if (eq? (regexp-match re-ip ip-or-host) #f)
                             (with-handlers ((exn:fail? (lambda (exn) #f)))
                               (dns-get-address (dns-find-nameserver) ip-or-host))
                             ip-or-host)))
                (if (eq? ip #f)
                    #f
                    (let ((result (get-cache ip)))
                      (if (eq? result #f)
                          (let ((fh (-> bot get (format "~a?ip=~a" GEOLOC-SERVICE-URL ip))))
                            (if (eq? fh 'no-contact)
                                #f
                                (let ((loc (make-geoloc))
                                      (get-value (lambda (p xml . convert)
                                                   (let ((R (xpath-xexpr p xml))
                                                         (f (if (null? convert)
                                                                (lambda (obj) (eq? obj #f) "" obj)
                                                                (car convert))))
                                                     (f (if (null? R) #f (car R)))))))
                                  (let ((xml (xexpr-remove-whitespace (read-xexpr fh))))
                                    (let ((city    (get-value "//HostipLookupResultSet/gml:featureMember/Hostip/gml:name" xml
                                                              (lambda (obj)
                                                                (if (eq? obj #f)
                                                                    #f
                                                                    (let ((R (string-downcase obj)))
                                                                      (if (or (string=? R "(unknown city)")
                                                                              (string=? R "(unknown city?)"))
                                                                          #f
                                                                          R))))))
                                          (country (get-value "//HostipLookupResultSet/gml:featureMember/Hostip/countryAbbrev" xml
                                                              (lambda (obj)
                                                                (if (eq? obj #f)
                                                                    #f
                                                                    (let ((R (string->symbol (string-downcase obj))))
                                                                      (if (eq? R 'xx)
                                                                          #f
                                                                          R))))))
                                          (latlong (get-value "//HostipLookupResultSet/gml:featureMember/Hostip/ipLocation/gml:PointProperty/gml:Point/gml:coordinates"
                                                              xml
                                                              (lambda (obj)
                                                                (if (eq? obj #f)
                                                                    (list #f #f)
                                                                    (map string->number (splitstr obj #\,)))))))
                                      (geoloc-city     loc city)
                                      (if latlong (geoloc-lat loc (car latlong)))
                                      (if latlong (geoloc-long loc (cadr latlong)))
                                      (geoloc-ip       loc ip)
                                      (geoloc-country  loc country)
                                      (close-input-port fh)
                                      (cache! loc)
                                      loc)))))
                          result))))))
        
        (define %module-doc (spod-module-doc))
        (define (geoloc-documentation)
          %module-doc)

        
        )