module Data.Geolocation.GeoIP
(
GeoDB
, GeoIPOption
, combineOptions
, standard
, memory_cache
, check_cache
, index_cache
, mmap_cache
, GeoIPRecord(..)
, openGeoDB
, geoLocateByIPAddress
, geoLocateByIPNum
, geoStringByIPAddress
, geoStringByIPNum
, mkIpNum
) where
import Control.Applicative
import Control.DeepSeq
import Data.ByteString.Char8 (ByteString, packCString, split, unpack)
import Foreign
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
data GeoIP
newtype GeoDB = GeoDB { unGeoDB :: ForeignPtr GeoIP }
data GeoIPRecord = GeoIPRecord
{ geoCountryCode :: !ByteString
, geoCountryCode3 :: !ByteString
, geoCountryName :: !ByteString
, geoRegion :: !ByteString
, geoCity :: !ByteString
, geoPostalCode :: !ByteString
, geoLatitude :: !Double
, geoLongitude :: !Double
, geoAreaCode :: !Int
, geoContinentCode :: !ByteString
, geoAccuracyRadius :: !Int
} deriving (Eq, Show)
instance NFData GeoIPRecord where
rnf a = a `seq` ()
peekGeoIPRecord :: Ptr GeoIPRecord -> IO (Maybe GeoIPRecord)
peekGeoIPRecord p =
case nullPtr == p of
True -> return Nothing
False -> fmap Just r
where
!r = GeoIPRecord
<$> peekBS ((\hsc_ptr -> peekByteOff hsc_ptr 0))
<*> peekBS ((\hsc_ptr -> peekByteOff hsc_ptr 4))
<*> peekBS ((\hsc_ptr -> peekByteOff hsc_ptr 8))
<*> peekBS ((\hsc_ptr -> peekByteOff hsc_ptr 12))
<*> peekBS ((\hsc_ptr -> peekByteOff hsc_ptr 16))
<*> peekBS ((\hsc_ptr -> peekByteOff hsc_ptr 20))
<*> fmap tofloat ((\hsc_ptr -> peekByteOff hsc_ptr 24) p)
<*> fmap tofloat ((\hsc_ptr -> peekByteOff hsc_ptr 28) p)
<*> fmap toInt ((\hsc_ptr -> peekByteOff hsc_ptr 36) p)
<*> peekBS ((\hsc_ptr -> peekByteOff hsc_ptr 44))
<*> pure 0
peekBS f = do
!sptr <- f p
case nullPtr == sptr of
True -> return ""
False -> let x = packCString sptr in x `seq` x
tofloat :: CFloat -> Double
tofloat = realToFrac
toInt :: CInt -> Int
toInt = fromIntegral
newtype GeoIPOption = GeoIPOption { unGeoIPOpt :: CInt }
standard :: GeoIPOption
standard = GeoIPOption 0
memory_cache :: GeoIPOption
memory_cache = GeoIPOption 1
check_cache :: GeoIPOption
check_cache = GeoIPOption 2
index_cache :: GeoIPOption
index_cache = GeoIPOption 4
mmap_cache :: GeoIPOption
mmap_cache = GeoIPOption 8
combineOptions :: [GeoIPOption] -> GeoIPOption
combineOptions = GeoIPOption . foldr ((.|.) . unGeoIPOpt) 0
mkIpNum :: ByteString -> Maybe Integer
mkIpNum x = case valid of
False -> Nothing
True -> Just $ a * 16777216 + b * 65536 + 256 * c + d
where
valid = length parts == 4 && foldr (\x acc -> acc && x <= 255) True [a,b,c,d]
a : b : c : d : _ = map (read . unpack) parts
parts = split '.' x
openGeoDB :: GeoIPOption -> String -> IO GeoDB
openGeoDB ops dbname = withCString dbname $ \dbname' -> do
ptr <- c_GeoIP_open dbname' ops
GeoDB <$> newForeignPtr c_GeoIP_delete ptr
geoLocateByIPAddress :: GeoDB -> ByteString -> IO (Maybe GeoIPRecord)
geoLocateByIPAddress db ip =
case mkIpNum ip of
Nothing -> return Nothing
Just inum -> geoLocateByIPNum db inum
geoStringByIPAddress :: GeoDB -> ByteString -> IO (Maybe ByteString)
geoStringByIPAddress db ip =
case mkIpNum ip of
Nothing -> return Nothing
Just inum -> geoStringByIPNum db inum
geoStringByIPNum :: GeoDB -> Integer -> IO (Maybe ByteString)
geoStringByIPNum (GeoDB db) ip =
withForeignPtr db $ \db' -> do
ptr <- c_GeoIP_name_by_ipnum db' (fromIntegral ip)
str <- if nullPtr == ptr
then return Nothing
else let x = packCString ptr in x `seq` fmap Just x
free ptr
return str
geoLocateByIPNum :: GeoDB -> Integer -> IO (Maybe GeoIPRecord)
geoLocateByIPNum (GeoDB db) ip =
withForeignPtr db $ \db' -> do
ptr <- c_GeoIP_record_by_ipnum db' (fromIntegral ip)
rec <- peekGeoIPRecord ptr
return $ rec `deepseq` ()
case ptr == nullPtr of
True -> return ()
False -> c_GeoIPRecord_delete ptr
return rec
foreign import ccall safe "GeoIP.h GeoIP_new"
c_GeoIP_new
:: GeoIPOption
-> IO (Ptr GeoIP)
foreign import ccall safe "GeoIP.h &GeoIP_delete"
c_GeoIP_delete
:: FunPtr (Ptr GeoIP -> IO ())
foreign import ccall safe "GeoIP.h GeoIP_open"
c_GeoIP_open
:: CString
-> GeoIPOption
-> IO (Ptr GeoIP)
foreign import ccall safe "GeoIPCity.h GeoIP_record_by_ipnum"
c_GeoIP_record_by_ipnum
:: Ptr GeoIP
-> CULong
-> IO (Ptr GeoIPRecord)
foreign import ccall safe "GeoIP.h GeoIP_name_by_ipnum"
c_GeoIP_name_by_ipnum
:: Ptr GeoIP
-> CULong
-> IO CString
foreign import ccall safe "GeoIPCity.h &GeoIPRecord_delete"
c_GeoIPRecord_delete_funPtr
:: FunPtr (Ptr GeoIPRecord -> IO ())
foreign import ccall safe "GeoIPCity.h GeoIPRecord_delete"
c_GeoIPRecord_delete
:: Ptr GeoIPRecord -> IO ()