(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
)
(define GEOLOC-SERVICE-URL "http://api.hostip.info/")
(define CACHE (make-hash-table))
(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)))))
(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)
)![[logo]](/logo.png){kind=logo}