extra/geo-ip/geo-ip.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences io.files io.files.temp io.launcher
   4 io.pathnames io.encodings.ascii io.streams.string http.client
   5 generalizations combinators math.parser math.vectors
   6 math.intervals interval-maps memoize csv accessors assocs
   7 strings math splitting grouping arrays combinators.smart ;
   8 IN: geo-ip
   9
  10 : db-path ( -- path ) "IpToCountry.csv" temp-file ;
  11
  12 : db-url ( -- url ) "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
  13
  14 : download-db ( -- path )
  15     db-path dup exists? [
  16         db-url over ".gz" append download-to
  17         { "gunzip" } over ".gz" append (normalize-path) suffix try-process
  18     ] unless ;
  19
  20 TUPLE: ip-entry from to registry assigned city cntry country ;
  21
  22 : parse-ip-entry ( row -- ip-entry )
  23     [
  24         {
  25             [ string>number ]
  26             [ string>number ]
  27             [ ]
  28             [ ]
  29             [ ]
  30             [ ]
  31             [ ]
  32         } spread
  33     ] input<sequence ip-entry boa ;
  34
  35 MEMO: ip-db ( -- seq )
  36     download-db ascii file-lines
  37     [ "#" head? not ] filter "\n" join <string-reader> csv
  38     [ parse-ip-entry ] map ;
  39
  40 : filter-overlaps ( alist -- alist' )
  41     2 clump
  42     [ first2 [ first second ] [ first first ] bi* < ] filter
  43     [ first ] map ;
  44
  45 MEMO: ip-intervals ( -- interval-map )
  46     ip-db [ [ [ from>> ] [ to>> ] bi 2array ] keep ] { } map>assoc
  47     filter-overlaps <interval-map> ;
  48
  49 GENERIC: lookup-ip ( ip -- ip-entry )
  50
  51 M: string lookup-ip
  52     "." split [ string>number ] map
  53     { HEX: 1000000 HEX: 10000 HEX: 100 HEX: 1 } v.
  54     lookup-ip ;
  55
  56 M: integer lookup-ip ip-intervals interval-at ;