extra/geo-ip/geo-ip.factor

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